diff --git a/.gitattributes b/.gitattributes
index 80cfa87137519c86db47f55f969f2cd8bf7f7780..e91cd7328a66cab454f390593b1fc263a0754928 100644
--- a/.gitattributes
+++ b/.gitattributes
@@ -1706,612 +1706,8 @@ CEP/Pipeline/test/test_framework/unittest_runner.py eol=lf
CEP/Pipeline/visual_studio/Pipeline.pyproj -text
CEP/Pipeline/visual_studio/Pipeline.sln -text
CEP/Pipeline/visual_studio/Pipeline.v12.suo -text
-CEP/PyBDSM/doc/anaamika_overview.doc -text
-CEP/PyBDSM/doc/source/HydraA_74MHz_fit.png -text svneol=unset#image/png
-CEP/PyBDSM/doc/source/_templates/searchbox.html -text
-CEP/PyBDSM/doc/source/algorithms.rst -text
-CEP/PyBDSM/doc/source/art_fit_alt.png -text svneol=unset#image/png
-CEP/PyBDSM/doc/source/art_fit_def.png -text svneol=unset#image/png
-CEP/PyBDSM/doc/source/art_rms_alt.png -text svneol=unset#image/png
-CEP/PyBDSM/doc/source/art_rms_def.png -text svneol=unset#image/png
-CEP/PyBDSM/doc/source/capabilities.rst -text
-CEP/PyBDSM/doc/source/colourcorr_delta_spin.png -text svneol=unset#image/png
-CEP/PyBDSM/doc/source/colourcorr_full.png -text svneol=unset#image/png
-CEP/PyBDSM/doc/source/colourcorr_order1-2.png -text svneol=unset#image/png
-CEP/PyBDSM/doc/source/context.rst -text
-CEP/PyBDSM/doc/source/examples.rst -text
-CEP/PyBDSM/doc/source/export_image.rst -text
-CEP/PyBDSM/doc/source/front_pic.png -text svneol=unset#image/png
-CEP/PyBDSM/doc/source/index.rst -text
-CEP/PyBDSM/doc/source/installation.rst -text
-CEP/PyBDSM/doc/source/parameters.rst -text
-CEP/PyBDSM/doc/source/process_image.rst -text
-CEP/PyBDSM/doc/source/pt_src_example.png -text svneol=unset#image/png
-CEP/PyBDSM/doc/source/pybdsm_manual_dia.png -text svneol=unset#image/png
-CEP/PyBDSM/doc/source/quick_example.png -text svneol=unset#image/png
-CEP/PyBDSM/doc/source/scripting.rst -text
-CEP/PyBDSM/doc/source/show_fit.rst -text
-CEP/PyBDSM/doc/source/ug_basics.rst -text
-CEP/PyBDSM/doc/source/whats_new.rst -text
-CEP/PyBDSM/doc/source/write_catalog.rst -text
-CEP/PyBDSM/src/fortran/constants.inc -text
-CEP/PyBDSM/src/fortran/gaul2gaulbin.f -text
-CEP/PyBDSM/src/fortran/pytess_roundness.f -text
-CEP/PyBDSM/src/fortran/pytess_simple.f -text
-CEP/PyBDSM/src/minpack/CMakeLists.txt_minpack -text
-CEP/PyBDSM/src/minpack/DISCLAIMER -text
-CEP/PyBDSM/src/minpack/chkder.f -text
-CEP/PyBDSM/src/minpack/dogleg.f -text
-CEP/PyBDSM/src/minpack/dpmpar.f -text
-CEP/PyBDSM/src/minpack/enorm.f -text
-CEP/PyBDSM/src/minpack/ex/file01 -text
-CEP/PyBDSM/src/minpack/ex/file02 -text
-CEP/PyBDSM/src/minpack/ex/file03 -text
-CEP/PyBDSM/src/minpack/ex/file04 -text
-CEP/PyBDSM/src/minpack/ex/file05 -text
-CEP/PyBDSM/src/minpack/ex/file06 -text
-CEP/PyBDSM/src/minpack/ex/file07 -text
-CEP/PyBDSM/src/minpack/ex/file08 -text
-CEP/PyBDSM/src/minpack/ex/file09 -text
-CEP/PyBDSM/src/minpack/ex/file11 -text
-CEP/PyBDSM/src/minpack/ex/file12 -text
-CEP/PyBDSM/src/minpack/ex/file13 -text
-CEP/PyBDSM/src/minpack/ex/file14 -text
-CEP/PyBDSM/src/minpack/ex/file15 -text
-CEP/PyBDSM/src/minpack/ex/file16 -text
-CEP/PyBDSM/src/minpack/ex/file17 -text
-CEP/PyBDSM/src/minpack/ex/file18 -text
-CEP/PyBDSM/src/minpack/ex/file19 -text
-CEP/PyBDSM/src/minpack/ex/file20 -text
-CEP/PyBDSM/src/minpack/ex/file21 -text
-CEP/PyBDSM/src/minpack/ex/file22 -text
-CEP/PyBDSM/src/minpack/ex/file23 -text
-CEP/PyBDSM/src/minpack/fdjac1.f -text
-CEP/PyBDSM/src/minpack/fdjac2.f -text
-CEP/PyBDSM/src/minpack/hybrd.f -text
-CEP/PyBDSM/src/minpack/hybrd1.f -text
-CEP/PyBDSM/src/minpack/hybrj.f -text
-CEP/PyBDSM/src/minpack/hybrj1.f -text
-CEP/PyBDSM/src/minpack/lmder.f -text
-CEP/PyBDSM/src/minpack/lmder1.f -text
-CEP/PyBDSM/src/minpack/lmdif.f -text
-CEP/PyBDSM/src/minpack/lmdif1.f -text
-CEP/PyBDSM/src/minpack/lmpar.f -text
-CEP/PyBDSM/src/minpack/lmstr.f -text
-CEP/PyBDSM/src/minpack/lmstr1.f -text
-CEP/PyBDSM/src/minpack/qform.f -text
-CEP/PyBDSM/src/minpack/qrfac.f -text
-CEP/PyBDSM/src/minpack/qrsolv.f -text
-CEP/PyBDSM/src/minpack/r1mpyq.f -text
-CEP/PyBDSM/src/minpack/r1updt.f -text
-CEP/PyBDSM/src/minpack/rwupdt.f -text
-CEP/PyBDSM/src/natgrid/natgridmodule.doc -text svneol=unset#application/msword
-CEP/PyBDSM/src/port3/CHANGES -text
-CEP/PyBDSM/src/port3/CMakeLists.txt_port3 -text
-CEP/PyBDSM/src/port3/a0xtrp.f -text
-CEP/PyBDSM/src/port3/a7sst.f -text
-CEP/PyBDSM/src/port3/a9rntc.f -text
-CEP/PyBDSM/src/port3/a9rntd.f -text
-CEP/PyBDSM/src/port3/a9rnti.f -text
-CEP/PyBDSM/src/port3/a9rntl.f -text
-CEP/PyBDSM/src/port3/a9rntr.f -text
-CEP/PyBDSM/src/port3/aprntc.f -text
-CEP/PyBDSM/src/port3/aprntd.f -text
-CEP/PyBDSM/src/port3/aprnti.f -text
-CEP/PyBDSM/src/port3/aprntl.f -text
-CEP/PyBDSM/src/port3/aprntr.f -text
-CEP/PyBDSM/src/port3/c6lcf.f -text
-CEP/PyBDSM/src/port3/c7vfn.f -text
-CEP/PyBDSM/src/port3/call.f -text
-CEP/PyBDSM/src/port3/cddiv.f -text
-CEP/PyBDSM/src/port3/d0xtrp.f -text
-CEP/PyBDSM/src/port3/d1mach.f -text
-CEP/PyBDSM/src/port3/d4sqr.f -text
-CEP/PyBDSM/src/port3/d7dgb.f -text
-CEP/PyBDSM/src/port3/d7dog.f -text
-CEP/PyBDSM/src/port3/d7dup.f -text
-CEP/PyBDSM/src/port3/d7egr.f -text
-CEP/PyBDSM/src/port3/d7mlp.f -text
-CEP/PyBDSM/src/port3/d7tpr.f -text
-CEP/PyBDSM/src/port3/d7upd.f -text
-CEP/PyBDSM/src/port3/da7sst.f -text
-CEP/PyBDSM/src/port3/dalloc.f -text
-CEP/PyBDSM/src/port3/dc6lcf.f -text
-CEP/PyBDSM/src/port3/dc7vfn.f -text
-CEP/PyBDSM/src/port3/dd4sqr.f -text
-CEP/PyBDSM/src/port3/dd7dgb.f -text
-CEP/PyBDSM/src/port3/dd7dog.f -text
-CEP/PyBDSM/src/port3/dd7dup.f -text
-CEP/PyBDSM/src/port3/dd7mlp.f -text
-CEP/PyBDSM/src/port3/dd7tpr.f -text
-CEP/PyBDSM/src/port3/dd7upd.f -text
-CEP/PyBDSM/src/port3/deigen.f -text
-CEP/PyBDSM/src/port3/df7dhb.f -text
-CEP/PyBDSM/src/port3/df7hes.f -text
-CEP/PyBDSM/src/port3/dg7itb.f -text
-CEP/PyBDSM/src/port3/dg7lit.f -text
-CEP/PyBDSM/src/port3/dg7qsb.f -text
-CEP/PyBDSM/src/port3/dg7qts.f -text
-CEP/PyBDSM/src/port3/dh2rfa.f -text
-CEP/PyBDSM/src/port3/dh2rfg.f -text
-CEP/PyBDSM/src/port3/dhqr2.f -text
-CEP/PyBDSM/src/port3/ditsum.f -text
-CEP/PyBDSM/src/port3/divset.f -text
-CEP/PyBDSM/src/port3/dl7itv.f -text
-CEP/PyBDSM/src/port3/dl7ivm.f -text
-CEP/PyBDSM/src/port3/dl7msb.f -text
-CEP/PyBDSM/src/port3/dl7mst.f -text
-CEP/PyBDSM/src/port3/dl7nvr.f -text
-CEP/PyBDSM/src/port3/dl7sqr.f -text
-CEP/PyBDSM/src/port3/dl7srt.f -text
-CEP/PyBDSM/src/port3/dl7svn.f -text
-CEP/PyBDSM/src/port3/dl7svx.f -text
-CEP/PyBDSM/src/port3/dl7tsq.f -text
-CEP/PyBDSM/src/port3/dl7tvm.f -text
-CEP/PyBDSM/src/port3/dl7upd.f -text
-CEP/PyBDSM/src/port3/dl7vml.f -text
-CEP/PyBDSM/src/port3/dmnf.f -text
-CEP/PyBDSM/src/port3/dmnfb.f -text
-CEP/PyBDSM/src/port3/dmng.f -text
-CEP/PyBDSM/src/port3/dmngb.f -text
-CEP/PyBDSM/src/port3/dmnh.f -text
-CEP/PyBDSM/src/port3/dmnhb.f -text
-CEP/PyBDSM/src/port3/dn2cvp.f -text
-CEP/PyBDSM/src/port3/dn2f.f -text
-CEP/PyBDSM/src/port3/dn2fb.f -text
-CEP/PyBDSM/src/port3/dn2g.f -text
-CEP/PyBDSM/src/port3/dn2gb.f -text
-CEP/PyBDSM/src/port3/dn2lrd.f -text
-CEP/PyBDSM/src/port3/dn2p.f -text
-CEP/PyBDSM/src/port3/dn2pb.f -text
-CEP/PyBDSM/src/port3/dn2rdp.f -text
-CEP/PyBDSM/src/port3/dnsf.f -text
-CEP/PyBDSM/src/port3/dnsfb.f -text
-CEP/PyBDSM/src/port3/dnsg.f -text
-CEP/PyBDSM/src/port3/dnsgb.f -text
-CEP/PyBDSM/src/port3/do7prd.f -text
-CEP/PyBDSM/src/port3/dorthe.f -text
-CEP/PyBDSM/src/port3/dortra.f -text
-CEP/PyBDSM/src/port3/dparck.f -text
-CEP/PyBDSM/src/port3/dpostx1.f -text
-CEP/PyBDSM/src/port3/dpostx10.f -text
-CEP/PyBDSM/src/port3/dpostx2.f -text
-CEP/PyBDSM/src/port3/dpostx3.f -text
-CEP/PyBDSM/src/port3/dpostx4.f -text
-CEP/PyBDSM/src/port3/dpostx5.f -text
-CEP/PyBDSM/src/port3/dpostx6.f -text
-CEP/PyBDSM/src/port3/dpostx7.f -text
-CEP/PyBDSM/src/port3/dpostx8.f -text
-CEP/PyBDSM/src/port3/dpostx9.f -text
-CEP/PyBDSM/src/port3/dq7apl.f -text
-CEP/PyBDSM/src/port3/dq7rad.f -text
-CEP/PyBDSM/src/port3/dq7rfh.f -text
-CEP/PyBDSM/src/port3/dq7rsh.f -text
-CEP/PyBDSM/src/port3/dr7mdc.f -text
-CEP/PyBDSM/src/port3/dr7tvm.f -text
-CEP/PyBDSM/src/port3/drldst.f -text
-CEP/PyBDSM/src/port3/drmnf.f -text
-CEP/PyBDSM/src/port3/drmnfb.f -text
-CEP/PyBDSM/src/port3/drmng.f -text
-CEP/PyBDSM/src/port3/drmngb.f -text
-CEP/PyBDSM/src/port3/drmnh.f -text
-CEP/PyBDSM/src/port3/drmnhb.f -text
-CEP/PyBDSM/src/port3/drn2g.f -text
-CEP/PyBDSM/src/port3/drn2gb.f -text
-CEP/PyBDSM/src/port3/drnsg.f -text
-CEP/PyBDSM/src/port3/drnsgb.f -text
-CEP/PyBDSM/src/port3/ds3grd.f -text
-CEP/PyBDSM/src/port3/ds7bqn.f -text
-CEP/PyBDSM/src/port3/ds7cpr.f -text
-CEP/PyBDSM/src/port3/ds7dmp.f -text
-CEP/PyBDSM/src/port3/ds7grd.f -text
-CEP/PyBDSM/src/port3/ds7ipr.f -text
-CEP/PyBDSM/src/port3/ds7lup.f -text
-CEP/PyBDSM/src/port3/ds7lvm.f -text
-CEP/PyBDSM/src/port3/dsm.f -text
-CEP/PyBDSM/src/port3/dsmnfb.f -text
-CEP/PyBDSM/src/port3/dttgrx1.f -text
-CEP/PyBDSM/src/port3/dttgrx1p.f -text
-CEP/PyBDSM/src/port3/dttgrx2.f -text
-CEP/PyBDSM/src/port3/dttgrx3.f -text
-CEP/PyBDSM/src/port3/dttgrx4.f -text
-CEP/PyBDSM/src/port3/dttgrx5.f -text
-CEP/PyBDSM/src/port3/dttgrx6.f -text
-CEP/PyBDSM/src/port3/dttgux1.f -text
-CEP/PyBDSM/src/port3/dttgux1p.f -text
-CEP/PyBDSM/src/port3/dttgux2.f -text
-CEP/PyBDSM/src/port3/dttgux3.f -text
-CEP/PyBDSM/src/port3/dttgux4.f -text
-CEP/PyBDSM/src/port3/dttgux5.f -text
-CEP/PyBDSM/src/port3/dv2axy.f -text
-CEP/PyBDSM/src/port3/dv2nrm.f -text
-CEP/PyBDSM/src/port3/dv7cpy.f -text
-CEP/PyBDSM/src/port3/dv7dfl.f -text
-CEP/PyBDSM/src/port3/dv7ipr.f -text
-CEP/PyBDSM/src/port3/dv7prm.f -text
-CEP/PyBDSM/src/port3/dv7scl.f -text
-CEP/PyBDSM/src/port3/dv7scp.f -text
-CEP/PyBDSM/src/port3/dv7shf.f -text
-CEP/PyBDSM/src/port3/dv7swp.f -text
-CEP/PyBDSM/src/port3/dv7vmp.f -text
-CEP/PyBDSM/src/port3/dw7zbf.f -text
-CEP/PyBDSM/src/port3/dxtrap.f -text
-CEP/PyBDSM/src/port3/dzero.f -text
-CEP/PyBDSM/src/port3/e9rint.f -text
-CEP/PyBDSM/src/port3/eigen.f -text
-CEP/PyBDSM/src/port3/enter.f -text
-CEP/PyBDSM/src/port3/entsrc.f -text
-CEP/PyBDSM/src/port3/eprint.f -text
-CEP/PyBDSM/src/port3/erroff.f -text
-CEP/PyBDSM/src/port3/ex/apnr.f -text
-CEP/PyBDSM/src/port3/ex/bura.f -text
-CEP/PyBDSM/src/port3/ex/burb.f -text
-CEP/PyBDSM/src/port3/ex/cdex.f -text
-CEP/PyBDSM/src/port3/ex/cdlg.f -text
-CEP/PyBDSM/src/port3/ex/cpla.f -text
-CEP/PyBDSM/src/port3/ex/cspa.f -text
-CEP/PyBDSM/src/port3/ex/cspe.f -text
-CEP/PyBDSM/src/port3/ex/cspg.f -text
-CEP/PyBDSM/src/port3/ex/cspq.f -text
-CEP/PyBDSM/src/port3/ex/ddea.f -text
-CEP/PyBDSM/src/port3/ex/desa.f -text
-CEP/PyBDSM/src/port3/ex/dpostx1.f -text
-CEP/PyBDSM/src/port3/ex/dpostx10.f -text
-CEP/PyBDSM/src/port3/ex/dpostx2.f -text
-CEP/PyBDSM/src/port3/ex/dpostx3.f -text
-CEP/PyBDSM/src/port3/ex/dpostx4.f -text
-CEP/PyBDSM/src/port3/ex/dpostx5.f -text
-CEP/PyBDSM/src/port3/ex/dpostx6.f -text
-CEP/PyBDSM/src/port3/ex/dpostx7.f -text
-CEP/PyBDSM/src/port3/ex/dpostx8.f -text
-CEP/PyBDSM/src/port3/ex/dpostx9.f -text
-CEP/PyBDSM/src/port3/ex/dpt1.f -text
-CEP/PyBDSM/src/port3/ex/dpt2.f -text
-CEP/PyBDSM/src/port3/ex/dpt3.f -text
-CEP/PyBDSM/src/port3/ex/dpt4.f -text
-CEP/PyBDSM/src/port3/ex/dpt5.f -text
-CEP/PyBDSM/src/port3/ex/dpt6.f -text
-CEP/PyBDSM/src/port3/ex/dpt7.f -text
-CEP/PyBDSM/src/port3/ex/dpt8.f -text
-CEP/PyBDSM/src/port3/ex/dpt9.f -text
-CEP/PyBDSM/src/port3/ex/dptt.f -text
-CEP/PyBDSM/src/port3/ex/dtg1.f -text
-CEP/PyBDSM/src/port3/ex/dtg2.f -text
-CEP/PyBDSM/src/port3/ex/dtg3.f -text
-CEP/PyBDSM/src/port3/ex/dtg4.f -text
-CEP/PyBDSM/src/port3/ex/dtg5.f -text
-CEP/PyBDSM/src/port3/ex/dtg6.f -text
-CEP/PyBDSM/src/port3/ex/dtgp.f -text
-CEP/PyBDSM/src/port3/ex/dttgrx1.f -text
-CEP/PyBDSM/src/port3/ex/dttgrx1p.f -text
-CEP/PyBDSM/src/port3/ex/dttgrx2.f -text
-CEP/PyBDSM/src/port3/ex/dttgrx3.f -text
-CEP/PyBDSM/src/port3/ex/dttgrx4.f -text
-CEP/PyBDSM/src/port3/ex/dttgrx5.f -text
-CEP/PyBDSM/src/port3/ex/dttgrx6.f -text
-CEP/PyBDSM/src/port3/ex/ebea.f -text
-CEP/PyBDSM/src/port3/ex/errk.f -text
-CEP/PyBDSM/src/port3/ex/evaa.f -text
-CEP/PyBDSM/src/port3/ex/extr.f -text
-CEP/PyBDSM/src/port3/ex/ffta -text
-CEP/PyBDSM/src/port3/ex/fftc -text
-CEP/PyBDSM/src/port3/ex/fmtr.f -text
-CEP/PyBDSM/src/port3/ex/ftra.f -text
-CEP/PyBDSM/src/port3/ex/ftrc.f -text
-CEP/PyBDSM/src/port3/ex/lbaa.f -text
-CEP/PyBDSM/src/port3/ex/lbab.f -text
-CEP/PyBDSM/src/port3/ex/lbaf.f -text
-CEP/PyBDSM/src/port3/ex/lbaj.f -text
-CEP/PyBDSM/src/port3/ex/lbak.f -text
-CEP/PyBDSM/src/port3/ex/lbal.f -text
-CEP/PyBDSM/src/port3/ex/lban.f -text
-CEP/PyBDSM/src/port3/ex/lbap.f -text
-CEP/PyBDSM/src/port3/ex/lgea.f -text
-CEP/PyBDSM/src/port3/ex/lgeb.f -text
-CEP/PyBDSM/src/port3/ex/lgef.f -text
-CEP/PyBDSM/src/port3/ex/lgeh.f -text
-CEP/PyBDSM/src/port3/ex/lgej.f -text
-CEP/PyBDSM/src/port3/ex/lgel.f -text
-CEP/PyBDSM/src/port3/ex/lgem.f -text
-CEP/PyBDSM/src/port3/ex/llza.f -text
-CEP/PyBDSM/src/port3/ex/lnab.f -text
-CEP/PyBDSM/src/port3/ex/lpsa.f -text
-CEP/PyBDSM/src/port3/ex/lpsb.f -text
-CEP/PyBDSM/src/port3/ex/lpsf.f -text
-CEP/PyBDSM/src/port3/ex/lpsg.f -text
-CEP/PyBDSM/src/port3/ex/lpsj.f -text
-CEP/PyBDSM/src/port3/ex/lpsk.f -text
-CEP/PyBDSM/src/port3/ex/lpsm.f -text
-CEP/PyBDSM/src/port3/ex/lrpa.f -text
-CEP/PyBDSM/src/port3/ex/lrpb.f -text
-CEP/PyBDSM/src/port3/ex/lrpe.f -text
-CEP/PyBDSM/src/port3/ex/lrpf.f -text
-CEP/PyBDSM/src/port3/ex/lrpg.f -text
-CEP/PyBDSM/src/port3/ex/lsfa.f -text
-CEP/PyBDSM/src/port3/ex/lyma.f -text
-CEP/PyBDSM/src/port3/ex/lymb.f -text
-CEP/PyBDSM/src/port3/ex/lymk.f -text
-CEP/PyBDSM/src/port3/ex/lymp.f -text
-CEP/PyBDSM/src/port3/ex/mfte.f -text
-CEP/PyBDSM/src/port3/ex/mftf.f -text
-CEP/PyBDSM/src/port3/ex/mftg.f -text
-CEP/PyBDSM/src/port3/ex/mllr.f -text
-CEP/PyBDSM/src/port3/ex/mnna.f -text
-CEP/PyBDSM/src/port3/ex/nlsa.f -text
-CEP/PyBDSM/src/port3/ex/nlsb.f -text
-CEP/PyBDSM/src/port3/ex/nlsj.f -text
-CEP/PyBDSM/src/port3/ex/nlsk.f -text
-CEP/PyBDSM/src/port3/ex/nlsp.f -text
-CEP/PyBDSM/src/port3/ex/nlsr.f -text
-CEP/PyBDSM/src/port3/ex/nmsk.f -text
-CEP/PyBDSM/src/port3/ex/np2a.f -text
-CEP/PyBDSM/src/port3/ex/np2b.f -text
-CEP/PyBDSM/src/port3/ex/np2e.f -text
-CEP/PyBDSM/src/port3/ex/np2f.f -text
-CEP/PyBDSM/src/port3/ex/nsfa.f -text
-CEP/PyBDSM/src/port3/ex/nsnm.f -text
-CEP/PyBDSM/src/port3/ex/ntle.f -text
-CEP/PyBDSM/src/port3/ex/ntlf.f -text
-CEP/PyBDSM/src/port3/ex/ntlh.f -text
-CEP/PyBDSM/src/port3/ex/ntlk.f -text
-CEP/PyBDSM/src/port3/ex/ntlm.f -text
-CEP/PyBDSM/src/port3/ex/ntlp.f -text
-CEP/PyBDSM/src/port3/ex/ntlr.f -text
-CEP/PyBDSM/src/port3/ex/ntlt.f -text
-CEP/PyBDSM/src/port3/ex/ntlu.f -text
-CEP/PyBDSM/src/port3/ex/pdea.f -text
-CEP/PyBDSM/src/port3/ex/pdew.f -text
-CEP/PyBDSM/src/port3/ex/postx1.f -text
-CEP/PyBDSM/src/port3/ex/postx10.f -text
-CEP/PyBDSM/src/port3/ex/postx2.f -text
-CEP/PyBDSM/src/port3/ex/postx3.f -text
-CEP/PyBDSM/src/port3/ex/postx4.f -text
-CEP/PyBDSM/src/port3/ex/postx5.f -text
-CEP/PyBDSM/src/port3/ex/postx6.f -text
-CEP/PyBDSM/src/port3/ex/postx7.f -text
-CEP/PyBDSM/src/port3/ex/postx8.f -text
-CEP/PyBDSM/src/port3/ex/postx9.f -text
-CEP/PyBDSM/src/port3/ex/prea.f -text
-CEP/PyBDSM/src/port3/ex/prma.f -text
-CEP/PyBDSM/src/port3/ex/prs1.f -text
-CEP/PyBDSM/src/port3/ex/prs3.f -text
-CEP/PyBDSM/src/port3/ex/prsa.f -text
-CEP/PyBDSM/src/port3/ex/prsf.f -text
-CEP/PyBDSM/src/port3/ex/prsj.f -text
-CEP/PyBDSM/src/port3/ex/prsm.f -text
-CEP/PyBDSM/src/port3/ex/prsp.f -text
-CEP/PyBDSM/src/port3/ex/prst.f -text
-CEP/PyBDSM/src/port3/ex/prsy.f -text
-CEP/PyBDSM/src/port3/ex/prsz.f -text
-CEP/PyBDSM/src/port3/ex/pst1.f -text
-CEP/PyBDSM/src/port3/ex/pst2.f -text
-CEP/PyBDSM/src/port3/ex/pst3.f -text
-CEP/PyBDSM/src/port3/ex/pst4.f -text
-CEP/PyBDSM/src/port3/ex/pst5.f -text
-CEP/PyBDSM/src/port3/ex/pst6.f -text
-CEP/PyBDSM/src/port3/ex/pst7.f -text
-CEP/PyBDSM/src/port3/ex/pst8.f -text
-CEP/PyBDSM/src/port3/ex/pst9.f -text
-CEP/PyBDSM/src/port3/ex/pstt.f -text
-CEP/PyBDSM/src/port3/ex/qbla.f -text
-CEP/PyBDSM/src/port3/ex/qblc.f -text
-CEP/PyBDSM/src/port3/ex/qblg.f -text
-CEP/PyBDSM/src/port3/ex/qgsg.f -text
-CEP/PyBDSM/src/port3/ex/qgsh.f -text
-CEP/PyBDSM/src/port3/ex/qgsj.f -text
-CEP/PyBDSM/src/port3/ex/qgsm.f -text
-CEP/PyBDSM/src/port3/ex/qgsp.f -text
-CEP/PyBDSM/src/port3/ex/qgsr.f -text
-CEP/PyBDSM/src/port3/ex/qgst.f -text
-CEP/PyBDSM/src/port3/ex/qodd.f -text
-CEP/PyBDSM/src/port3/ex/qpra.f -text
-CEP/PyBDSM/src/port3/ex/ranc.f -text
-CEP/PyBDSM/src/port3/ex/rnrm.f -text
-CEP/PyBDSM/src/port3/ex/rpad.f -text
-CEP/PyBDSM/src/port3/ex/sdba.f -text
-CEP/PyBDSM/src/port3/ex/splf.f -text
-CEP/PyBDSM/src/port3/ex/ttg1.f -text
-CEP/PyBDSM/src/port3/ex/ttg2.f -text
-CEP/PyBDSM/src/port3/ex/ttg3.f -text
-CEP/PyBDSM/src/port3/ex/ttg4.f -text
-CEP/PyBDSM/src/port3/ex/ttg5.f -text
-CEP/PyBDSM/src/port3/ex/ttg6.f -text
-CEP/PyBDSM/src/port3/ex/ttgp.f -text
-CEP/PyBDSM/src/port3/ex/ttgrx1.f -text
-CEP/PyBDSM/src/port3/ex/ttgrx1p.f -text
-CEP/PyBDSM/src/port3/ex/ttgrx2.f -text
-CEP/PyBDSM/src/port3/ex/ttgrx3.f -text
-CEP/PyBDSM/src/port3/ex/ttgrx4.f -text
-CEP/PyBDSM/src/port3/ex/ttgrx5.f -text
-CEP/PyBDSM/src/port3/ex/ttgrx6.f -text
-CEP/PyBDSM/src/port3/ex/vdsa.f -text
-CEP/PyBDSM/src/port3/ex/vdsb.f -text
-CEP/PyBDSM/src/port3/ex/vdse.f -text
-CEP/PyBDSM/src/port3/ex/xkhd.f -text
-CEP/PyBDSM/src/port3/ex/xkhi.f -text
-CEP/PyBDSM/src/port3/ex/xkt.f -text
-CEP/PyBDSM/src/port3/ex/xkth -text
-CEP/PyBDSM/src/port3/ex/zap.ed -text
-CEP/PyBDSM/src/port3/ex/zap.ex -text
-CEP/PyBDSM/src/port3/ex/zap.head -text
-CEP/PyBDSM/src/port3/ex/zap.t -text
-CEP/PyBDSM/src/port3/ex/zera.f -text
-CEP/PyBDSM/src/port3/ex/zip.ed -text
-CEP/PyBDSM/src/port3/ex/zona.f -text
-CEP/PyBDSM/src/port3/ex/zonb.f -text
-CEP/PyBDSM/src/port3/f7dhb.f -text
-CEP/PyBDSM/src/port3/f7hes.f -text
-CEP/PyBDSM/src/port3/fdump.f -text
-CEP/PyBDSM/src/port3/frmatd.f -text
-CEP/PyBDSM/src/port3/frmati.f -text
-CEP/PyBDSM/src/port3/frmatr.f -text
-CEP/PyBDSM/src/port3/g7itb.f -text
-CEP/PyBDSM/src/port3/g7lit.f -text
-CEP/PyBDSM/src/port3/g7qsb.f -text
-CEP/PyBDSM/src/port3/g7qts.f -text
-CEP/PyBDSM/src/port3/h2rfa.f -text
-CEP/PyBDSM/src/port3/h2rfg.f -text
-CEP/PyBDSM/src/port3/hqr2.f -text
-CEP/PyBDSM/src/port3/i0tk00.f -text
-CEP/PyBDSM/src/port3/i0tk01.f -text
-CEP/PyBDSM/src/port3/i10wid.f -text
-CEP/PyBDSM/src/port3/i1mach.f -text
-CEP/PyBDSM/src/port3/i7copy.f -text
-CEP/PyBDSM/src/port3/i7do.f -text
-CEP/PyBDSM/src/port3/i7mdcn.f -text
-CEP/PyBDSM/src/port3/i7pnvr.f -text
-CEP/PyBDSM/src/port3/i7shft.f -text
-CEP/PyBDSM/src/port3/i8save.f -text
-CEP/PyBDSM/src/port3/i8tsel.f -text
-CEP/PyBDSM/src/port3/ialloc.f -text
-CEP/PyBDSM/src/port3/iceil.f -text
-CEP/PyBDSM/src/port3/iflr.f -text
-CEP/PyBDSM/src/port3/istkgt.f -text
-CEP/PyBDSM/src/port3/istkin.f -text
-CEP/PyBDSM/src/port3/istkmd.f -text
-CEP/PyBDSM/src/port3/istkqu.f -text
-CEP/PyBDSM/src/port3/istkrl.f -text
-CEP/PyBDSM/src/port3/istkst.f -text
-CEP/PyBDSM/src/port3/itsum.f -text
-CEP/PyBDSM/src/port3/ivset.f -text
-CEP/PyBDSM/src/port3/l5stp.f -text
-CEP/PyBDSM/src/port3/l7itv.f -text
-CEP/PyBDSM/src/port3/l7ivm.f -text
-CEP/PyBDSM/src/port3/l7msb.f -text
-CEP/PyBDSM/src/port3/l7mst.f -text
-CEP/PyBDSM/src/port3/l7nvr.f -text
-CEP/PyBDSM/src/port3/l7sqr.f -text
-CEP/PyBDSM/src/port3/l7srt.f -text
-CEP/PyBDSM/src/port3/l7svn.f -text
-CEP/PyBDSM/src/port3/l7svx.f -text
-CEP/PyBDSM/src/port3/l7tsq.f -text
-CEP/PyBDSM/src/port3/l7tvm.f -text
-CEP/PyBDSM/src/port3/l7upd.f -text
-CEP/PyBDSM/src/port3/l7vml.f -text
-CEP/PyBDSM/src/port3/leave.f -text
-CEP/PyBDSM/src/port3/m7seq.f -text
-CEP/PyBDSM/src/port3/m7slo.f -text
-CEP/PyBDSM/src/port3/mnf.f -text
-CEP/PyBDSM/src/port3/mnfb.f -text
-CEP/PyBDSM/src/port3/mng.f -text
-CEP/PyBDSM/src/port3/mngb.f -text
-CEP/PyBDSM/src/port3/mnh.f -text
-CEP/PyBDSM/src/port3/mnhb.f -text
-CEP/PyBDSM/src/port3/movebc.f -text
-CEP/PyBDSM/src/port3/movebd.f -text
-CEP/PyBDSM/src/port3/movebi.f -text
-CEP/PyBDSM/src/port3/movebl.f -text
-CEP/PyBDSM/src/port3/movebr.f -text
-CEP/PyBDSM/src/port3/movefc.f -text
-CEP/PyBDSM/src/port3/movefd.f -text
-CEP/PyBDSM/src/port3/movefi.f -text
-CEP/PyBDSM/src/port3/movefl.f -text
-CEP/PyBDSM/src/port3/movefr.f -text
-CEP/PyBDSM/src/port3/mtstak.f -text
-CEP/PyBDSM/src/port3/n2cvp.f -text
-CEP/PyBDSM/src/port3/n2f.f -text
-CEP/PyBDSM/src/port3/n2fb.f -text
-CEP/PyBDSM/src/port3/n2g.f -text
-CEP/PyBDSM/src/port3/n2gb.f -text
-CEP/PyBDSM/src/port3/n2lrd.f -text
-CEP/PyBDSM/src/port3/n2p.f -text
-CEP/PyBDSM/src/port3/n2pb.f -text
-CEP/PyBDSM/src/port3/n2rdp.f -text
-CEP/PyBDSM/src/port3/n7msrt.f -text
-CEP/PyBDSM/src/port3/nerror.f -text
-CEP/PyBDSM/src/port3/nirall.f -text
-CEP/PyBDSM/src/port3/nsf.f -text
-CEP/PyBDSM/src/port3/nsfb.f -text
-CEP/PyBDSM/src/port3/nsg.f -text
-CEP/PyBDSM/src/port3/nsgb.f -text
-CEP/PyBDSM/src/port3/o7prd.f -text
-CEP/PyBDSM/src/port3/orthe.f -text
-CEP/PyBDSM/src/port3/ortra.f -text
-CEP/PyBDSM/src/port3/parck.f -text
-CEP/PyBDSM/src/port3/postx1.f -text
-CEP/PyBDSM/src/port3/postx10.f -text
-CEP/PyBDSM/src/port3/postx2.f -text
-CEP/PyBDSM/src/port3/postx3.f -text
-CEP/PyBDSM/src/port3/postx4.f -text
-CEP/PyBDSM/src/port3/postx5.f -text
-CEP/PyBDSM/src/port3/postx6.f -text
-CEP/PyBDSM/src/port3/postx7.f -text
-CEP/PyBDSM/src/port3/postx8.f -text
-CEP/PyBDSM/src/port3/postx9.f -text
-CEP/PyBDSM/src/port3/q7apl.f -text
-CEP/PyBDSM/src/port3/q7rad.f -text
-CEP/PyBDSM/src/port3/q7rfh.f -text
-CEP/PyBDSM/src/port3/q7rsh.f -text
-CEP/PyBDSM/src/port3/r1mach.f -text
-CEP/PyBDSM/src/port3/r7mdc.f -text
-CEP/PyBDSM/src/port3/r7tvm.f -text
-CEP/PyBDSM/src/port3/retsrc.f -text
-CEP/PyBDSM/src/port3/rldst.f -text
-CEP/PyBDSM/src/port3/rmnf.f -text
-CEP/PyBDSM/src/port3/rmnfb.f -text
-CEP/PyBDSM/src/port3/rmng.f -text
-CEP/PyBDSM/src/port3/rmngb.f -text
-CEP/PyBDSM/src/port3/rmnh.f -text
-CEP/PyBDSM/src/port3/rmnhb.f -text
-CEP/PyBDSM/src/port3/rn2g.f -text
-CEP/PyBDSM/src/port3/rn2gb.f -text
-CEP/PyBDSM/src/port3/rnsg.f -text
-CEP/PyBDSM/src/port3/rnsgb.f -text
-CEP/PyBDSM/src/port3/s1mach.f -text
-CEP/PyBDSM/src/port3/s2mach.f -text
-CEP/PyBDSM/src/port3/s3grd.f -text
-CEP/PyBDSM/src/port3/s3mach.f -text
-CEP/PyBDSM/src/port3/s7bqn.f -text
-CEP/PyBDSM/src/port3/s7cpr.f -text
-CEP/PyBDSM/src/port3/s7dmp.f -text
-CEP/PyBDSM/src/port3/s7etr.f -text
-CEP/PyBDSM/src/port3/s7grd.f -text
-CEP/PyBDSM/src/port3/s7ipr.f -text
-CEP/PyBDSM/src/port3/s7lup.f -text
-CEP/PyBDSM/src/port3/s7lvm.f -text
-CEP/PyBDSM/src/port3/s7rtdt.f -text
-CEP/PyBDSM/src/port3/s88fmt.f -text
-CEP/PyBDSM/src/port3/sdump.f -text
-CEP/PyBDSM/src/port3/setc.f -text
-CEP/PyBDSM/src/port3/setd.f -text
-CEP/PyBDSM/src/port3/seterr.f -text
-CEP/PyBDSM/src/port3/seti.f -text
-CEP/PyBDSM/src/port3/setl.f -text
-CEP/PyBDSM/src/port3/setr.f -text
-CEP/PyBDSM/src/port3/smnfb.f -text
-CEP/PyBDSM/src/port3/srecap.f -text
-CEP/PyBDSM/src/port3/stinit.f -text
-CEP/PyBDSM/src/port3/stkdmp.f -text
-CEP/PyBDSM/src/port3/stopx.f -text
-CEP/PyBDSM/src/port3/ttgrx1.f -text
-CEP/PyBDSM/src/port3/ttgrx1p.f -text
-CEP/PyBDSM/src/port3/ttgrx2.f -text
-CEP/PyBDSM/src/port3/ttgrx3.f -text
-CEP/PyBDSM/src/port3/ttgrx4.f -text
-CEP/PyBDSM/src/port3/ttgrx5.f -text
-CEP/PyBDSM/src/port3/ttgrx6.f -text
-CEP/PyBDSM/src/port3/ttgux1.f -text
-CEP/PyBDSM/src/port3/ttgux1p.f -text
-CEP/PyBDSM/src/port3/ttgux2.f -text
-CEP/PyBDSM/src/port3/ttgux3.f -text
-CEP/PyBDSM/src/port3/ttgux4.f -text
-CEP/PyBDSM/src/port3/ttgux5.f -text
-CEP/PyBDSM/src/port3/u9dmp.f -text
-CEP/PyBDSM/src/port3/v2axy.f -text
-CEP/PyBDSM/src/port3/v2nrm.f -text
-CEP/PyBDSM/src/port3/v7cpy.f -text
-CEP/PyBDSM/src/port3/v7dfl.f -text
-CEP/PyBDSM/src/port3/v7ipr.f -text
-CEP/PyBDSM/src/port3/v7prm.f -text
-CEP/PyBDSM/src/port3/v7scl.f -text
-CEP/PyBDSM/src/port3/v7scp.f -text
-CEP/PyBDSM/src/port3/v7shf.f -text
-CEP/PyBDSM/src/port3/v7swp.f -text
-CEP/PyBDSM/src/port3/v7vmp.f -text
-CEP/PyBDSM/src/port3/w7zbf.f -text
-CEP/PyBDSM/src/port3/xtrap.f -text
-CEP/PyBDSM/src/port3/zero.f -text
-CEP/PyBDSM/src/python/multi_proc.py -text
+CEP/PyBDSM/__init__.py -text
+CEP/PyBDSM/test/setpythonpath.run_tmpl -text
CEP/PyBDSM/test/tbdsm_process_image.in -text
CEP/PyBDSM/test/tbdsm_process_image.in_fits -text svneol=unset#image/x-fits
CEP/PyBDSM/test/tbdsm_process_image.py -text
@@ -2367,6 +1763,7 @@ Docker/lofar-base/chuser.sh -text
Docker/lofar-outputproc/Dockerfile.tmpl -text
Docker/lofar-pipeline/Dockerfile.tmpl -text
Docker/lofar-pipeline/bashrc.d/10-aoflagger -text
+Docker/lofar-pipeline/bashrc.d/11-pybdsf -text
Docker/lofar-pulp/Dockerfile.tmpl -text
Docker/lofar-pulp/bashrc -text
Docker/lofar-pulp/sudoers -text
diff --git a/CEP/PyBDSM/CMakeLists.txt b/CEP/PyBDSM/CMakeLists.txt
index ee7f507c036696c05a3a5ca86b33ec1ed3a317c1..4df41a77d88e16b7b47bb7a5d822d18f19fb4b97 100644
--- a/CEP/PyBDSM/CMakeLists.txt
+++ b/CEP/PyBDSM/CMakeLists.txt
@@ -1,12 +1,13 @@
# $Id$
lofar_package(PyBDSM 1.0)
-enable_language(Fortran)
-include(LofarFindPackage)
-lofar_find_package(Boost REQUIRED COMPONENTS python)
-lofar_find_package(Python 2.6 REQUIRED)
-lofar_find_package(Numpy REQUIRED)
+include(PythonInstall)
-add_subdirectory(src)
+python_install(
+ __init__.py
+ DESTINATION lofar/bdsm)
+
+include(FindPythonModule)
+find_python_module(bdsf REQUIRED HINTS ${BDSF_ROOT_DIR})
add_subdirectory(test)
diff --git a/CEP/PyBDSM/__init__.py b/CEP/PyBDSM/__init__.py
new file mode 100644
index 0000000000000000000000000000000000000000..f74ce05f96e4747d2cc43ab745d834d93b51cdea
--- /dev/null
+++ b/CEP/PyBDSM/__init__.py
@@ -0,0 +1,6 @@
+# Backward compatibility, so that import lofar.bdsm will still work
+
+import sys
+import bdsf
+
+sys.modules[__name__] = sys.modules["bdsf"]
diff --git a/CEP/PyBDSM/doc/CMakeLists.txt b/CEP/PyBDSM/doc/CMakeLists.txt
deleted file mode 100644
index 5028478d8a026c654a8eecfad9bfc376b516cb0e..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/doc/CMakeLists.txt
+++ /dev/null
@@ -1,15 +0,0 @@
-find_package(Sphinx REQUIRED)
-
-# configured documentation tools and intermediate build results
-set(BINARY_BUILD_DIR "${CMAKE_CURRENT_BINARY_DIR}/_build")
-
-# Sphinx cache with pickled ReST documents
-set(SPHINX_CACHE_DIR "${CMAKE_CURRENT_BINARY_DIR}/_doctrees")
-
-set(SPHINX_SOURCE_DIR "${CMAKE_CURRENT_SOURCE_DIR}/source")
-
-# HTML output directory
-set(SPHINX_HTML_DIR "${CMAKE_CURRENT_BINARY_DIR}/html")
-
-add_custom_target(bdsm_doc ALL
- ${SPHINX_EXECUTABLE} -q -b html -d "${SPHINX_CACHE_DIR}" "${SPHINX_SOURCE_DIR}" "${SPHINX_HTML_DIR}")
\ No newline at end of file
diff --git a/CEP/PyBDSM/doc/Makefile b/CEP/PyBDSM/doc/Makefile
deleted file mode 100644
index 04333e4bb8ac0e2776f6aa2df04ce81fc71ca1cb..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/doc/Makefile
+++ /dev/null
@@ -1,153 +0,0 @@
-# Makefile for Sphinx documentation
-#
-
-# You can set these variables from the command line.
-SPHINXOPTS =
-SPHINXBUILD = sphinx-build
-PAPER =
-BUILDDIR = build
-
-# Internal variables.
-PAPEROPT_a4 = -D latex_paper_size=a4
-PAPEROPT_letter = -D latex_paper_size=letter
-ALLSPHINXOPTS = -d $(BUILDDIR)/doctrees $(PAPEROPT_$(PAPER)) $(SPHINXOPTS) source
-# the i18n builder cannot share the environment and doctrees with the others
-I18NSPHINXOPTS = $(PAPEROPT_$(PAPER)) $(SPHINXOPTS) source
-
-.PHONY: help clean html dirhtml singlehtml pickle json htmlhelp qthelp devhelp epub latex latexpdf text man changes linkcheck doctest gettext
-
-help:
- @echo "Please use \`make <target>' where <target> is one of"
- @echo " html to make standalone HTML files"
- @echo " dirhtml to make HTML files named index.html in directories"
- @echo " singlehtml to make a single large HTML file"
- @echo " pickle to make pickle files"
- @echo " json to make JSON files"
- @echo " htmlhelp to make HTML files and a HTML help project"
- @echo " qthelp to make HTML files and a qthelp project"
- @echo " devhelp to make HTML files and a Devhelp project"
- @echo " epub to make an epub"
- @echo " latex to make LaTeX files, you can set PAPER=a4 or PAPER=letter"
- @echo " latexpdf to make LaTeX files and run them through pdflatex"
- @echo " text to make text files"
- @echo " man to make manual pages"
- @echo " texinfo to make Texinfo files"
- @echo " info to make Texinfo files and run them through makeinfo"
- @echo " gettext to make PO message catalogs"
- @echo " changes to make an overview of all changed/added/deprecated items"
- @echo " linkcheck to check all external links for integrity"
- @echo " doctest to run all doctests embedded in the documentation (if enabled)"
-
-clean:
- -rm -rf $(BUILDDIR)/*
-
-html:
- $(SPHINXBUILD) -b html $(ALLSPHINXOPTS) $(BUILDDIR)/html
- @echo
- @echo "Build finished. The HTML pages are in $(BUILDDIR)/html."
-
-dirhtml:
- $(SPHINXBUILD) -b dirhtml $(ALLSPHINXOPTS) $(BUILDDIR)/dirhtml
- @echo
- @echo "Build finished. The HTML pages are in $(BUILDDIR)/dirhtml."
-
-singlehtml:
- $(SPHINXBUILD) -b singlehtml $(ALLSPHINXOPTS) $(BUILDDIR)/singlehtml
- @echo
- @echo "Build finished. The HTML page is in $(BUILDDIR)/singlehtml."
-
-pickle:
- $(SPHINXBUILD) -b pickle $(ALLSPHINXOPTS) $(BUILDDIR)/pickle
- @echo
- @echo "Build finished; now you can process the pickle files."
-
-json:
- $(SPHINXBUILD) -b json $(ALLSPHINXOPTS) $(BUILDDIR)/json
- @echo
- @echo "Build finished; now you can process the JSON files."
-
-htmlhelp:
- $(SPHINXBUILD) -b htmlhelp $(ALLSPHINXOPTS) $(BUILDDIR)/htmlhelp
- @echo
- @echo "Build finished; now you can run HTML Help Workshop with the" \
- ".hhp project file in $(BUILDDIR)/htmlhelp."
-
-qthelp:
- $(SPHINXBUILD) -b qthelp $(ALLSPHINXOPTS) $(BUILDDIR)/qthelp
- @echo
- @echo "Build finished; now you can run "qcollectiongenerator" with the" \
- ".qhcp project file in $(BUILDDIR)/qthelp, like this:"
- @echo "# qcollectiongenerator $(BUILDDIR)/qthelp/PyBDSM.qhcp"
- @echo "To view the help file:"
- @echo "# assistant -collectionFile $(BUILDDIR)/qthelp/PyBDSM.qhc"
-
-devhelp:
- $(SPHINXBUILD) -b devhelp $(ALLSPHINXOPTS) $(BUILDDIR)/devhelp
- @echo
- @echo "Build finished."
- @echo "To view the help file:"
- @echo "# mkdir -p $$HOME/.local/share/devhelp/PyBDSM"
- @echo "# ln -s $(BUILDDIR)/devhelp $$HOME/.local/share/devhelp/PyBDSM"
- @echo "# devhelp"
-
-epub:
- $(SPHINXBUILD) -b epub $(ALLSPHINXOPTS) $(BUILDDIR)/epub
- @echo
- @echo "Build finished. The epub file is in $(BUILDDIR)/epub."
-
-latex:
- $(SPHINXBUILD) -b latex $(ALLSPHINXOPTS) $(BUILDDIR)/latex
- @echo
- @echo "Build finished; the LaTeX files are in $(BUILDDIR)/latex."
- @echo "Run \`make' in that directory to run these through (pdf)latex" \
- "(use \`make latexpdf' here to do that automatically)."
-
-latexpdf:
- $(SPHINXBUILD) -b latex $(ALLSPHINXOPTS) $(BUILDDIR)/latex
- @echo "Running LaTeX files through pdflatex..."
- $(MAKE) -C $(BUILDDIR)/latex all-pdf
- @echo "pdflatex finished; the PDF files are in $(BUILDDIR)/latex."
-
-text:
- $(SPHINXBUILD) -b text $(ALLSPHINXOPTS) $(BUILDDIR)/text
- @echo
- @echo "Build finished. The text files are in $(BUILDDIR)/text."
-
-man:
- $(SPHINXBUILD) -b man $(ALLSPHINXOPTS) $(BUILDDIR)/man
- @echo
- @echo "Build finished. The manual pages are in $(BUILDDIR)/man."
-
-texinfo:
- $(SPHINXBUILD) -b texinfo $(ALLSPHINXOPTS) $(BUILDDIR)/texinfo
- @echo
- @echo "Build finished. The Texinfo files are in $(BUILDDIR)/texinfo."
- @echo "Run \`make' in that directory to run these through makeinfo" \
- "(use \`make info' here to do that automatically)."
-
-info:
- $(SPHINXBUILD) -b texinfo $(ALLSPHINXOPTS) $(BUILDDIR)/texinfo
- @echo "Running Texinfo files through makeinfo..."
- make -C $(BUILDDIR)/texinfo info
- @echo "makeinfo finished; the Info files are in $(BUILDDIR)/texinfo."
-
-gettext:
- $(SPHINXBUILD) -b gettext $(I18NSPHINXOPTS) $(BUILDDIR)/locale
- @echo
- @echo "Build finished. The message catalogs are in $(BUILDDIR)/locale."
-
-changes:
- $(SPHINXBUILD) -b changes $(ALLSPHINXOPTS) $(BUILDDIR)/changes
- @echo
- @echo "The overview file is in $(BUILDDIR)/changes."
-
-linkcheck:
- $(SPHINXBUILD) -b linkcheck $(ALLSPHINXOPTS) $(BUILDDIR)/linkcheck
- @echo
- @echo "Link check complete; look for any errors in the above output " \
- "or in $(BUILDDIR)/linkcheck/output.txt."
-
-doctest:
- $(SPHINXBUILD) -b doctest $(ALLSPHINXOPTS) $(BUILDDIR)/doctest
- @echo "Testing of doctests in the sources finished, look at the " \
- "results in $(BUILDDIR)/doctest/output.txt."
diff --git a/CEP/PyBDSM/doc/anaamika_overview.doc b/CEP/PyBDSM/doc/anaamika_overview.doc
deleted file mode 100644
index a93c36d12f2c14705b7ebef354ad3dc8d14aa863..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/doc/anaamika_overview.doc
+++ /dev/null
@@ -1,68 +0,0 @@
-
-//_______________________________________________________________________________
-// Description of source code tree
-
-/*!
- \page Anaamika Anaamika
- \defgroup Anaamika Anaamika - Blob Detection and Source Measurement
-
- The current version of BDSM is the Python version PyBDSM. It is currently maintained and developed at Sterrewacht Leiden.
-
- \section anaamika_code_tree Organiation of the source code
-
- The diagram below show the basic organisation of the source code directories:
-
- \verbatim
- lofarsoft
- |-- data
- |-- doc
- |-- release
- |-- build
- |-- devel_common
- |-- external
- `-- src
- |-- contrib
- |-- CR-Tools
- |-- DAL
- `-- Anaamika <-- Project top-level directory
- |-- implement
- | |-- fBDSM
- | |-- fits
- | |-- shaplelets
- | `-- PyBDSM
- |-- apps
- |-- data
- |-- doc
- `-- scripts
- \endverbatim
-
- In this:
-
- <ul>
- <li>\c implement contains source code from which a library or a set of
- libraries is build. The generic substructure is
- \verbatim
- implement
- |-- Module1
- |-- Module2
- |
- `-- ModuleN
- \endverbatim
- which allows for the creation of multiple smaller library (one per module),
- as well as the creation of a single library based on the contents of the
- various modules.
- <li>\c apps contains application executables, typically C/C++ (or Fortran)
- sources which are compile into a stand-alone program; most of the types
- these source will link again the library created from the sources contained
- in \c implement.
- <li>\c scripts contains (shell) scripts. Depending one the point of view,
- this also might be considerated the location for Python scripts, when
- drawing the line between code being executed in a dynamic environment and
- code resulting in a static executable originating from a compiled source.
- <li>\c doc contains all sorts of documentation -- user manual, reference
- manuals -- but also additional sources (such as this file) processed by
- Doxygen.
- </ul>
-
-*/
-
diff --git a/CEP/PyBDSM/doc/source/HydraA_74MHz_fit.png b/CEP/PyBDSM/doc/source/HydraA_74MHz_fit.png
deleted file mode 100644
index 9d4cc728a0e39de861166e8b47e7b339a82f6dc4..0000000000000000000000000000000000000000
Binary files a/CEP/PyBDSM/doc/source/HydraA_74MHz_fit.png and /dev/null differ
diff --git a/CEP/PyBDSM/doc/source/_templates/searchbox.html b/CEP/PyBDSM/doc/source/_templates/searchbox.html
deleted file mode 100644
index 5899a99386a7af32caef158b19909e6e781b19ad..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/doc/source/_templates/searchbox.html
+++ /dev/null
@@ -1,24 +0,0 @@
-{#
- basic/searchbox.html
- ~~~~~~~~~~~~~~~~~~~~
-
- Sphinx sidebar template: quick search box.
-
- :copyright: Copyright 2007-2011 by the Sphinx team, see AUTHORS.
- :license: BSD, see LICENSE for details.
-#}
-{%- if pagename != "search" %}
-<div id="searchbox" style="display: none">
- <h3>{{ _('Quick search') }}</h3>
- <form class="search" action="{{ pathto('search') }}" method="get">
- <input type="text" name="q" />
- <input type="submit" value="{{ _('Go') }}" />
- <input type="hidden" name="check_keywords" value="yes" />
- <input type="hidden" name="area" value="default" />
- </form>
- <p class="searchtip" style="font-size: 90%">
- {{ _('Enter search terms or a command, task, or parameter name.') }}
- </p>
-</div>
-<script type="text/javascript">$('#searchbox').show(0);</script>
-{%- endif %}
diff --git a/CEP/PyBDSM/doc/source/algorithms.rst b/CEP/PyBDSM/doc/source/algorithms.rst
deleted file mode 100644
index 1f2ae7499e59a87ebe362e2b841688fcc42e7410..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/doc/source/algorithms.rst
+++ /dev/null
@@ -1,92 +0,0 @@
-.. _algorithms:
-
-Determining whether an image is confused
-----------------------------------------
-The number of beams per source (if not set with the :term:`bmpersrc_th` parameter) is calculated by assuming the number of sources in the
-image, :math:`N_s`, as:
-
-.. math::
-
- N_s = (\text{No. pixels} > 5\sigma)/(<\text{pix/src}>),
-
-where the average number of pixels per source, :math:`<pix/src>`, is given by:
-
-.. math::
-
- 2\pi \sigma_{\text{major}} \sigma_{\text{minor}} \times (\ln(S_{\text{min}}/5\sigma) - 1/(\alpha - 1)),
-
-where :math:`\alpha` is the slope of the differential source counts taken from Katgert et al. (1988) [#f1]_. Assuming
-a minimum of one pixel to define a source and ignoring the effect of noise for sources close to
-the threshold, we can ignore the logarithmic term and hence :math:`\text{bmpersrc\_th} = (n\times m)/(\text{No. pixels} > 5\sigma)/(\alpha-1))`. The value of :term:`bmpersrc_th` is used to decide whether
-the image is expected to be confused (and if so, the mean image is taken to be zero) and also
-to estimate the box size for calculating the rms image (see below).
-
-Calculation of mean and rms maps
---------------------------------
-The box size and step size for calculating the rms image are estimated as follows (if not set by the :term:`rms_box` parameter).
-Typical intersource seperation, :math:`s_1`, is :math:`2\sqrt{\text{bmpersrc\_th}} \times B_{\text{major}}`.
-The size of brightest source, :math:`s_{\text{max}}`, is :math:`2 B_{\text{major}} \times \sqrt{[2\ln(Max_{\text{flux}}/threshold)]}`. Lastly, the maximum dimension of the largest island, :math:`s_{\text{isl}}`, defined at 10--20 sigma above the clipped rms is also found.
-The box size is estimated as the larger of the quantities :math:`s_1`, :math:`s_{\text{max}}`, and :math:`s_{\text{isl}}`. The step size is then calculated as the minimum of a third of the box size and a tenth of the smallest image dimension. These prescriptions yield
-reasonable numbers for the images tested.
-
-Either the calculated rms image or a constant rms is used for subsequent analysis based on
-whether the dispersion in the rms image is consistent with, or is higher than, the expected
-statistics. Hence if the dispersion of the rms image is higher than 1.1 times the (clipped) rms of
-the image times the inverse of :math:`\sqrt{2} \times Boxsize_{\text{pixels}}` then the rms image is taken. Otherwise, the constant
-value of the clipped rms is used.
-
-Gaussian fitting
-----------------
-The current procedure for calculating the number of Gaussians to be fit simultaneously to an
-island is as follows. First, the number of Gaussians is identified with the number of distinct
-peaks (higher than the pixel threshold) of emission inside the island (negative gradient in all 8
-directions). These peaks are CLEANed from the subimage assuming the theoretical beam. If
-the (unclipped) rms of the residual subimage is greater than the (clipped) rms in the region,
-the maximum pixel in the residue is greater than the threshold for this former rms, and is
-located at least 0.5 beams (and :math:`\sqrt{5}` pixels) away from all previous peaks, then this residual
-peak is identified as a new one.
-
-.. _grouping:
-
-Grouping of Gaussians into sources
-----------------------------------
-Inside each island, groups of Gaussians are deemed to be a part of the same source if:
-
- 1. no pixel on the line joining the centers of any pair of Gaussians has a (Gaussian-reconstructed) value less than the island threshold, and
- 2. the centers are separated by a distance less than half the sum of their FWHMs along the line joining them.
-
-Once the Gaussians that belong to a source are identified, fluxes for the grouped Gaussians are summed to obtain the total flux of the source. The uncertainty on the total flux is calculated by summing the uncertainties on the total fluxes of the individual Gaussians in quadrature. The source RA and Dec position is set to the source centroid determined from moment analysis (the position of the maximum of the source is also calculated). The total source size is also measured using moment analysis (see http://en.wikipedia.org/wiki/Image_moment for an overview of moment analysis).
-
-.. _colorcorrections:
-
-Effect of neglecting color corrections
---------------------------------------
-No color correction is performed when averaging channels. However, as is shown below, errors in the derived parameters are generally small unless the averaged bandwidth is large.
-
-.. figure:: colourcorr_full.png
- :scale: 80 %
- :figwidth: 75 %
- :align: center
- :alt: color correction errors
-
- The correction in frequency in kHz as a function of the frequency resulting from averaging *n* channels each of bandwidth *bw*, for sources with various spectral indices :math:`-1.3 < \alpha < -0.3`.
-
-.. figure:: colourcorr_order1-2.png
- :scale: 80 %
- :figwidth: 75 %
- :align: center
- :alt: color correction errors
-
- The error induced in the frequency by not including the 2nd order term, due to the colour correction of an individual channel, in Hz.
-
-.. figure:: colourcorr_delta_spin.png
- :scale: 80 %
- :figwidth: 75 %
- :align: center
- :alt: color correction errors
-
- The fractional error made in the spectral index while calculating with the incorrect frequency, with a second frequency which is 10 MHz different.
-
-
-
-.. [#f1] Katgert, P., Oort, M. J. A., & Windhorst, R. A. 1988, A&A, 195, 21
diff --git a/CEP/PyBDSM/doc/source/art_fit_alt.png b/CEP/PyBDSM/doc/source/art_fit_alt.png
deleted file mode 100644
index dbfb395184fcbb08ee080544638110e237ab6460..0000000000000000000000000000000000000000
Binary files a/CEP/PyBDSM/doc/source/art_fit_alt.png and /dev/null differ
diff --git a/CEP/PyBDSM/doc/source/art_fit_def.png b/CEP/PyBDSM/doc/source/art_fit_def.png
deleted file mode 100644
index cfa17291a51d2825dc883acb5b99bb833d1d9f89..0000000000000000000000000000000000000000
Binary files a/CEP/PyBDSM/doc/source/art_fit_def.png and /dev/null differ
diff --git a/CEP/PyBDSM/doc/source/art_rms_alt.png b/CEP/PyBDSM/doc/source/art_rms_alt.png
deleted file mode 100644
index 28e7d478cf5c71239b1e6e72b634354e49e956e1..0000000000000000000000000000000000000000
Binary files a/CEP/PyBDSM/doc/source/art_rms_alt.png and /dev/null differ
diff --git a/CEP/PyBDSM/doc/source/art_rms_def.png b/CEP/PyBDSM/doc/source/art_rms_def.png
deleted file mode 100644
index b85aa4d552f016dd3f0bd6ca06222cc4d9474272..0000000000000000000000000000000000000000
Binary files a/CEP/PyBDSM/doc/source/art_rms_def.png and /dev/null differ
diff --git a/CEP/PyBDSM/doc/source/capabilities.rst b/CEP/PyBDSM/doc/source/capabilities.rst
deleted file mode 100644
index 87dbbaf7dacbed1c104747ecf156bf06d7211a5b..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/doc/source/capabilities.rst
+++ /dev/null
@@ -1,38 +0,0 @@
-**********************
-Capabilities of PyBDSM
-**********************
-
-PyBDSM can be run on FITS images (using PyFITS [#f1]_) or CASA images (using pyrap [#f2]_), including 3-D and 4-D cubes, and can handle blanked image pixels. If a spectral cube is given, then all source extraction as well as other computation (psf variation, wavelet decomposition, etc.) are done on a collapsed 2-D stokes I image. Once sources have been identified, their spectral and polarisation properties are then extracted from the full cubes. If you need a full 3-D Gaussian decomposition, then DUCHAMP [#f3]_ is what you need.
-
-PyBDSM performs the following tasks:
-
- * Reads in the image, collapses specific frequency channels, with weights, and produces a 'continuum' image (the 'ch0' image) for all polarisations. The Stokes I ch0 image is used for all further computation.
-
- * Preprocessing is done, whereby some basic parameters like image statistics are computed. Also, any input parameters that are left to default are calculated using sensible algorithms.
-
- * The background rms and mean images are computed. If the variation in these images is not statistically significant, then a constant value is taken. The parameters for this calculation are computed generically and hence do not have information about, for example, the typical size of the artifacts around bright sources. These parameters (e.g., :term:`rms_box`) are probably the only ones the user needs to take care to specify.
-
- * A constant threshold for separating source and noise pixels is set. This threshold can be either a hard threshold or calculated using the False Detection Rate algorithm.
-
- * Using these parameters, islands of contiguous source emission are identified. Islands are the basic units which are operated upon subsequently.
-
- * Each island is now fit with multiple Gaussians. Depending on the number of degrees of freedom, etc, the size of the fitted Gaussian could be fixed to be the restoring beam. The fitted Gaussians are then flagged to produce a list of acceptable set of Gaussians.
-
- * Each island can also be decomposed into shapelets. Currently only cartesian shapelets are implemented, and only one shapelet set, with the same scale in both dimensions, can be fit to an island. The shapelets parameters can be written out as ASCII or FITS tables.
-
- * Residual FITS images are computed, for both Gaussians and shapelets. The Gaussian parameters can be written out in various formats (ASCII, FITS tables, LOFAR BBS, ds9 region files, AIPS star, Kvis, etc). Shapelet parameters can be written out to FITS tables.
-
- * Gaussians within a given island are grouped into discrete sources.
-
- * If a frequency cube is input, then for each source identified in an island, the spectral index is computed. If possible, a spectral index is calculated for each Gaussian as well. This is done for point as well as extended sources.
-
- * If all four Stokes images are present, then the polarisation percentage and angle are calculated for each source.
-
- * The residual ch0 image, after subtracting fitted Gaussians, is processed using the *Ã trous* wavelet transform to generate images at various scales. Islands are identified in each of these wavelet images and fitted with Gaussians, all of which are then grouped to form pyramidal sources. These can be used further by the user as a starting point for morphological filters.
-
- * Since the ionosphere affects low frequencies significantly, PyBDSM can also estimate the spatial variation of the PSF across the image, which can be used to correct various source parameters.
-
-.. rubric:: Footnotes
-.. [#f1] http://www.stsci.edu/resources/software_hardware/pyfits/
-.. [#f2] http://code.google.com/p/pyrap/
-.. [#f3] http://www.atnf.csiro.au/people/Matthew.Whiting/Duchamp/
diff --git a/CEP/PyBDSM/doc/source/colourcorr_delta_spin.png b/CEP/PyBDSM/doc/source/colourcorr_delta_spin.png
deleted file mode 100644
index 4a3742237fd74f14a34fda22ba6540d47b7eed41..0000000000000000000000000000000000000000
Binary files a/CEP/PyBDSM/doc/source/colourcorr_delta_spin.png and /dev/null differ
diff --git a/CEP/PyBDSM/doc/source/colourcorr_full.png b/CEP/PyBDSM/doc/source/colourcorr_full.png
deleted file mode 100644
index 0cb818e1e4d5438ef68ab77f1172da530331a939..0000000000000000000000000000000000000000
Binary files a/CEP/PyBDSM/doc/source/colourcorr_full.png and /dev/null differ
diff --git a/CEP/PyBDSM/doc/source/colourcorr_order1-2.png b/CEP/PyBDSM/doc/source/colourcorr_order1-2.png
deleted file mode 100644
index 8916c3c0fb668a170fe230da14a532927e37f699..0000000000000000000000000000000000000000
Binary files a/CEP/PyBDSM/doc/source/colourcorr_order1-2.png and /dev/null differ
diff --git a/CEP/PyBDSM/doc/source/conf.py b/CEP/PyBDSM/doc/source/conf.py
deleted file mode 100644
index fe682b9ede0967deea7cb7d3e2c0e4531fa95185..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/doc/source/conf.py
+++ /dev/null
@@ -1,285 +0,0 @@
-# -*- coding: utf-8 -*-
-#
-# PyBDSM documentation build configuration file, created by
-# sphinx-quickstart on Thu Jan 19 13:27:03 2012.
-#
-# This file is execfile()d with the current directory set to its containing dir.
-#
-# Note that not all possible configuration values are present in this
-# autogenerated file.
-#
-# All configuration values have a default; values that are commented out
-# serve to show the default.
-
-import sys, os
-
-# If extensions (or modules to document with autodoc) are in another directory,
-# add these directories to sys.path here. If the directory is relative to the
-# documentation root, use os.path.abspath to make it absolute, like shown here.
-#sys.path.insert(0, os.path.abspath('.'))
-
-# -- General configuration -----------------------------------------------------
-
-# If your documentation needs a minimal Sphinx version, state it here.
-#needs_sphinx = '1.0'
-
-# Add any Sphinx extension module names here, as strings. They can be extensions
-# coming with Sphinx (named 'sphinx.ext.*') or your custom ones.
-extensions = ['sphinx.ext.pngmath', 'sphinx.ext.mathjax']
-
-# Add any paths that contain templates here, relative to this directory.
-templates_path = ['_templates']
-
-# The suffix of source filenames.
-source_suffix = '.rst'
-
-# The encoding of source files.
-source_encoding = 'utf-8-sig'
-
-# The master toctree document.
-master_doc = 'index'
-
-# General information about the project.
-project = u'PyBDSM'
-copyright = u'2016, David Rafferty and Niruj Mohan'
-
-# The version info for the project you're documenting, acts as replacement for
-# |version| and |release|, also used in various other places throughout the
-# built documents.
-#
-# The short X.Y version.
-version = '1.8'
-# The full version, including alpha/beta/rc tags.
-release = '1.8.7'
-
-# The language for content autogenerated by Sphinx. Refer to documentation
-# for a list of supported languages.
-#language = None
-
-# There are two options for replacing |today|: either, you set today to some
-# non-false value, then it is used:
-#today = ''
-# Else, today_fmt is used as the format for a strftime call.
-#today_fmt = '%B %d, %Y'
-
-# List of patterns, relative to source directory, that match files and
-# directories to ignore when looking for source files.
-exclude_patterns = []
-
-# The reST default role (used for this markup: `text`) to use for all documents.
-#default_role = None
-
-# If true, '()' will be appended to :func: etc. cross-reference text.
-#add_function_parentheses = True
-
-# If true, the current module name will be prepended to all description
-# unit titles (such as .. function::).
-#add_module_names = True
-
-# If true, sectionauthor and moduleauthor directives will be shown in the
-# output. They are ignored by default.
-#show_authors = False
-
-# The name of the Pygments (syntax highlighting) style to use.
-pygments_style = 'sphinx'
-
-# A list of ignored prefixes for module index sorting.
-#modindex_common_prefix = []
-
-
-# -- Options for HTML output ---------------------------------------------------
-
-# The theme to use for HTML and HTML Help pages. See the documentation for
-# a list of builtin themes.
-html_theme = 'default'
-
-# Theme options are theme-specific and customize the look and feel of a theme
-# further. For a list of options available for each theme, see the
-# documentation.
-#html_theme_options = {}
-
-# Add any paths that contain custom themes here, relative to this directory.
-#html_theme_path = []
-
-# The name for this set of Sphinx documents. If None, it defaults to
-# "<project> v<release> documentation".
-#html_title = None
-
-# A shorter title for the navigation bar. Default is the same as html_title.
-#html_short_title = None
-
-# The name of an image file (relative to this directory) to place at the top
-# of the sidebar.
-html_logo = 'front_pic.png'
-
-# The name of an image file (within the static path) to use as favicon of the
-# docs. This file should be a Windows icon file (.ico) being 16x16 or 32x32
-# pixels large.
-#html_favicon = None
-
-# Add any paths that contain custom static files (such as style sheets) here,
-# relative to this directory. They are copied after the builtin static files,
-# so a file named "default.css" will overwrite the builtin "default.css".
-html_static_path = ['_static']
-
-# If not '', a 'Last updated on:' timestamp is inserted at every page bottom,
-# using the given strftime format.
-#html_last_updated_fmt = '%b %d, %Y'
-
-# If true, SmartyPants will be used to convert quotes and dashes to
-# typographically correct entities.
-#html_use_smartypants = True
-
-# Custom sidebar templates, maps document names to template names.
-#html_sidebars = {}
-
-# Additional templates that should be rendered to pages, maps page names to
-# template names.
-#html_additional_pages = {}
-
-# If false, no module index is generated.
-#html_domain_indices = True
-
-# If false, no index is generated.
-#html_use_index = True
-
-# If true, the index is split into individual pages for each letter.
-#html_split_index = False
-
-# If true, links to the reST sources are added to the pages.
-#html_show_sourcelink = True
-
-# If true, "Created using Sphinx" is shown in the HTML footer. Default is True.
-#html_show_sphinx = True
-
-# If true, "(C) Copyright ..." is shown in the HTML footer. Default is True.
-#html_show_copyright = True
-
-# If true, an OpenSearch description file will be output, and all pages will
-# contain a <link> tag referring to it. The value of this option must be the
-# base URL from which the finished HTML is served.
-#html_use_opensearch = ''
-
-# This is the file name suffix for HTML files (e.g. ".xhtml").
-#html_file_suffix = None
-
-# Output file base name for HTML help builder.
-htmlhelp_basename = 'PyBDSMdoc'
-
-
-# -- Options for LaTeX output --------------------------------------------------
-
-latex_elements = {
-# The paper size ('letterpaper' or 'a4paper').
-#'papersize': 'letterpaper',
-
-# The font size ('10pt', '11pt' or '12pt').
-#'pointsize': '10pt',
-
-# Additional stuff for the LaTeX preamble.
-#'preamble': '',
-}
-
-# Grouping the document tree into LaTeX files. List of tuples
-# (source start file, target name, title, author, documentclass [howto/manual]).
-latex_documents = [
- ('index', 'PyBDSM.tex', u'PyBDSM Documentation',
- u'David Rafferty and Niruj Mohan', 'manual'),
-]
-
-# The name of an image file (relative to this directory) to place at the top of
-# the title page.
-#latex_logo = None
-
-# For "manual" documents, if this is true, then toplevel headings are parts,
-# not chapters.
-#latex_use_parts = False
-
-# If true, show page references after internal links.
-#latex_show_pagerefs = False
-
-# If true, show URL addresses after external links.
-#latex_show_urls = False
-
-# Documents to append as an appendix to all manuals.
-#latex_appendices = []
-
-# If false, no module index is generated.
-#latex_domain_indices = True
-
-
-# -- Options for manual page output --------------------------------------------
-
-# One entry per manual page. List of tuples
-# (source start file, name, description, authors, manual section).
-man_pages = [
- ('index', 'pybdsm', u'PyBDSM Documentation',
- [u'David Rafferty and Niruj Mohan'], 1)
-]
-
-# If true, show URL addresses after external links.
-#man_show_urls = False
-
-
-# -- Options for Texinfo output ------------------------------------------------
-
-# Grouping the document tree into Texinfo files. List of tuples
-# (source start file, target name, title, author,
-# dir menu entry, description, category)
-texinfo_documents = [
- ('index', 'PyBDSM', u'PyBDSM Documentation',
- u'David Rafferty and Niruj Mohan', 'PyBDSM', 'One line description of project.',
- 'Miscellaneous'),
-]
-
-# Documents to append as an appendix to all manuals.
-#texinfo_appendices = []
-
-# If false, no module index is generated.
-#texinfo_domain_indices = True
-
-# How to display URL addresses: 'footnote', 'no', or 'inline'.
-#texinfo_show_urls = 'footnote'
-
-
-# -- Options for Epub output ---------------------------------------------------
-
-# Bibliographic Dublin Core info.
-epub_title = u'PyBDSM'
-epub_author = u'David Rafferty and Niruj Mohan'
-epub_publisher = u'David Rafferty and Niruj Mohan'
-epub_copyright = u'2016, David Rafferty and Niruj Mohan'
-
-# The language of the text. It defaults to the language option
-# or en if the language is not set.
-#epub_language = ''
-
-# The scheme of the identifier. Typical schemes are ISBN or URL.
-#epub_scheme = ''
-
-# The unique identifier of the text. This can be a ISBN number
-# or the project homepage.
-#epub_identifier = ''
-
-# A unique identification for the text.
-#epub_uid = ''
-
-# A tuple containing the cover image and cover page html template filenames.
-#epub_cover = ()
-
-# HTML files that should be inserted before the pages created by sphinx.
-# The format is a list of tuples containing the path and title.
-#epub_pre_files = []
-
-# HTML files shat should be inserted after the pages created by sphinx.
-# The format is a list of tuples containing the path and title.
-#epub_post_files = []
-
-# A list of files that should not be packed into the epub file.
-#epub_exclude_files = []
-
-# The depth of the table of contents in toc.ncx.
-#epub_tocdepth = 3
-
-# Allow duplicate toc entries.
-#epub_tocdup = True
diff --git a/CEP/PyBDSM/doc/source/context.rst b/CEP/PyBDSM/doc/source/context.rst
deleted file mode 100644
index 3cb024088b8570eccfc64cbc6729dcddb951855b..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/doc/source/context.rst
+++ /dev/null
@@ -1,12 +0,0 @@
-***********
-Why PyBDSM?
-***********
-
-PyBDSM was developed to serve the needs of LOFAR, the **LO**\w **F**\requency **AR**\ray [#f1]_, functioning primarily in The Netherlands. LOFAR achieves orders of magnitude better sensitivity and resolution at low frequencies (15-80 MHz, 120-240 MHz) than previous radio interferometers. In addition, given the large primary beam, the field of view is large (2-16 degrees), and the spectral coverage is wider than usual (up to 48 MHz bandwidth and up to 62,464 channels). Lastly, up to 244 independent beams can be electronically generated on the sky. These capabilities make LOFAR an ideal survey instrument, but also create challenges in data processing. In particular, for surveys a good source extraction software is essential. Before PyBDSM was developed, a survey was made of the existing source extraction packages (SAD in AIPS, SFIND in MIRIAD and SExtractor). It was concluded that none of these packages were adequate to the task, and further, it would be difficult to modify any of these to suit the needs of LOFAR. Hence, PyBDSM was written. However, in the recent years, new low frequency telescope projects have started which are a similar to LOFAR in some parameters (e.g., MEERKAT, Mileura Array, ASKAP and other SKA pathfinders) and there has been considerable effort to develop source extraction software at some these project sites, e.g. DUCHAMP [#f2]_.
-
-Traditionally, source extraction software, at least in radio astronomy, has defined the process as fitting (multiple) Gaussians to source pixels. This makes sense since all interferometric images are convolved with a Gaussian (fit to the main lobe of the dirty beam) after deconvolution. This process is adequate also because most radio images have primarily consisted of point (or slightly extended) sources. LOFAR images, however, will be very different. Note that the antenna diameter is 50 m, maximum baselines extend to 100 km or more, and in addition, LOFAR will have almost no missing short spacing measurements (unless flagged due to RFI) and with the planned MFS (multi-frequency synthesis) parameters, will have some of the smallest fraction of uv-holes ever. Hence, the images will have a much wider range of scales of emission than usual - from point sources up to 3C sources. Decomposing such sources into gaussians may not be very effective (as well as highly degenerate and hence not very useful). Hence alternative basis sets which can capture a variety of scales is essential. AIPS (Classic AIPS as well as CASA) have been experimenting with multi-resolution CLEAN methods for many years now and in the same spirit, we have included shapelet and wavelet decomposition as well, among others. With the kind of image morphologies LOFAR images will routinely produce, complex ways of describing sources are needed, not just to catalog them but also to perform other filtering operations post-extraction for science purposes.
-Note that although PyBDSM is written for LOFAR, it will obviously work for images from any radio interferometric telescope.
-
-.. rubric:: Footnotes
-.. [#f1] http://www.lofar.org
-.. [#f2] http://www.atnf.csiro.au/people/Matthew.Whiting/Duchamp/
diff --git a/CEP/PyBDSM/doc/source/examples.rst b/CEP/PyBDSM/doc/source/examples.rst
deleted file mode 100644
index 6fc7b73ef2a4fa0dc02d462b8dbac11b04c7bfbd..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/doc/source/examples.rst
+++ /dev/null
@@ -1,328 +0,0 @@
-.. _simple_example:
-
-Simple image with point sources
--------------------------------
-Below is an example of running PyBDSM on an image composed primarily of point sources (a VLSS image).
-
-::
-
- $ pybdsm
-
- PyBDSM version 1.7.0 (LOFAR revision 20883)
- ========================================================================
- PyBDSM commands
- inp task ............ : Set current task and list parameters
- par = val ........... : Set a parameter (par = '' sets it to default)
- Autocomplete (with TAB) works for par and val
- go .................. : Run the current task
- default ............. : Set current task parameters to default values
- tput ................ : Save parameter values
- tget ................ : Load parameter values
- PyBDSM tasks
- process_image ....... : Process an image: find sources, etc.
- show_fit ............ : Show the results of a fit
- write_catalog ....... : Write out list of sources to a file
- export_image ........ : Write residual/model/rms/mean image to a file
- PyBDSM help
- help command/task ... : Get help on a command or task
- (e.g., help process_image)
- help 'par' .......... : Get help on a parameter (e.g., help 'rms_box')
- help changelog ...... : See list of recent changes
- ________________________________________________________________________
-
-
- BDSM [1]: filename='VLSS.fits'
-
-.. note::
-
- When PyBDSM starts up, the ``process_image`` task is automatically set to be the current task, so one does not need to set it with ``inp process_image``.
-
-::
-
- BDSM [2]: frequency=74e6
-
-.. note::
-
- For this image, no frequency information was present in the image header, so the frequency must be specified manually.
-
-::
-
- BDSM [3]: interactive=T
-
-.. note::
-
- It is often advisable to use the interactive mode when processing an image for the first time. This mode will display the islands that PyBDSM has found before proceeding to fitting, allowing the user to check that they are reasonable.
-
-::
-
- BDSM [4]: go
- ---------> go()
- --> Opened 'VLSS.fits'
- Image size .............................. : (1024, 1024) pixels
- Number of channels ...................... : 1
- Number of Stokes parameters ............. : 1
- Beam shape (major, minor, pos angle) .... : (0.02222, 0.02222, 0.0) degrees
- Frequency of image ...................... : 74.000 MHz
- Number of blank pixels .................. : 0 (0.0%)
- Flux from sum of (non-blank) pixels ..... : 177.465 Jy
- Derived rms_box (box size, step size) ... : (196, 65) pixels
- --> Variation in rms image significant
- --> Using 2D map for background rms
- --> Variation in mean image significant
- --> Using 2D map for background mean
- Min/max values of background rms map .... : (0.06305, 0.16508) Jy/beam
- Min/max values of background mean map ... : (-0.01967, 0.01714) Jy/beam
- --> Expected 5-sigma-clipped false detection rate < fdr_ratio
- --> Using sigma-clipping thresholding
- Minimum number of pixels per island ..... : 5
- Number of islands found ................. : 115
- --> Displaying islands and rms image...
- ========================================================================
- NOTE -- With the mouse pointer in plot window:
- Press "i" ........ : Get integrated fluxes and mean rms values
- for the visible portion of the image
- Press "m" ........ : Change min and max scaling values
- Press "n" ........ : Show / hide island IDs
- Press "0" ........ : Reset scaling to default
- Click Gaussian ... : Print Gaussian and source IDs (zoom_rect mode,
- toggled with the "zoom" button and indicated in
- the lower right corner, must be off)
- ________________________________________________________________________
-
-.. note::
-
- At this point, because ``interactive=True``, PyBDSM plots the islands. Once the plot window is closed, PyBDSM prompts the user to continue or to quit fitting:
-
-::
-
- Press enter to continue or 'q' to quit .. :
- Fitting islands with Gaussians .......... : [==========================================] 115/115
- Total number of Gaussians fit to image .. : 147
- Total flux in model ..................... : 211.800 Jy
- Number of sources formed from Gaussians : 117
-
-
-The ``process_image`` task has now finished. PyBDSM estimated a reasonable value for the ``rms_box`` parameter and determined that 2-D rms and mean maps were required to model the background of the image. Straightforward island thresholding at the 5-sigma level was used, and the minimum island size was set at 5 pixels. In total 115 islands were found, and 147 Gaussians were fit to these islands. These 147 Gaussians were then grouped into 117 sources. To check the fit, call the ``show_fit`` task:
-
-::
-
- BDSM [5]: show_fit
- ---------> show_fit()
- ========================================================================
- NOTE -- With the mouse pointer in plot window:
- Press "i" ........ : Get integrated fluxes and mean rms values
- for the visible portion of the image
- Press "m" ........ : Change min and max scaling values
- Press "n" ........ : Show / hide island IDs
- Press "0" ........ : Reset scaling to default
- Click Gaussian ... : Print Gaussian and source IDs (zoom_rect mode,
- toggled with the "zoom" button and indicated in
- the lower right corner, must be off)
- ________________________________________________________________________
-
-The ``show_fit`` task produces the figure below. It is clear that the fit worked well and all significant sources were identified and modeled successfully.
-
-.. figure:: pt_src_example.png
- :scale: 40 %
- :figwidth: 75 %
- :align: center
- :alt: example output
-
- Example fit with default parameters of an image with mostly point sources.
-
-Lastly, the plot window is closed, and the source catalog is written out to an ASCII file with the ``write_catalog`` task:
-
-::
-
- BDSM [6]: inp write_catalog
- --------> inp(write_catalog)
- WRITE_CATALOG: Write the Gaussian, source, or shapelet list to a file.
- ================================================================================
- outfile ............... None : Output file name. None => file is named
- automatically; 'SAMP' => send to SAMP hub (e.g.,
- to TOPCAT, ds9, or Aladin)
- bbs_patches ........... None : For BBS format, type of patch to use: None => no
- patches. 'single' => all Gaussians in one patch.
- 'gaussian' => each Gaussian gets its own patch.
- 'source' => all Gaussians belonging to a single
- source are grouped into one patch
- bbs_patches_mask ...... None : Name of the mask file (of same size as input image)
- that defines the patches if bbs_patches = 'mask'
- catalog_type .......... 'srl': Type of catalog to write: 'gaul' - Gaussian
- list, 'srl' - source list (formed by grouping
- Gaussians), 'shap' - shapelet list
- clobber .............. False : Overwrite existing file?
- correct_proj .......... True : Correct source parameters for image projection
- (BBS format only)?
- format ............... 'fits': Format of output catalog: 'bbs', 'ds9', 'fits',
- 'star', 'kvis', or 'ascii', 'csv', 'casabox',
- or 'sagecal'
- incl_chan ............ False : Include flux densities from each channel (if any)?
- incl_empty ........... False : Include islands without any valid Gaussians (source
- list only)?
- srcroot ............... None : Root name for entries in the output catalog. None
- => use image file name
-
- BDSM [7]: format='ascii'
-
- BDSM [8]: go
- ---------> go()
- --> Wrote ASCII file 'VLSS.fits.pybdsm.srl'
-
-
-
-Image with artifacts
---------------------
-Occasionally, an analysis run with the default parameters does not produce good results. For example, if there are significant deconvolution artifacts in the image, the ``thresh_isl``, ``thresh_pix``, or ``rms_box`` parameters might need to be changed to prevent PyBDSM from fitting Gaussians to such artifacts. An example of running PyBDSM with the default parameters on such an image is shown in the figures below.
-
-.. figure:: art_fit_def.png
- :scale: 50 %
- :figwidth: 75 %
- :align: center
- :alt: example output
-
- Example fit with default parameters of an image with strong artifacts around bright sources. A number of artifacts near the bright sources are incorrectly identified as real sources.
-
-.. figure:: art_rms_def.png
- :scale: 70 %
- :figwidth: 75 %
- :align: center
- :alt: example output
-
- The background rms map for the same region (produced using ``show_fit``) is shown in the lower panel: the rms varies fairly slowly across the image, whereas ideally it would increase strongly near the bright sources (reflecting the increased rms in those regions due to the artifacts).
-
-It is clear that a number of spurious sources are being detected. Simply raising the threshold for island detection (using the ``thresh_pix`` parameter) would remove these sources but would also remove many real but faint sources in regions of low rms. Instead, by setting the ``rms_box`` parameter to better match the typical scale over which the artifacts vary significantly, one obtains much better results. In this example, the scale of the regions affected by artifacts is approximately 20 pixels, whereas PyBDSM used a ``rms_box`` of 63 pixels when run with the default parameters, resulting in an rms map that is over-smoothed. Therefore, one should set ``rms_box=(20,10)`` so that the rms map is computed using a box of 20 pixels in size with a step size of 10 pixels (i.e., the box is moved across the image in 10-pixel steps). See the figures below for a summary of the results of this call.
-
-.. figure:: art_fit_alt.png
- :scale: 50 %
- :figwidth: 75 %
- :align: center
- :alt: example output
-
- Results of the fit with ``rms_box=(20,10)``. Both bright and faint sources are recovered properly.
-
-.. figure:: art_rms_alt.png
- :scale: 70 %
- :figwidth: 75 %
- :align: center
- :alt: example output
-
- The rms map produced with ``rms_box=(20,10)``. The rms map now varies on scales similar to that of the regions affected by the artifacts.
-
-
-Image with extended emission
-----------------------------
-If there is extended emission that fills a significant portion of the image, the background rms map will likely be biased high in regions where extended emission is present, affecting the island determination (this can be checked during a run by setting ``interactive=True``). Setting ``rms_map=False`` and ``mean_map='const'`` or ``'zero'`` will force PyBDSM to use a constant mean and rms value across the whole image. Additionally, setting ``flag_maxsize_bm`` to a large value (50 to 100) will allow large Gaussians to be fit, and setting ``atrous_do=True`` will fit Gaussians of various scales to the residual image to recover extended emission missed in the standard fitting. Depending on the source structure, the ``thresh_isl`` and ``thresh_pix`` parameters may also have to be adjusted as well to ensure that PyBDSM finds and fits islands of emission properly. An example analysis of an image with significant extended emission is shown below. Note that large, complex sources can require a long time to fit (on the order of hours).
-
-.. figure:: HydraA_74MHz_fit.png
- :scale: 40 %
- :figwidth: 75 %
- :align: center
- :alt: example output
-
- Example fit of an image of Hydra A with ``rms_map=False``, ``mean_map='zero'``, ``flag_maxsize_bm=50`` and ``atrous_do=True``. The values of ``thresh_isl`` and ``thresh_pix`` were adjusted before fitting (by setting ``interactive=True``) to obtain an island that enclosed all significant emission.
-
-
-.. _script_example:
-
-Scripting example
------------------
-You can use the complete functionality of PyBDSM within Python scripts (see :ref:`scripting` for details). Scripting can be useful, for example, if you have a large number of images or if PyBDSM needs to be called as part of an automated reduction. Below is a short example of using PyBDSM to find sources in a number of images automatically. In this example, the best reduction parameters were determined beforehand for a representative image and saved to a PyBDSM save file using the ``tput`` command (see :ref:`commands` for details).
-
-.. note::
-
- If you are working on the LOFAR CEP I/II clusters, then at some point before running the script, you will need to do::
-
- $ use LofIm
-
-::
-
- # pybdsm_example.py
- #
- # This script fits a number of images automatically, writing out source
- # catalogs and residual and model images for each input image. Call it
- # with "python pybdsm_example.py"
-
- from lofar import bdsm
-
- # Define the list of images to process and the parameter save file
- input_images = ['a2597.fits', 'a2256_1.fits', 'a2256_2.fits',
- 'a2256_3.fits', 'a2256_4.fits', 'a2256_5.fits']
- save_file = 'a2256.sav'
-
- # Now loop over the input images and process them
- for input_image in input_images:
-
- if input_image == 'a2597.fits':
- # For this one image, run with different parameters.
- # Note that the image name is the first argument to
- # process_image:
- img = bdsm.process_image(input_image, rms_box=(100,20))
-
- else:
- # For the other images, use the 'a2256.sav` parameter save file.
- # The quiet argument is used to supress output to the terminal
- # (it still goes to the log file).
- # Note: when a save file is used, it must be given first in the
- # call to process_image:
- img = bdsm.process_image(save_file, filename=input_image, quiet=True)
-
- # Write the source list catalog. File is named automatically.
- img.write_catalog(format='fits', catalog_type='srl')
-
- # Write the residual image. File is name automatically.
- img.export_image(img_type='gaus_resid')
-
- # Write the model image. File name is specified.
- img.export_image(img_type='gaus_model', outfile=input_image+'.model')
-
-
-.. _samp_example:
-
-Using SAMP interoperability
----------------------------
-PyBDSM supports SAMP (Simple Application Messaging Protocol) to provide interoperability to other applications, such as TOPCAT [#f1]_, ds9 [#f2]_, and Aladin [#f3]_. To use this functionality, a SAMP hub must be running (both TOPCAT and Aladin come with SAMP hubs). Below is an example of using PyBDSM with TOPCAT. In this example, it is assumed that an image has already been processed with ``process_image``.
-
-::
-
- BDSM [1]: process_image('VLSS.fits')
- ...
-
-At this point, make sure that TOPCAT is started and its SAMP hub is running (activated by clicking the "Attempt to connect to SAMP hub" icon in the lower right-hand corner and selecting "Start internal hub"). Next, we send the PyBDSM source list to TOPCAT with ``write_catalog``:
-
-::
-
- BDSM [2]: inp write_catalog
-
- BDSM [3]: outfile='SAMP'
-
- BDSM [4]: go
- ---------> go()
- --> Table sent to SAMP hub.
-
-TOPCAT should automatically load the table. Double-click on the table name in TOPCAT to open the table viewer. We can use now the ``show_fit`` task to highlight the table row that corresponds to a source of interest. To do this, we start ``show_fit`` with ``broadcast = True``:
-
-::
-
- BDSM [6]: show_fit(broadcast=T)
- ========================================================================
- NOTE -- With the mouse pointer in plot window:
- Press "i" ........ : Get integrated flux densities and mean rms
- values for the visible portion of the image
- Press "m" ........ : Change min and max scaling values
- Press "n" ........ : Show / hide island IDs
- Press "0" ........ : Reset scaling to default
- Click Gaussian ... : Print Gaussian and source IDs (zoom_rect mode,
- toggled with the "zoom" button and indicated in
- the lower right corner, must be off)
- ________________________________________________________________________
-
-Now, clicking on a Gaussian will highlight the row corresponding to the source to which the Gaussian belongs. Gaussian catalogs (i.e., made with ``catalog_type='srl'`` in ``write_catalog``) are also supported (and may be used simultaneously in TOPCAT with source catalogs).
-
-Images can be sent to ds9 or Aladin using the ``export_image`` task in the same way (with ``outfile = 'SAMP'``). Furthermore, if an image was sent, clicking on a Gaussian in the ``show_fit`` window will tell ds9 or Aladin to center their view on the coordinates of the Gaussian's center.
-
-
-.. rubric:: Footnotes
-.. [#f1] http://www.star.bristol.ac.uk/~mbt/topcat/
-.. [#f2] http://hea-www.harvard.edu/RD/ds9/site/Home.html
-.. [#f3] http://aladin.u-strasbg.fr
diff --git a/CEP/PyBDSM/doc/source/export_image.rst b/CEP/PyBDSM/doc/source/export_image.rst
deleted file mode 100644
index 4da6ce46a67705d4621d4b9f6389a5023e174020..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/doc/source/export_image.rst
+++ /dev/null
@@ -1,76 +0,0 @@
-.. _export_image:
-
-**************************************************************
-``export_image``: exporting internally derived images
-**************************************************************
-
-Internally derived images (e.g, the Gaussian model image) can be exported to FITS or CASA files using the ``export_image`` task:
-
-.. parsed-literal::
-
- EXPORT_IMAGE: Write one or more images to a file.
- ================================================================================
- :term:`outfile` ............... None : Output file name. None => file is named
- automatically; 'SAMP' => send to SAMP hub (e.g., to
- TOPCAT, ds9, or Aladin)
- :term:`clobber` .............. False : Overwrite existing file?
- :term:`img_format` ........... 'fits': Format of output image: 'fits' or 'casa'
- :term:`img_type` ....... 'gaus_resid': Type of image to export: 'gaus_resid',
- 'shap_resid', 'rms', 'mean', 'gaus_model',
- 'shap_model', 'ch0', 'pi', 'psf_major', 'psf_minor',
- 'psf_pa', 'psf_ratio', 'psf_ratio_aper', 'island_mask'
- :term:`mask_dilation` ............ 0 : Number of iterations to use for island-mask dilation.
- 0 => no dilation
- :term:`pad_image` ............ False : Pad image (with zeros) to original size
-
-
-Each of the parameters is described in detail below.
-
-.. glossary::
-
- outfile
- This parameter is a string (default is ``None``) that sets the name of the output file. If ``None``, the file is named automatically. If 'SAMP' the image is sent to a running SAMP Hub (e.g., to ds9 or Aladin).
-
- clobber
- This parameter is a Boolean (default is ``False``) that determines whether existing files are overwritten or not.
-
- img_format
- This parameter is a string (default is ``'fits'``) that sets the output file format: ``'fits'`` - FITS format, ``'casa'`` - CASA format (requires pyrap).
-
- img_type
- This parameter is a string (default is ``'gaus_resid'``) that sets the type of image to export.
- The following images can be exported:
-
- * ``'ch0'`` - image used for source detection
-
- * ``'rms'`` - rms map image
-
- * ``'mean'`` - mean map image
-
- * ``'pi'`` - polarized intensity image
-
- * ``'gaus_resid'`` - Gaussian model residual image
-
- * ``'gaus_model'`` - Gaussian model image
-
- * ``'shap_resid'`` - Shapelet model residual image
-
- * ``'shap_model'`` - Shapelet model image
-
- * ``'psf_major'`` - image of major axis FWHM variation (arcsec)
-
- * ``'psf_minor'`` - image of minor axis FWHM variation (arcsec)
-
- * ``'psf_pa'`` - image of position angle variation (degrees east of north)
-
- * ``'psf_ratio'`` - image of peak-to-total flux variation (1/beam)
-
- * ``'psf_ratio_aper'`` - image of peak-to-aperture flux variation (1/beam)
-
- * ``'island_mask'`` - mask of islands (0 = outside island, 1 = inside island)
-
- mask_dilation
- This parameter is an integer (default is ``0``) that sets the number of dilation iterations to use when making the island mask. More iterations implies larger masked regions (one iteration expands the size of features in the mask by one pixel in all directions).
-
- pad_image
- This parameter is a Boolean (default is ``False``) that determines whether the output image is padded to be the same size as the original image (without any trimming defined by the ``trim_box`` parameter). If ``False``, the output image will have the size specified by the ``trim_box`` parameter.
diff --git a/CEP/PyBDSM/doc/source/front_pic.png b/CEP/PyBDSM/doc/source/front_pic.png
deleted file mode 100644
index 119ad2ead9329d2980a9eede2a4884e986b4628d..0000000000000000000000000000000000000000
Binary files a/CEP/PyBDSM/doc/source/front_pic.png and /dev/null differ
diff --git a/CEP/PyBDSM/doc/source/index.rst b/CEP/PyBDSM/doc/source/index.rst
deleted file mode 100644
index 9880b43e6aa8f81108ce2f59f7b7504706e5b5b9..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/doc/source/index.rst
+++ /dev/null
@@ -1,69 +0,0 @@
-.. PyBDSM documentation master file, created by
- sphinx-quickstart on Thu Jan 19 13:27:03 2012.
- You can adapt this file completely to your liking, but it should at least
- contain the root `toctree` directive.
-
-====================
-PyBDSM Documentation
-====================
-
-PyBDSM (the **Py**\thon **B**\lob **D**\etection and **S**\ource **M**\easurement software) is a tool designed to decompose radio interferometry images into sources and make available their properties for further use. PyBDSM can decompose an image into a set of Gaussians, shapelets, or wavelets as well as calculate spectral indices and polarization properties of sources and measure the psf variation across an image. PyBDSM uses an interactive environment based on CASA [#f1]_ that will be familiar to most radio astronomers. Additionally, PyBDSM may also be used in Python scripts.
-
-.. .. image:: overview_image.png
-.. :align: center
-
-
-Introduction
-============
-
-.. toctree::
- :maxdepth: 2
-
- context
- capabilities
-
-
-Obtaining PyBDSM
-================
-
-.. toctree::
- :maxdepth: 2
-
- installation
- whats_new
-
-
-User's Guide
-============
-
-.. toctree::
- :maxdepth: 3
-
- ug_basics
- process_image
- show_fit
- export_image
- write_catalog
- scripting
- parameters
-
-
-Analysis Examples
-=================
-
-.. toctree::
- :maxdepth: 2
-
- examples
-
-
-Details of the Algorithms
-=========================
-
-.. toctree::
- :maxdepth: 2
-
- algorithms
-
-.. rubric:: Footnotes
-.. [#f1] http://casa.nrao.edu
diff --git a/CEP/PyBDSM/doc/source/installation.rst b/CEP/PyBDSM/doc/source/installation.rst
deleted file mode 100644
index 4d0e232dccd997b162ca60595a8ea726174cad04..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/doc/source/installation.rst
+++ /dev/null
@@ -1,103 +0,0 @@
-.. _installing:
-
-**************************
-Downloading and installing
-**************************
-.. note::
-
- If you are working on the LOFAR CEP I/II clusters, then PyBDSM is already installed. All that needs to be done is to initialize your environment as follows::
-
- $ use LofIm
-
-Downloading the code
---------------------
-The latest version of the code may be obtained as a gzipped tar file from the Hamburg Observatory FTP server at ftp://ftp.hs.uni-hamburg.de/pub/outgoing/rafferty/PyBDSM (e.g., ``PyBDSM-1.8.2.tar.gz``). Once downloaded, extract the files in the directory where you would like to install PyBDSM. The files are all contained in a subdirectory named ``LOFAR``.
-
-Preparing to compile the code
------------------------------
-Before compiling the PyBDSM source code, you need to make sure you have the required dependencies:
-
-.. note::
-
- The minimal set of dependencies is usually part of most Linux distributions, so if you are installing PyBDSM on Linux you can likely skip to the next step (compiling and installing). On a Mac, you will also need to have XCode installed (from the Mac App Store), including the command-line tools (installed either from XCode's Preferences or, on 10.9 Mavericks, by running ``xcode-select --install`` in a terminal).
-
-* Python 2.6 or 2.7 (including NumPy, SciPy, Matplotlib, and IPython). The easiest way to install Python and all of the required modules is to use the free 64-bit Anaconda distribution, available at http://www.continuum.io/downloads (Anaconda also includes Astropy, which is needed by PyBDSM). Python 3 is not yet supported.
-* gfortran. Binaries are available from http://gcc.gnu.org/wiki/GFortranBinaries.
-* A C++ compiler. Note that the default system compiler on OS 10.9 does not work with PyBDSM at this time, so it is necessary to install a recent version of the GCC compiler suite (e.g., the GCC 4.8 binaries from http://hpc.sourceforge.net). The easiest way to use these alternative compilers is to replace the system versions of the compilers in /usr/bin/ (i.e., cc, gcc, g++, c++) with these versions (before compiling Boost).
-* Boost. Get the latest version from http://www.boost.org. Only the Python libraries need to be compiled. For example, on a Mac, do the following (which assumes the latest version is ``boost_1_49_0.tar.gz``)::
-
- $ cd /usr/local/
- $ sudo tar --bzip2 -xf ~/Downloads/boost_1_49_0.tar.gz
- $ cd boost_1_49_0/
- $ sudo ./bootstrap.sh --with-libraries=python
- $ sudo ./b2 install
-
-.. note::
-
- If you are using Anaconda Python, you may need to edit the ``project_config.bjam`` file before running the b2 executable by changing the line::
-
- using python : 2.7 : /path/to/anaconda ;
-
- to::
-
- using python : 2.7 : /path/to/anaconda : /path/to/anaconda/include/python2.7 : /path/to/anaconda/lib ;
-
- then run::
-
- sudo ./b2 toolset=clang cxxflags=-stdlib=libstdc++ linkflags=-stdlib=libstdc++ -j2 install
-
-.. note::
-
- If you don't have superuser access, you can install Boost to a local directory by adding::
-
- --prefix=path/to/installation/prefix
-
- to the bootstrap.sh command above and then passing this directory to the cmake command below by adding::
-
- -DBOOST_ROOT_DIR=/path/to/boost
-
-
-* Astropy (if you use the Anaconda Python distribution above, Astropy is already included). You can get Astropy from http://www.astropy.org.
-
-
-Compiling and installing
-------------------------
-Lastly, compile the software. To do so, change to the ``LOFAR`` directory and make a ``build/gnu_opt`` directory, go there, and execute ``make``::
-
- $ cd LOFAR
- $ mkdir -p build/gnu_opt
- $ cd build/gnu_opt
- $ cmake -DBUILD_PACKAGES=PyBDSM -DUSE_LOG4CPLUS=OFF -DUSE_LOG4CXX=OFF ../..
- $ make install
-
-If successful, PyBDSM should now be installed in ``LOFAR/build/gnu_opt/installed/``.
-
-.. _add_to_path:
-
-Adding PyBDSM to your PATH
---------------------------
-You can add PyBDSM to your PATH by adding the following lines to your ``.cshrc`` (for the C-shell) or ``.bash_profile`` files (for the Bash shell):
-
-For the C-shell::
-
- setenv LOFAR <root directory of code tree>
- source $LOFAR/build/gnu_opt/installed/lofarinit.csh
-
-For the Bash shell::
-
- export LOFAR="<root directory of code tree>"
- source $LOFAR/build/gnu_opt/installed/lofarinit.sh
-
-.. note::
-
- If you are working on the LOFAR CEP I/II clusters, then you need only to do::
-
- $ use LofIm
-
-Keeping up-to-date
-------------------
-PyBDSM is currently under active development, and bug fixes and improvements are frequently implemented. PyBDSM will automatically check for updates each time the interactive shell is started. To update PyBDSM to the latest version, download the new version and repeat the "compiling and installing" steps.
-
-Major updates will be listed in :ref:`new`.
-
-
diff --git a/CEP/PyBDSM/doc/source/parameters.rst b/CEP/PyBDSM/doc/source/parameters.rst
deleted file mode 100644
index 5ce6f49c743495656bf577105f87d8bdc621da71..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/doc/source/parameters.rst
+++ /dev/null
@@ -1,5 +0,0 @@
-**************************************
-Alphabetical listing of all parameters
-**************************************
-
-For a listing of all parameters, please see the Index (:ref:`genindex`).
diff --git a/CEP/PyBDSM/doc/source/process_image.rst b/CEP/PyBDSM/doc/source/process_image.rst
deleted file mode 100644
index 0f6f2e318e857dbec1c959898db5a68681732fe6..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/doc/source/process_image.rst
+++ /dev/null
@@ -1,1198 +0,0 @@
-.. _process_image:
-
-***********************************************
-``process_image``: processing an image
-***********************************************
-
-A standard analysis is performed using the ``process_image`` task. This task reads in the input image, calculates background rms and mean images, finds islands of emission, fits Gaussians to the islands, and groups the Gaussians into sources. Furthermore, the ``process_image`` task encompases a number of modules that allow decomposing an image into shapelets, calculating source spectral indices, deriving source polarization properties, and correcting for PSF variations across the image.
-
-When process_image is executed, PyBDSM performs the following steps in
-order:
-
-#. Reads in the image and collapses specific frequency channels with weights (see :ref:`multichan_opts`) and produces a 'continuum' image (the ch0 image) for all polarisations with which source detection is done.
-
-#. Calculates basic statistics of the image and sensible values of the processing parameters. First, the number of beams per
- source is calculated (see :ref:`algorithms` for details), using a
- sensible estimate of box size and step size (which can be set using the
- :term:`rms_box` parameter). Next, the thresholds are set. They can either be
- hard thresholded (by the user or set as 5-sigma for pixel threshold and
- 3-sigma for island boundaries by default) or can be calculated using the
- False Detection Rate (FDR) method using a user defined value for
- :math:`\alpha` (the :term:`fdr_alpha` parameter). If the user does not specify whether hard thresholding or FDR thresholding
- should be applied, one or the other is chosen internally based on the
- ratio of expected false pixels to true pixels.
-
-#. Calculates the rms and mean images. The 3-sigma clipped rms and mean are calculated
- inside boxes of defined by the :term:`rms_box` parameter. Optionally, these images can be calculated using
- adaptive scaling of this box, so that a smaller box (defined the the :term:`rms_box_bright` parameter) is used near bright sources (where strong artifacts are more likely). Intermediate values
- are calculated using bicubic spline interpolation by default (the order of the spline interpolation can be set with the :term:`spline_rank` parameter). Depending on the resulting statistics (see :ref:`algorithms` for details), we either adopt the rms image or a constant rms
- in the following analysis.
-
-#. Identifies islands of contiguous emission. First all pixels greater
- than the pixel threshold are identified. Next, starting from each of these pixels, all contiguous pixels
- (defined by 8-connectivity, i.e., the surrounding eight pixels) higher
- than the island boundary threshold are identified as belonging to one
- island, accounting properly for overlaps of islands.
-
-#. Fits multiple Gaussians to each island. The number of
- multiple Gaussians to be fit can be determined by three different
- methods (using the :term:`ini_gausfit` parameter). With initial guesses
- corresponding to these peaks, Gaussians are simultaneously fit to the
- island using the Levenberg-Marqhardt algorithm. Sensible criteria for bad
- solutions are defined (see :ref:`flagging_opts`). If multiple Gaussians are fit and one of them is
- a bad solution then the number of Gaussians is decreased by one and fit
- again, until all solutions in the island are good (or zero in number, in
- which case it's flagged). After the final fit to the island, the
- deconvolved size is computed assuming the theoretical beam, and the
- statistics in the source area and in the island are computed and
- stored. Errors on each of the fitted parameters are computed using the
- formulae in Condon (1997) [#f1]_.
-
-#. Groups nearby Gaussians within an island into sources. See :ref:`grouping`
- for details. Fluxes for the grouped Gaussians are summed to obtain the
- total flux of the source (the uncertainty is calculated by summing the
- Gaussian uncertainties in quadrature). The source position is set to be its
- centroid (the position of the maximum of the source is also calculated and
- output). The total source size is measured using moment analysis (see
- http://en.wikipedia.org/wiki/Image_moment for a nice overview of moment
- analysis). Errors on the source position and size are estimated using
- Condon (1997), but additional uncertainties due to uncertainties in the
- constituent Gaussians may be estimated using a Monte Carlo technique.
-
-#. Continues with further processing, if the user has specified that one or more of the following modules be used:
-
- * Shapelet decomposition (see :ref:`shapelet_do` for details)
-
- * Wavelet decomposition (see :ref:`atrous_do` for details)
-
- * Estimation of PSF variation (see :ref:`psf_vary_do` for details)
-
- * Calculation of polarization properties (see :ref:`polarisation_do` for details)
-
- * Calculation of spectral indices (see :ref:`spectralindex_do` for details)
-
-.. _general_pars:
-
-General reduction parameters
-----------------------------
-Type ``inp process_image`` to list the main reduction parameters:
-
-.. parsed-literal::
-
- PROCESS_IMAGE: Find and measure sources in an image.
- ================================================================================
- :term:`filename` ................. '': Input image file name
- :term:`adaptive_rms_box` ..... False : Use adaptive rms_box when determining rms and
- mean maps
- :term:`advanced_opts` ........ False : Show advanced options
- :term:`atrous_do` ............ False : Decompose Gaussian residual image into multiple
- scales
- :term:`beam` .................. None : FWHM of restoring beam. Specify as (maj, min, pos
- ang E of N) in degrees. E.g., beam = (0.06, 0.02,
- 13.3). None => get from header
- :term:`flagging_opts` ........ False : Show options for Gaussian flagging
- :term:`frequency` ............. None : Frequency in Hz of input image. E.g., frequency =
- 74e6. None => get from header. For more than one
- channel, use the frequency_sp parameter.
- :term:`interactive` .......... False : Use interactive mode
- :term:`mean_map` .......... 'default': Background mean map: 'default' => calc whether to
- use or not, 'zero' => 0, 'const' => clipped mean,
- 'map' => use 2-D map.
- :term:`multichan_opts` ....... False : Show options for multi-channel images
- :term:`output_opts` .......... False : Show output options
- :term:`polarisation_do` ...... False : Find polarisation properties
- :term:`psf_vary_do` .......... False : Calculate PSF variation across image
- :term:`rms_box` ............... None : Box size, step size for rms/mean map calculation.
- Specify as (box, step) in pixels. E.g., rms_box =
- (40, 10) => box of 40x40 pixels, step of 10
- pixels. None => calculate inside program
- :term:`rms_map` ............... None : Background rms map: True => use 2-D rms map;
- False => use constant rms; None => calculate
- inside program
- :term:`shapelet_do` .......... False : Decompose islands into shapelets
- :term:`spectralindex_do` ..... False : Calculate spectral indices (for multi-channel
- image)
- :term:`thresh` ................ None : Type of thresholding: None => calculate inside
- program, 'fdr' => use false detection rate
- algorithm, 'hard' => use sigma clipping
- :term:`thresh_isl` ............. 3.0 : Threshold for the island boundary in number of
- sigma above the mean. Determines extent of
- island used for fitting
- :term:`thresh_pix` ............. 5.0 : Source detection threshold: threshold for the
- island peak in number of sigma above the mean. If
- false detection rate thresholding is used, this
- value is ignored and thresh_pix is calculated
- inside the program
-
-Each of the parameters is described in detail below.
-
-.. glossary::
- filename
- This parameter is a string (no default) that sets the input image file name. The input image can be a FITS or CASA 2-, 3-, or 4-D cube.
-
- adaptive_rms_box
- This parameter is a Boolean (default is ``False``). If ``True``, an adaptive box is used when calculating the rms and mean maps. See :ref:`adaptive_rms_box` for details of the options.
-
- advanced_opts
- This parameter is a Boolean (default is ``False``). If ``True``, the advanced options are shown. See :ref:`advanced_opts` for details of the advanced options.
-
- atrous_do
- This parameter is a Boolean (default is ``False``). If ``True``, wavelet decomposition will be performed. See :ref:`atrous_do` for details of the options.
-
- beam
- This parameter is a tuple (default is ``None``) that defines the FWHM of restoring beam. Specify as (maj, min, pos ang E of N) in degrees. E.g., ``beam = (0.06, 0.02, 13.3)``. For more than one channel, use the ``beam_spectrum`` parameter. If the beam is not given by the user, then it is looked for in the image header. If not found, then an error is raised. PyBDSM will not work without knowledge of the restoring beam.
-
- flagging_opts
- This parameter is a Boolean (default is ``False``). If ``True``, the Gaussian flagging options will be listed. See :ref:`flagging_opts` for details of the options.
-
- frequency
- This parameter is a float (default is ``None``) that defines the frequency in Hz of the input image. E.g., ``frequency = 74e6``. For more than one channel, use the :term:`frequency_sp` parameter. If the frequency is not given by the user, then it is looked for in the image header. If not found, then an error is raised. PyBDSM will not work without knowledge of the frequency.
-
- interactive
- This parameter is a Boolean (default is ``False``). If ``True``, interactive mode is used. In interactive mode, plots are displayed at various stages of the processing so that the user may check the progress of the fit.
-
- First, plots of the rms and mean background images are displayed along with the islands found, before fitting of Gaussians takes place. The user should verify that the islands and maps are reasonable before preceding.
-
- Next, if ``atrous_do = True``, the fits to each wavelet scale are shown. The wavelet fitting may be truncated at the current scale if desired.
-
- Lastly, the final results are shown.
-
- mean_map
- This parameter is a string (default is ``'default'``) that determines how the background mean map is computed and
- how it is used further.
-
- If ``'const'``\, then the value of the clipped mean of the entire image (set
- by the ``kappa_clip`` option) is used as the background mean map.
-
- If ``'zero'``\, then a value of zero is used.
-
- If ``'map'``\, then the 2-dimensional mean map is computed and used. The
- resulting mean map is largely determined by the value of the ``rms_box``
- parameter (see the ``rms_box`` parameter for more information).
-
- If ``'default'``\, then PyBDSM will attempt to determine automatically
- whether to use a 2-dimensional map or a constant one as follows. First,
- the image is assumed to be confused if ``bmpersrc_th`` < 25 or the ratio of
- the clipped mean to rms (clipped mean/clipped rms) is > 0.1, else the
- image is not confused. Next, the mean map is checked to see if its
- spatial variation is significant. If so, then a 2-D map is used and, if
- not, then the mean map is set to either 0.0 or a constant depending on
- whether the image is thought to be confused or not.
-
- Generally, ``'default'`` works well. However, if there is significant
- extended emission in the image, it is often necessary to force the use
- of a constant mean map using either ``'const'`` or ``'mean'``\.
-
- multichan_opts
- This parameter is a Boolean (default is ``False``). If ``True``, the multichannel options will be listed. See :ref:`multichan_opts` for details of the options.
-
- output_opts
- This parameter is a Boolean (default is ``False``). If ``True``, the output options will be listed. See :ref:`output_opts` for details of the options.
-
- polarisation_do
- This parameter is a Boolean (default is ``False``). If ``True``, polarization properties will be calculated for the sources. See :ref:`polarisation_do` for details of the options.
-
- psf_vary_do
- This parameter is a Boolean (default is ``False``). If ``True``, the spatial variation of the PSF will be estimated and its effects corrected. See :ref:`psf_vary_do` for details of the options.
-
- rms_box
- This parameter is a tuple (default is ``None``) of two integers and is probably the most important input
- parameter for PyBDSM. The first integer, boxsize, is the size of the 2-D
- sliding box for calculating the rms and mean over the entire image. The
- second, stepsize, is the number of pixels by which this box is moved for
- the next measurement. If ``None``\, then suitable values are calculated
- internally.
-
- In general, it is best to choose a box size that corresponds to the
- typical scale of artifacts in the image, such as those that are common
- around bright sources. Too small of a box size will effectively raise
- the local rms near a source so much that a source may not be fit at all;
- too large a box size can result in underestimates of the rms due to
- oversmoothing. A step size of 1/3 to 1/4 of the box size usually works
- well.
-
- .. note::
-
- The :term:`spline_rank` parameter also affects the rms and mean maps. If you find ringing artifacts in the rms or mean maps near bright sources, try adjusting this parameter.
-
- rms_map
- This parameter is a Boolean (default is ``None``). If ``True``\, then the 2-D background rms image is computed and used. If
- ``False``\, then a constant value is assumed (use ``rms_value`` to force the rms
- to a specific value). If ``None``\, then the 2-D rms image is calculated, and
- if the variation is statistically significant then it is taken, else a
- constant value is assumed. The rms image used for each channel in
- computing the spectral index follows what was done for the
- channel-collapsed image.
-
- Generally, the default value works well. However, if there is significant extended
- emission in the image, it is often necessary to force the use of a
- constant rms map by setting ``rms_map = False``.
-
- shapelet_do
- This parameter is a Boolean (default is ``False``). If ``True``, shapelet decomposition of the islands will be performed. See :ref:`shapelet_do` for details of the options.
-
- spectralindex_do
- This parameter is a Boolean (default is ``False``). If ``True``, spectral indices will be calculated for the sources. See :ref:`spectralindex_do` for details of the options.
-
- thresh
- This parameter is a string (default is ``None``). If ``thresh = 'hard'``\, then a hard threshold is assumed, given by
- thresh_pix. If ``thresh = 'fdr'``\, then the False Detection Rate algorithm
- of Hopkins et al. (2002) is used to calculate the value of ``thresh_pix``\.
- If ``thresh = None``\, then the false detection probability is first
- calculated, and if the number of false source pixels is more than
- ``fdr_ratio`` times the estimated number of true source pixels, then the
- ``'fdr'`` threshold option is chosen, else the ``'hard'`` threshold option is
- chosen.
-
- thresh_isl
- This parameter is a float (default is 3.0) that determines the region to which fitting is done. A higher
- value will produce smaller islands, and hence smaller regions that are
- considered in the fits. A lower value will produce larger islands. Use
- the thresh_pix parameter to set the detection threshold for sources.
- Generally, ``thresh_isl`` should be lower than ``thresh_pix``\.
-
- Only regions above the absolute threshold will be used. The absolute
- threshold is calculated as ``abs_thr = mean + thresh_isl * rms``\. Use the
- ``mean_map`` and ``rms_map`` parameters to control the way the mean and rms are
- determined.
-
- thresh_pix
- This parameter is a float (default is 5.0) that sets the source detection threshold in number of
- sigma above the mean. If false detection rate thresholding is used, this
- value is ignored and ``thresh_pix`` is calculated inside the program
-
- This parameter sets the overall detection threshold for islands (i.e.
- ``thresh_pix = 5`` will find all sources with peak flux densities per beam of 5-sigma or
- greater). Use the ``thresh_isl`` parameter to control how much of each
- island is used in fitting. Generally, ``thresh_pix`` should be larger than
- ``thresh_isl``.
-
- Only islands with peaks above the absolute threshold will be used. The
- absolute threshold is calculated as ``abs_thr = mean + thresh_pix * rms``\.
- Use the ``mean_map`` and ``rms_map`` parameters to control the way the mean and
- rms are determined.
-
-
-.. _adaptive_rms_box:
-
-Adaptive box options
-====================
-If ``adaptive_rms_box = True``, the rms_box is reduced in size near bright sources and enlarged far from them. This scaling attempts to account for possible strong artifacts around bright sources while still acheiving accurate background rms and mean values when extended sources are present. This option is generally slower than non-adaptive scaling.
-
-Use the ``rms_box`` parameter to set the large-scale box and the ``rms_box_bright`` parameter to set the small-scale box. The threshold for bright sources can be set with the ``adaptive_thresh`` parameter:
-
-.. parsed-literal::
-
- adaptive_rms_box ...... True : Use adaptive rms_box when determining rms and mean maps
- :term:`adaptive_thresh` ..... None : Sources with pixels above adaptive_thresh*
- clipped_rms will be considered as bright sources (i.e.,
- with potential artifacts). None => calculate inside
- program
- :term:`rms_box_bright` ...... None : Box size, step size for rms/mean map
- calculation near bright sources. Specify as (box, step)
- in pixels. None => calculate inside program
-
-.. glossary::
-
- adaptive_thresh
- This parameter is a float (default is ``None``) that sets the SNR above which sources may be affected by strong artifacts Sources that meet the SNR threshold will use the small-scale box (set by the ``rms_box_bright`` parameter) if their sizes at a threshold of 10.0 is less than 25 beam areas.
-
- If None, the threshold is varied from 500 to 50 to attempt to obtain at least 5 candidate bright sources.
-
- rms_box_bright
- This parameter is a tuple (default is ``None``) of two integers that sets the box and step sizes to use near bright sources (determined by the ``adaptive_thresh`` parameter). The large-scale box size is set with the ``rms_box`` parameter.
-
-.. _advanced_opts:
-
-Advanced options
-================
-If ``advanced_opts = True``, a number of additional options are listed. The advanced options do not usually need to be altered from the default values, but can be useful, for example, for fine tuning a fit or for quickly fitting a small region of a much larger image.
-
-The advanced options are:
-
-.. parsed-literal::
-
- advanced_opts ......... True : Show advanced options
- :term:`aperture` ............ None : Radius of aperture in pixels inside which aperture
- fluxes are measured for each source. None => no aperture
- fluxes measured
- :term:`aperture_posn` .. 'centroid': Position the aperture (if aperture is not None) on: 'centroid' or
- 'peak' of the source.
- :term:`blank_limit` ......... None : Limit in Jy/beam below which pixels are blanked. None => no such
- blanking is done
- :term:`bmpersrc_th` ......... None : Theoretical estimate of number of beams per
- source. None => calculate inside program
- :term:`check_outsideuniv` .. False : Check for pixels outside the universe
- :term:`detection_image` ........ '': Detection image file name used only for
- detecting islands of emission. Source
- measurement is still done on the main image
- :term:`do_cache` ........... False : Cache internally derived images to disk
- :term:`do_mc_errors` ....... False : Estimate uncertainties for 'M'-type sources
- using Monte Carlo method
- :term:`fdr_alpha` ........... 0.05 : Alpha for FDR algorithm for thresholds
- :term:`fdr_ratio` ............ 0.1 : For thresh = None; if #false_pix / #source_pix <
- fdr_ratio, thresh = 'hard' else thresh = 'fdr'
- :term:`fittedimage_clip` ..... 0.1 : Sigma for clipping Gaussians while creating fitted
- image
- :term:`fix_to_beam` ........ False : Fix major and minor axes and PA of Gaussians to beam?
- :term:`group_by_isl` ....... False : Group all Gaussians in each island into a single
- source
- :term:`group_method` .. 'intensity': Group Gaussians into sources using 'intensity' map or
- 'curvature' map
- :term:`group_tol` ............ 1.0 : Tolerance for grouping of Gaussians into sources:
- larger values will result in larger sources
- :term:`ini_gausfit` ..... 'default': Initial guess for Gaussian parameters: 'default',
- 'fbdsm', or 'nobeam'
- :term:`ini_method` .... 'intensity': Method by which inital guess for fitting of Gaussians is chosen:
- 'intensity' or 'curvature'
- :term:`kappa_clip` ........... 3.0 : Kappa for clipped mean and rms
- :term:`minpix_isl` .......... None : Minimal number of pixels with emission per island.
- None -> calculate inside program
- :term:`ncores` .............. None : Number of cores to use during fitting, None => use
- all
- :term:`peak_fit` ............ True : Find and fit peaks of large islands before fitting
- entire island
- :term:`peak_maxsize` ........ 30.0 : If island size in beam area is more than this,
- attempt to fit peaks separately (if
- peak_fit=True). Min value is 30
- :term:`rms_value` ........... None : Value of constant rms in Jy/beam to use if rms_map
- = False. None => calculate inside program
- :term:`spline_rank` ............ 3 : Rank of the interpolating function for rms/mean
- map
- :term:`split_isl` ........... True : Split island if it is too large, has a large
- convex deficiency and it opens well. If it doesn't
- open well, then isl.mean = isl.clipped_mean, and
- is taken for fitting. Splitting, if needed, is
- always done for wavelet images
- :term:`splitisl_maxsize` .... 50.0 : If island size in beam area is more than this,
- consider splitting island. Min value is 50
- :term:`src_ra_dec` .......... None : List of source positions at which fitting is done. E.g.,
- src_ra_dec = [(197.1932, 47.9188), (196.5573, 42.4852)].
- :term:`src_radius_pix` ...... None : Radius of the island (if src_ra_dec is not None) in pixels. None
- => radius is set to the FWHM of the beam major axis.
- :term:`stop_at` ............. None : Stops after: 'isl' = island finding step or 'read'
- = image reading step
- :term:`trim_box` ............ None : Do source detection on only a part of the image.
- Specify as (xmin, xmax, ymin, ymax) in pixels.
- E.g., trim_box = (120, 840, 15, 895). None => use
- entire image
-
-.. glossary::
-
- aperture
- This parameter is a float (default is ``None``) that sets the radius (in
- pixels) inside which the aperture flux is measured for each source.
- The aperture is centered on the either the centroid or the peak of the
- source (depending on the value of the ``aperture_posn`` option). Errors
- are calculated from the mean of the rms map inside the aperture.
-
- aperture_posn
- This parameter is a string (default is ``'centroid'``) that sets the
- how the aperture is positioned relative to the source. If 'centroid',
- the aperture is centered on the source centroid.
- If 'peak', the aperture is centered on the source peak. If aperture=None
- (i.e., no aperture radius is specified), this parameter is ignored.
-
- blank_limit
- This parameter is a float (default is ``None``) that sets the limit in
- Jy/beam below which pixels are blanked. All pixels in the ch0 image with
- a value less than the specified limit and with at least 4 neighboring
- pixels with values also less than this limit are blanked. If ``None``,
- any such pixels are left unblanked (and hence will affect the rms and
- mean maps, etc.). Pixels with a value of NaN are always blanked.
-
- bmpersrc_th
- This parameter is a float (default is ``None``) that sets the
- theoretical estimate of number of beams per source. If ``None``, the
- value is calculated as N/[n*(alpha-1)], where N is the total number of
- pixels in the image, n is the number of pixels in the image whose value
- is greater than 5 times the clipped rms, and alpha is the slope of the
- differential source counts distribution, assumed to be 2.5.
-
- The value of ``bmpersrc_th`` is used
- to estimate the average separation in pixels between two sources, which
- in turn is used to estimate the boxsize for calculating the background
- rms and mean images. In addition, if the value is below 25 (or the ratio
- of clipped mean to clipped rms of the image is greater than 0.1), the
- image is assumed to be confused and hence the background mean is put to
- zero.
-
- check_outsideuniv
- This parameter is a Boolean (default is ``False``). If ``True``, then
- the coordinate of each pixel is examined to check if it is outside the
- universe, which may happen when, e.g., an all sky image is made with SIN
- projection (commonly done at LOFAR earlier). When found, these pixels
- are blanked (since imaging software do not do this on their own). Note
- that this process takes a lot of time, as every pixel is checked in case
- weird geometries and projections are used.
-
- detection_image
- This parameter is a string (default is ``''``) that sets the detection
- image file name used only for detecting islands of emission. Source
- measurement is still done on the main image. The detection image can be
- a FITS or CASA 2-, 3-, or 4-D cube and must have the same size and WCS
- parameters as the main image.
-
- do_cache
- This parameter is a Boolean (default is ``False``) that controls
- whether internally derived images are stored in memory or are cached
- to disk. Caching can reduce the amount of memory used, and is
- therefore useful when analyzing large images.
-
- do_mc_errors
- This parameter is a Boolean (default is ``False``). If ``True``,
- uncertainties on the sizes and positions of 'M'-type sources due to
- uncertainties in the constituent Gaussians are estimated using a Monte
- Carlo technique. These uncertainties are added in quadrature with those
- calculated using Condon (1997). If ``False``, these uncertainties are
- ignored, and errors are calculated using Condon (1997) only.
-
- Enabling this option will result in longer run times if many 'M'-type
- sources are present, but should give better estimates of the
- uncertainites, particularly for complex sources composed of many
- Gaussians.
-
- fdr_alpha
- This parameter is a float (default is 0.05) that sets the value of alpha
- for the FDR algorithm for thresholding. If ``thresh`` is ``'fdr'``, then
- the estimate of ``fdr_alpha`` (see Hopkins et al. 2002 [#f2]_ for
- details) is stored in this parameter.
-
- fdr_ratio
- This parameter is a float (default is 0.1). When ``thresh = None``, if
- #false_pix / #source_pix < fdr_ratio, ``thresh = 'hard'`` otherwise
- ``thresh = 'fdr'``.
-
- fittedimage_clip
- This parameter is a float (default is 0.1). When the residual image is
- being made after Gaussian decomposition, the model images for each
- fitted Gaussian are constructed up to a size 2b, such that the amplitude
- of the Gaussian falls to a value of ``fitted_image_clip`` times the
- local rms, b pixels from the peak.
-
- fix_to_beam
- This parameter is a Boolean (default is ``False``). If True, then during
- fitting the major and minor axes and PA of the Gaussians are fixed to
- the beam. Only the amplitude and position are fit. If False, all
- parameters are fit.
-
- group_by_isl
- This parameter is a Boolean (default is ``False``). If True, all
- Gaussians in the island belong to a single source. If False, grouping is
- controlled by the group_tol parameter.
-
- group_method
- This parameter is a string (default is ``'intensity'``). Gaussians are
- deemed to be a part of the same source if: 1. no pixel on the line
- joining the centers of any pair of Gaussians has a
- (Gaussian-reconstructed) value less than the island threshold, and 2.
- the centers are separated by a distance less than half the sum of their
- FWHMs along the line joining them. If ``'curvature'``, the above
- comparisons are done on the curature map (see Hancock et al. 2012). If
- ``'intensity'``, the comparisons are done on the intensity map.
-
- group_tol
- This parameter is a float (default is 1.0) that sets the tolerance for
- grouping of Gaussians into sources: larger values will result in larger
- sources. Sources are created by grouping nearby Gaussians as follows:
- (1) If the minimum value between two Gaussians in an island is more than
- ``group_tol * thresh_isl * rms_clip``\, and (2) if the centres are
- seperated by a distance less than 0.5*``group_tol`` of the sum of their
- FWHMs along the PA of the line joining them, they belong to the same
- island.
-
- ini_gausfit
- This parameter is a string (default is ``'default'``). These are three
- different ways of estimating the initial guess for fitting of Gaussians
- to an island of emission. If ``'default'``, the maximum number of
- Gaussians is estimated from the number of peaks in the island. An
- initial guess is made for the parameters of these Gaussians before final
- fitting is done. This method should produce the best results when there
- are no large sources present. If ``'simple'``, the maximum number of
- Gaussians per island is set to 25, and no initial guess for the Gaussian
- parameters is made. Lastly, the ``'nobeam'`` method is similar to the
- ``'default'`` method, but no information about the beam is used. This
- method is best used when source sizes are expected to be very different
- from the beam and is generally slower than the other methods. For
- wavelet images, the value used for the original image is used for
- wavelet order j <= 3 and ``'nobeam'`` for higher orders.
-
- ini_method
- This parameter is a string (default is ``'intensity'``). If
- ``'intensity'``, the inital guess described in the help for the
- ``ini_gausfit`` parameter is calculated using the intensity (ch0) image.
- If ``'curvature'``, it is done using the curvature map (see Hancock et
- al. 2012).
-
- kappa_clip
- This parameter is a float (default is 3.0) that is the factor used for
- Kappa-alpha clipping, as in AIPS. For an image with few source pixels
- added on to (Gaussian) noise pixels, the dispersion of the underlying
- noise will need to be determined. This is done iteratively, whereby the
- actual dispersion is first computed. Then, all pixels whose value
- exceeds kappa clip times this rms are excluded and the rms is computed
- again. This process is repeated until no more pixels are excluded. For
- well behaved noise statistics, this process will converge to the true
- noise rms with a value for this parameter ~3-5. A large fraction of
- source pixels, less number of pixels in total, or significant
- non-Gaussianity of the underlying noise will all lead to non-convergence.
-
- minpix_isl
- This parameter is an integer (default is ``None``) that sets the minimum
- number of pixels in an island for the island to be included. If
- ``None``, the number of pixels is set to 1/3 of the area of an
- unresolved source using the beam and pixel size information in the image
- header. It is set to 6 pixels for all wavelet images.
-
- ncores
- This parameter is an integer (default is ``None``) that sets the number
- of cores to use during fitting. If ``None``, all available cores are
- used (one core is reserved for plotting).
-
- peak_fit
- This parameter is a Boolean (default is ``True``). When True, PyBDSM
- will identify and fit peaks of emission in large islands iteratively
- (the size of islands for which peak fitting is done is controlled with
- the peak_maxsize option), using a maximum of 10 Gaussians per iteration.
- Enabling this option will generally speed up fitting (by factors of many
- for large islands), but may result in somewhat higher residuals.
-
- peak_maxsize
- This parameter is a float (default is 30.0). If island size in beam area
- is more than this value, attempt to fit peaks iteratively (if ``peak_fit
- = True``). The minimum value is 30.
-
- rms_value
- This parameter is a float (default is ``None``) that sets the value of
- constant rms in Jy/beam to use if ``rms_map = False``. If ``None``, the
- value is calculated inside the program.
-
- spline_rank
- This parameter is an integer (default is 3) that sets the order of the
- interpolating spline function to interpolate the background rms and mean
- maps over the entire image.
-
- .. note::
-
- Bicubic interpolation (the default) can cause ringing artifacts to
- appear in the rms and mean maps in regions where sharp changes
- occur. These artifacts can result in regions with negative values.
- If you find such artifacts, try changing the :term:`spline_rank`
- parameter.
-
- split_isl
- This parameter is a Boolean (default is ``True``). If ``True``, an
- island is split if it is too large, has a large convex deficiency and it
- opens well. If it doesn't open well, then ``isl.mean =
- isl.clipped_mean``, and is taken for fitting. Splitting, if needed, is
- always done for wavelet images
-
- splitisl_maxsize
- This parameter is a float (default is 50.0). If island size in beam area
- is more than this, consider splitting island. The minimum value is 50.
-
- src_ra_dec
- This parameter is a list of tuples (default is ``None``) that defines
- the center positions at which fitting will be done. The size of the
- region used for the fit is given by the ``src_radius_pix`` parameter.
- Positions should be given as a list of RA and Dec, in degrees, one set
- per source. These positions will override the normal island finding
- module.
-
- src_radius_pix
- This parameter is a float (default is ``None``) that determines the size
- of the region used to fit the source positions specified by the
- ``src_ra_dec`` parameter. If ``None``, the radius is set to the FWHM of
- the beam major axis.
-
- stop_at
- This parameter is a string (default is ``None``) that stops an analysis
- after: 'isl' = island finding step or 'read' = image reading step.
-
- trim_box
- This parameter is a tuple (default is ``None``) that defines a subregion
- of the image on which to do source detection. It is specified as (xmin,
- xmax, ymin, ymax) in pixels. E.g., ``trim_box = (120, 840, 15, 895)``\.
- If ``None``, the entire image is used.
-
-
-.. _flagging_opts:
-
-Flagging options
-================
-If ``flagging_opts = True``, a number of options are listed for flagging unwanted Gaussians that occur durring a fit. Flagged Gaussians are not included in any further analysis or catalog. They may be viewed using the ``show_fit`` task (see :ref:`showfit`). A flag value is associated with each flagged Gaussian that allows the user to determine the reason or reasons that it was flagged. If multiple flagging conditions are met by a single Gaussian, the flag values are summed. For example, if a Gaussian is flagged because it is too large (its size exceeds that implied by ``flag_maxsize_bm``, giving a flag value of 64) and because it is too bright (its peak flux density per beam exceeds that implied by ``flag_maxsnr``, giving a flag value of 2) then the final flag value is 64 + 2 = 66.
-
-.. note::
-
- If a fit did not produce good results, it is often useful to check whether there are flagged Gaussians and adjust the flagging options as necessary. Flagged Gaussians can be viewed by setting ``ch0_flagged = True`` in the ``show_fit`` task.
-
-The options for flagging of Gaussians are:
-
-.. parsed-literal::
-
- flagging_opts ......... True : Show options for Gaussian flagging
- :term:`flag_bordersize` ........ 0 : Flag Gaussian if centre is outside border -
- flag_bordersize pixels
- :term:`flag_maxsize_bm` ..... 25.0 : Flag Gaussian if area greater than flag_maxsize_bm
- times beam area
- :term:`flag_maxsize_isl` ..... 1.0 : Flag Gaussian if x, y bounding box around
- sigma-contour is factor times island bbox
- :term:`flag_maxsnr` .......... 1.5 : Flag Gaussian if peak is greater than flag_maxsnr
- times max value in island
- :term:`flag_minsize_bm` ...... 0.7 : Flag Gaussian if flag_smallsrc = True and area
- smaller than flag_minsize_bm times beam area
- :term:`flag_minsnr` .......... 0.9 : Flag Gaussian if peak is less than flag_minsnr
- times thresh_pix times local rms
- :term:`flag_smallsrc` ...... False : Flag sources smaller than flag_minsize_bm times
- beam area
-
-.. glossary::
-
- flag_bordersize
- This parameter is an integer (default is 0). Any fitted Gaussian whose centre is ``flag_bordersize`` pixels outside the island
- bounding box is flagged. The flag value is increased by 4 (for x) and 8
- (for y).
-
- flag_maxsize_bm
- This parameter is a float (default is 25.0). Any fitted Gaussian whose size is greater than ``flag_maxsize_bm`` times the
- synthesized beam is flagged. The flag value is increased by 64.
-
- flag_maxsize_fwhm
- This parameter is a float (default is 0.3). Any fitted Gaussian whose contour of ``flag_maxsize_fwhm`` times the FWHM falls outside the island is flagged. The flag value is increased by 256.
-
- flag_maxsize_isl
- This parameter is a float (default is 1.0). Any fitted Gaussian whose maximum x-dimension is larger than
- ``flag_maxsize_isl`` times the x-dimension of the island (and likewise for
- the y-dimension) is flagged. The flag value is increased by 16 (for x)
- and 32 (for y).
-
- flag_maxsnr
- This parameter is a float (default is 1.5). Any fitted Gaussian whose peak is greater than ``flag_maxsnr`` times
- the value of the image at the peak of the Gaussian is flagged. The flag value is increased
- by 2.
-
- flag_minsize_bm
- This parameter is a float (default is 0.7). If ``flag_smallsrc`` is True, then any fitted Gaussian whose size is less
- than ``flag_maxsize_bm`` times the synthesized beam is flagged. The Gaussian
- flag is increased by 128.
-
- flag_minsnr
- This parameter is a float (default is 0.7). Any fitted Gaussian whose peak is less than ``flag_minsnr`` times ``thresh_pix``
- times the local rms is flagged. The flag value is increased by 1.
-
- flag_smallsrc
- This parameter is a Boolean (default is ``False``). If ``True``\, then fitted Gaussians whose size is less than ``flag_minsize_bm``
- times the synthesized beam area are flagged. When combining Gaussians
- into sources, an error is raised if a 2x2 box with the peak of the
- Gaussian does not have all four pixels belonging to the source. Usually
- this means that the Gaussian is an artifact or has a very small size.
-
- If ``False``\, then if either of the sizes of the fitted Gaussian is zero,
- then the Gaussian is flagged.
-
- If the image is barely Nyquist sampled, this flag is best set to ``False``\.
- This flag is automatically set to ``False`` while decomposing wavelet images
- into Gaussians.
-
-.. _output_opts:
-
-Output options
-==============
-If ``output_opts = True``, options to control the output generated by ``process_image`` are listed. By default, only a log file is generated and output is controlled with the ``export_image`` (see :ref:`export_image`) and ``write_catalog`` (see :ref:`write_catalog`) tasks. However, the user can specify that a number of optional output files be made automatically whenever ``process_image`` is run. These options are most useful for debugging or when running PyBDSM non-interactively in a Python script (see :ref:`scripting`).
-
-The output options are:
-
-.. parsed-literal::
-
- output_opts ........... True : Show output options
- :term:`bbs_patches` ......... None : For BBS format, type of patch to use: None => no
- patches. 'single' => all Gaussians in one patch.
- 'gaussian' => each Gaussian gets its own patch.
- 'source' => all Gaussians belonging to a single
- source are grouped into one patch. 'mask' => use mask
- file specified by bbs_patches_mask
- :term:`bbs_patches_mask` .... None : Name of the mask file (of same size as input image)
- that defines the patches if bbs_patches = 'mask'
- :term:`indir` ............... None : Directory of input FITS files. None => get from
- filename
- :term:`opdir_overwrite` .. 'overwrite': 'overwrite'/'append': If output_all=True,
- delete existing files or append a new directory
- :term:`output_all` ......... False : Write out all files automatically to directory
- 'filename_pybdsm'
- :term:`plot_allgaus` ....... False : Make a plot of all Gaussians at the end
- :term:`plot_islands` ....... False : Make separate plots of each island during fitting
- (for large images, this may take a long time and a
- lot of memory)
- :term:`print_timing` ....... False : Print basic timing information
- :term:`quiet` .............. False : Suppress text output to screen. Output is still
- sent to the log file as usual
- :term:`savefits_meanim` .... False : Save background mean image as fits file
- :term:`savefits_normim` .... False : Save norm image as fits file
- :term:`savefits_rankim` .... False : Save island rank image as fits file
- :term:`savefits_residim` ... False : Save residual image as fits file
- :term:`savefits_rmsim` ..... False : Save background rms image as fits file
- :term:`solnname` ............ None : Name of the run, to be appended to the name of the
- output directory
- :term:`verbose_fitting` .... False : Print out extra information during fitting
-
-.. glossary::
-
- bbs_patches
- This parameter is a string (default is ``None``) that sets the type of patch to use in BBS-formatted catalogs. When the Gaussian catalogue is written as a BBS-readable sky file, this option determines whether all Gaussians are in a single patch (``'single'``), there are no patches (``None``), all Gaussians for a given source are in a separate patch (``'source'``), each Gaussian gets its own patch (``'gaussian'``), or a mask image is used to define the patches (``'mask'``).
-
- If you wish to have patches defined by island, then set
- ``group_by_isl = True`` before fitting to force all
- Gaussians in an island to be in a single source. Then set
- ``bbs_patches = 'source'`` when writing the catalog.
-
- bbs_patches_mask
- This parameter is a string (default is ``None``) that sets the file name of the mask file to use to define patches in BBS-formatted catalogs. The mask image should be 1 inside the patches and 0 elsewhere and should be the same size as the input image (before any ``trim_box`` is applied). Any Gaussians that fall outside of the patches will be ignored and will not appear in the output sky model.
-
- indir
- This parameter is a string (default is ``None``) that sets the directory of input FITS files. If ``None``, the directory is defined by the input filename.
-
- opdir_overwrite
- This parameter is a string (default is ``'overwrite'``) that determines whether existing output files are overwritten or not.
-
- output_all
- This parameter is a Boolean (default is ``False``). If ``True``\, all output products are written automatically to the directory ``'filename_pybdsm'``.
-
- plot_allgaus
- This parameter is a Boolean (default is ``False``). If ``True``\, make a plot of all Gaussians at the end.
-
- plot_islands
- This parameter is a Boolean (default is ``False``). If ``True``\, make separate plots of each island during fitting
- (for large images, this may take a long time and a
- lot of memory).
-
- print_timing
- This parameter is a Boolean (default is ``False``). If ``True``\, print basic timing information.
-
- quiet
- This parameter is a Boolean (default is ``False``). If ``True``\, suppress text output to screen. Output is still
- sent to the log file as usual.
-
- savefits_meanim
- This parameter is a Boolean (default is ``False``). If ``True``\, save background mean image as a FITS file.
-
- savefits_normim
- This parameter is a Boolean (default is ``False``). If ``True``\, save norm image as a FITS file.
-
- savefits_rankim
- This parameter is a Boolean (default is ``False``). If ``True``\, save island rank image as a FITS file.
-
- savefits_residim
- This parameter is a Boolean (default is ``False``). If ``True``\, save residual image as a FITS file.
-
- savefits_rmsim
- This parameter is a Boolean (default is ``False``). If ``True``\, save background rms image as a FITS file.
-
- solnname
- This parameter is a string (default is ``None``) that sets the name of the run, to be appended to the name of the
- output directory.
-
- verbose_fitting
- This parameter is a Boolean (default is ``False``). If ``True``\, print out extra information during fitting.
-
-
-
-.. _multichan_opts:
-
-Multichannel options
-====================
-If ``multichan_opts = True``, the options used to control the way PyBDSM handles images with more than one frequency channel are listed. In particular, these options control how the multichannel image is collapsed to form the ``ch0`` image on which source detection is done.
-
-The options concerning multichannel images are:
-
-.. parsed-literal::
-
- multichan_opts ........ True : Show options for multi-channel images
- :term:`beam_sp_derive` ..... False : If True and beam_spectrum is None, then assume
- header beam is for median frequency and scales
- with frequency for channels
- :term:`beam_spectrum` ....... None : FWHM of synthesized beam per channel. Specify as
- [(bmaj_ch1, bmin_ch1, bpa_ch1), (bmaj_ch2,
- bmin_ch2, bpa_ch2), etc.] in degrees. E.g.,
- beam_spectrum = [(0.01, 0.01, 45.0), (0.02, 0.01,
- 34.0)] for two channels. None => all equal to beam
- :term:`collapse_av` ........... [] : List of channels to average if collapse_mode =
- 'average'; None => all
- :term:`collapse_ch0` ........... 0 : Number of the channel for source extraction, if
- collapse_mode = 'single'
- :term:`collapse_mode` ... 'average': Collapse method: 'average' or 'single'. Average
- channels or take single channel to perform source
- detection on
- :term:`collapse_wt` ....... 'unity': Weighting: 'unity' or 'rms'. Average channels with
- weights = 1 or 1/rms_clip^2 if collapse_mode =
- 'average'
- :term:`frequency_sp` ........ None : Frequency in Hz of channels in input image when
- more than one channel is present. E.g., frequency
- = [74e6, 153e6]. None => get from header
-
-.. glossary::
-
- beam_sp_derive
- This parameter is a Boolean (default is ``False``). If `True` and the parameter beam_spectrum is ``None``, then we assume that the
- beam in the header is for the median frequency of the image cube and
- scale accordingly to calculate the beam per channel. If ``False``, then a
- constant value of the beam is taken instead.
-
- beam_spectrum
- This parameter is a list of tuples (default is ``None``) that sets the FWHM of synthesized beam per channel. Specify as [(bmaj_ch1, bmin_ch1,
- bpa_ch1), (bmaj_ch2, bmin_ch2, bpa_ch2), etc.] in degrees. E.g.,
- ``beam_spectrum = [(0.01, 0.01, 45.0), (0.02, 0.01, 34.0)]`` for two
- channels.
-
- If ``None``, then the channel-dependent restoring beam is either assumed to
- be a constant or to scale with frequency, depending on whether the
- parameter ``beam_sp_derive`` is ``False`` or ``True``.
-
- collapse_av
- This parameter is a list of integers (default is ``[]``) that specifies the channels to be averaged to produce the
- continuum image for performing source extraction, if ``collapse_mode`` is
- ``'average'``. If the value is ``[]``, then all channels are used. Otherwise, the
- value is a Python list of channel numbers.
-
- collapse_ch0
- This parameter is an integer (default is 0) that specifies the number of the channel for source extraction, if ``collapse_mode = 'single'``.
-
- collapse_mode
- This parameter is a string (default is ``'average'``) that determines whether, when multiple channels are present,
- the source extraction is done on a single channel (``'single'``) or an average of many
- channels (``'average'``).
-
- collapse_wt
- This parameter is a string (default is ``'unity'``). When ``collapse_mode`` is ``'average'``, then if this value is ``'unity'``, the
- channels given by ``collapse_av`` are averaged with unit weights and if
- ``'rms'``, then they are averaged with weights which are inverse square of
- the clipped rms of each channel image.
-
- frequency_sp
- This parameter is a list of floats (default is ``None``) that sets the frequency in Hz of channels in input image when more than one channel is present. E.g., ``frequency_sp = [74e6, 153e6]``.
-
- If the frequency is not given by the user, then it is looked for in the
- image header. If not found, then an error is raised. PyBDSM will not
- work without the knowledge of the frequency.
-
-
-.. _atrous_do:
-
-*À trous* wavelet decomposition module
---------------------------------------
-If ``atrous_do = True``, this module decomposes the residual image that results from the normal fitting of Gaussians into wavelet images of various scales. Such a decomposition is useful if there is extended emission that is not well fit during normal fitting. Such emission therefore remains in the Gaussian residual image and can be further fit by Gaussians whose size is tuned to the various wavelet scales. Therefore, wavelet decomposition should be used when there is significant residual emission that remains after normal Gaussian fitting.
-
-The wavelet module performs the following steps:
-
-* The number of wavelet scales to be considered is set by the ``atrous_jmax`` parameter. By default, this number is determined automatically from the size of the largest island in the image. Wavelet images are then made for scales of order (*j*) ranging from 1 to *jmax*.
-
-* For each scale (*j*), the appropriate *Ã trous* wavelet transformation is made (see Holschneider et al. 1989 for details). Additionally, the "remainder" image (called the *c_J* image) is also made. This image includes all emission not included in the other wavelet images.
-
-* Depending on the value of the ``atrous_sum`` option, fitting is done to either an image that is a sum over all scales equal to or larger than the scale under consideration (``atrous_sum = True``) or to an image of a single scale (``atrous_sum = False``). Fitting to the sum over all larger scales will generally result in increased signal to noise.
-
-* If ``atrous_bdsm = True``, an rms map and a mean map are made for each wavelet image and Gaussians are fit in the normal way. Gaussians can be optionally restricted to lie within islands found from the initial image. If a wavelet island overlaps spatially with an existing island, the two islands are merged together to form a single island. The wavelet Gaussians can then be included in source catalogs (see :ref:`write_catalog`).
-
-The options for this module are as follows:
-
-.. parsed-literal::
-
- atrous_do ............. True : Decompose Gaussian residual image into multiple
- scales
- :term:`atrous_bdsm_do` ...... True : Perform source extraction on each wavelet scale
- :term:`atrous_jmax` ............ 0 : Max allowed wavelength order, 0 => calculate
- inside program
- :term:`atrous_lpf` ........... 'b3': Low pass filter, either 'b3' or 'tr', for B3
- spline or Triangle
- :term:`atrous_orig_isl` .... False : Restrict wavelet Gaussians to islands found in
- original image
- :term:`atrous_sum` .......... True : Fit to the sum of images of the remaining wavelet
- scales
- :term:`use_scipy_fft` ....... True : Use fast SciPy FFT for convolution
-
-.. glossary::
-
- atrous_bdsm_do
- This parameter is a Boolean (default is ``False``). If ``True``, PyBDSM performs source extraction on each wavelet scale.
-
- atrous_jmax
- This parameter is an integer (default is 0) which is the maximum order of the *Ã trous* wavelet
- decomposition. If 0 (or <0 or >15), then the value is determined within
- the program. The value of this parameter is then estimated as the
- (lower) rounded off value of ln[(nm-l)/(l-1) + 1]/ln2 + 1 where nm is
- the minimum of the residual image size (n, m) in pixels and l is the
- length of the filter *Ã trous* lpf (see the ``atrous_lpf`` parameter for more
- info).
-
- A sensible value is such that the size of the kernel is not more than
- 3-4 times smaller than the smallest image dimension.
-
- atrous_lpf
- This parameter is a string (default is ``'b3'``) that sets the low pass filter, which can be either the B3 spline
- or the triangle function, which is used to generate the *Ã trous*
- wavelets. The B3 spline is [1, 4, 6, 4, 1] and the triangle is [1, 2,
- 1], normalised so that the sum is unity. The lengths of the filters are
- hence 5 and 3 respectively.
-
- atrous_orig_isl
- This parameter is a Boolean (default is ``False``). If ``True``, all wavelet Gaussians must lie within the boundaries of islands found in the original image. If ``False``, new islands that are found only
- in the wavelet images are included in the final fit.
-
- atrous_sum
- This parameter is a Boolean (default is ``True``). If ``True``, fitting is done on an image that is the sum of the remaining wavelet scales. Using the sum will generally result in improved signal.
- If ``False``, fitting is done on only the wavelet scale under consideration.
-
- use_scipy_fft
- This parameter is a Boolean (default is ``True``). If ``True``, the SciPy FFT function will be used instead of the custom version. The SciPy version is much faster but also uses much more memory.
-
-.. _psf_vary_do:
-
-PSF variation module
---------------------
-If ``psf_vary_do = True``, then the spatial variations in the PSF are estimated and their effects corrected for. To this end, PyBDSM performs the following steps:
-
-* A list of sources that are likely to be unresolved is constructed. This is done by first selecting only type 'S' sources by default (see :ref:`output_cols` for details of source types), but this restriction can be overridden using the ``psf_stype_only`` option) and sources with SNRs that exceed ``psf_snrcut``. Next, a function is fit to determine how the size of sources (normalized by the median size) varies with the SNR. The function used is defined as :math:`\sigma / median = \sqrt(c_1^2 + c_2^2/SNR^2)`, where :math:`\sigma` is the size of the Gaussian and :math:`c_1` and :math:`c_2` are free parameters. Clipping of outliers is done during this fitting, controlled by the ``psf_nsig`` parameter. Lastly, unresolved sources are selected by choosing sources that lie within ``psf_kappa2`` times the rms of this best-fit sigma-SNR relation. As this last step can be unreliable for high-SNR sources, an additional selection can be made for the highest SNR sources using the ``psf_high_snr`` parameter. All sources with SNRs above ``psf_high_snr`` will be taken as unresolved.
-
-* Next the image is tessellated using Voronoi tessellation to produce tiles within which the PSF shape is calculated (and assumed to be constant). The list of probable unresolved sources is filtered to select "calibrator" sources to use to determine the tessellation tiles. These sources are the brightest sources (known as the primary generators), defined as those sources that have SNRs in the top fraction of sources defined by ``psf_snrtop`` and that also have SNRs greater than ``psf_snrcutstack``. These sources are then grouped by their proximity, if they are within 50% of the distance to third closest source.
-
-* The unresolved sources within each tile that have SNRs greater than ``psf_snrcutstack`` are then stacked to form a high-SNR PSF. For each tile, this PSF is fit with a Gaussian to recover its size. The significance of the variation in the sizes across the image is quantified.
-
-* If the variation is significant, the major axis, minor axis, and position angle are then interpolated across the image. Smoothing can be applied to these images to smooth out artifacts due to noise and the interpolation. Additionally, images are made of the ratio of peak-to-total flux and peak-to-aperture flux (if an aperture is specified). These ratio images provide conversions from total flux to peak flux for point sources. In the absence of smearing effects, these ratios should be around unity. However, if ionospheric effects are present, significant smearing can be present. In this case, these ratio images can be useful, for example, in determining the sensitivity at a particular location in the image to a point source with a given total flux.
-
-* Lastly, the deconvolved source sizes are adjusted to include the PSF variation as a function of position.
-
-The options for this module are as follows:
-
-.. parsed-literal::
-
- psf_vary_do ........... True : Calculate PSF variation across image
- :term:`psf_high_snr` ........ None : SNR above which all sources are taken to be
- unresolved. E.g., psf_high_snr = 20.0. None => no
- such selection is made
- :term:`psf_itess_method` ....... 0 : 0 = normal, 1 = 0 + round, 2 = LogSNR, 3 =
- SqrtLogSNR
- :term:`psf_kappa2` ........... 2.0 : Kappa for clipping for analytic fit
- :term:`psf_nsig` ............. 3.0 : Kappa for clipping within each bin
- :term:`psf_over` ............... 2 : Factor of nyquist sample for binning bmaj, etc. vs
- SNR
- :term:`psf_smooth` .......... None : Size of Gaussian to use for smoothing of
- interpolated images in arcsec. None => no smoothing
- :term:`psf_snrcut` .......... 10.0 : Minimum SNR for statistics
- :term:`psf_snrcutstack` ..... 15.0 : Unresolved sources with higher SNR taken for
- stacked psfs
- :term:`psf_snrtop` .......... 0.15 : Fraction of SNR > snrcut as primary generators
- :term:`psf_stype_only` ...... True : Restrict sources used in PSF variation
- estimating to be only of type 'S'
-
-.. glossary::
-
- psf_high_snr
- This parameter is a float (default is ``None``). Gaussians with SNR greater than this are used to determine the PSF
- variation, even if they are deemed to be resolved. This corrects for the
- unreliability at high SNRs in the algorithm used to find unresolved
- sources. The minimum value is 20.0. If ``None``, then no such selection is made.
-
- psf_itess_method
- This parameter is an integer (default is 0) which can be 0, 1, 2 or 3, which
- corresponds to a tessellation method. If 0, 2 or 3, then the weights
- used for Voronoi tessellation are unity, log(SNR) and sqrt[log(SNR)]
- where SNR is the signal to noise ratio of the generator in a tile. If 1,
- then the image is tessellated such that each tile has smooth boundaries
- instead of straight lines, using pixel-dependent weights.
-
- psf_kappa2
- This parameter is a float (default is 2.0). When iteratively arriving at a statistically probable set of
- 'unresolved' sources, the fitted major and minor axis sizes versus SNR
- are binned and fitted with analytical functions. Those Gaussians which
- are within ``psf_kappa2`` times the fitted rms from the fitted median are
- then considered 'unresolved' and are used further to estimate the PSFs.
-
- psf_nsig
- This parameter is a float (default is 3.0). When constructing a set of 'unresolved' sources for psf estimation, the
- (clipped) median, rms and mean of major and minor axis sizes of
- Gaussians versus SNR within each bin is calculated using ``kappa = psf_nsig``.
-
- psf_over
- This parameter is an integer (default is 2). When constructing a set of 'unresolved' sources for psf estimation, this parameter controls the factor of nyquist sample for binning bmaj, etc. vs SNR.
-
- psf_smooth
- This parameter is a float (default is ``None``) that sets the smoothing scale (in arcsec) used to smooth the interpolated images. Generally, artifacts due to noise and the interpolation can be significantly reduced if the smoothing scale is similar to the typical source separation scale.
-
- psf_snrcut
- This parameter is a float (default is 10.0). Only Gaussians with SNR greater than this are considered for processing.
- The minimum value is 5.0
-
- psf_snrcutstack
- This parameter is a float (default is 15.0). Only Gaussians with SNR greater than this are used for estimating PSF
- images in each tile.
-
- psf_snrtop
- This parameter is a float (default is 0.15). If ``psf_generators`` is 'calibrator', then the peak pixels of Gaussians
- which are the ``psf_snrtop`` fraction of the SNR distribution are taken as Voronoi
- generators.
-
- psf_stype_only
- This parameter is a Boolean (default is ``False``). If ``True``\, sources are restricted to be only of type 'S'.
-
-.. _spectralindex_do:
-
-Spectral index module
----------------------
-If ``spectralindex_do = True`` (and the input image has more than one frequency), then spectral indices are calculated for the sources in the following way:
-
-* The rms maps for the remaining channels are determined.
-
-* Neighboring channels are averaged to attempt to obtain the target SNR per channel for a given source, set by the ``specind_snr`` parameter.
-
- .. note::
-
- No color corrections are applied during averaging. However, unless the source spectral index is very steep or the channels are very wide, the correction is minimal. See :ref:`colorcorrections` for details.
-
-* Flux densities are measured for both individual Gaussians and for total sources. Once source flux densities have been measured in each channel, the SEDs are fit with a polynomial function. The best-fit parameters are then included in any catalogs that are written out (see :ref:`write_catalog`). In addition, plots of the fits can be viewed with the ``show_fit`` task (see :ref:`showfit`).
-
-The options for this module are as follows:
-
-.. parsed-literal::
-
- spectralindex_do ...... True : Calculate spectral indices (for multi-channel
- image)
- :term:`flagchan_rms` ........ True : Flag channels before (averaging and) extracting
- spectral index, if their rms if more than 5
- (clipped) sigma outside the median rms over all
- channels, but only if <= 10% of channels
- :term:`flagchan_snr` ........ True : Flag channels that do not meet SNR criterion set
- by specind_snr
- :term:`specind_maxchan` ........ 0 : Maximum number of channels to average for a
- given source when when attempting to meet target
- SNR. 1 => no averaging; 0 => no maximum
- :term:`specind_snr` .......... 3.0 : Target SNR to use when fitting power law. If
- there is insufficient SNR, neighboring channels
- are averaged to obtain the target SNR
-
-.. glossary::
-
- flagchan_rms
- This parameter is a Boolean (default is ``True``). If ``True``, then the clipped rms and median (r and m) of the clipped rms of
- each channel is calculated. Those channels whose clipped rms is greater
- than 4r away from m are flagged prior to averaging and calculating
- spectral indices from the image cube. However, these channels are
- flagged only if the total number of these bad channels does not exceed
- 10% of the total number of channels themselves.
-
- flagchan_snr
- This parameter is a Boolean (default is ``True``). If ``True``, then flux densities in channels that do not meet the target SNR are not used in fitting.
-
- specind_maxchan
- This parameter is an integer (default is 0) that sets the maximum number of channels that can be averaged together to attempt to reach the target SNR set by the ``specind_snr`` parameter. If 0, there is no limit to the number of channels that can be averaged. If 1, no averaging will be done.
-
- specind_snr
- This parameter is a float (default is 3.0) that sets the target SNR to use when fitting for the spectral index. If there is insufficient SNR, neighboring channels are averaged to obtain the target SNR. The maximum allowable number of channels to average is determined by the ``specind_maxchan`` parameter. Channels (after averaging) that fail to meet the target SNR are not used in fitting.
-
-.. _polarisation_do:
-
-Polarization module
--------------------
-If ``polarisation_do = True``, then the polarization properties of the sources are calculated. First, if ``pi_fit = True``, source detection is performed on the polarized intensity (PI) image [#f3]_ to detect sources without Stokes I counterparts. The polarization module then calculates the I, Q, U, and V flux densities, the total, linear, and circular polarisation fractions and the linear polarisation angle of each Gaussian and source. The linear polarisation angle is defined from North, with positive angles towards East. Flux densities are calculated by fitting the normalization of the Gaussians found using the Stokes I or PI images.
-
-For linearly polarised emission, the signal and noise add vectorially, giving a
-Rice distribution instead of a Gaussian one. To correct for this, a bias
-is estimated and removed from the polarisation fraction using the same method used for the
-NVSS catalog (see ftp://ftp.cv.nrao.edu/pub/nvss/catalog.ps). Errors on the linear and total
-polarisation fractions and polarisation angle are estimated using the debiased polarised flux density
-and standard error propagation. See Sparks & Axon (1999) [#f4]_ for a more detailed treatment.
-
-The options for this module are as follows:
-
-.. parsed-literal::
-
- polarisation_do ....... True : Find polarisation properties
- :term:`pi_fit` .............. True : Check the polarized intesity (PI) image for
- sources not found in Stokes I
- :term:`pi_thresh_isl` ....... None : Threshold for PI island boundary in number
- of sigma above the mean. None => use thresh_isl
- :term:`pi_thresh_pix` ....... None : Source detection threshold for PI image:
- threshold for the island peak in number of sigma
- above the mean. None => use thresh_pix
-
-.. glossary::
-
- pi_fit
- This parameter is a Boolean (default is ``True``). If ``True``, the polarized intensity image is searched for sources not
- present in the Stokes I image. If any such sources are found, they are
- added to the the Stokes I source lists. Use the ``pi_thresh_pix`` and
- ``pi_thresh_isl`` parameters to control island detection in the PI image.
-
- pi_thresh_isl
- This parameter is a float (default is ``None``) that determines the region to which fitting is done in the
- polarized intensity (PI) image. If ``None``, the value is set to that of the ``thresh_isl`` parameter. A higher value will produce smaller
- islands, and hence smaller regions that are considered in the fits. A
- lower value will produce larger islands. Use the ``pi_thresh_pix`` parameter
- to set the detection threshold for sources. Generally, ``pi_thresh_isl``
- should be lower than ``pi_thresh_pix``.
-
- pi_thresh_pix
- This parameter is a float (default is ``None``) that sets the overall detection threshold for islands in the
- polarized intensity (PI) image (i.e. pi_thresh_pix = 5 will find all
- sources with peak flux densities per beam of 5-sigma or greater). If ``None``, the value is set to that of the ``thresh_pix`` parameter. Use the ``pi_thresh_isl``
- parameter to control how much of each island is used in fitting.
- Generally, ``pi_thresh_pix`` should be larger than ``pi_thresh_isl``.
-
-.. _shapelet_do:
-
-Shapelet decomposition module
------------------------------
-If ``shapelet_do = True``, then islands are decomposed into shapelets. Shapelets are a set of 2-D basis functions (for details, see Refregier 2003 [#f5]_) that can be used to completely model any source, typically with far fewer parameters than pixels in the source. Shapelets are useful in particular for modeling complex islands that are not well modeled by Gaussians alone. PyBDSM can currently fit cartesian shapelets to an image. The shapelet parameters can be written to a catalog using ``write_catalog`` (see :ref:`write_catalog`).
-
-For each island of emission, a shapelet decomposition is done after estimating the best values of the
-center, the scale :math:`\beta`, and nmax in the following way. First, an initial guess of :math:`\beta` is taken as :math:`2\sqrt{[m2(x)m2(y)]}`,
-where :math:`m2` is the second moment over the island, based on shapeelt analysis
-of simulated images of resolved sources. Similarly, a guess for nmax is taken as the minimum
-of 14, and maximum of 10 and :math:`2n + 2` where :math:`n=\sqrt{(n^2 + m^2)}/n_p^n - 1`, where (n, m) is the size of
-the island and :math:`n^m_p` is the synthesized beam minor axis FWHM in pixels. This guess for nmax is
-based partly on simulations and partly on the requirememts of computing time, number of
-constraints, etc, for shapelet decomposition.
-
-These initial values are then used to calculate the optimal central position around which
-to decompose the island. First, for every pixel in the island, the coefficients c12 and c21
-are computed assuming that pixel as the centre of expansion. Next, the zero crossings for
-every vertical line of the c12 image and horizontal line of the c21 image are computed. The
-intersection point of these two zero-crossing vectors is then taken as the proper centre of the
-expansion for the image. If this procedure does not work, then the first moment is taken as
-the center.
-
-This updated center position is used to compute the optimal :math:`\beta`, which is taken as the value of
-:math:`\beta` that minimises the residual rms in the island area. Using this :math:`\beta`, the center is computed
-once more and the final shapelet deocmposition is then made.
-
-The options for this module are as follows:
-
-.. parsed-literal::
-
- shapelet_do ........... True : Decompose islands into shapelets
- :term:`shapelet_basis` .. 'cartesian': Basis set for shapelet decomposition:
- 'cartesian' or 'polar'
- :term:`shapelet_fitmode` .... 'fit': Calculate shapelet coeff's by fitting ('fit') or
- integrating (None)
-
-.. glossary::
-
- shapelet_basis
- This parameter is a string (default is ``'cartesian'``) that determines the type of shapelet
- basis used. Currently however, only cartesian is supported.
-
- shapelet_fitmode
- This parameter is a string (default is ``'fit'``) that determines the method of calculating
- shapelet coefficients. If ``None``, then these are calculated by integrating
- (actually, by summing over pixels, which introduces errors due to
- discretisation). If 'fit', then the coefficients are found by
- least-squares fitting of the shapelet basis functions to the image.
-
-.. rubric:: Footnotes
-
-.. [#f1] Condon, J. J. 1997, PASP, 109, 166
-
-.. [#f2] Hopkins, A. M., Miller, C. J., Connolly, A. J., et al. 2002, AJ, 123, 1086
-
-.. [#f3] The polarized intensity image is calculated as :math:`\sqrt{(Q^2 + U^2)}`.
-
-.. [#f4] Sparks, W. B., & Axon, D. J. 1999, PASP, 111, 1298
-
-.. [#f5] Refregier, A. 2003, MNRAS, 338, 35.
diff --git a/CEP/PyBDSM/doc/source/pt_src_example.png b/CEP/PyBDSM/doc/source/pt_src_example.png
deleted file mode 100644
index 6f7d0badbef80e45b434696f623b030d7bd68041..0000000000000000000000000000000000000000
Binary files a/CEP/PyBDSM/doc/source/pt_src_example.png and /dev/null differ
diff --git a/CEP/PyBDSM/doc/source/pybdsm_manual_dia.png b/CEP/PyBDSM/doc/source/pybdsm_manual_dia.png
deleted file mode 100644
index 571276200277c9ce7cfbdcadecf74520f1f49db9..0000000000000000000000000000000000000000
Binary files a/CEP/PyBDSM/doc/source/pybdsm_manual_dia.png and /dev/null differ
diff --git a/CEP/PyBDSM/doc/source/quick_example.png b/CEP/PyBDSM/doc/source/quick_example.png
deleted file mode 100644
index 348c1a9ba49b9eafd15489213fc7d6eb6155f3bb..0000000000000000000000000000000000000000
Binary files a/CEP/PyBDSM/doc/source/quick_example.png and /dev/null differ
diff --git a/CEP/PyBDSM/doc/source/scripting.rst b/CEP/PyBDSM/doc/source/scripting.rst
deleted file mode 100644
index e698362102222c7984c9ba7d1bcdcd27c8eaf9b2..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/doc/source/scripting.rst
+++ /dev/null
@@ -1,42 +0,0 @@
-.. _scripting:
-
-****************
-Scripting PyBDSM
-****************
-
-Because PyBDSM is written in Python, it is straightforward to use PyBDSM non-interactively within Python scripts (for example, to automate source detection in a large number of images for which the optimal analysis parameters are known). To use PyBDSM in a Python script, import it by calling::
-
- from lofar import bdsm
-
-inside your script.
-
-.. note::
-
- If you are working on the LOFAR CEP I/II clusters, then at some point before running the script, you will need to do::
-
- $ use LofIm
-
-Processing may then be done using ``process_image()`` as follows::
-
- img = bdsm.process_image(filename, <args>)
-
-where ``filename`` is the name of the image (in FITS or CASA format) or PyBDSM parameter save file and ``<args>`` is a comma-separated list of arguments defined as in the interactive environment (e.g., ``beam = (0.033, 0.033, 0.0), rms_map=False``). See :ref:`process_image` for details.
-
-.. note::
-
- The filename of the input image is also stored in the parameter save file. If you wish to override this filename (e.g., to use the saved parameters on a different image), give the save file as the first parameter and then explicitly set the filename. For example: ``img = bdsm.process_image('image1_savefile.sav', filename='image2.fits')``.
-
-If the fit is successful, PyBDSM will return an Image object (in this example named ``img``) which contains the results of the fit (among many other things).
-
-When run in a Python script, it may be desirable to set ``output_all = True`` to write all output, including source lists, residual images, etc. to a directory named ``filename_pybdsm``. Optionally, the same tasks used in the interactive PyBDSM shell are available for examining the fit and writing out the source list, residual image, etc. These tasks are methods of the Image object returned by ``bdsm.process_image()`` and are described below. The input parameters to each of these tasks are the same as those available in the interactive shell (see the relevant task section for details).
-
-``img.show_fit()``
- This method shows a quick summary of the fit by plotting the input image with the islands and Gaussians found, along with the model and residual images. See :ref:`showfit` for details.
-
-``img.export_image()``
- Write an internally derived image (e.g., the model image) to a FITS file. See :ref:`export_image` for details.
-
-``img.write_catalog()``
- This method writes the Gaussian or source list to a file. See :ref:`write_catalog` for details.
-
-An example of using PyBDSM within a Python script is given in :ref:`script_example`.
diff --git a/CEP/PyBDSM/doc/source/show_fit.rst b/CEP/PyBDSM/doc/source/show_fit.rst
deleted file mode 100644
index 2a676f81fc9658517fb8cb5e282ba9ac2fda8266..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/doc/source/show_fit.rst
+++ /dev/null
@@ -1,84 +0,0 @@
-.. _showfit:
-
-**************************************************
-``show_fit``: visualizing the fit results
-**************************************************
-
-PyBDSM includes a task named ``show_fit`` that allows the user to quickly check the results of the ``process_image`` task. Use ``inp show_fit`` to list the parameters:
-
-.. parsed-literal::
-
- SHOW_FIT: Show results of fit.
- ================================================================================
- :term:`broadcast` ............ False : Broadcast Gaussian and source IDs and coordinates
- to SAMP hub when a Gaussian is clicked?
- :term:`ch0_flagged` .......... False : Show the ch0 image with flagged Gaussians (if
- any) overplotted
- :term:`ch0_image` ............. True : Show the ch0 image. This is the image used for
- source detection
- :term:`ch0_islands` ........... True : Show the ch0 image with islands and Gaussians (if
- any) overplotted
- :term:`gmodel_image` .......... True : Show the Gaussian model image
- :term:`gresid_image` .......... True : Show the Gaussian residual image
- :term:`mean_image` ............ True : Show the background mean image
- :term:`pi_image` ............. False : Show the polarized intensity image
- :term:`psf_major` ............ False : Show the PSF major axis variation
- :term:`psf_minor` ............ False : Show the PSF minor axis variation
- :term:`psf_pa` ............... False : Show the PSF position angle variation
- :term:`rms_image` ............. True : Show the background rms image
- :term:`smodel_image` ......... False : Show the shapelet model image
- :term:`source_seds` .......... False : Plot the source SEDs and best-fit spectral
- indices (if image was processed with
- spectralindex_do = True). Sources may be chosen
- by ID with the 'c' key or, if ch0_islands = True,
- by picking a source with the mouse
- :term:`sresid_image` ......... False : Show the shapelet residual image
-
-Each of the parameters is described in detail below.
-
-.. glossary::
-
- broadcast
- This parameter is a Boolean (default is ``False``) that determines whether the Gaussian and source IDs and coordinates are sent to a running SAMP Hub when a Gaussian is clicked on. Note that for the IDs to be useful, a catalog must have been sent to the SAMP hub previously using the ``write_catalog`` task (with ``outfile = 'SAMP'``).
-
- ch0_flagged
- This parameter is a Boolean (default is ``False``) that determines whether to plot the ch0 image (the image used for source detection) with any flagged Gaussians overplotted.
-
- ch0_image
- This parameter is a Boolean (default is ``True``) that determines whether to plot the ch0 image (the image used for source detection).
-
- ch0_islands
- This parameter is a Boolean (default is ``True``) that determines whether to plot the ch0 image (the image used for source detection) with islands and Gaussians overplotted.
-
- gmodel_image
- This parameter is a Boolean (default is ``True``) that determines whether to plot the Gaussian model image.
-
- gresid_image
- This parameter is a Boolean (default is ``True``) that determines whether to plot the Gaussian residual image.
-
- mean_image
- This parameter is a Boolean (default is ``True``) that determines whether to plot the background mean image.
-
- pi_image
- This parameter is a Boolean (default is ``False``) that determines whether to plot the polarized intensity image.
-
- psf_major
- This parameter is a Boolean (default is ``False``) that determines whether to plot the variation of the major axis of the PSF.
-
- psf_minor
- This parameter is a Boolean (default is ``False``) that determines whether to plot the variation of the minor axis of the PSF.
-
- psf_pa
- This parameter is a Boolean (default is ``False``) that determines whether to plot the variation of the position angle of the PSF.
-
- rms_image
- This parameter is a Boolean (default is ``True``) that determines whether to plot the background rms image.
-
- smodel_image
- This parameter is a Boolean (default is ``False``) that determines whether to plot the shapelet model image.
-
- source_seds
- This parameter is a Boolean (default is ``False``) that determines whether to plot the source SEDs and best-fit spectral indices.
-
- sresid_image
- This parameter is a Boolean (default is ``False``) that determines whether to plot the shapelet residual image.
diff --git a/CEP/PyBDSM/doc/source/ug_basics.rst b/CEP/PyBDSM/doc/source/ug_basics.rst
deleted file mode 100644
index 5861dd8c57eefdcac37da6a11a5f87e3f3a4ff0b..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/doc/source/ug_basics.rst
+++ /dev/null
@@ -1,265 +0,0 @@
-.. _basics:
-
-*************
-PyBDSM Basics
-*************
-PyBDSM has been designed to share many similarities with the CASA interactive environment (known as ``casapy`` [#f1]_ ), which is in turn based on AIPS. Therefore, the commands used in PyBDSM should be familiar to anyone who has used these software packages.
-
-Starting PyBDSM
----------------
-After installing (see :ref:`installing`) you can start PyBDSM by simply opening a terminal and typing::
-
- $ pybdsm
-
-at the terminal prompt.
-
-.. note::
-
- If the above command does not work, make sure you environment is initialized correctly for PyBDSM (see :ref:`add_to_path`).
-
-The interactive environment will then load, and a welcome screen listing common commands and tasks will be shown. You will then be at the PyBDSM prompt, which looks like this::
-
- BDSM [1]:
-
-Quitting PyBDSM
----------------
-To quit PyBDSM, type ``quit`` or enter ``CNTL-D`` at the prompt.
-
-
-Getting help
-------------
-PyBDSM has an extensive built-in help system. To get help on a command or task, type::
-
- help <command or task name>
-
-For example, to get help on the ``process_image`` task, type::
-
- help process_image
-
-To get help on a input parameter to a task, type::
-
- help '<parameter name>'
-
-Note the quotes, which are necessary (since parameter names are strings). For example, to get help on the ``'rms_box'`` paramter, type::
-
- help 'rms_box'
-
-Simply typing ``help`` will start the Python help system.
-
-
-Logging
--------
-Logging of all task output is done automatically to a log file. Logs for subsequent runs on the same image are appended to the end of the log file. The log for each run includes a listing of all the non-default and internally derived parameters, so that a run can be easily reproduced using only information in the log.
-
-.. _commands:
-
-Commands
---------
-As in CASA, PyBDSM uses a number of commands to list input parameters for tasks, to execute the tasks, etc. The PyBDSM commands are as follows:
-
-.. parsed-literal::
-
- :term:`inp` task ............ : Set current task and list parameters
- :term:`go` .................. : Run the current task
- :term:`default` ............. : Set current task parameters to default values
- :term:`tput` ................ : Save parameter values
- :term:`tget` ................ : Load parameter values
-
-.. glossary::
- inp
- This command sets the current task (e.g., ``inp process_image``) and lists the relevant parameters for that task. If entered without a task name, the parameters of the previously set task will be listed.
-
- .. note::
-
- At startup, the current task is set to the ``process_image`` task.
-
- go
- This command executes the current task.
-
- default
- This command resets all parameters for a task to their default values.
-
- If a task name is given (e.g.,``default show_fit``), the
- parameters for that task are reset. If no task name is
- given, the parameters of the current task are reset.
-
- tput
- This command saves the processing parameters to a file.
-
- .. note::
-
- After the successful completion of a task, the current parameters are saved to the file 'pybdsm.last'.
-
- A file name may be given (e.g., ``tput 'savefile.sav'``), in which case the
- parameters are saved to the file specified. If no file name is given, the
- parameters are saved to the file 'pybdsm.last'. The saved parameters can be
- loaded using the :term:`tget` command.
-
- tget
- This command loads the processing parameters from a parameter save file.
-
- A file name may be given (e.g., ``tget 'savefile.sav'``), in which case the
- parameters are loaded from the file specified. If no file name is given,
- the parameters are loaded from the file 'pybdsm.last' if it exists.
-
- Normally, the save file is created by the :term:`tput` command.
-
-Tasks
------
-The following tasks are available in PyBDSM:
-
-.. parsed-literal::
-
- :term:`process_image` ....... : Process an image: find sources, etc.
- :term:`show_fit` ............ : Show the results of a fit
- :term:`write_catalog` ....... : Write out list of sources to a file
- :term:`export_image` ........ : Write residual/model/rms/mean image to a file
-
-.. glossary::
- process_image
- This task processes an image to find and measure sources. See :ref:`process_image` for details.
-
- show_fit
- This task shows the result of a fit. See :ref:`showfit` for details.
-
- write_catalog
- This task writes the source catalog. See :ref:`write_catalog` for details.
-
- export_image
- This task exports an internally derived image. See :ref:`export_image` for details.
-
-
-Hierarchy of an astronomical image
-----------------------------------
-The following figure shows the basic hierarchy of an image adopted by PyBDSM. Islands of emission are identified and decomposed into Gaussians. The Gaussians are then grouped into sources.
-
-.. figure:: pybdsm_manual_dia.png
- :scale: 100 %
- :figwidth: 75 %
- :align: center
- :alt: image hierarchy
-
- The hierarchy of an image.
-
-
-.. _quick_example:
-
-Quick-start example
--------------------
-Below is an example of using PyBDSM to find and measure sources in an image::
-
- $ pybdsm
- PyBDSM version 1.1 (LOFAR revision 20883)
- ========================================================================
- PyBDSM commands
- inp task ............ : Set current task and list parameters
- par = val ........... : Set a parameter (par = '' sets it to default)
- Autocomplete (with TAB) works for par and val
- go .................. : Run the current task
- default ............. : Set current task parameters to default values
- tput ................ : Save parameter values
- tget ................ : Load parameter values
- PyBDSM tasks
- process_image ....... : Process an image: find sources, etc.
- show_fit ............ : Show the results of a fit
- write_catalog ....... : Write out list of sources to a file
- export_image ........ : Write residual/model/rms/mean image to a file
- PyBDSM help
- help command/task ... : Get help on a command or task
- (e.g., help process_image)
- help 'par' .......... : Get help on a parameter (e.g., help 'rms_box')
- help changelog ...... : See list of recent changes
- ________________________________________________________________________
-
- BDSM [1]: inp process_image
- --------> inp(process_image)
- PROCESS_IMAGE: Find and measure sources in an image.
- =================================================================================
- filename ................. '': Input image file name
- advanced_opts ........ False : Show advanced options
- adaptive_rms_box ..... False : Use adaptive rms_box when determining rms and
- mean maps
- atrous_do ............ False : Decompose Gaussian residual image into multiple
- scales
- beam .................. None : FWHM of restoring beam. Specify as (maj, min, pos
- ang E of N) in degrees. E.g., beam = (0.06, 0.02,
- 13.3). None => get from header
- flagging_opts ........ False : Show options for Gaussian flagging
- frequency ............. None : Frequency in Hz of input image. E.g., frequency =
- 74e6. None => get from header.
- interactive .......... False : Use interactive mode
- mean_map .......... 'default': Background mean map: 'default' => calc whether to
- use or not, 'zero' => 0, 'const' => clipped mean,
- 'map' => use 2-D map
- multichan_opts ....... False : Show options for multi-channel images
- output_opts .......... False : Show output options
- polarisation_do ...... False : Find polarisation properties
- psf_vary_do .......... False : Calculate PSF variation across image
- rms_box ............... None : Box size, step size for rms/mean map calculation.
- Specify as (box, step) in pixels. E.g., rms_box =
- (40, 10) => box of 40x40 pixels, step of 10
- pixels. None => calculate inside program
- rms_map ............... None : Background rms map: True => use 2-D rms map; False
- => use constant rms; None => calculate inside
- program
- shapelet_do .......... False : Decompose islands into shapelets
- spectralindex_do ..... False : Calculate spectral indices (for multi-channel
- image)
- thresh ................ None : Type of thresholding: None => calculate inside
- program, 'fdr' => use false detection rate
- algorithm, 'hard' => use sigma clipping
- thresh_isl ............. 3.0 : Threshold for the island boundary in number of
- sigma above the mean. Determines extent of island
- used for fitting
- thresh_pix ............. 5.0 : Source detection threshold: threshold for the
- island peak in number of sigma above the mean. If
- false detection rate thresholding is used, this
- value is ignored and thresh_pix is calculated
- inside the program
-
- BDSM [2]: filename = 'sb48.fits'
- BDSM [3]: go
- --------> go()
- --> Opened 'sb48.fits'
- Image size .............................. : (256, 256) pixels
- Number of channels ...................... : 1
- Beam shape (major, minor, pos angle) .... : (0.002916, 0.002654, -173.36) degrees
- Frequency of averaged image ............. : 146.497 MHz
- Blank pixels in the image ............... : 0 (0.0%)
- Flux from sum of (non-blank) pixels ..... : 29.565 Jy
- Derived rms_box (box size, step size) ... : (61, 20) pixels
- --> Variation in rms image significant
- --> Using 2D map for background rms
- --> Variation in mean image significant
- --> Using 2D map for background mean
- Min/max values of background rms map .... : (0.05358, 0.25376) Jy/beam
- Min/max values of background mean map ... : (-0.03656, 0.06190) Jy/beam
- --> Expected 5-sigma-clipped false detection rate < fdr_ratio
- --> Using sigma-clipping thresholding
- Number of islands found ................. : 4
- Fitting islands with Gaussians .......... : [====] 4/4
- Total number of Gaussians fit to image .. : 12
- Total flux in model ..................... : 27.336 Jy
- Number of sources formed from Gaussians : 6
-
- BDSM [4]: show_fit
- --------> show_fit()
-
-The figure made by ``show_fit`` is shown in the figure below. In the plot window, one can zoom in, save the plot to a file, etc. The list of best-fit Gaussians found by PyBDSM may be written to a file for use in other programs as follows::
-
- BDSM [5]: write_catalog
- --------> write_catalog()
- --> Wrote FITS file 'sb48.pybdsm.srl.fits'
-
-The output Gaussian or source list contains source positions, fluxes, etc.
-
-.. figure:: quick_example.png
- :scale: 50 %
- :figwidth: 75 %
- :align: center
- :alt: show_fit example output
-
- Output of ``show_fit``, showing the original image with and without sources, the model image, and the residual (original minus model) image. Boundaries of the islands of emission found by PyBDSM are shown in light blue. The fitted Gaussians are shown for each island as ellipses (the sizes of which correspond to the FWHMs of the Gaussians). Gaussians that have been grouped together into a source are shown with the same color. For example, the two red Gaussians of island #1 have been grouped together into one source, and the nine Gaussians of island #0 have been grouped into 4 separate sources.
-
-.. rubric:: Footnotes
-.. [#f1] http://casa.nrao.edu
diff --git a/CEP/PyBDSM/doc/source/whats_new.rst b/CEP/PyBDSM/doc/source/whats_new.rst
deleted file mode 100644
index 48421f72da263cc3b346dc149c64c7d48b3e3f47..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/doc/source/whats_new.rst
+++ /dev/null
@@ -1,302 +0,0 @@
-.. _new:
-
-**********
-What's New
-**********
-
- * Fix to issues related to numpy versions >= 1.12.0
-
-Version 1.8.7 (2016/06/10):
-
- * Fix to bug that caused incorrect output images when input image was not square.
-
-Version 1.8.6 (2016/01/20):
-
- * Fix to bug that caused incorrect island mask when two islands are very close together.
-
- * Fix to bug that caused crash when image is masked and the ``src_ra_dec`` option is used.
-
-Version 1.8.5 (2015/11/30):
-
- * Fix to bug in ``export_image`` that resulted in incorrect output image when both ``trim_box`` and ``pad_image`` were used.
-
- * Fix to bug in wavelet module related to merging of islands.
-
- * Fix to bug in polarization module related to numbering of new islands.
-
- * Added option to use much faster (but also much more memory intensive) SciPy ``fftconvolve`` function instead of custom PyBDSM one. The option (``use_scipy_fft``) defaults to ``True``.
-
- * Increased number of digits for values in output text catalogs
-
-Version 1.8.4 (2015/08/06):
-
- * Improved speed of wavelet module.
-
- * Added option to use PyFFTW in wavelet module if available.
-
- * Fix to IPython version check.
-
- * Fix to bug that caused a failure to write shapelet models in FITS format.
-
- * Fix to bug that caused a crash when both ``atrous_do = True`` and ``output_all = True``.
-
- * Fixed a bug that caused a crash on machines with only one core.
-
-Version 1.8.3 (2014/09/26):
-
- * Fix to bug that caused a crash when using the wavelet module and all Gaussians in an island were flagged.
-
-Version 1.8.2 (2014/05/14):
-
- * Island masks generated by the ``export_image`` task will now be expanded to match input image shape (as required by the AWimager).
-
- * Fix to bug that caused image read failure when image lacks a Stokes axis.
-
- * Fix to bug in CASA masks generated with ``export_image`` that caused cleaning to fail in CASA 4.2 and above.
-
- * Fix to bug that resulted in output file names being converted to lower case inappropriately.
-
-Version 1.8.1 (2014/01/14):
-
- * Added option (``bbs_patches = 'mask'``) to allow patches in an output BBS sky model to be defined using a mask image (set with the ``bbs_patches_mask`` option).
-
- * Fix to bug that caused the ``incl_empty`` option to be ignored when ``format = 'fits'`` in the ``write_catalog`` task.
-
- * Enabled output of images in CASA format in the ``export_image`` task (``img_format = 'casa'``).
-
- * Added an option to ``export_image`` to export an island-mask image, with ones where there is emission and zeros elsewhere (``image_type = 'island_mask'``). Features in the island mask may be optionally dilated by specifying the number of dilation iterations with the ``mask_dilation`` parameter. The mask image may be padded with zeros to match the original image when the ``trim_box`` option was used to analyze only a portion of the image (``pad_image = True``).
-
- * Added an option to write a CASA region file to the ``write_catalog`` task (``format = 'casabox'``).
-
- * Added an option to write a CSV catalog to the ``write_catalog`` task (``format = 'csv'``).
-
- * Added error message when the rms is zero in some part of the rms map.
-
-Version 1.8.0 (2013/10/16):
-
- * Improved wavelet fitting. Added option so that wavelet fitting can be done to the sum of images on the remaining wavelet scales, improving the signal for fitting (controlled with the ``atrous_sum`` option). Added option so that user can choose whether to include new islands found only in the wavelet images in the final fit or not (controlled with the ``atrous_orig_isl`` option).
-
- * Fixed a bug that could lead to incomplete fitting of some islands.
-
- * Improved overall convergence of fits.
-
-Version 1.7.7 (2013/10/10):
-
- * Improved fitting of bright sources under certain circumstances.
-
-Version 1.7.6 (2013/09/27):
-
- * Changed caching behavior to ensure that temporary files are always deleted after they are no longer needed or on exit.
-
- * Renamed ``blank_zeros`` to ``blank_limit``. The ``blank_limit`` option now specifies a limit below which pixels are blanked.
-
- * Enabled SAGECAL sky-model output.
-
-Version 1.7.5 (2013/09/02):
-
- * Fix to bug that caused a crash when images with 2 or 3 axes were used.
-
- * Improved rms and mean calculation (following the implementation used in PySE, see http://dare.uva.nl/document/174052 for details). The threshold used to determine the clipped rms and mean values is now determined internally by default (i.e., ``kappa_clip = None``).
-
-Version 1.7.4 (2013/08/29):
-
- * Fix to bug in ``show_fit`` that caused error when ``i`` is pressed in the plot window and shapelet decomposition had not been done.
-
- * Tweak to ``pybdsm`` startup shell script to avoid problems with the Mac OS X matplotlib backend on non-framework Python installations (such as Anaconda Python).
-
- * Fix to bug in ``process_image`` that could result in wavelet Gaussians being excluded from model image under certain conditions.
-
-Version 1.7.3 (2013/08/27):
-
- * Fix to bug in image reading that caused images to be distorted.
-
-Version 1.7.2 (2013/08/23):
-
- * Improved handling of non-standard FITS CUNIT keywords.
-
- * Improved loading of FITS images when ``trim_box`` is specified.
-
-Version 1.7.1 (2013/08/22):
-
- * Fix to bug that caused cached images to be deleted when rerunning an analysis.
-
- * Fix to bug in ``show_fit`` due to undefined images.
-
- * Fix to bug in ``process_image`` (and ``img.process()``) that would result in unneeded reprocessing.
-
-Version 1.7.0 (2013/08/20):
-
- * PyBDSM will now use Astropy if installed for FITS and WCS modules.
-
- * Fix to avoid excessive memory usage in the wavelet module (replaced ``scipy.signal.fftconvolve`` with a custom function).
-
- * Added option to use disk caching for internally derived images (``do_cache``). Caching can reduce memory usage and is therefore useful when processing large images.
-
- * Implemented a variable operation chain for process_image (and ``img.process()``) that allows unneeded steps to be skipped if the image is being reprocessed.
-
- * Fixed a bug that could cause Gaussian fitting to hang during iterative fitting of large islands.
-
- * Added option (``fix_to_beam``) to fix the size and position angle of Gaussians to the restoring beam during fitting.
-
- * Fix to bug that caused the position angle used to initialize fitting to be incorrect.
-
-Version 1.6.1 (2013/03/22):
-
- * Fix to bug in ds9 and kvis catalog files that resulted in incorrect position angles.
-
- * Fix to bug in position-dependent WCS transformations that caused incorrect source parameters in output catalogs.
-
- * Added option to output uncorrected source parameters to a BBS sky model file (``correct_proj``).
-
- * Removed sky transformations for flagged Gaussians, as these could sometimes give math domain errors.
-
- * Disabled aperture flux measurement on wavelet images as it is not used/needed.
-
-Version 1.6.0 (2013/03/05):
-
- * Improved speed and accuracy of aperture flux calculation.
-
- * Added option to use the curvature map method of Hancock et al. (2012) for the initial estimation of Gaussian parameters (``ini_method = 'curvature'``) and for grouping of Gaussians into sources (``group_method = 'curvature'``).
-
- * Fix to bug in spectral index module that caused sources with multiple Gaussians to be skipped. Minor adjustments to the wavelet module to improve performance.
-
- * Implemented position-dependent WCS transformations.
-
- * Added option to fit to any arbitrary location in the image within a given radius (``src_ra_dec`` and ``src_radius_pix``).
-
- * Fix to bug in wavelet module that caused crash when no Gaussians were fit to the main image.
-
- * Fix to bug that resulted in incorrect numbering of wavelet Gaussians. Added ``'srl'`` output in ds9 format when using ``output_all = True``.
-
- * Fix to bug in source grouping algorithm. Improved fitting when background mean is nonzero. Fix to allow images with GLAT and GLON WCS coordinates. Fix to bug when equinox is taken from the epoch keyword.
-
-
-Version 1.5.1 (2012/12/19):
-
- * Fix to bug in wavelet module that occurred when the center of the wavelet Gaussian lies outside of the image.
-
- * Fix to re-enable srl output catalogs in ds9 region format.
-
- * Fix to bug that resulted in the output directory not always being created.
-
- * Added an option (``aperture_posn``), used when aperture fluxes are desired, to specify whether to center the aperture on the source centroid or the source peak.
-
- * Changes to reduce memory usage, particularly in the wavelet module.
-
- * Fix to bypass bug in matplotlib when display variable is not set.
-
- * Fixed bug that caused a crash when a detection image was used.
-
- * Fixed a bug with incorrect save directory when "plot_allgaus" is True.
-
-Version 1.5.0 (2012/10/29):
-
- * Improved WCS handling. PyBDSM can now read images with a much greater variety of WCS systems (e.g., the ``VOPT`` spectral system).
-
- * Fixed a bug related to the use of a detection image when a subimage is specified (with ``trim_box``).
-
-Version 1.4.5 (2012/10/12):
-
- * Added option (``incl_empty``) to include empty islands (that have no un-flagged Gaussians) in output catalogs. Any such empty islands are given negative source IDs and have positions given by the location of the peak of the island.
-
- * Fixed a bug in Gaussian fitting that could cause a crash when fitting fails.
-
- * Fixed a bug in parallelization that could cause a crash due to improper concatenation of result lists.
-
-Version 1.4.4 (2012/10/09):
-
- * Fixed a bug related to the parallelization of Gaussian fitting that could cause a crash due to improper mapping of island lists to processes.
-
- * Improved logging.
-
- * Added a warning when one or more islands are not fit (i.e., no valid, unflagged Gaussians were found).
-
- * Added code to handle images with no unblanked pixels.
-
- * Improved fitting robustness.
-
-Version 1.4.3 (2012/10/04):
-
- * Fixed a bug in the mean map calculation that caused mean maps with constant values (i.e., non-2D maps) to have values of 0.0 Jy/beam unless ``mean_map = 'const'`` was explicitly specified.
-
- * Fixed a bug in the PSF vary module that resulted in incorrect PSF generators being used. Added an option to smooth the resulting PSF images (``psf_smooth``). Parallelized the PSF interpolation and smoothing steps. Improved PSF vary documentation.
-
-Version 1.4.2 (2012/09/25):
-
- * Dramatically reduced time required to identify valid wavelet islands. Fixed bug that resulted in output FITS gaul tables being improperly sorted.
-
-Version 1.4.1 (2012/09/11):
-
- * Added SAMP (Simple Application Messaging Protocol) support to the write_catalog, export_image, and show_fit tasks. These tasks can now use SAMP to communicate with other programs connected to a SAMP hub (e.g., ds9, Topcat, Aladin).
-
-Version 1.4.0 (2012/09/11):
-
- * Parallelized Gaussian fitting, shapelet decomposition, validation of wavelet islands, and mean/rms map generation. The number of cores to be used can be specified with the ``ncores`` option (default is to use all).
-
-Version 1.3.2 (2012/08/22):
-
- * Fixed a bug that could cause the user-specified ``rms_box`` value to be ignored. Added an option to enable the Monte Carlo error estimation for 'M'-type sources (the ``do_mc_errors`` option), which is now disabled by default.
-
-Version 1.3.1 (2012/07/11):
-
- * Fixed a bug that caused images written when ``output_all = True`` to be transposed. Added frequency information to all output images. Improved fitting robustness to prevent rare cases in which no valid Gaussians could be fit to an island. Modified the island-finding routine to handle NaNs properly.
-
-Version 1.3.0 (2012/07/03):
-
- * Fixed a bug in the calculation of positional errors for Gaussians.
-
- * Adjusted ``rms_box`` algorithm to check for negative rms values (due to interpolation with cubic spline). If negative values are found, either the box size is increased or the interpolation is done with ``order=1`` (bilinear) instead.
-
- * Output now includes the residual image produced using only wavelet Gaussians (if any) when ``atrous_do=True`` and ``output_all=True``.
-
- * Improved organization of files when ``output_all=True``.
-
- * Added logging of simple statistics (mean, std. dev, skew, and kurtosis) of the residual images.
-
- * Included image rotation (if any) in beam definition. Rotation angle can vary across the image (defined by image WCS).
-
- * Added Sagecal output format for Gaussian catalogs.
-
- * Added check for newer versions of the PyBDSM software ``tar.gz`` file available on ftp.strw.leidenuniv.nl.
-
- * Added total island flux (from sum of pixels) to ``gaul`` and ``srl`` catalogs.
-
-Version 1.2 (2012/06/06):
-
- * Added option to output flux densities for every channel found by the spectral index module.
-
- * Added option to spectral index module to allow use of flux densities that do not meet the desired SNR.
-
- * Implemented an adaptive scaling scheme for the ``rms_box`` parameter that shrinks the box size near bright sources and expands it far from them (enabled with the ``adaptive_rms_box`` option when ``rms_box`` is None). This scheme generally results in improved rms and mean maps when both strong artifacts and extended sources are present.
-
- * Improved speed of Gaussian fitting to wavelet images.
-
- * Added option to calculate fluxes within a specified aperture radius in pixels (set with the ``aperture`` option). Aperture fluxes, if measured, are output in the ``srl`` format catalogs.
-
-Version 1.1 (2012/03/28):
-
- * Tweaked settings that affect fitting of Gaussians to improve fitting in general.
-
- * Modified calculation of the ``rms_box`` parameter (when the ``rms_box`` option is None) to work better with fields composed mainly of point sources when strong artifacts are present.
-
- * Modified fitting of large islands to adopt an iterative fitting scheme that limits the number of Gaussians fit simultaneously per iteration to 10. This change speeds up fitting of large islands considerably.
-
- * Added the option to use a "detection" image for island detection (the ``detection_image`` option); source properties are still measured from the main input image. This option is particularly useful with images made with LOFAR's AWImager, as the uncorrected, flat-noise image (the ``*.restored`` image) is better for source detection than the corrected image (the ``*.restored.corr`` image).
-
- * Modified the polarization module so that sources that appear only in Stokes Q or U (and hence not in Stokes I) are now identified. This identification is done using the polarized intensity (PI) image.
-
- * Improved the plotting speed (by a factor of many) in ``show_fit`` when there are a large number of islands present.
-
- * Simplified the spectral index module to make it more user friendly and stable.
-
- * Altered reading of images to correctly handle 4D cubes.
-
- * Extended the ``psf_vary`` module to include fitting of stacked PSFs with Gaussians, interpolation of the resulting parameters across the image, and correction of the deconvolved source sizes using the interpolated PSFs.
-
- * Added residual rms and mean values to source catalogs. These values can be compared to background rms and mean values as a quick check of fit quality.
-
- * Added output of shapelet parameters as FITS tables.
-
- * Fixed many minor bugs.
-
-See the changelog (accessible from the interactive shell using ``help changelog``) for details of all changes since the last version.
diff --git a/CEP/PyBDSM/doc/source/write_catalog.rst b/CEP/PyBDSM/doc/source/write_catalog.rst
deleted file mode 100644
index a842cc8dde9e33b702fa9f40710d5dd47d31b0df..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/doc/source/write_catalog.rst
+++ /dev/null
@@ -1,301 +0,0 @@
-.. _write_catalog:
-
-***************************************************
-``write_catalog``: writing source catalogs
-***************************************************
-
-The properties of the fitted Gaussians, sources, and shapelets may be written in a number of formats to a file using the ``write_catalog`` task. See below (:ref:`output_cols`) for a detailed description of the output columns.
-
-.. note::
-
- For BBS and SAGECAL formats, the output catalogs always use the J2000 equinox. If the input image does not have an equinox of J2000, the coordinates of sources will be precessed to J2000. Catalogs in other formats will have the equinox of the image.
-
-The task parameters are as follows:
-
-.. parsed-literal::
-
- WRITE_CATALOG: Write the Gaussian, source, or shapelet list to a file.
- ================================================================================
- :term:`outfile` ............... None : Output file name. None => file is named
- automatically; 'SAMP' => send to SAMP hub (e.g., to
- TOPCAT, ds9, or Aladin)
- :term:`bbs_patches` ........... None : For BBS format, type of patch to use: None => no
- patches. 'single' => all Gaussians in one patch.
- 'gaussian' => each Gaussian gets its own patch.
- 'source' => all Gaussians belonging to a single
- source are grouped into one patch. 'mask' => use mask
- file specified by bbs_patches_mask
- :term:`bbs_patches_mask` ...... None : Name of the mask file (of same size as input image)
- that defines the patches if bbs_patches = 'mask'
- :term:`catalog_type` .......... 'srl': Type of catalog to write: 'gaul' - Gaussian
- list, 'srl' - source list (formed by grouping
- Gaussians), 'shap' - shapelet list (FITS
- format only)
- :term:`clobber` .............. False : Overwrite existing file?
- :term:`correct_proj` .......... True : Correct source parameters for image projection
- (BBS format only)?
- :term:`format` ............... 'fits': Format of output Gaussian list: 'bbs', 'ds9',
- 'fits', 'star', 'kvis', 'ascii', 'csv', 'casabox', or
- 'sagecal'
- :term:`incl_chan` ............ False : Include fluxes from each channel (if any)?
- :term:`incl_empty` ........... False : Include islands without any valid Gaussians
- (source list only)?
- :term:`srcroot` ............... None : Root name for entries in the output catalog. None
- => use image file name
-
-Each of the parameters is described in detail below.
-
-.. glossary::
-
- outfile
- This parameter is a string (default is ``None``) that sets the name of the output file. If ``None``, the file is named automatically. If 'SAMP' the full catalog (i.e., ``format = 'fits'``) is sent to a running SAMP Hub (e.g., to TOPCAT or Aladin).
-
- bbs_patches
- This parameter is a string (default is ``None``) that sets the type of patch to use in BBS-formatted catalogs. When the Gaussian catalogue is written as a BBS-readable sky file, this option determines whether all Gaussians are in a single patch (``'single'``), there are no patches (``None``), all Gaussians for a given source are in a separate patch (``'source'``), each Gaussian gets its own patch (``'gaussian'``), or a mask image is used to define the patches (``'mask'``).
-
- If you wish to have patches defined by island, then set
- ``group_by_isl = True`` before fitting to force all
- Gaussians in an island to be in a single source. Then set
- ``bbs_patches = 'source'`` when writing the catalog.
-
- bbs_patches_mask
- This parameter is a string (default is ``None``) that sets the file name of the mask file to use to define patches in BBS-formatted catalogs. The mask image should be 1 inside the patches and 0 elsewhere and should be the same size as the input image (before any ``trim_box`` is applied). Any Gaussians that fall outside of the patches will be ignored and will not appear in the output sky model.
-
- catalog_type
- This parameter is a string (default is ``'srl'``) that sets the type of catalog to write: ``'gaul'`` - Gaussian list, ``'srl'`` - source list
- (formed by grouping Gaussians), ``'shap'`` - shapelet list (``'fits'`` format only)
-
- .. note::
-
- The choice of ``'srl'`` or ``'gaul'`` depends on whether you want all the source structure in your catalog or not. For example, if you are making a sky model for use as a model in calibration, you want to include all the source structure in your model, so you would use a Gaussian list (``'gaul'``), which writes each Gaussian. On the other hand, if you want to compare to other source catalogs, you want instead the total source flux densities, so use source lists (``'srl'``). For example, say you have a source that is unresolved in WENSS, but is resolved in your image into two nearby Gaussians that are grouped into a single source. In this case, you want to compare the sum of the Gaussians to the WENSS flux density, and hence should use a source list.
-
- clobber
- This parameter is a Boolean (default is ``False``) that determines whether existing files are overwritten or not.
-
- correct_proj
- This parameter is a Boolean (default is ``True``) that determines
- whether the source parameters in the output catalog will be corrected
- for first-order projection effects. If ``False``, no correction is done. In
- this case, the position angle is relative to the +y axis, NOT true
- north, and source sizes are calculated assuming a constant pixel scale
- (equal to the scale at the image center).
-
- If ``True``, the position angle and source size are corrected using the
- average pixel size and angle offset (between the +y axis and north) at
- the location of the source center.
-
- format
- This parameter is a string (default is ``'fits'``) that sets the format of the output catalog. The following formats are supported:
-
- * ``'bbs'`` - BlackBoard Selfcal sky model format (Gaussian list only)
-
- * ``'ds9'`` - ds9 region format
-
- * ``'fits'`` - FITS catalog format, readable by many software packages, including IDL, TOPCAT, Python, fv, Aladin, etc.
-
- * ``'star'`` - AIPS STAR format (Gaussian list only)
-
- * ``'kvis'`` - kvis format (Gaussian list only)
-
- * ``'ascii'`` - simple text file with spaces separating the values
-
- * ``'csv'`` - Comma-separated Values (CSV) text file
-
- * ``'casabox'`` - CASA region file (boxes only)
-
- * ``'sagecal'`` - SAGECAL sky model format (Gaussian list only)
-
- Catalogues with the ``'fits'``, ``'ascii'``, and ``'csv'`` formats include all available
- information (see :ref:`output_cols` for column definitions). The
- other formats include only a subset of the full information.
-
- incl_chan
- This parameter is a Boolean (default is ``False``) that determines whether the total flux densities of each source measured in each channel by the spectral index module are included in the output.
-
- incl_empty
- This parameter is a Boolean (default is ``False``) that determines whether islands without any valid Gaussians are included in the output catalog. This option is only available for source lists. If True, islands for which Gaussian fitting failed will be included in the output catalog. In these cases, the source IDs are negative and only a subset of the standard columns will be populated (columns requiring information from Gaussian fits are left blank).
-
- srcroot
- This parameter is a string (default is ``None``) that sets the root for source names in the output catalog.
-
-
-.. _output_cols:
-
-Definition of output columns
-----------------------------
-The information included in the Gaussian and source catalogs varies by format and can include the following quantities.
-
-.. note::
- For ACSII, CSV, and FITS formats, the reference frequency (in Hz) and equinox are stored in the header of the catalog. The header in ASCII and CSV catalogs is the first few lines of the catalog. For FITS catalogs, this information is stored in the comments as well as in the FREQ0 and EQUINOX keywords in the primary header.
-
-* **Gaus_id:** a unique number that identifies the Gaussian, starting from zero
-
-* **Source_id:** a unique number that identifies the Source, starting from zero
-
-* **Isl_id:** a unique number that identifies the Island, starting from zero
-
-* **Wave_id:** the wavelet scale from which the source was extracted, starting from zero (for the ch0 image)
-
-* **RA:** the right ascension of the source (for the equinox of the image), in degrees
-
-* **E_RA:** the error on the right ascension of the source, in degrees
-
-* **DEC:** the declination of the source (for the equinox of the image), in degrees
-
-* **E_DEC:** the 1-:math:`\sigma` error on the declination of the source, in degrees
-
-* **RA_max:** the right ascension of the maximum of the source (for the equinox of the image), in degrees (``'srl'`` catalogs only)
-
-* **E_RA_max:** the 1-:math:`\sigma` error on the right ascension of the maximum of the source, in degrees (``'srl'`` catalogs only)
-
-* **DEC_max:** the declination of the maximum of the source (for the equinox of the image), in degrees (``'srl'`` catalogs only)
-
-* **E_DEC_max:** the 1-:math:`\sigma` error on the declination of the maximum of the source, in degrees (``'srl'`` catalogs only)
-
-* **Total_flux:** the total, integrated Stokes I flux density of the source at the reference frequency, in Jy
-
-* **E_Total_flux:** the 1-:math:`\sigma` error on the total flux density of the source, in Jy
-
-* **Peak_flux:** the peak Stokes I flux density per beam of the source, in Jy/beam
-
-* **E_Peak_flux:** the 1-:math:`\sigma` error on the peak flux density per beam of the source, in Jy/beam
-
-* **Aperture_flux:** the total Stokes I flux density of the source within the specified aperture, in Jy (``'srl'`` catalogs only)
-
-* **E_Aperture_flux:** the 1-:math:`\sigma` error on the total flux density of the source within the specified aperture, in Jy (``'srl'`` catalogs only)
-
-* **Xposn:** the x image coordinate of the source, in pixels
-
-* **E_Xposn:** the 1-:math:`\sigma` error on the x image coordinate of the source, in pixels
-
-* **Yposn:** the y image coordinate of the source, in pixels
-
-* **E_Yposn:** the 1-:math:`\sigma` error on the y image coordinate of the source, in pixels
-
-* **Xposn_max:** the x image coordinate of the maximum of the source, in pixels (``'srl'`` catalogs only)
-
-* **E_Xposn_max:** the 1-:math:`\sigma` error on the x image coordinate of the maximum of the source, in pixels (``'srl'`` catalogs only)
-
-* **Yposn_max:** the y image coordinate of the maximum of the source, in pixels (``'srl'`` catalogs only)
-
-* **E_Yposn_max:** the 1-:math:`\sigma` error on the y image coordinate of the maximum of the source, in pixels (``'srl'`` catalogs only)
-
-* **Maj:** the FWHM of the major axis of the source, in degrees
-
-* **E_Maj:** the 1-:math:`\sigma` error on the FWHM of the major axis of the source, in degrees
-
-* **Min:** the FWHM of the minor axis of the source, in degrees
-
-* **E_Min:** the 1-:math:`\sigma` error on the FWHM of the minor axis of the source, in degrees
-
-* **PA:** the position angle of the major axis of the source measured east of north, in degrees
-
-* **E_PA:** the 1-:math:`\sigma` error on the position angle of the major axis of the source, in degrees
-
-* **Maj_img_plane:** the FWHM of the major axis of the source in the image plane, in degrees
-
-* **E_Maj_img_plane:** the 1-:math:`\sigma` error on the FWHM of the major axis of the source in the image plane, in degrees
-
-* **Min_img_plane:** the FWHM of the minor axis of the source in the image plane, in degrees
-
-* **E_Min_img_plane:** the 1-:math:`\sigma` error on the FWHM of the minor axis of the source in the image plane, in degrees
-
-* **PA_img_plane:** the position angle in the image plane of the major axis of the source measured east of north, in degrees
-
-* **E_PA_img_plane:** the 1-:math:`\sigma` error on the position angle in the image plane of the major axis of the source, in degrees
-
-* **DC_Maj:** the FWHM of the deconvolved major axis of the source, in degrees
-
-* **E_DC_Maj:** the 1-:math:`\sigma` error on the FWHM of the deconvolved major axis of the source, in degrees
-
-* **DC_Min:** the FWHM of the deconvolved minor axis of the source, in degrees
-
-* **E_DC_Min:** the 1-:math:`\sigma` error on the FWHM of the deconvolved minor axis of the source, in degrees
-
-* **DC_PA:** the position angle of the deconvolved major axis of the source measured east of north, in degrees
-
-* **E_DC_PA:** the 1-:math:`\sigma` error on the position angle of the deconvolved major axis of the source, in degrees
-
-* **DC_Maj_img_plane:** the FWHM of the deconvolved major axis of the source in the image plane, in degrees
-
-* **E_DC_Maj_img_plane:** the 1-:math:`\sigma` error on the FWHM of the deconvolved major axis of the source in the image plane, in degrees
-
-* **DC_Min_img_plane:** the FWHM of the deconvolved minor axis of the source in the image plane, in degrees
-
-* **E_DC_Min_img_plane:** the 1-:math:`\sigma` error on the FWHM of the deconvolved minor axis of the source in the image plane, in degrees
-
-* **DC_PA_img_plane:** the position angle in the image plane of the deconvolved major axis of the source measured east of north, in degrees
-
-* **E_DC_PA_img_plane:** the 1-:math:`\sigma` error on the position angle in the image plane of the deconvolved major axis of the source, in degrees
-
-* **Isl_Total_flux:** the total, integrated Stokes I flux density of the island in which the source is located, in Jy. This value is calculated from the sum of all non-masked pixels in the island with values above ``thresh_isl``
-
-* **E_Isl_Total_flux:** the 1-:math:`\sigma` error on the total flux density of the island in which the source is located, in Jy
-
-* **Isl_rms:** the average background rms value of the island, in Jy/beam
-
-* **Isl_mean:** the averge background mean value of the island, in Jy/beam
-
-* **Resid_Isl_rms:** the average residual background rms value of the island, in Jy/beam
-
-* **Resid_Isl_mean:** the averge residual background mean value of the island, in Jy/beam
-
-* **S_Code:** a code that defines the source structure.
- * 'S' = a single-Gaussian source that is the only source in the island
- * 'C' = a single-Gaussian source in an island with other sources
- * 'M' = a multi-Gaussian source
-
-* **Spec_Indx:** the spectral index of the source
-
-* **E_Spec_Indx:** the 1-:math:`\sigma` error on the spectral index of the source
-
-* **Total_flux_ch#** the total, integrated Stokes I flux density of the source in channel #, in Jy
-
-* **E_Total_flux_ch#** the 1-:math:`\sigma` error on the total, integrated Stokes I flux density of the source in channel #, in Jy
-
-* **Freq_ch#** the frequency of channel #, in Hz
-
-* **Total_Q:** the total, integrated Stokes Q flux density of the source at the reference frequency, in Jy
-
-* **E_Total_Q:** the 1-:math:`\sigma` error on the total Stokes Q flux density of the source at the reference frequency, in Jy
-
-* **Total_U:** the total, integrated Stokes U flux density of the source at the reference frequency, in Jy
-
-* **E_Total_U:** the 1-:math:`\sigma` error on the total Stokes U flux density of the source at the reference frequency, in Jy
-
-* **Total_V:** the total, integrated Stokes V flux density of the source at the reference frequency, in Jy
-
-* **E_Total_V:** the 1-:math:`\sigma` error on the total Stokes V flux density of the source at the reference frequency, in Jy
-
-* **Linear_Pol_frac:** the linear polarization fraction of the source
-
-* **Elow_Linear_Pol_frac:** the 1-:math:`\sigma` error on the linear polarization fraction of the source
-
-* **Ehigh_Linear_Pol_frac:** the 1-:math:`\sigma` error on the linear polarization fraction of the source
-
-* **Circ_Pol_Frac:** the circular polarization fraction of the source
-
-* **Elow_Circ_Pol_Frac:** the 1-:math:`\sigma` error on the circular polarization fraction of the source
-
-* **Ehigh_Circ_Pol_Frac:** the 1-:math:`\sigma` error on the circular polarization fraction of the source
-
-* **Total_Pol_Frac:** the total polarization fraction of the source
-
-* **Elow_Total_Pol_Frac:** the 1-:math:`\sigma` error on the total polarization fraction of the source
-
-* **Ehigh_Total_Pol_Frac:** the 1-:math:`\sigma` error on the total polarization fraction of the source
-
-* **Linear_Pol_Ang:** the linear polarization angle, measured east of north, in degrees
-
-* **E_Linear_Pol_Ang:** the 1-:math:`\sigma` error on the linear polarization angle, in degrees
-
-
-The shapelet catalog contains the following additional columns:
-
-* **shapelet_basis:** the basis coordinate system: 'c' for cartesian, 's' for spherical
-
-* **shapelet_beta:** the :math:`\beta` parameter of the shapelet decomposition
-
-* **shapelet_nmax:** the maximum order of the shapelet
-
-* **shapelet_cf:** a (flattened) array of the shapelet coefficients
diff --git a/CEP/PyBDSM/src/CMakeLists.txt b/CEP/PyBDSM/src/CMakeLists.txt
deleted file mode 100644
index 88092924e565687f8a1cdabe846bb1671c647e68..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/CMakeLists.txt
+++ /dev/null
@@ -1,11 +0,0 @@
-# $Id$
-
-include(PythonInstall)
-
-add_subdirectory(apps)
-add_subdirectory(c++)
-add_subdirectory(fortran)
-add_subdirectory(minpack)
-add_subdirectory(natgrid)
-add_subdirectory(port3)
-add_subdirectory(python)
diff --git a/CEP/PyBDSM/src/apps/CMakeLists.txt b/CEP/PyBDSM/src/apps/CMakeLists.txt
deleted file mode 100644
index a4e6ba80a670785779fbe696c4f8dcd7849c6a51..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/apps/CMakeLists.txt
+++ /dev/null
@@ -1,8 +0,0 @@
-# $Id$
-
-configure_file(
- ${CMAKE_CURRENT_SOURCE_DIR}/pybdsm.in
- ${CMAKE_CURRENT_BINARY_DIR}/pybdsm @ONLY)
-
-lofar_add_bin_scripts(${CMAKE_CURRENT_BINARY_DIR}/pybdsm)
-
diff --git a/CEP/PyBDSM/src/apps/pybdsm.in b/CEP/PyBDSM/src/apps/pybdsm.in
deleted file mode 100644
index ff70747efd13e81bed62e96aeb5645d46fc087f3..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/apps/pybdsm.in
+++ /dev/null
@@ -1,20 +0,0 @@
-#!/bin/bash
-#
-# This script simply starts the interactive PyBDSM
-# IPython shell.
-
-# Add the PyBDSM libraries to the relevant paths.
-if [ `uname` == "Darwin" ]; then
- DYLD_FALLBACK_LIBRARY_PATH=@CMAKE_INSTALL_PREFIX@/@LOFAR_LIBDIR@${DYLD_FALLBACK_LIBRARY_PATH:+:${DYLD_FALLBACK_LIBRARY_PATH}}
-else
- LD_LIBRARY_PATH=${LD_LIBRARY_PATH:+${LD_LIBRARY_PATH}:}@CMAKE_INSTALL_PREFIX@/@LOFAR_LIBDIR@
-fi
-PYTHONPATH=${PYTHONPATH:+${PYTHONPATH}:}@PYTHON_INSTALL_DIR@
-
-# And execute pybdsm.py. On a Mac, use pythonw if it exists instead of python
-# to avoid problems with the matplotlib OS X backend.
-if [ `uname` == "Darwin" ] && [ -f @PYTHON_EXECUTABLE@w ]; then
- exec @PYTHON_EXECUTABLE@w -W ignore @PYTHON_INSTALL_DIR@/lofar/bdsm/pybdsm.py
-else
- exec @PYTHON_EXECUTABLE@ -W ignore @PYTHON_INSTALL_DIR@/lofar/bdsm/pybdsm.py
-fi
diff --git a/CEP/PyBDSM/src/c++/CMakeLists.txt b/CEP/PyBDSM/src/c++/CMakeLists.txt
deleted file mode 100644
index f4fc1c53aabecb4b927380cad508972a6a3e23e9..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/c++/CMakeLists.txt
+++ /dev/null
@@ -1,34 +0,0 @@
-# $Id$
-
-# Add current directory to -I path
-include_directories(${CMAKE_CURRENT_SOURCE_DIR})
-
-add_library(_cbdsm MODULE
- Fitter_dn2g.cc
- Fitter_dnsg.cc
- Fitter_lmder.cc
- MGFunction1.cc
- MGFunction2.cc
- cbdsm_main.cc
- stat.cc
- num_util/num_util.cpp)
-
-target_link_libraries(_cbdsm
- ${BOOST_LIBRARIES}
- minpack
- port3
-)
-
-set_target_properties(_cbdsm PROPERTIES
- PREFIX ""
- LINKER_LANGUAGE Fortran)
-
-if (APPLE)
- set_target_properties(_cbdsm PROPERTIES
- LINK_FLAGS "-undefined dynamic_lookup")
-endif (APPLE)
-
-install(TARGETS _cbdsm
- DESTINATION ${PYTHON_INSTALL_DIR}/lofar/bdsm)
-
-
diff --git a/CEP/PyBDSM/src/c++/Fitter_dn2g.cc b/CEP/PyBDSM/src/c++/Fitter_dn2g.cc
deleted file mode 100644
index c94a3ab7cdb615e9a6626e96730d6c46e95daa30..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/c++/Fitter_dn2g.cc
+++ /dev/null
@@ -1,150 +0,0 @@
-/*!
- \file Fitter_dn2g.cc
-
- \ingroup pybdsm
-
- \author Oleksandr Usov
-
- \date 30/10/2007
-*/
-
-#include "Fitters.h"
-#include <iostream>
-
-using namespace std;
-
-/**
- This fitter uses DN2G algorithm from the (free subset of) PORT3
- library (www.netlib.org/port).
-
- DN2G is an implementation of the NL2SOL -- adaptive nonlinear least squares
- algorithm; also known as TOMS/573.
-**/
-
-
-// this is prototype for a fortran routines
-extern "C"
-void dn2g_(int &n, int &p, double *x, void *F, void *J,
- int *iv, int &liv, int &lv, double *v,
- int *uiparm, double *urparm, void *ufparm);
-
-extern "C"
-void divset_(const int &alg, int *iv, int &liv, int &lv, double *v);
-
-
-// user functions
-// FIXME: these should have been declared "extern "C" static ...", but gcc 4.2.2 rejects such declarations
-static
-void dn2g_f(int &n, int &p, double *x, int &nf, double *F,
- void *uiparm, void *urparm, void *ufparm);
-
-static
-void dn2g_df(int &n, int &p, double *x, int &nf, double *J,
- void *uiparm, void *urparm, void *ufparm);
-
-
-// dn2g driver
-bool dn2g_fit(MGFunction &fcn, bool final, int verbose)
-{
- int dsize = fcn.data_size();
- int npar = fcn.parameters_size();
-
- // working variables
- int n = dsize, p = npar, liv = 82+p, lv = 105 + p*(n+2*p+17) + 2*n;
- vector<double> x(p), v(lv);
- vector<int> iv(liv);
-
- // set run-time parameters
- divset_(1, &iv[0], liv, lv, &v[0]);
-
- iv[16] = 1000; // MXFCAL - maximal number of function calls
- iv[17] = 1000; // MXITER - maximal number of iterations
- if (final)
- v[32] = 1e-8; // XCTOL - x-convergence tolerance
- else
- v[32] = 1e-4; // XCTOL - x-convergence tolerance
-
- verbose = (verbose < 0) ? 0 : verbose;
-
- switch (verbose) {
- case 0: // silence it completely
- case 1:
- iv[20] = 0; // PRUNIT
- break;
-
- case 2: // print out some results
- iv[13] = 0; // COVPRT - covariance & regression diagnostic (0 ... 3)
- iv[18] = 1; // OUTLEV - iteration summary (0, 1, ...)
- iv[19] = 1; // PARPRT - non-default parameters (0, 1)
- iv[21] = 1; // SOLPRT - solution (x, F, J) (0, 1)
- iv[22] = 1; // STATPR - summary statistics (-1, 0, 1)
- iv[23] = 0; // X0PRT - input X (0, 1)
- break;
- }
-
- iv[56] = 0; // RDREQ -- do not calculate covariance & regression diagnostic arrays
-
- fcn.get_parameters(&x[0]);
-
- dn2g_(n, p, &x[0], (void *)dn2g_f, (void *)dn2g_df,
- &iv[0], liv, lv, &v[0],
- (int *)0, (double *)0, (void *)&fcn);
-
- fcn.set_parameters(&x[0]);
-
- // extract errors information
- if (final) {
- // TODO
- }
-
- // check convergence and (possibly) print out status line
- int info = iv[0];
- bool converged = (info > 2) && (info < 7);
-
- if (verbose) {
- int nfev = iv[5]; // NFCALL - number of function evaluations
- int njev = iv[29]; // NGCALL - number of gradient evaluations
- double chi2 = fcn.chi2();
- cout << "status: " << converged
- << " code: " << info
- << " Fev/Jev: " << nfev << "/" << njev
- << " chi2(/dp): " << chi2 << "(" << chi2/dsize << ")"
- << " DN2G"
- << endl;
- }
-
- return converged;
-}
-
-// user-supplied functions
-static void dn2g_f(int &n, int &p, double *x, int &nf, double *F,
- void *uiparm, void *urparm, void *ufparm)
-{
- (void)nf;
- (void)uiparm;
- (void)urparm;
-
- MGFunction *fcn = (MGFunction *)ufparm;
-
- assert(n == fcn->data_size());
- assert(p == fcn->parameters_size());
-
- fcn->set_parameters(x);
- fcn->fcn_diff(F);
-}
-
-static void dn2g_df(int &n, int &p, double *x, int &nf, double *J,
- void *uiparm, void *urparm, void *ufparm)
-{
- (void)nf;
- (void)uiparm;
- (void)urparm;
-
- MGFunction *fcn = (MGFunction *)ufparm;
-
- assert(n == fcn->data_size());
- assert(p == fcn->parameters_size());
-
- fcn->set_parameters(x);
- fcn->fcn_diff_transposed_gradient(J);
-}
diff --git a/CEP/PyBDSM/src/c++/Fitter_dnsg.cc b/CEP/PyBDSM/src/c++/Fitter_dnsg.cc
deleted file mode 100644
index b944f9cb8edc01451ce5b605f36bd2c27a57a393..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/c++/Fitter_dnsg.cc
+++ /dev/null
@@ -1,170 +0,0 @@
-/*!
- \file Fitter_dn2g.cc
-
- \ingroup pybdsm
-
- \author Oleksandr Usov
-
- \date 30/10/2007
-*/
-
-#include "Fitters.h"
-#include <iostream>
-
-using namespace std;
-
-/**
- This fitter uses DNSG algorithm from the (free subset of) PORT3
- library (www.netlib.org/port).
-
- DNSG is an separable least-squares solver which calls DN2G
- algorithm to solve for non-linear parameters and then uses
- linear least-squares solver to compute the linear parameters.
-**/
-
-
-// this is prototype for a fortran routines
-extern "C"
-void dnsg_ (int &n, int &p, int &l,
- double *alf, double *c, double *Y, void *F, void *J,
- int *inc, int &iinc, int *iv, int &liv, int &lv, double *v,
- int *uiparm, double *urparm, void *ufparm);
-
-extern "C"
-void divset_(const int &alg, int *iv, int &liv, int &lv, double *v);
-
-
-// user functions
-// FIXME: these should have been declared "extern "C" static ...", but gcc 4.2.2 rejects such declarations
-static
-void dnsg_f(int &n, int &p, int &l, double *alf, int &nf, double *phi,
- void *uiparm, void *urparm, void *ufparm);
-
-static
-void dnsg_df(int &n, int &p, int &l, double *alf, int &nf, double *der,
- void *uiparm, void *urparm, void *ufparm);
-
-
-// dnsg driver
-bool dnsg_fit(MGFunction &fcn, bool final, int verbose)
-{
- int dsize = fcn.data_size();
- int lpar = fcn.gaul_size();
- int nlpar = fcn.parameters_size() - lpar;
-
- // working variables
- int n = dsize, p = nlpar, l = lpar;
- int iinc = l+1, liv = 115 + p + l + 2*p;
- int lv = 105 + n*(l+p+3) + (l+p)*(n+l+p+1) + l*(l+3)/2 + p*(2*p+17);
- vector<double> alf(p), c(l), y(n), v(lv);
- vector<int> inc((l+1)*p), iv(liv);
-
- // set run-time parameters
- divset_(1, &iv[0], liv, lv, &v[0]);
-
- iv[16] = 1000; // MXFCAL - maximal number of function calls
- iv[17] = 1000; // MXITER - maximal number of iterations
- if (final)
- v[32] = 1e-8; // XCTOL - x-convergence tolerance
- else
- v[32] = 1e-4; // XCTOL - x-convergence tolerance
-
- verbose = (verbose < 0) ? 0 : verbose;
-
- switch (verbose) {
- case 0: // silence it completely
- case 1:
- iv[20] = 0; // PRUNIT
- break;
-
- case 2: // print out some results
- iv[13] = 0; // COVPRT - covariance & regression diagnostic (0 ... 3)
- iv[18] = 1; // OUTLEV - iteration summary (0, 1, ...)
- iv[19] = 1; // PARPRT - non-default parameters (0, 1)
- iv[21] = 1; // SOLPRT - solution (x, F, J) (0, 1)
- iv[22] = 1; // STATPR - summary statistics (-1, 0, 1)
- iv[23] = 0; // X0PRT - input X (0, 1)
- break;
- }
-
- iv[56] = 0; // RDREQ -- do not calculate covariance & regression diagnostic arrays
-
- fcn.get_nlin_parameters(&alf[0]);
- fcn.data(&y[0]);
-
- // fill in incidence matrix
- int pi = 0;
- for (int li = 0; li < l; ++li) {
- for (int i = 0; i < fcn.gaussian_size(li) - 1; ++i) {
- inc[li + pi * (l+1)] = 1;
- ++ pi;
- }
- }
-
- dnsg_(n, p, l,
- &alf[0], &c[0], &y[0], (void *)dnsg_f, (void *)dnsg_df,
- &inc[0], iinc, &iv[0], liv, lv, &v[0],
- (int *)0, (double *)0, (void *)&fcn);
-
- fcn.set_nlin_parameters(&alf[0]);
- fcn.set_lin_parameters(&c[0]);
-
- // extract errors information
- if (final) {
- // TODO
- }
-
- // check convergence and (possibly) print out status line
- int info = iv[0];
- bool converged = (info > 2) && (info < 7);
-
- if (verbose) {
- int nfev = iv[5]; // NFCALL - number of function evaluations
- int njev = iv[29]; // NGCALL - number of gradient evaluations
- double chi2 = fcn.chi2();
- cout << "status: " << converged
- << " code: " << info
- << " Fev/Jev: " << nfev << "/" << njev
- << " chi2(/dp): " << chi2 << "(" << chi2/dsize << ")"
- << " DNSG"
- << endl;
- }
-
- return converged;
-}
-
-// user-supplied functions
-static void dnsg_f(int &n, int &p, int &l, double *alf, int &nf, double *phi,
- void *uiparm, void *urparm, void *ufparm)
-{
- (void)nf;
- (void)uiparm;
- (void)urparm;
-
- MGFunction *fcn = (MGFunction *)ufparm;
-
- assert(n == fcn->data_size());
- assert(p == fcn->parameters_size() - fcn->gaul_size());
- assert(l == fcn->gaul_size());
-
- fcn->set_nlin_parameters(alf);
- fcn->fcn_partial_value(phi);
-}
-
-static void dnsg_df(int &n, int &p, int &l, double *alf, int &nf, double *der,
- void *uiparm, void *urparm, void *ufparm)
-{
- (void)nf;
- (void)uiparm;
- (void)urparm;
-
- MGFunction *fcn = (MGFunction *)ufparm;
-
- assert(n == fcn->data_size());
- assert(p == fcn->parameters_size() - fcn->gaul_size());
- assert(l == fcn->gaul_size());
-
- fcn->set_nlin_parameters(alf);
- fcn->fcn_partial_gradient(der);
-}
-
diff --git a/CEP/PyBDSM/src/c++/Fitter_lmder.cc b/CEP/PyBDSM/src/c++/Fitter_lmder.cc
deleted file mode 100644
index 4dc9f943948e59d582baa9e6723f554fd83261ab..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/c++/Fitter_lmder.cc
+++ /dev/null
@@ -1,122 +0,0 @@
-/*!
- \file Fitter_lmder.cc
-
- \ingroup pybdsm
-
- \author Oleksandr Usov
-
- \date 30/10/2007
-*/
-
-#include "Fitters.h"
-#include <iostream>
-
-using namespace std;
-
-/**
- This fitter uses slightly modified version of the Levenberg-Marquardt
- algorithm lmder from netlib's MINPACK-1 (www.netlib.org/minpack).
-
- The modification of the original lmder.f was needed to pass extra
- arguments into user function.
-**/
-
-
-// this is prototype for a fortran minimization routine
-extern "C"
-void lmder_(void *fcn, int &m, int &n, double *x, double *F, double *J, int &ldfjac,
- double &ftol, double &xtol, double >ol, int &maxfev,
- double *diag, int &mode, double &factor,
- int &nprint, int &info, int &nfev, int &njev,
- int *ipvt, double *qtf, double *wa1, double *wa2, double *wa3, double *wa4,
- void *userpar);
-
-// user function
-// FIXME: these should have been declared "extern "C" static ...", but gcc 4.2.2 rejects such declarations
-static
-void lmder_fcn(int &m, int &n, double *x, double *F, double *J, int &ldfjac,
- int &iflag, void *userpar);
-
-
-// lmder driver
-bool lmder_fit(MGFunction &fcn, bool final, int verbose)
-{
- int dsize = fcn.data_size();
- int npar = fcn.parameters_size();
-
- // working variables
- int m = dsize, n = npar, ldfjac = m, maxfev = 200,
- mode = 1, nprint = 0, info, nfev, njev;
- double ftol, xtol, gtol, factor = 10;
- vector<double> x(n), F(m), J(ldfjac * n), diag(n),
- qtf(n), wa1(n), wa2(n), wa3(n), wa4(m);
- vector<int> ipvt(n);
-
- // set run-time parameters
- gtol = 0;
- if (final)
- ftol = xtol = 1e-6;
- else
- ftol = xtol = 1e-4;
-
- fcn.get_parameters(&x[0]);
-
- lmder_((void *)lmder_fcn, m, n, &x[0], &F[0], &J[0], ldfjac,
- ftol, xtol, gtol, maxfev,
- &diag[0], mode, factor,
- nprint, info, nfev, njev,
- &ipvt[0], &qtf[0], &wa1[0], &wa2[0], &wa3[0], &wa4[0],
- (void *)&fcn);
-
- fcn.set_parameters(&x[0]);
-
- // extract errors information
- if (final) {
- // TODO
- }
-
- // check convergence and (possibly) print out status line
- bool converged = (info > 0) && (info < 4);
-
- if (verbose) {
- double chi2 = fcn.chi2();
- cout << "status: " << converged
- << " code: " << info
- << " Fev/Jev: " << nfev << "/" << njev
- << " chi2(/dp): " << chi2 << "(" << chi2/dsize << ")"
- << " LMDER"
- << endl;
- }
-
- return converged;
-}
-
-// user-supplied function
-static void lmder_fcn(int &m, int &n, double *x, double *F, double *J, int &ldfjac,
- int &iflag, void *userpar)
-{
- (void)ldfjac;
-
- MGFunction *fcn = (MGFunction *)userpar;
-
- assert(m == fcn->data_size());
- assert(n == fcn->parameters_size());
-
- fcn->set_parameters(x);
-
- switch (iflag) {
- case 1:
- return fcn->fcn_diff(F);
-
- case 2:
- return fcn->fcn_diff_transposed_gradient(J);
-
- default:
- cerr <<
- "!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!\n"
- " LMDER C-wrapper\n"
- " unexpected value of iflag\n"
- "!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!\n";
- abort();
- }
-}
diff --git a/CEP/PyBDSM/src/c++/Fitters.h b/CEP/PyBDSM/src/c++/Fitters.h
deleted file mode 100644
index 829c645cc1ce9035994b8e7f1b7f2482548a178b..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/c++/Fitters.h
+++ /dev/null
@@ -1,21 +0,0 @@
-
-#ifndef _FITTERS_H_INCLUDED
-#define _FITTERS_H_INCLUDED
-
-#include "MGFunction.h"
-
-/*!
- \file Fitters.h
-
- \ingroup pybdsm
-
- \author Oleksandr Usov
-
- \date 30/10/2007
-*/
-
-bool lmder_fit(MGFunction &fcn, bool final, int verbose);
-bool dn2g_fit(MGFunction &fcn, bool final, int verbose);
-bool dnsg_fit(MGFunction &fcn, bool final, int verbose);
-
-#endif // _FITTERS_H_INCLUDED
diff --git a/CEP/PyBDSM/src/c++/MGFunction.h b/CEP/PyBDSM/src/c++/MGFunction.h
deleted file mode 100644
index 33859651e8d4f67f5e6ac5c4feca3f6e167aa85d..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/c++/MGFunction.h
+++ /dev/null
@@ -1,161 +0,0 @@
-#include "Python.h"
-#ifndef _MGFUNCTION_H_INCLUDED
-#define _MGFUNCTION_H_INCLUDED
-
-#include <vector>
-#include <utility>
-#include <boost/python.hpp>
-
-using namespace boost::python;
-
-/*!
- \class MGFunction
-
- \ingroup pybdsm
-
- \brief Multi-Gaussian function.
-
- \author Oleksandr Usov
-
- \date 15/10/2007
-
- This class allows you to manage multi-gaussian function and implements
- all math required to use it for fitting.
-
- In order to improve fitting performance a number of tricks are done.
- MGFunction maintains internal caches of unmasked data points (mm_data)
- and partially evaluated gaussians (mm_fcn).
-
- End-user interface consists of functions to add (py_add_gaussian),
- remove (py_remove_gaussian), retrieve (py_get_gaussian) single gaussians
- and a functions to access all parameters at once (py_get/set_parameters).
-
- Few more support routines are present too (py_find_peak, py_reset, etc).
-
-
- Internal interface for fitter routines provides a number of low-level
- functions to evaluate gaussians (and their derivatives) in a number of
- ways (fcn_value, fcn_diff, fcn_gradient, etc).
-
- An important note -- current implementation isn't thread-safe, as caches
- are shared between all instances. One of the possibilities change it is
- to define caches thread-local, but this will require special care for the
- cleanup to prevent memory leaks.
-*/
-
-class MGFunction
-{
- public:
- MGFunction(numeric::array data, numeric::array mask, double weight);
- ~MGFunction();
-
- ////////////////////////////////
- // High-level Python interface
- ////////////////////////////////
- enum Gtype {
- G_Amplitude_Only = 1,
- G_Reduced_Gaussian = 3,
- G_Gaussian = 6,
- };
-
- void py_reset();
- void py_add_gaussian(Gtype type, object parameters);
- void py_remove_gaussian(int idx);
- tuple py_get_gaussian(int idx);
- void py_set_gaussian(int idx, object parameters);
- list py_get_parameters();
- void py_set_parameters(object parameters);
- list py_get_errors();
- tuple py_find_peak();
- static void register_class();
-
- ////////////////////////////////
- // Low-level interface for fitting routines
- ////////////////////////////////
- int data_size() const { return m_ndata; }
- int gaul_size() const { return m_gaul.size(); }
- int parameters_size() const { return m_npar; }
- int gaussian_size(unsigned idx) const { assert(idx < m_gaul.size()); return m_gaul[idx]; }
-
- void get_parameters(double *buf) const;
- void set_parameters(const double *buf);
- void get_nlin_parameters(double *buf) const;
- void set_nlin_parameters(const double *buf);
- void set_lin_parameters(const double *buf);
-
- /*! data (unmasked pixels only) */
- void data(double *buf) const;
- /*! value of the function (unmasked pixels only) */
- void fcn_value(double *buf) const;
- /*! data - value (unmasked pixels only) */
- void fcn_diff(double *buf) const;
- /*! values of single (unscaled) gaussians */
- void fcn_partial_value(double *buf) const;
- /*! fcn_value gradient */
- void fcn_gradient(double *buf) const;
- /*! fcn_diff gradient */
- void fcn_diff_gradient(double *buf) const;
- /*! fcn_value gradient (transposed) */
- void fcn_transposed_gradient(double *buf) const;
- /*! fcn_diff gradient (transposed) */
- void fcn_diff_transposed_gradient(double *buf) const;
- /*! fcn_partial_value gradient */
- void fcn_partial_gradient(double *buf) const;
- /*! calculate chi^2 of the residual image */
- double chi2() const;
-
-protected:
-
- /*! gaussians types (lengths) */
- std::vector<int> m_gaul;
- /*! parameters of gaussians */
- std::vector<std::vector<double> > m_parameters;
- /*! error bars */
- std::vector<std::vector<double> > m_errors;
-
- /*! weight for chi^2 calculation */
- double m_weight;
- /*! number of fitted parameters */
- unsigned m_npar;
- /*! number of fitted (unmasked) datapoints */
- unsigned m_ndata;
- /*! Data array */
- numeric::array m_data;
- /*! Mask array */
- numeric::array m_mask;
-
- private:
- /*! prevent copying of the MGFunction objects */
- MGFunction(MGFunction const &);
-
- /// these are used to cache intermediate calculations
- template<class T>
- void __update_dcache() const;
- void _update_dcache() const; /// update cached data
- void _update_fcache() const; /// update cached function
- unsigned long _cksum() const; /// cksum of m_parameters
-
-
- typedef struct {
- int x1, x2;
- double d;
- } dcache_t;
-
- typedef struct {
- double sn, cs, f1, f2, val;
- } fcache_t;
-
- typedef std::vector<dcache_t>::iterator dcache_it;
- typedef std::vector<fcache_t>::iterator fcache_it;
-
- /*! Data cache */
- static std::vector<dcache_t> mm_data;
- /*! cache for function/gradient evaluations */
- static std::vector<fcache_t> mm_fcn;
-
- // these are used to verify whether cached values are up-to-date
- static void *mm_obj;
- static unsigned long mm_cksum;
-};
-
-#endif // _MGFUNCTION_H_INCLUDED
diff --git a/CEP/PyBDSM/src/c++/MGFunction1.cc b/CEP/PyBDSM/src/c++/MGFunction1.cc
deleted file mode 100644
index 9aacf8e516e234c9be727e9c68d5b6a5ac316eea..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/c++/MGFunction1.cc
+++ /dev/null
@@ -1,265 +0,0 @@
-/*!
- \file MGFunction.cc
-
- \ingroup pybdsm
-
- \author Oleksandr Usov
-
- \author 15/10/2007
-
-
-Python interface.
-Most routines here are pretty straighforward, as they just wrap/unwrap
-parameters coming to/from python side.
-*/
-
-#define PY_ARRAY_UNIQUE_SYMBOL PyArrayHandle
-#define NO_IMPORT_ARRAY
-
-#include "boost_python.h"
-#include "MGFunction.h"
-
-#include <num_util/num_util.h>
-#include <cfloat>
-
-using namespace std;
-namespace n = num_util;
-
-
-//
-// Constructor -- check data types/shapes and store them
-//
-MGFunction::MGFunction(numeric::array data, numeric::array mask, double weight)
- : m_weight(weight), m_npar(0), m_data(data), m_mask(mask)
-{
- py_assert(n::rank(data) == 2 && n::rank(mask) == 2,
- PyExc_ValueError, "Data and mask should be rank-2 arrays");
- py_assert(n::shape(data) == n::shape(mask),
- PyExc_ValueError, "Shape of mask doesn't matches that of data");
- py_assert(n::type(mask) == NPY_BOOL,
- PyExc_TypeError, "Incorrect mask datatype");
-
- // to calculate m_ndata we subtract masked pixels
- PyObject *sum = PyArray_Sum((PyArrayObject *)mask.ptr(), NPY_MAXDIMS, NPY_INT, NULL);
- m_ndata = n::size(data) - PyInt_AsLong(sum);
- Py_DECREF(sum);
-}
-
-//
-// Destructor -- essentially do-nothing thing
-//
-MGFunction::~MGFunction()
-{
- // enforce data cache reset
- // this is needed if new MGFunction object is allocated
- // at the same spot in memory as previous one
- if (mm_obj == this)
- mm_obj = 0;
-}
-
-//
-// Clear MGFunction, dropping all gaussians
-//
-void MGFunction::py_reset()
-{
- m_npar = 0;
- m_gaul.clear();
- m_parameters.clear();
- m_errors.clear();
-}
-
-//
-// Add a gaussian of a specific kind
-//
-void MGFunction::py_add_gaussian(Gtype type, object parameters)
-{
- py_assert(len(parameters) == 6,
- PyExc_ValueError, "Wrong number of parameters for gaussian");
-
- vector<double> t(6);
- for (int i = 0; i < 6; ++i)
- t[i] = extract<double>(parameters[i]);
-
- m_npar += int(type);
- m_gaul.push_back(int(type));
- m_parameters.push_back(t);
- m_errors.push_back(vector<double>(6));
-}
-
-//
-// Remove gaussian by index
-//
-void MGFunction::py_remove_gaussian(int idx)
-{
- if (idx < 0)
- idx += m_gaul.size();
-
- py_assert(idx >= 0 && idx < (int)m_gaul.size(),
- PyExc_IndexError, "Incorrect index");
-
- m_npar -= m_gaul[idx];
- m_gaul.erase(m_gaul.begin() + idx);
- m_parameters.erase(m_parameters.begin() + idx);
- m_errors.erase(m_errors.begin() + idx);
-}
-
-//
-// Get gaussian parameters by index
-//
-boost::python::tuple MGFunction::py_get_gaussian(int idx)
-{
- if (idx < 0)
- idx += m_gaul.size();
-
- py_assert(idx >= 0 && idx < (int)m_gaul.size(),
- PyExc_IndexError, "Incorrect index");
-
- vector<double> &p = m_parameters[idx];
-
- return boost::python::make_tuple(p[0], p[1], p[2], p[3], p[4], p[5]);
-}
-
-//
-// Set gaussian parameters by index
-//
-void MGFunction::py_set_gaussian(int idx, object parameters)
-{
- if (idx < 0)
- idx += m_gaul.size();
-
- py_assert(idx >= 0 && idx < (int)m_gaul.size(),
- PyExc_IndexError, "Incorrect index");
- py_assert(len(parameters) == 6,
- PyExc_ValueError, "Wrong number of parameters for gaussian");
-
- for (int i = 0; i < 6; ++i)
- m_parameters[idx][i] = extract<double>(parameters[i]);
-}
-
-//
-// Get all gaussian parameters as a list of tuples
-//
-list MGFunction::py_get_parameters()
-{
- list res;
-
- for (unsigned i = 0; i < m_gaul.size(); ++i)
- res.append(py_get_gaussian(i));
-
-
- return res;
-}
-
-//
-// Set all gaussian parameters from a list of tuples
-//
-void MGFunction::py_set_parameters(object parameters)
-{
- py_assert(len(parameters) == int(m_gaul.size()),
- PyExc_ValueError, "Wrong number of gaussians");
-
- for (unsigned i = 0; i < m_parameters.size(); ++i)
- py_set_gaussian(i, parameters[i]);
-}
-
-//
-// Errors -- not really implemented now
-//
-list MGFunction::py_get_errors()
-{
- list res;
-
- for (unsigned i = 0; i < m_gaul.size(); ++i) {
- vector<double> &e = m_errors[i];
- res.append(boost::python::make_tuple(e[0], e[1], e[2], e[3], e[4], e[5]));
- }
-
- return res;
-}
-
-//
-// Find highest peak in the data-MGFunction residual
-//
-boost::python::tuple MGFunction::py_find_peak()
-{
- vector<double> buf(data_size());
- fcn_diff(&buf.front());
-
- double peak = buf[0];
- unsigned pidx = 0;
-
- for (unsigned i = 0; i < buf.size(); ++i)
- if (buf[i] > peak) {
- peak = buf[i];
- pidx = i;
- }
-
- int x1 = mm_data[pidx].x1;
- int x2 = mm_data[pidx].x2;
-
- return boost::python::make_tuple(peak, boost::python::make_tuple(x1, x2));
-}
-
-
-//
-// Register MGFunction class in python interpreter
-//
-void MGFunction::register_class()
-{
- /*
- FIXME: I don't really understand why this 'using' statement should be here, but
- my compiler (apple gcc 4.0.1) can't find arg without it.
- */
- using boost::python::arg;
-
- enum_<Gtype>("Gtype")
- .value("g1", G_Amplitude_Only)
- .value("g3", G_Reduced_Gaussian)
- .value("g6", G_Gaussian)
- ;
-
- class_<MGFunction,
- boost::noncopyable>("MGFunction",
- "Multi-Gaussian function.\n\n"
- "This class allows you to manage multi-gaussian function\n"
- "and implements all math required to use it for fitting.\n\n"
- "NEVER EVER USE IT IN MULTITHREADED SOFTWARE WITHOUT APPROPRIATE LOCKING\n"
- "IT'S INTERNAL CACHES ARE NOT THREAD-SAFE\n\n",
- init<numeric::array, numeric::array,
- double>((arg("data"), "mask", arg("weight") = 1.)))
-
- .def("__len__", &MGFunction::gaul_size,
- "total number of gaussians")
-
- .def("add_gaussian", &MGFunction::py_add_gaussian, (arg("type"), "parameters"),
- "add gaussian to the set")
-
- .def("remove_gaussian", &MGFunction::py_remove_gaussian, arg("idx"),
- "remove given gaussian")
-
- .def("__delitem__", &MGFunction::py_remove_gaussian, arg("idx"),
- "remove given gaussian")
-
- .def("__getitem__", &MGFunction::py_get_gaussian, arg("idx"),
- "get parameters of the given gaussian")
-
- .def("__setitem__", &MGFunction::py_set_gaussian, (arg("idx"), "parameters"),
- "set parameters of the given gaussian")
-
- .def("find_peak", &MGFunction::py_find_peak,
- "find highest peak in the residual image\n"
- "returns (value, (x1, x2))")
-
- .def("fitted_parameters", &MGFunction::parameters_size,
- "total number of fitted parameters")
-
- .def("reset", &MGFunction::py_reset,
- "reset MGFunction by forgetting all gaussians")
-
- ADD_PROPERTY2("parameters", &MGFunction::py_get_parameters, &MGFunction::py_set_parameters,
- "get/set parameters of all gaussians together")
-
- ADD_PROPERTY1("errors", &MGFunction::py_get_errors,
- "get error bounds")
- ;
-}
diff --git a/CEP/PyBDSM/src/c++/MGFunction2.cc b/CEP/PyBDSM/src/c++/MGFunction2.cc
deleted file mode 100644
index 4417d0a0bb56e96a220090e9216a155e19fe57d6..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/c++/MGFunction2.cc
+++ /dev/null
@@ -1,537 +0,0 @@
-/*!
- \file MGFunction.cc
-
- \ingroup pybdsm
-
- \author Oleksandr Usov
-
- \date 15/10/2007
-
-
-Low-level interface.
-Beware that most routines here are quite involved and unforgiving.
-Make sure output array sizes are correct.
-
-MGFunction class stores internally all unmasked data points, and
-a list of 2D gaussians, and provides functions to evaluate them
-in the variety of ways. Let me introduce some notation.
-
-MGFunction object with N 2D gaussians in it is defined as:
-
-
-MGF(x1,x2) = sum(A_i * fcn_i(x1,x2; NL_ij)), where
-
-fcn_i(x1,x2; NL_ij) = exp(-0.5 * (f1^2 + f2^2))
-f1 = ( (x1-NL_i1)*cos(NL_i5) + (x2-NL_i2)*sin(NL_i5))/NL_i3
-f2 = (-(x1-NL_i1)*sin(NL_i5) + (x2-NL_i2)*cos(NL_i5))/NL_i4
-
-so amplitudes of sub-gaussians (A_i) are linear fitted parameters,
-and parameters under exponents (NL_ij) are non-linear.
-*/
-
-#define PY_ARRAY_UNIQUE_SYMBOL PyArrayHandle
-#define NO_IMPORT_ARRAY
-
-#include "boost_python.h"
-#include "MGFunction.h"
-
-#if defined(__GLIBCXX__) and __cplusplus <= 199711L
-#include <ext/algorithm>
-#endif
-#include <num_util/num_util.h>
-#include <cfloat>
-
-#if not(defined(_LIBCPP_VERSION)) and __cplusplus <= 199711L
-using namespace __gnu_cxx;
-#endif
-using namespace std;
-namespace n = num_util;
-
-vector<MGFunction::dcache_t> MGFunction::mm_data;
-vector<MGFunction::fcache_t> MGFunction::mm_fcn;
-void * MGFunction::mm_obj = 0;
-unsigned long MGFunction::mm_cksum = -1;
-static const double deg = M_PI/180;
-
-
-//
-// Copy all fitted parameters to buf.
-// buf should be parameters_size() long.
-//
-void MGFunction::get_parameters(double *buf) const
-{
- double *chk = buf;
- for (unsigned i = 0; i < m_gaul.size(); ++i) {
- copy_n(m_parameters[i].begin(), m_gaul[i], buf);
- buf += m_gaul[i];
- }
- assert(buf - chk == (int)m_npar);
-}
-
-//
-// Set all fitted parameters from buf
-// buf should be parameters_size() long.
-//
-void MGFunction::set_parameters(const double *buf)
-{
- const double *chk = buf;
- for(unsigned i = 0; i < m_gaul.size(); ++i) {
- copy_n(buf, m_gaul[i], m_parameters[i].begin());
- buf += m_gaul[i];
- }
- assert(buf - chk == (int)m_npar);
-}
-
-//
-// Copy all fitted non-linear parameters to buf
-// buf should be parameters_size() - gaul_size() long.
-//
-void MGFunction::get_nlin_parameters(double *buf) const
-{
- double *chk = buf;
- for (unsigned i = 0; i < m_gaul.size(); ++i) {
- copy_n(m_parameters[i].begin() + 1, m_gaul[i] - 1, buf);
- buf += m_gaul[i] - 1;
- }
- assert(buf - chk == (int)(m_npar - m_gaul.size()));
-}
-
-//
-// Set all fitted non-linear parameters from buf
-// buf should be parameters_size() - gaul_size() long.
-//
-void MGFunction::set_nlin_parameters(const double *buf)
-{
- const double *chk = buf;
- for(unsigned i = 0; i < m_gaul.size(); ++i) {
- copy_n(buf, m_gaul[i] - 1, m_parameters[i].begin() + 1);
- buf += m_gaul[i] - 1 ;
- }
- assert(buf - chk == (int)(m_npar - m_gaul.size()));
-}
-
-//
-// Set all fitted linear parameters from buf
-// buf should be gaul_size() long.
-//
-void MGFunction::set_lin_parameters(const double *buf)
-{
- const double *chk = buf;
- for(unsigned i = 0; i < m_gaul.size(); ++i, ++buf)
- m_parameters[i][0] = *buf;
- assert(buf - chk == (int)m_gaul.size());
-}
-
-//
-// Copy (unmasked) data into buf.
-// buf should be data_size() long.
-//
-void MGFunction::data(double *buf) const
-{
- _update_fcache();
- double *chk = buf;
-
- for (dcache_it d = mm_data.begin(); d != mm_data.end(); ++d, ++buf)
- *buf = d->d;
- assert(buf - chk == (int)m_ndata);
-}
-
-//
-// Evaluate MGFunction (for unmasked pixels only)
-// buf should be data_size() long.
-//
-void MGFunction::fcn_value(double *buf) const
-{
- _update_fcache();
- double *chk = buf;
-
- fcache_it f = mm_fcn.begin();
- for (unsigned didx = 0; didx < m_ndata; ++didx, ++buf) {
- *buf = 0;
- for (unsigned gidx = 0; gidx < m_gaul.size(); ++gidx, ++f)
- *buf += m_parameters[gidx][0] * f->val;
- }
- assert(buf - chk == (int)m_ndata);
-}
-
-//
-// Evaluate (data-MGFunction) (for unmasked pixels only)
-// buf should be data_size() long.
-//
-void MGFunction::fcn_diff(double *buf) const
-{
- _update_fcache();
- double *chk = buf;
-
- fcache_it f = mm_fcn.begin();
- for (dcache_it d = mm_data.begin(); d != mm_data.end(); ++d, ++buf) {
- *buf = d->d;
- for (unsigned gidx = 0; gidx < m_gaul.size(); ++gidx, ++f)
- *buf -= m_parameters[gidx][0] * f->val;
- }
- assert(buf - chk == (int)m_ndata);
-}
-
-//
-// Evaluate non-linear part of MGFunction
-// each gaussian is evaluated for all data points and stored contiguously
-// buf should be data_size()*gaul_size() long.
-//
-// buf layout is following:
-// fcn_0(X_0; ...), fcn_0(X_1; ...), ....... fcn_0(X_n; ...)
-// .............................................
-// fcn_m(X_0; ...), fcn_m(X_1; ...), ....... fcn_m(X_n; ...)
-//
-// where n == data_size() and m == gaul_size()
-//
-void MGFunction::fcn_partial_value(double *buf) const
-{
- _update_fcache();
-
- fcache_it f = mm_fcn.begin();
- unsigned didx, gidx = 0;
- for (didx = 0; didx < m_ndata; ++didx) {
- for (gidx = 0; gidx < m_gaul.size(); ++gidx, ++f)
- buf[gidx * m_ndata + didx] = f->val;
- }
- assert((gidx - 1) * m_ndata + didx == m_ndata * m_gaul.size());
-}
-
-//
-// Gradient of MGFunction
-// all derivatives are evaluated for each data point and stored contiguously
-// buf should be data_size()*parameters_size() long
-//
-// buf layout:
-// dF(X_0)/dx_0 , dF(X_0)/dx_1, .... dF(X_0)/dx_m
-// ....................................
-// dF(X_n)/dx_0 , dF(X_n)/dx_1, .... dF(X_n)/dx_m
-//
-// where n == data_size() and m == parameters_size()
-//
-void MGFunction::fcn_gradient(double *buf) const
-{
- _update_fcache();
- double *chk = buf;
-
- fcache_it f = mm_fcn.begin();
- for (unsigned didx = 0; didx < m_ndata; ++didx)
- for (unsigned gidx = 0; gidx < m_gaul.size(); ++gidx, ++f) {
- const vector<double> &p = m_parameters[gidx];
- double cs = f->cs;
- double sn = f->sn;
- double f1 = f->f1;
- double f2 = f->f2;
- double V = p[0] * f->val;
-
- *(buf++) = f->val;
- if (m_gaul[gidx] == G_Gaussian || m_gaul[gidx] == G_Reduced_Gaussian) {
- *(buf++) = (V * (f1*cs/p[3] - f2*sn/p[4]));
- *(buf++) = (V * (f1*sn/p[3] + f2*cs/p[4]));
- if (m_gaul[gidx] == G_Gaussian) {
- *(buf++) = (V * f1*f1/p[3]);
- *(buf++) = (V * f2*f2/p[4]);
- *(buf++) = (V * deg * f1 * f2 * (p[3]/p[4] - p[4]/p[3]));
- }
- }
- }
- assert(buf - chk == (int)(m_ndata * m_npar));
-}
-
-//
-// Gradient of (data-MGFunction)
-// all derivatives are evaluated for each data point and stored contiguously
-// buf should be data_size()*parameters_size() long
-//
-// see fcn_gradient for layout description
-//
-void MGFunction::fcn_diff_gradient(double *buf) const
-{
- _update_fcache();
- double *chk = buf;
-
- fcache_it f = mm_fcn.begin();
- for (unsigned didx = 0; didx < m_ndata; ++didx)
- for (unsigned gidx = 0; gidx < m_gaul.size(); ++gidx, ++f) {
- const vector<double> &p = m_parameters[gidx];
- double cs = f->cs;
- double sn = f->sn;
- double f1 = f->f1;
- double f2 = f->f2;
- double V = - p[0] * f->val; // EXTRA MINUS SIGN INCLUDED
-
- *(buf++) = - f->val; // EXTRA MINUS SIGN INCLUDED
- if (m_gaul[gidx] == G_Gaussian || m_gaul[gidx] == G_Reduced_Gaussian) {
- *(buf++) = (V * (f1*cs/p[3] - f2*sn/p[4]));
- *(buf++) = (V * (f1*sn/p[3] + f2*cs/p[4]));
- if (m_gaul[gidx] == G_Gaussian) {
- *(buf++) = (V * f1*f1/p[3]);
- *(buf++) = (V * f2*f2/p[4]);
- *(buf++) = (V * deg * f1 * f2 * (p[3]/p[4] - p[4]/p[3]));
- }
- }
- }
- assert(buf - chk == (int)(m_ndata * m_npar));
-}
-
-//
-// Gradient of MGFunction
-// each derivative is evaluated for all data points and stored contiguously
-// buf should be data_size()*parameters_size() long
-//
-// buf layout:
-// dF(X_0)/dx_0 , dF(X_1)/dx_0, .... dF(X_n)/dx_0
-// ....................................
-// dF(X_0)/dx_m , dF(X_1)/dx_m, .... dF(X_n)/dx_m
-//
-// where n == data_size() and m == parameters_size()
-//
-void MGFunction::fcn_transposed_gradient(double *buf) const
-{
- _update_fcache();
-
- fcache_it f = mm_fcn.begin();
- unsigned didx, gidx = 0, ggidx = 0;
- for (didx = 0; didx < m_ndata; ++didx) {
- ggidx = 0;
- for (gidx = 0; gidx < m_gaul.size(); ++gidx, ++f) {
- const vector<double> &p = m_parameters[gidx];
- double cs = f->cs;
- double sn = f->sn;
- double f1 = f->f1;
- double f2 = f->f2;
- double V = p[0] * f->val;
-
- buf[(0 + ggidx)*m_ndata + didx] = f->val;
- if (m_gaul[gidx] == G_Gaussian || m_gaul[gidx] == G_Reduced_Gaussian) {
- buf[(1 + ggidx)*m_ndata + didx] = (V * (f1*cs/p[3] - f2*sn/p[4]));
- buf[(2 + ggidx)*m_ndata + didx] = (V * (f1*sn/p[3] + f2*cs/p[4]));
- if (m_gaul[gidx] == G_Gaussian) {
- buf[(3 + ggidx)*m_ndata + didx] = (V * f1*f1/p[3]);
- buf[(4 + ggidx)*m_ndata + didx] = (V * f2*f2/p[4]);
- buf[(5 + ggidx)*m_ndata + didx] = (V * deg * f1 * f2 * (p[3]/p[4] - p[4]/p[3]));
- }
- }
- ggidx += m_gaul[gidx];
- }
- }
- assert(ggidx * m_ndata == m_ndata * m_npar);
-}
-
-//
-// Gradient of (data-MGFunction)
-// each derivative is evaluated for all data points and stored contiguously
-// buf should be data_size()*parameters_size() long
-//
-// see fcn_transposed_gradient for layout description
-//
-void MGFunction::fcn_diff_transposed_gradient(double *buf) const
-{
- _update_fcache();
-
- fcache_it f = mm_fcn.begin();
- unsigned didx, gidx = 0, ggidx = 0;
- for (didx = 0; didx < m_ndata; ++didx) {
- ggidx = 0;
- for (gidx = 0; gidx < m_gaul.size(); ++gidx, ++f) {
- const vector<double> &p = m_parameters[gidx];
- double cs = f->cs;
- double sn = f->sn;
- double f1 = f->f1;
- double f2 = f->f2;
- double V = - p[0] * f->val; // EXTRA MINUS SIGN INCLUDED
-
- buf[(0 + ggidx)*m_ndata + didx] = - f->val; // EXTRA MINUS SIGN INCLUDED
- if (m_gaul[gidx] == G_Gaussian || m_gaul[gidx] == G_Reduced_Gaussian) {
- buf[(1 + ggidx)*m_ndata + didx] = (V * (f1*cs/p[3] - f2*sn/p[4]));
- buf[(2 + ggidx)*m_ndata + didx] = (V * (f1*sn/p[3] + f2*cs/p[4]));
- if (m_gaul[gidx] == G_Gaussian) {
- buf[(3 + ggidx)*m_ndata + didx] = (V * f1*f1/p[3]);
- buf[(4 + ggidx)*m_ndata + didx] = (V * f2*f2/p[4]);
- buf[(5 + ggidx)*m_ndata + didx] = (V * deg * f1 * f2 * (p[3]/p[4] - p[4]/p[3]));
- }
- }
- ggidx += m_gaul[gidx];
- }
- }
- assert(ggidx * m_ndata == m_ndata * m_npar);
-}
-
-//
-// Gradient of non-linear functions (corresponds to fcn_partial_value)
-// each derivative is evaluated for all data points and stored contiguously
-// buf should be data_size()*(parameters_size() - gaul_size()) long
-//
-// buf layout:
-// dF(X_0)/dNL_0 , dF(X_1)/dNL_0, .... dF(X_n)/dNL_0
-// ....................................
-// dF(X_0)/dNL_m , dF(X_1)/dNL_m, .... dF(X_n)/dNL_m
-//
-// where n == data_size() and m == (parameters_size()-gaul_size())
-//
-void MGFunction::fcn_partial_gradient(double *buf) const
-{
- _update_fcache();
-
- fcache_it f = mm_fcn.begin();
- unsigned didx, gidx = 0, ggidx = 0;
- for (didx = 0; didx < m_ndata; ++didx) {
- ggidx = 0;
- for (gidx = 0; gidx < m_gaul.size(); ++gidx, ++f) {
- const vector<double> &p = m_parameters[gidx];
- double cs = f->cs;
- double sn = f->sn;
- double f1 = f->f1;
- double f2 = f->f2;
- double V = f->val;
-
- if (m_gaul[gidx] == G_Gaussian || m_gaul[gidx] == G_Reduced_Gaussian) {
- buf[(0 + ggidx)*m_ndata + didx] = (V * (f1*cs/p[3] - f2*sn/p[4]));
- buf[(1 + ggidx)*m_ndata + didx] = (V * (f1*sn/p[3] + f2*cs/p[4]));
- if (m_gaul[gidx] == G_Gaussian) {
- buf[(2 + ggidx)*m_ndata + didx] = (V * f1*f1/p[3]);
- buf[(3 + ggidx)*m_ndata + didx] = (V * f2*f2/p[4]);
- buf[(4 + ggidx)*m_ndata + didx] = (V * deg * f1 * f2 * (p[3]/p[4] - p[4]/p[3]));
- }
- }
- ggidx += m_gaul[gidx] - 1;
- }
- }
- assert(ggidx * m_ndata == m_ndata * (m_npar - m_gaul.size()));
-}
-
-//
-// Calculate \chi^2 measure between data and MGFunction
-// uses uniform weighting for all data points
-//
-double MGFunction::chi2() const
-{
- _update_fcache();
-
- double res = 0;
- fcache_it f = mm_fcn.begin();
- for (dcache_it d = mm_data.begin(); d != mm_data.end(); ++d) {
- double v = d->d;
- for (unsigned gidx = 0; gidx < m_gaul.size(); ++gidx, ++f)
- v -= m_parameters[gidx][0] * f->val;
- v /= m_weight;
- res += v*v;
- }
-
- return res;
-}
-
-
-//////////////////////////////
-// cache-handling
-//////////////////////////////
-
-//
-// Calculate checksum of values of fitted parameters.
-// this is used as for a quick check whether cached values of
-// function should be updated
-//
-unsigned long MGFunction::_cksum() const
-{
- typedef unsigned long T;
-
- T res = 0;
-
- for (unsigned i = 0; i < m_gaul.size(); ++i) {
- T *buf = (T *)&m_parameters[i][0];
- int size = m_parameters[i].size() * sizeof(double) / sizeof(T);
- for (int j = 0; j < size; ++j)
- res ^= buf[j];
- }
-
- return res;
-}
-
-//
-// Update data-cache: rescan data and mask arrays and copy
-// unmasked pixels into data-cache
-//
-template<class T>
-void MGFunction::__update_dcache() const
-{
- PyObject *data = (PyObject *)m_data.ptr();
- PyObject *mask = (PyObject *)m_mask.ptr();
- vector<int> shape = n::shape(m_data);
- dcache_t t;
-
- mm_data.clear();
- mm_data.reserve(m_ndata);
-
- for (int i = 0; i < shape[0]; ++i)
- for (int j = 0; j < shape[1]; ++j)
- if (!*(npy_bool *)PyArray_GETPTR2(mask, i, j)) {
- t.x1 = i;
- t.x2 = j;
- t.d = *(T *)PyArray_GETPTR2(data, i, j);
- mm_data.push_back(t);
- }
-
- assert(mm_data.size() == m_ndata);
-}
-
-//
-// Type-dispatcher for __update_dcache
-//
-void MGFunction::_update_dcache() const
-{
- PyArray_TYPES type = n::type(m_data);
-
- switch (type) {
- case NPY_DOUBLE:
- return __update_dcache<npy_double>();
- case NPY_FLOAT:
- return __update_dcache<npy_float>();
- default:
- py_assert(false,
- PyExc_TypeError, "Incorrect data datatype");
- }
-}
-
-//
-// Update function-cache: check if fitted parameters were changed
-// and recalculate all gaussians.
-//
-// Also calls _update_dcache if needed
-//
-void MGFunction::_update_fcache() const
-{
- unsigned long cksum = _cksum();
- unsigned ngaul = m_gaul.size();
-
- // reallocate function/data arrays
- if (mm_fcn.size() != m_ndata * ngaul || mm_obj != (void *)this) {
- if (mm_obj != (void *)this) {
- _update_dcache();
- mm_obj = (void *)this;
- }
-
- mm_fcn.resize(m_ndata * ngaul);
- mm_cksum = cksum-1; // force wrong mm_cksum
- }
-
- if (mm_cksum != cksum) {
- fcache_it f = mm_fcn.begin();
- for (dcache_it d = mm_data.begin(); d != mm_data.end(); ++d)
- for (unsigned gidx = 0; gidx < ngaul; ++gidx, ++f) {
- const vector<double> &p = m_parameters[gidx];
- int x1 = d->x1;
- int x2 = d->x2;
- double cs = cos(p[5]*deg);
- double sn = sin(p[5]*deg);
- double f1 = ( (x1 - p[1]) * cs + (x2 - p[2]) * sn)/p[3];
- double f2 = (-(x1 - p[1]) * sn + (x2 - p[2]) * cs)/p[4];
- double v = exp((f1*f1 + f2*f2)/(-2.L));
-
- f->sn = sn; f->cs = cs;
- f->f1 = f1; f->f2 = f2;
- f->val = v;
- }
-
- mm_cksum = cksum;
- }
-}
diff --git a/CEP/PyBDSM/src/c++/boost_python.h b/CEP/PyBDSM/src/c++/boost_python.h
deleted file mode 100644
index 89b16bdd7ed5ec4a74819ab3d74ee60ef3e45151..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/c++/boost_python.h
+++ /dev/null
@@ -1,32 +0,0 @@
-#ifndef _AUX_H_INCLUDED
-#define _AUX_H_INCLUDED
-
-/*!
- \file boost_python.h
-
- \ingroup pybdsm
-
- \brief Miscellaneous usefull routines
-*/
-
-#include <boost/version.hpp>
-#include <boost/python.hpp>
-#include <boost/python/detail/api_placeholder.hpp>
-
-#if BOOST_VERSION > 103200
-#define ADD_PROPERTY1(name, get, doc) .add_property(name, get, doc)
-#define ADD_PROPERTY2(name, get, set, doc) .add_property(name, get, set, doc)
-#else
-#define ADD_PROPERTY1(name, get, doc) .add_property(name, get)
-#define ADD_PROPERTY2(name, get, set, doc) .add_property(name, get, set)
-#endif
-
-inline void py_assert(bool cond, PyObject *exc, const char *msg)
-{
- if(!cond) {
- PyErr_SetString(exc, msg);
- throw boost::python::error_already_set();
- }
-}
-
-#endif // _AUX_H_INCLUDED
diff --git a/CEP/PyBDSM/src/c++/cbdsm_main.cc b/CEP/PyBDSM/src/c++/cbdsm_main.cc
deleted file mode 100644
index fd4bd3b0f5e457d6cb614d5c91f5656627032dcc..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/c++/cbdsm_main.cc
+++ /dev/null
@@ -1,40 +0,0 @@
-/*!
- \file cbdsm_main.cc
-
- \ingroup pybdsm
-
- \author Oleksandr Usov
-*/
-
-#define PY_ARRAY_UNIQUE_SYMBOL PyArrayHandle
-
-#include "stat.h"
-#include "MGFunction.h"
-#include "Fitters.h"
-#include <num_util/num_util.h>
-
-using namespace boost::python;
-
-BOOST_PYTHON_MODULE(_cbdsm)
-{
- import_array();
- numeric::array::set_module_and_type("numpy", "ndarray");
-
- scope().attr("__doc__") =
- "A collection of optimized C & Fortran routines for pybdsm";
-
- def("bstat", &bstat, (arg("array"), arg("mask") = false, arg("kappa") = 3),
- "calculate (clipped) mean and rms of the n-dimensional (masked) image\n"
- "returns 4-tuple (mean, dev, cmean, cdev)\n");
-
- MGFunction::register_class();
-
- def("lmder_fit", &lmder_fit, (arg("fcn"), arg("final") = false, arg("verbose") = 1),
- "Fitter using the Levenberg-Marquardt algorithm LMDER from MINPACK-1");
-
- def("dn2g_fit", &dn2g_fit, (arg("fcn"), arg("final") = false, arg("verbose") = 1),
- "Fitter using DN2G algorithm from PORT3 library");
-
- def("dnsg_fit", &dnsg_fit, (arg("fcn"), arg("final") = false, arg("verbose") = 1),
- "Fitter using DNSG algorithm from PORT3 library");
-}
diff --git a/CEP/PyBDSM/src/c++/num_util/num_util.cpp b/CEP/PyBDSM/src/c++/num_util/num_util.cpp
deleted file mode 100644
index 94c621f14d39866aa4adaf98f75e95483211b77c..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/c++/num_util/num_util.cpp
+++ /dev/null
@@ -1,443 +0,0 @@
-// Copyright 2006 Phil Austin (http://www.eos.ubc.ca/personal/paustin)
-// Distributed under the Boost Software License, Version 1.0. (See
-// accompanying file LICENSE_1_0.txt or copy at
-// http://www.boost.org/LICENSE_1_0.txt)
-
-#define PY_ARRAY_UNIQUE_SYMBOL PyArrayHandle
-#define NO_IMPORT_ARRAY
-#include "num_util.h"
-
-// namespace { const char* rcsid = "$Id$"; }
-
-using namespace boost::python;
-
-namespace num_util{
-
- //specializations for use by makeNum
-
-
- template <>
- PyArray_TYPES getEnum<unsigned char>(void)
- {
- return PyArray_UBYTE;
- }
-
-
- template <>
- PyArray_TYPES getEnum<signed char>(void)
- {
- return PyArray_BYTE;
- }
-
- template <>
- PyArray_TYPES getEnum<short>(void)
- {
- return PyArray_SHORT;
- }
-
- template <>
- PyArray_TYPES getEnum<unsigned short>(void)
- {
- return PyArray_USHORT;
- }
-
-
- template <>
- PyArray_TYPES getEnum<unsigned int>(void)
- {
- return PyArray_UINT;
- }
-
- template <>
- PyArray_TYPES getEnum<int>(void)
- {
- return PyArray_INT;
- }
-
- template <>
- PyArray_TYPES getEnum<long>(void)
- {
- return PyArray_LONG;
- }
-
- template <>
- PyArray_TYPES getEnum<unsigned long>(void)
- {
- return PyArray_ULONG;
- }
-
-
- template <>
- PyArray_TYPES getEnum<long long>(void)
- {
- return PyArray_LONGLONG;
- }
-
- template <>
- PyArray_TYPES getEnum<unsigned long long>(void)
- {
- return PyArray_ULONGLONG;
- }
-
- template <>
- PyArray_TYPES getEnum<float>(void)
- {
- return PyArray_FLOAT;
- }
-
- template <>
- PyArray_TYPES getEnum<double>(void)
- {
- return PyArray_DOUBLE;
- }
-
- template <>
- PyArray_TYPES getEnum<long double>(void)
- {
- return PyArray_LONGDOUBLE;
- }
-
- template <>
- PyArray_TYPES getEnum<std::complex<float> >(void)
- {
- return PyArray_CFLOAT;
- }
-
-
- template <>
- PyArray_TYPES getEnum<std::complex<double> >(void)
- {
- return PyArray_CDOUBLE;
- }
-
- template <>
- PyArray_TYPES getEnum<std::complex<long double> >(void)
- {
- return PyArray_CLONGDOUBLE;
- }
-
-
-typedef KindStringMap::value_type KindStringMapEntry;
-KindStringMapEntry kindStringMapEntries[] =
- {
- KindStringMapEntry(PyArray_UBYTE, "PyArray_UBYTE"),
- KindStringMapEntry(PyArray_BYTE, "PyArray_BYTE"),
- KindStringMapEntry(PyArray_SHORT, "PyArray_SHORT"),
- KindStringMapEntry(PyArray_INT, "PyArray_INT"),
- KindStringMapEntry(PyArray_LONG, "PyArray_LONG"),
- KindStringMapEntry(PyArray_FLOAT, "PyArray_FLOAT"),
- KindStringMapEntry(PyArray_DOUBLE, "PyArray_DOUBLE"),
- KindStringMapEntry(PyArray_CFLOAT, "PyArray_CFLOAT"),
- KindStringMapEntry(PyArray_CDOUBLE,"PyArray_CDOUBLE"),
- KindStringMapEntry(PyArray_OBJECT, "PyArray_OBJECT"),
- KindStringMapEntry(PyArray_NTYPES, "PyArray_NTYPES"),
- KindStringMapEntry(PyArray_NOTYPE ,"PyArray_NOTYPE")
- };
-
-typedef KindCharMap::value_type KindCharMapEntry;
-KindCharMapEntry kindCharMapEntries[] =
- {
- KindCharMapEntry(PyArray_UBYTE, 'B'),
- KindCharMapEntry(PyArray_BYTE, 'b'),
- KindCharMapEntry(PyArray_SHORT, 'h'),
- KindCharMapEntry(PyArray_INT, 'i'),
- KindCharMapEntry(PyArray_LONG, 'l'),
- KindCharMapEntry(PyArray_FLOAT, 'f'),
- KindCharMapEntry(PyArray_DOUBLE, 'd'),
- KindCharMapEntry(PyArray_CFLOAT, 'F'),
- KindCharMapEntry(PyArray_CDOUBLE,'D'),
- KindCharMapEntry(PyArray_OBJECT, 'O')
- };
-
-typedef KindTypeMap::value_type KindTypeMapEntry;
-KindTypeMapEntry kindTypeMapEntries[] =
- {
- KindTypeMapEntry('B',PyArray_UBYTE),
- KindTypeMapEntry('b',PyArray_BYTE),
- KindTypeMapEntry('h',PyArray_SHORT),
- KindTypeMapEntry('i',PyArray_INT),
- KindTypeMapEntry('l',PyArray_LONG),
- KindTypeMapEntry('f',PyArray_FLOAT),
- KindTypeMapEntry('d',PyArray_DOUBLE),
- KindTypeMapEntry('F',PyArray_CFLOAT),
- KindTypeMapEntry('D',PyArray_CDOUBLE),
- KindTypeMapEntry('O',PyArray_OBJECT)
- };
-
-
-int numStringEntries = sizeof(kindStringMapEntries)/sizeof(KindStringMapEntry);
-int numCharEntries = sizeof(kindCharMapEntries)/sizeof(KindCharMapEntry);
-int numTypeEntries = sizeof(kindTypeMapEntries)/sizeof(KindTypeMapEntry);
-
-
-using namespace boost::python;
-
-static KindStringMap kindstrings(kindStringMapEntries,
- kindStringMapEntries + numStringEntries);
-
-static KindCharMap kindchars(kindCharMapEntries,
- kindCharMapEntries + numCharEntries);
-
-static KindTypeMap kindtypes(kindTypeMapEntries,
- kindTypeMapEntries + numTypeEntries);
-
-//Create a numarray referencing Python sequence object
-numeric::array makeNum(object x){
- if (!PySequence_Check(x.ptr())){
- PyErr_SetString(PyExc_ValueError, "expected a sequence");
- throw_error_already_set();
- }
- object obj(handle<>
- (PyArray_ContiguousFromObject(x.ptr(),PyArray_NOTYPE,0,0)));
- check_PyArrayElementType(obj);
- return extract<numeric::array>(obj);
-}
-
-//Create a one-dimensional Numeric array of length n and Numeric type t
-numeric::array makeNum(int n, PyArray_TYPES t=PyArray_DOUBLE){
- object obj(handle<>(PyArray_FromDims(1, &n, t)));
- return extract<numeric::array>(obj);
-}
-
-//Create a Numeric array with dimensions dimens and Numeric type t
-numeric::array makeNum(std::vector<int> dimens,
- PyArray_TYPES t=PyArray_DOUBLE){
- object obj(handle<>(PyArray_FromDims(dimens.size(), &dimens[0], t)));
- return extract<numeric::array>(obj);
-}
-
-numeric::array makeNum(const numeric::array& arr){
- //Returns a reference of arr by calling numeric::array copy constructor.
- //The copy constructor increases arr's reference count.
- return numeric::array(arr);
-}
-
-PyArray_TYPES type(numeric::array arr){
- return PyArray_TYPES(PyArray_TYPE(arr.ptr()));
-}
-
-void check_type(boost::python::numeric::array arr,
- PyArray_TYPES expected_type){
- PyArray_TYPES actual_type = type(arr);
- if (actual_type != expected_type) {
- std::ostringstream stream;
- stream << "expected Numeric type " << kindstrings[expected_type]
- << ", found Numeric type " << kindstrings[actual_type] << std::ends;
- PyErr_SetString(PyExc_TypeError, stream.str().c_str());
- throw_error_already_set();
- }
- return;
-}
-
-//Return the number of dimensions
-int rank(numeric::array arr){
- //std::cout << "inside rank" << std::endl;
- if(!PyArray_Check(arr.ptr())){
- PyErr_SetString(PyExc_ValueError, "expected a PyArrayObject");
- throw_error_already_set();
- }
- return PyArray_NDIM(arr.ptr());
-}
-
-void check_rank(boost::python::numeric::array arr, int expected_rank){
- int actual_rank = rank(arr);
- if (actual_rank != expected_rank) {
- std::ostringstream stream;
- stream << "expected rank " << expected_rank
- << ", found rank " << actual_rank << std::ends;
- PyErr_SetString(PyExc_RuntimeError, stream.str().c_str());
- throw_error_already_set();
- }
- return;
-}
-
-int size(numeric::array arr)
-{
- if(!PyArray_Check(arr.ptr())){
- PyErr_SetString(PyExc_ValueError, "expected a PyArrayObject");
- throw_error_already_set();
- }
- return PyArray_Size(arr.ptr());
-}
-
-void check_size(boost::python::numeric::array arr, int expected_size){
- int actual_size = size(arr);
- if (actual_size != expected_size) {
- std::ostringstream stream;
- stream << "expected size " << expected_size
- << ", found size " << actual_size << std::ends;
- PyErr_SetString(PyExc_RuntimeError, stream.str().c_str());
- throw_error_already_set();
- }
- return;
-}
-
-std::vector<int> shape(numeric::array arr){
- std::vector<int> out_dims;
- if(!PyArray_Check(arr.ptr())){
- PyErr_SetString(PyExc_ValueError, "expected a PyArrayObject");
- throw_error_already_set();
- }
- npy_intp* dims_ptr = PyArray_DIMS(arr.ptr());
- int the_rank = rank(arr);
- for (int i = 0; i < the_rank; i++){
- out_dims.push_back(*(dims_ptr + i));
- }
- return out_dims;
-}
-
-int get_dim(boost::python::numeric::array arr, int dimnum){
- assert(dimnum >= 0);
- int the_rank=rank(arr);
- if(the_rank < dimnum){
- std::ostringstream stream;
- stream << "Error: asked for length of dimension ";
- stream << dimnum << " but rank of array is " << the_rank << std::ends;
- PyErr_SetString(PyExc_RuntimeError, stream.str().c_str());
- throw_error_already_set();
- }
- std::vector<int> actual_dims = shape(arr);
- return actual_dims[dimnum];
-}
-
-void check_shape(boost::python::numeric::array arr, std::vector<int> expected_dims){
- std::vector<int> actual_dims = shape(arr);
- if (actual_dims != expected_dims) {
- std::ostringstream stream;
- stream << "expected dimensions " << vector_str(expected_dims)
- << ", found dimensions " << vector_str(actual_dims) << std::ends;
- PyErr_SetString(PyExc_RuntimeError, stream.str().c_str());
- throw_error_already_set();
- }
- return;
-}
-
-void check_dim(boost::python::numeric::array arr, int dimnum, int dimsize){
- std::vector<int> actual_dims = shape(arr);
- if(actual_dims[dimnum] != dimsize){
- std::ostringstream stream;
- stream << "Error: expected dimension number ";
- stream << dimnum << " to be length " << dimsize;
- stream << ", but found length " << actual_dims[dimnum] << std::ends;
- PyErr_SetString(PyExc_RuntimeError, stream.str().c_str());
- throw_error_already_set();
- }
- return;
-}
-
-bool iscontiguous(numeric::array arr)
-{
- // return arr.iscontiguous();
- return PyArray_ISCONTIGUOUS(arr.ptr());
-}
-
-void check_contiguous(numeric::array arr)
-{
- if (!iscontiguous(arr)) {
- PyErr_SetString(PyExc_RuntimeError, "expected a contiguous array");
- throw_error_already_set();
- }
- return;
-}
-
-void* data(numeric::array arr){
- if(!PyArray_Check(arr.ptr())){
- PyErr_SetString(PyExc_ValueError, "expected a PyArrayObject");
- throw_error_already_set();
- }
- return PyArray_DATA(arr.ptr());
-}
-
-//Copy data into the array
-void copy_data(boost::python::numeric::array arr, char* new_data){
- char* arr_data = (char*) data(arr);
- int nbytes = PyArray_NBYTES(arr.ptr());
- for (int i = 0; i < nbytes; i++) {
- arr_data[i] = new_data[i];
- }
- return;
-}
-
-//Return a clone of this array
-numeric::array clone(numeric::array arr){
- object obj(handle<>(PyArray_NewCopy((PyArrayObject*)arr.ptr(),PyArray_CORDER)));
- return makeNum(obj);
-}
-
-
-//Return a clone of this array with a new type
-numeric::array astype(boost::python::numeric::array arr, PyArray_TYPES t){
- return (numeric::array) arr.astype(type2char(t));
-}
-
-std::vector<int> strides(numeric::array arr){
- std::vector<int> out_strides;
- if(!PyArray_Check(arr.ptr())){
- PyErr_SetString(PyExc_ValueError, "expected a PyArrayObject");
- throw_error_already_set();
- }
- npy_intp* strides_ptr = PyArray_STRIDES(arr.ptr());
- int the_rank = rank(arr);
- for (int i = 0; i < the_rank; i++){
- out_strides.push_back(*(strides_ptr + i));
- }
- return out_strides;
-}
-
-int refcount(numeric::array arr){
- return NPY_REFCOUNT(arr.ptr());
-}
-
-void check_PyArrayElementType(object newo){
- PyArray_TYPES theType=PyArray_TYPES(PyArray_TYPE(newo.ptr()));
- if(theType == PyArray_OBJECT){
- std::ostringstream stream;
- stream << "array elments have been cast to PyArray_OBJECT, "
- << "numhandle can only accept arrays with numerical elements"
- << std::ends;
- PyErr_SetString(PyExc_TypeError, stream.str().c_str());
- throw_error_already_set();
- }
- return;
-}
-
-std::string type2string(PyArray_TYPES t_type){
- return kindstrings[t_type];
-}
-
-char type2char(PyArray_TYPES t_type){
- return kindchars[t_type];
-}
-
-PyArray_TYPES char2type(char e_type){
- return kindtypes[e_type];
-}
-
-template <class T>
-inline std::string vector_str(const std::vector<T>& vec)
-{
- std::ostringstream stream;
- stream << "(" << vec[0];
-
- for(std::size_t i = 1; i < vec.size(); i++){
- stream << ", " << vec[i];
- }
- stream << ")";
- return stream.str();
-}
-
-inline void check_size_match(std::vector<int> dims, int n)
-{
- int total = std::accumulate(dims.begin(),dims.end(),1,std::multiplies<int>());
- if (total != n) {
- std::ostringstream stream;
- stream << "expected array size " << n
- << ", dimensions give array size " << total << std::ends;
- PyErr_SetString(PyExc_TypeError, stream.str().c_str());
- throw_error_already_set();
- }
- return;
-}
-
-} //namespace num_util
-
diff --git a/CEP/PyBDSM/src/c++/num_util/num_util.h b/CEP/PyBDSM/src/c++/num_util/num_util.h
deleted file mode 100644
index 72a9f48ca279f3c35f24dcbb5fbe1b820723b218..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/c++/num_util/num_util.h
+++ /dev/null
@@ -1,315 +0,0 @@
-#ifndef NUM_UTIL_H__
-#define NUM_UTIL_H__
-
-// Copyright 2006 Phil Austin (http://www.eos.ubc.ca/personal/paustin)
-// Distributed under the Boost Software License, Version 1.0. (See
-// accompanying file LICENSE_1_0.txt or copy at
-// http://www.boost.org/LICENSE_1_0.txt)
-
-//
-// $Id$
-//
-
-#include <boost/python.hpp>
-#include <numpy/arrayobject.h>
-#include <iostream>
-#include <sstream>
-#include <vector>
-#include <numeric>
-#include <map>
-#include <complex>
-
-
-
-namespace num_util{
- //!
- /**
- *A free function that extracts a PyArrayObject from any sequential PyObject.
- *@param x a sequential PyObject wrapped in a Boost/Python 'object'.
- *@return a PyArrayObject wrapped in Boost/Python numeric array.
- */
- boost::python::numeric::array makeNum(boost::python::object x);
-
- /**
- *Creates an one-dimensional numpy array of length n and numpy type t.
- * The elements of the array are initialized to zero.
- *@param n an integer representing the length of the array.
- *@param t elements' numpy type. Default is double.
- *@return a numeric array of size n with elements initialized to zero.
- */
- boost::python::numeric::array makeNum(int n, PyArray_TYPES t);
-
- /**
- *Creates a n-dimensional numpy array with dimensions dimens and numpy
- *type t. The elements of the array are initialized to zero.
- *@param dimens a vector of interger specifies the dimensions of the array.
- *@param t elements' numpy type. Default is double.
- *@return a numeric array of shape dimens with elements initialized to zero.
- */
- boost::python::numeric::array makeNum(std::vector<int> dimens,
- PyArray_TYPES t);
-
- /**
- *Function template returns PyArray_Type for C++ type
- *See num_util.cpp for specializations
- *@param T C++ type
- *@return numpy type enum
- */
-
- template<typename T> PyArray_TYPES getEnum(void)
- {
- PyErr_SetString(PyExc_ValueError, "no mapping available for this type");
- boost::python::throw_error_already_set();
- return PyArray_VOID;
- }
-
- /**
- *Function template creates a one-dimensional numpy array of length n containing
- *a copy of data at data*. See num_util.cpp::getEnum<T>() for list of specializations
- *@param T C type of data
- *@param T* data pointer to start of data
- *@param n an integer indicates the size of the array.
- *@return a numpy array of size n with elements initialized to data.
- */
-
- template <typename T> boost::python::numeric::array makeNum(T* data, int n = 0){
- boost::python::object obj(boost::python::handle<>(PyArray_FromDims(1, &n, getEnum<T>())));
- void *arr_data = PyArray_DATA((PyArrayObject*) obj.ptr());
- memcpy(arr_data, data, PyArray_ITEMSIZE((PyArrayObject*) obj.ptr()) * n); // copies the input data to
- return boost::python::extract<boost::python::numeric::array>(obj);
- }
-
- /**
- *Function template creates an n-dimensional numpy array with dimensions dimens containing
- *a copy of values starting at data. See num_util.cpp::getEnum<T>() for list of specializations
- *@param T C type of data
- *@param T* data pointer to start of data
- *@param n an integer indicates the size of the array.
- *@return a numpy array of size n with elements initialized to data.
- */
-
-
- template <typename T> boost::python::numeric::array makeNum(T * data, std::vector<int> dims){
- int total = std::accumulate(dims.begin(),dims.end(),1,std::multiplies<int>());
- boost::python::object obj(boost::python::handle<>(PyArray_FromDims(dims.size(),&dims[0], getEnum<T>())));
- void *arr_data = PyArray_DATA((PyArrayObject*) obj.ptr());
- memcpy(arr_data, data, PyArray_ITEMSIZE((PyArrayObject*) obj.ptr()) * total);
- return boost::python::extract<boost::python::numeric::array>(obj);
- }
-
-
- /**
- *Creates a numpy array from a numpy array, referencing the data.
- *@param arr a Boost/Python numeric array.
- *@return a numeric array referencing the input array.
- */
- boost::python::numeric::array makeNum(const
- boost::python::numeric::array& arr);
-
- /**
- *A free function that retrieves the numpy type of a numpy array.
- *@param arr a Boost/Python numeric array.
- *@return the numpy type of the array's elements
- */
- PyArray_TYPES type(boost::python::numeric::array arr);
-
- /**
- *Throws an exception if the actual array type is not equal to the expected
- *type.
- *@param arr a Boost/Python numeric array.
- *@param expected_type an expected numpy type.
- *@return -----
- */
- void check_type(boost::python::numeric::array arr,
- PyArray_TYPES expected_type);
-
- /**
- *A free function that retrieves the number of dimensions of a numpy array.
- *@param arr a Boost/Python numeric array.
- *@return an integer that indicates the rank of an array.
- */
- int rank(boost::python::numeric::array arr);
-
- /**
- *Throws an exception if the actual rank is not equal to the expected rank.
- *@param arr a Boost/Python numeric array.
- *@param expected_rank an expected rank of the numeric array.
- *@return -----
- */
- void check_rank(boost::python::numeric::array arr, int expected_rank);
-
- /**
- *A free function that returns the total size of the array.
- *@param arr a Boost/Python numeric array.
- *@return an integer that indicates the total size of the array.
- */
- int size(boost::python::numeric::array arr);
-
- /**
- *Throw an exception if the actual total size of the array is not equal to
- *the expected size.
- *@param arr a Boost/Python numeric array.
- *@param expected_size the expected size of an array.
- *@return -----
- */
- void check_size(boost::python::numeric::array arr, int expected_size);
-
- /**
- *Returns the dimensions in a vector.
- *@param arr a Boost/Python numeric array.
- *@return a vector with integer values that indicates the shape of the array.
- */
- std::vector<int> shape(boost::python::numeric::array arr);
-
- /**
- *Returns the size of a specific dimension.
- *@param arr a Boost/Python numeric array.
- *@param dimnum an integer that identifies the dimension to retrieve.
- *@return the size of the requested dimension.
- */
- int get_dim(boost::python::numeric::array arr, int dimnum);
-
- /**
- *Throws an exception if the actual dimensions of the array are not equal to
- *the expected dimensions.
- *@param arr a Boost/Python numeric array.
- *@param expected_dims an integer vector of expected dimension.
- *@return -----
- */
- void check_shape(boost::python::numeric::array arr,
- std::vector<int> expected_dims);
-
- /**
- *Throws an exception if a specific dimension from a numpy array does not
- *match the expected size.
- *@param arr a Boost/Python numeric array.
- *@param dimnum an integer that specifies which dimension of 'arr' to check.
- *@param dimsize an expected size of the specified dimension.
- *@return -----
- */
- void check_dim(boost::python::numeric::array arr, int dimnum, int dimsize);
-
- /**
- *Returns true if the array is contiguous.
- *@param arr a Boost/Python numeric array.
- *@return true if the array is contiguous, false otherwise.
- */
- bool iscontiguous(boost::python::numeric::array arr);
-
- /**
- *Throws an exception if the array is not contiguous.
- *@param arr a Boost/Python numeric array.
- *@return -----
- */
- void check_contiguous(boost::python::numeric::array arr);
-
- /**
- *Returns a pointer to the data in the array.
- *@param arr a Boost/Python numeric array.
- *@return a char pointer pointing at the first element of the array.
- */
- void* data(boost::python::numeric::array arr);
-
- /**
- *Copies data into the array.
- *@param arr a Boost/Python numeric array.
- *@param new_data a char pointer referencing the new data.
- *@return -----
- */
- void copy_data(boost::python::numeric::array arr, char* new_data);
-
- /**
- *Returns a clone of this array.
- *@param arr a Boost/Python numeric array.
- *@return a replicate of the Boost/Python numeric array.
- */
- boost::python::numeric::array clone(boost::python::numeric::array arr);
-
- /**
- *Returns a clone of this array with a new type.
- *@param arr a Boost/Python numeric array.
- *@param t PyArray_TYPES of the output array.
- *@return a replicate of 'arr' with type set to 't'.
- */
- boost::python::numeric::array astype(boost::python::numeric::array arr,
- PyArray_TYPES t);
-
-
-/* *Returns the reference count of the array. */
-/* *@param arr a Boost/Python numeric array. */
-/* *@return the reference count of the array. */
-
- int refcount(boost::python::numeric::array arr);
-
- /**
- *Returns the strides array in a vector of integer.
- *@param arr a Boost/Python numeric array.
- *@return the strides of an array.
- */
- std::vector<int> strides(boost::python::numeric::array arr);
-
- /**
- *Throws an exception if the element of a numpy array is type cast to
- *PyArray_OBJECT.
- *@param newo a Boost/Python object.
- *@return -----
- */
- void check_PyArrayElementType(boost::python::object newo);
-
- /**
- *Mapping from a PyArray_TYPE to its corresponding name in string.
- */
- typedef std::map<PyArray_TYPES, std::string> KindStringMap;
-
- /**
- *Mapping from a PyArray_TYPE to its corresponding typeID in char.
- */
- typedef std::map<PyArray_TYPES, char> KindCharMap;
-
- /**
- *Mapping from a typeID to its corresponding PyArray_TYPE.
- */
- typedef std::map<char, PyArray_TYPES> KindTypeMap;
-
- /**
- *Converts a PyArray_TYPE to its name in string.
- *@param t_type a PyArray_TYPES.
- *@return the corresponding name in string.
- */
- std::string type2string(PyArray_TYPES t_type);
-
- /**
- *Converts a PyArray_TYPE to its single character typecode.
- *@param t_type a PyArray_TYPES.
- *@return the corresponding typecode in char.
- */
- char type2char(PyArray_TYPES t_type);
-
- /**
- *Coverts a single character typecode to its PyArray_TYPES.
- *@param e_type a PyArray_TYPES typecode in char.
- *@return its corresponding PyArray_TYPES.
- */
- PyArray_TYPES char2type(char e_type);
-
- /**
- *Constructs a string which contains a list of elements extracted from the
- *input vector.
- *@param vec a vector of any type.
- *@return a string that lists the elements from the input vector.
- */
- template <class T>
- inline std::string vector_str(const std::vector<T>& vec);
-
- /**
- *Throws an exception if the total size computed from a vector of integer
- *does not match with the expected size.
- *@param dims an integer vector of dimensions.
- *@param n an expected size.
- *@return -----
- */
- inline void check_size_match(std::vector<int> dims, int n);
-
-} // namespace num_util
-
-#endif
diff --git a/CEP/PyBDSM/src/c++/stat.cc b/CEP/PyBDSM/src/c++/stat.cc
deleted file mode 100644
index 1220a250ed9a4ec02696ec3afc9c8d27c36c2f21..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/c++/stat.cc
+++ /dev/null
@@ -1,268 +0,0 @@
-/*!
- \file stat.cc
-
- \ingroup pybdsm
-
- \author Oleksandr Usov
-*/
-
-#define PY_ARRAY_UNIQUE_SYMBOL PyArrayHandle
-#define NO_IMPORT_ARRAY
-
-#include "boost_python.h"
-#include "stat.h"
-
-#include <num_util/num_util.h>
-#include <cfloat>
-
-using namespace boost::python;
-using namespace std;
-namespace n = num_util;
-
-// check if obj is numpy scalar object and it's value is val
-static bool
-npybool_check(PyObject *obj, bool val)
-{
- npy_bool tmp;
-
- if (PyArray_IsScalar(obj, Bool)) {
- PyArray_ScalarAsCtype(obj, &tmp);
- return tmp == val;
- }
-
- return false;
-}
-
-static inline
-bool _nonzero(const unsigned &n, const int *v)
-{
- bool res = true;
- for (unsigned i = 0; i < n; ++i)
- res = res && v[i];
-
- return res;
-}
-
-// calculate clipped mean/rms for array
-template<class T>
-static pair<double, double>
-_stat_nd(numeric::array arr, double _mean, double _threshold)
-{
- // ensure contiguous memory access by appropriately sorting indices
- vector<int> shape = n::shape(arr);
- vector<int> strides = n::strides(arr);
- const unsigned Nd = shape.size();
-
- for (unsigned i = 0; i < Nd; ++i)
- strides[i] /= sizeof(T);
-
- for (unsigned i = 0; i < Nd; ++i)
- for (unsigned j = i; j < Nd; ++j)
- if (strides[i] > strides[j]) {
- swap(shape[i], shape[j]);
- swap(strides[i], strides[j]);
- }
-
- // accumulators
- double sum = 0;
- double sumsq = 0;
- int N = n::size(arr);
-
- // data access machinery: we need adv to simplify jumping from
- // one line to the next one (offset from the end of previous line)
- T *data = (T *)n::data(arr);
- int idx[Nd];
- int adv[Nd];
-
- for (unsigned i = 0; i < Nd; ++i) {
- idx[i] = shape[i];
- adv[i] = strides[i];
- if (i)
- adv[i] -= shape[i-1]*strides[i-1];
- }
-
- while (_nonzero(Nd, idx)) {
- // inner loop over fastest index
- int _cnt = idx[0];
- int _adv = adv[0];
- while(_cnt) {
- --_cnt;
- double v = *data;
- if (fabs(v - _mean) > _threshold)
- --N;
- else {
- sum += v;
- sumsq += v*v;
- }
- data += _adv;
- }
- idx[0] = _cnt;
-
- // now a bit of magic to handle all other indices
- for (unsigned i = 1; i < Nd; ++i) {
- idx[i-1] = shape[i-1];
- data += adv[i];
- --idx[i];
- if (idx[i] != 0)
- break;
- }
- }
-
- double mean = sum/N;
- double dev = sqrt((sumsq + N*mean*mean - 2*mean*sum)/(N-1));
-
- return make_pair(mean, dev);
-}
-
-
-// calculate clipped mean/rms for masked array
-template<class T>
-static pair<double, double>
-_stat_nd_m(numeric::array arr, numeric::array mask, double _mean, double _threshold)
-{
- // ensure contiguous memory access by appropriately sorting indices
- vector<int> shape = n::shape(arr);
- vector<int> strides = n::strides(arr);
- vector<int> mstrides = n::strides(mask);
- const unsigned Nd = shape.size();
-
- for (unsigned i = 0; i < Nd; ++i) {
- strides[i] /= sizeof(T);
- mstrides[i] /= sizeof(npy_bool);
- }
-
- for (unsigned i = 0; i < Nd; ++i)
- for (unsigned j = i; j < Nd; ++j)
- if (strides[i] > strides[j]) {
- swap(shape[i], shape[j]);
- swap(strides[i], strides[j]);
- swap(mstrides[i], mstrides[j]);
- }
-
- // accumulators
- double sum = 0;
- double sumsq = 0;
- int N = n::size(arr);
-
- // data access machinery: we need adv to simplify jumping from
- // one line to the next one (offset from the end of previous line)
- T *data = (T *)n::data(arr);
- npy_bool *mdata = (npy_bool *)n::data(mask);
- int idx[Nd];
- int adv[Nd];
- int madv[Nd];
-
- for (unsigned i = 0; i < Nd; ++i) {
- idx[i] = shape[i];
- adv[i] = strides[i];
- madv[i] = mstrides[i];
- if (i) {
- adv[i] -= shape[i-1]*strides[i-1];
- madv[i] -= shape[i-1]*mstrides[i-1];
- }
- }
-
- while (_nonzero(Nd, idx)) {
- // inner loop over fastest index
- int _cnt = idx[0];
- int _adv = adv[0];
- int _madv = madv[0];
- while(_cnt) {
- --_cnt;
- double v = *data;
- if (*mdata || fabs(v - _mean) > _threshold)
- --N;
- else {
- sum += v;
- sumsq += v*v;
- }
- data += _adv;
- mdata += _madv;
- }
- idx[0] = _cnt;
-
- // now a bit of magic to handle all other indices
- for (unsigned i = 1; i < Nd; ++i) {
- idx[i-1] = shape[i-1];
- data += adv[i];
- mdata += madv[i];
- --idx[i];
- if (idx[i] != 0)
- break;
- }
- }
-
- double mean = sum/N;
- double dev = sqrt((sumsq + N*mean*mean - 2*mean*sum)/(N-1));
-
- return make_pair(mean, dev);
-}
-
-// dispatch calculation to the correct _stat_FOO function
-template<class T>
-static pair<double, double>
-_stat(numeric::array arr, object mask, double _mean, double _threshold)
-{
- if (mask.ptr() == Py_None || mask.ptr() == Py_False
- || npybool_check(mask.ptr(), false))
- return _stat_nd<T>(arr, _mean, _threshold);
- else
- return _stat_nd_m<T>(arr, extract<numeric::array>(mask), _mean, _threshold);
-}
-
-template<class T>
-static object _bstat(numeric::array arr, object mask, double kappa)
-{
- #include <iostream>
- const int max_iter = 200;
- vector<double> mean, dev;
- pair<double, double> res(0, DBL_MAX);
- int cnt = 0;
-
- do {
- ++cnt;
- mean.push_back(res.first);
- dev.push_back(res.second);
- res = _stat<T>(arr, mask, mean.back(), kappa*dev.back());
- } while (res.second != dev.back() && cnt < max_iter);
-
- /* py_assert(res.second == dev.back(),
- PyExc_RuntimeError, "clipped rRMS calculation does not converge"); */
-
- return boost::python::make_tuple(mean[1], dev[1], mean.back(), dev.back(), cnt);
-}
-
-object bstat(numeric::array arr, object mask, double kappa)
-{
- NPY_TYPES type = n::type(arr);
-
- if (PyArray_ISBYTESWAPPED(arr.ptr()))
- goto fail;
-
- if (mask.ptr() != Py_None && mask.ptr() != Py_False
- && !npybool_check(mask.ptr(), false)) {
- numeric::array amask = extract<numeric::array>(mask);
-
- n::check_type(amask, NPY_BOOL);
- int rank = n::rank(arr);
- n::check_rank(amask, rank);
- n::check_size(amask, n::size(arr));
- // this is pointless on pc, but might matter somewhere else
- if (PyArray_ISBYTESWAPPED(amask.ptr()))
- goto fail;
- }
-
- switch (type) {
- case NPY_DOUBLE:
- return _bstat<npy_double>(arr, mask, kappa);
- case NPY_FLOAT:
- return _bstat<npy_float>(arr, mask, kappa);
- default:
- goto fail;
- }
-
- fail:
- py_assert(false,
- PyExc_RuntimeError, "bstat dispatch failed: not implemented for this datatype/layout");
- return boost::python::tuple(); // this is fake return-statement to silence the compiler
-}
diff --git a/CEP/PyBDSM/src/c++/stat.h b/CEP/PyBDSM/src/c++/stat.h
deleted file mode 100644
index 86c8f5e0cb0d392facf801eed86e7e9129df4170..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/c++/stat.h
+++ /dev/null
@@ -1,20 +0,0 @@
-#ifndef _CBDSM_STAT_H_INCLUDED_
-#define _CBDSM_STAT_H_INCLUDED_
-
-#include <boost/python.hpp>
-
-/*!
- \file stat.h
-
- \ingroup pybdsm
-
- \author Oleksandr Usov
-
- Clipped RMS and mean value calculation for numpy array.
-*/
-
-boost::python::object bstat (boost::python::numeric::array arr,
- boost::python::object mask,
- double kappa);
-
-#endif // _CBDSM_STAT_H_INCLUDED_
diff --git a/CEP/PyBDSM/src/fortran/CMakeLists.txt b/CEP/PyBDSM/src/fortran/CMakeLists.txt
deleted file mode 100644
index 9e6b513b78eafb518b30298b8a970500ee23a4c6..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/fortran/CMakeLists.txt
+++ /dev/null
@@ -1,7 +0,0 @@
-# $Id$
-
-add_f2py_module(_pytesselate
- pytess_simple.f
- pytess_roundness.f
- DESTINATION ${PYTHON_INSTALL_DIR}/lofar/bdsm)
-
diff --git a/CEP/PyBDSM/src/fortran/Makefile b/CEP/PyBDSM/src/fortran/Makefile
deleted file mode 100644
index 174584edcb25009befb54cbb66a80c5847af2c15..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/fortran/Makefile
+++ /dev/null
@@ -1,55 +0,0 @@
-# All the routines which are needed for libraries for PyBDSM are compiled here
-# using gnu95, f2py and suitable flags depending on os. Include files are in ../includes
-# $(FC) -c *.f -o *.o
-
-DIR=../../fBDSM
-CFLAGS = -I$(DIR)/includes
-ODIR=./
-LIBDIR=../../fBDSM/libs
-IODIR=../../fBDSM/io
-MDIR=../../fBDSM/wout_pgplot
-
-ifeq ($(shell uname -m), x86_64)
- FC=gfortran -fPIC -fno-second-underscore $(CFLAGS)
-else # ! i686
- FC=/usr/bin/g77 -g -fno-second-underscore -fbounds-check $(CFLAGS)
-endif
-
-ifeq ($(shell uname -s), Darwin)
- FC=gfortran -fbounds-check $(CFLAGS)
-endif
-
-OBJ1 = iland_mat2list.o writearray.o gaul2gaulbin.o writefitshead.o sub_prog.o \
- readarray.o get_keyword.o check.o
-
-OBJ1_f = iland_mat2list.f writearray.f gaul2gaulbin.f writefitshead.f
-
-all: _pytesselate.so _py2fbdsm.so
-
-LIBS=$(LIBDIR)/libfbdsm_woutpg.a
-
-_pytesselate.pyf :
- f2py2.5 pytess_simple.f pytess_roundness.f -m _pytesselate -h _pytesselate.pyf
-
-_pytesselate.so: _pytesselate.pyf pytess_simple.o pytess_roundness.o
- f2py2.5 --fcompiler=gnu95 -c _pytesselate.pyf pytess_simple.o pytess_roundness.o dummy.f
-
-_py2fbdsm.pyf :
- cp $(IODIR)/readarray.f $(IODIR)/writearray.f $(IODIR)/writefitshead.f ./
- cp $(MDIR)/check.f $(MDIR)/get_keyword.f $(MDIR)/iland_mat2list.f $(MDIR)/sub_prog.f ./
- f2py2.5 $(OBJ1_f) -m _py2fbdsm -h _py2fbdsm.pyf
-
-_py2fbdsm.so: _py2fbdsm.pyf $(OBJ1)
- f2py2.5 --fcompiler=gnu95 -c _py2fbdsm.pyf $(OBJ1) $(LIBS) dummy.f
-
-
-%.o: %.f
- $(FC) -c $< -o $@
-
-clean:
- rm -fr *.o
-
-cleanall:
- rm -fr *.o *.so *.pyf
-
-
diff --git a/CEP/PyBDSM/src/fortran/constants.inc b/CEP/PyBDSM/src/fortran/constants.inc
deleted file mode 100644
index 110b0798460ccc853e29c5063012998ed4ee84b1..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/fortran/constants.inc
+++ /dev/null
@@ -1,12 +0,0 @@
-c! physical constants
-
- real*8 c,pi,rad,fwsig,bolt,sq2
-
- parameter (pi=3.14159265358979d0)
- parameter (fwsig=2.35482d0)
- parameter (rad=180.d0/pi)
- parameter (c=2.99792458d8)
- parameter (bolt=1.3806505d-23)
- parameter (sq2=1.41421356237310d0)
-
-
diff --git a/CEP/PyBDSM/src/fortran/gaul2gaulbin.f b/CEP/PyBDSM/src/fortran/gaul2gaulbin.f
deleted file mode 100644
index 2aced60e713c0c6556144ad823bbd95b06bcc83e..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/fortran/gaul2gaulbin.f
+++ /dev/null
@@ -1,40 +0,0 @@
-
- subroutine gaul2gaulbin(fname)
- implicit none
- character fname*500,word*10,f2*500
- integer gaulid,islid,flag,blc1,blc2,trc1,trc2,srcid,nchar
- real*8 tot,dtot,peak,epeak,ra,era,dec,edec,xpix,expix,ypix
- real*8 eypix,bmaj,ebmaj,bmin,ebmin,bpa,ebpa,dbmaj,edbmaj,dbmin
- real*8 edbmin,dbpa,edbpa,sstd,sav,rstd,rav,chisq,q,dumr1,dumr2
- real*8 dumr3,dumr4,dumr5,dumr6
-
-cf2py fname
-
- f2 = fname(1:nchar(fname))//'.bin'
- open(unit=21, file=fname)
- open(unit=22, file=f2, form='unformatted')
- word = ''
-
- do while (word.ne.'fmt')
- read (21,*) word
- end do
-200 read (21,*,END=100) gaulid,islid,flag,tot,dtot,peak,epeak,ra,
- / era,dec,edec,xpix,expix,ypix,eypix,bmaj,ebmaj,bmin,ebmin,bpa,
- / ebpa,dbmaj,edbmaj,dbmin,edbmin,dbpa,edbpa,sstd,sav,rstd,
- / rav,chisq,q,srcid,blc1,blc2,trc1,trc2,dumr1,dumr2,
- / dumr3,dumr4,dumr5,dumr6
- write (22) gaulid,islid,flag,tot,dtot,peak,epeak,ra,
- / era,dec,edec,xpix,expix,ypix,eypix,bmaj,ebmaj,bmin,ebmin,bpa,
- / ebpa,dbmaj,edbmaj,dbmin,edbmin,dbpa,edbpa,sstd,sav,rstd,
- / rav,chisq,q,srcid,blc1,blc2,trc1,trc2,dumr1,dumr2,
- / dumr3,dumr4,dumr5,dumr6
- goto 200
-
-100 close(21)
- close(22)
-
- return
- end
-
-
-
diff --git a/CEP/PyBDSM/src/fortran/pytess_roundness.f b/CEP/PyBDSM/src/fortran/pytess_roundness.f
deleted file mode 100755
index 135c96f99bc1468f6cd6cf2a8d45bed475bde208..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/fortran/pytess_roundness.f
+++ /dev/null
@@ -1,192 +0,0 @@
-c! roundness modified for python
-
- subroutine pytess_roundness(n,m,ngens,xgens,ygens,
- / snrgens,eps,code,volrank)
- implicit none
- integer n,m,ngens,i,areavec(ngens)
- integer roundfacold(ngens),niter
- real*8 volrank(n,m),xgens(ngens),ygens(ngens),snrgens(ngens)
- real*8 eps,roundfac(ngens)
- real*8 roundpix(ngens),x(ngens),y(ngens)
- character code*1
-
-cf2py intent(in) n,m,ngens,xgens,ygens,snrgens,code,eps
-cf2py intent(out) volrank
-
- do i=1,ngens
- roundfac(i)=2.d0/3.d0
- x(i)=0.d0
- y(i)=0.d0
- roundpix(i)=0.d0
- areavec(i)=1
- end do
-
- niter=0
-333 continue
- call tess_bin_complicated(n,m,ngens,xgens,ygens,
- / snrgens,volrank,roundpix,x,y,niter,code,eps)
- niter=niter+1
- do i=1,ngens
- roundfacold(i)=roundfac(i)
- end do
- call tile_roundness(volrank,n,m,ngens,xgens,
- / ygens,roundfac,roundpix,x,y)
- call calc_area_tess(volrank,n,m,ngens,areavec)
- if (niter.eq.1.or.(niter.lt.2)) then
- goto 333
- end if
- i=int(snrgens(1))
-
- return
- end
-
-c! same as simple but weights are fn of each pixel now rather than bin
-c! if code='s' then each pt belongs to one bin. If not then fuzzy tesselation
- subroutine tess_bin_complicated(n,m,ngens,xgens,ygens,
- / snrgens,volrank,roundpix,x,y,niter,code,eps)
- implicit none
- integer n,m,ngens,i,j,k,minind(n,m),l,niter
- real*8 volrank(n,m),xgens(ngens),ygens(ngens),dist,dist1
- real*8 dumr,snrgens(ngens),eps,roundpix(ngens)
- real*8 x(ngens),y(ngens),dumr1,wts
- character code*1
-
- do j=1,m
- do i=1,n
- volrank(i,j)=0.d0
- dumr=1.d90
- do k=1,ngens
- if (niter.eq.0) then
- wts=1.d0
- else
- dumr1=sqrt((x(k)-i)*(x(k)-i)+(y(k)-j)*(y(k)-j))
- dumr1=dumr1*roundpix(k)
- wts=1.d0/dumr1
- end if
- dist=sqrt((i-xgens(k))*(i-xgens(k))+
- / (j-ygens(k))*(j-ygens(k)))/wts
- if (dist.lt.dumr) then
- dumr=dist
- minind(i,j)=k
- end if ! minind(i,j) is number of nearest generator
- end do
- end do
- end do
-c!
- if (code.eq.'s') then
- do j=1,m
- do i=1,n
- volrank(i,j)=1.d0*minind(i,j)
- end do
- end do
- else
- do j=1,m
- do i=1,n
- do k=1,ngens
- l=minind(i,j)
- if (k.ne.l) then
- if (niter.eq.0) then
- wts=1.d0
- else
- dumr1=sqrt((x(k)-i)*(x(k)-i)+(y(k)-j)*(y(k)-j))
- dumr1=dumr1*roundpix(k)
- wts=1.d0/dumr1
- end if
- dist=sqrt((i-xgens(k))*(i-xgens(k))+
- / (j-ygens(k))*(j-ygens(k)))/wts
- dist1=sqrt((i-xgens(minind(i,j)))*(i-xgens(minind(i,j)))+
- / (j-ygens(minind(i,j)))*(j-ygens(minind(i,j))))/wts
- if (dist.le.(1.d0+eps)*dist1)
- / volrank(i,j)=volrank(i,j)+1.d0*(minind(i,j)+k)
- end if
- end do
- end do
- end do
- end if
- i=int(snrgens(1))
-
- return
- end
-
- subroutine calc_area_tess(volrank,n,m,x,areavec)
- implicit none
- integer n,m,x,areavec(x),i,j
- real*8 volrank(n,m)
-
- do i=1,x
- areavec(i)=0
- end do
- do j=1,m
- do i=1,n
- areavec(int(volrank(i,j)))=areavec(int(volrank(i,j)))+1
- end do
- end do
-
- return
- end
-c!
-c!
-c! check roundness.
-c! modify to make roundpix not include dist so that u dont have to
-c! define huge 3d arrays which crash.
- subroutine tile_roundness(volrank,n,m,ngens,xgens,
- / ygens,roundfac,roundpix,x,y)
- implicit none
- include "constants.inc"
- integer n,m,i,j,ngens,ind,npix(ngens),k
- real*8 volrank(n,m),area(ngens),sumrad(ngens),dist
- real*8 xgens(ngens),ygens(ngens),roundfac(ngens)
- real*8 x(ngens),y(ngens),roundpix(ngens)
-
- do i=1,ngens
- area(i)=0.d0
- sumrad(i)=0.d0
- npix(i)=0
- x(i)=0.d0
- y(i)=0.d0
- end do
-
- do j=1,m
- do i=1,n
- ind=int(volrank(i,j))
- x(ind)=x(ind)+i
- y(ind)=y(ind)+j
- npix(ind)=npix(ind)+1
- end do
- end do
- do i=1,ngens
- x(i)=x(i)/npix(i)
- y(i)=y(i)/npix(i)
- end do
-
- do i=1,ngens
- npix(i)=0
- end do
- do j=1,m
- do i=1,n
- ind=int(volrank(i,j))
- dist=sqrt((xgens(ind)-i)*(xgens(ind)-i)+
- / (ygens(ind)-j)*(ygens(ind)-j))
- dist=sqrt((x(ind)-i)*(x(ind)-i)+
- / (y(ind)-j)*(y(ind)-j))
- area(ind)=area(ind)+1
- sumrad(ind)=sumrad(ind)+dist
- npix(ind)=npix(ind)+1
- end do
- end do
-
- do i=1,ngens
- roundfac(i)=(sumrad(i)/npix(i))/(sqrt(area(i)/pi))
- end do
-
- do k=1,ngens
- roundpix(k)=1.d0/(sumrad(k)/npix(k))
- end do
-
- return
- end
-
-
-
-
-
diff --git a/CEP/PyBDSM/src/fortran/pytess_simple.f b/CEP/PyBDSM/src/fortran/pytess_simple.f
deleted file mode 100755
index 2622141f87dde31f4c2278559b57de7d11d399da..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/fortran/pytess_simple.f
+++ /dev/null
@@ -1,59 +0,0 @@
-c! if code='s' then each pt belongs to one bin. If not then fuzzy tesselation
-c! cut out just this part for pythn cos it takes forever to do this part
-c! in python
-
- subroutine pytess_simple(n,m,ngens,xgens,ygens,
- / snrgens,wts,eps,code,volrank)
- implicit none
- integer n,m,ngens,i,j,k,minind(n,m),l
- real*8 volrank(n,m),xgens(ngens),ygens(ngens),dist
- real*8 dumr,snrgens(ngens),wts(ngens),eps,distmin
- character code*1
-
-cf2py intent(in) n,m,ngens,xgens,ygens,snrgens,wts,code,eps
-cf2py intent(out) volrank
-
- do j=1,m
- do i=1,n
- volrank(i,j)=0.d0
- dumr=1.d90
- do k=1,ngens
- dist=sqrt((i-xgens(k))*(i-xgens(k))+
- / (j-ygens(k))*(j-ygens(k)))/wts(k)
- if (dist.lt.dumr) then
- dumr=dist
- minind(i,j)=k
- end if ! minind(i,j) is number of nearest generator
- end do
- end do
- end do
-c!
- if (code.eq.'s') then
- do j=1,m
- do i=1,n
- volrank(i,j)=1.d0*minind(i,j)
- end do
- end do
- else
- do j=1,m
- do i=1,n
- do k=1,ngens
- l=minind(i,j)
- if (k.ne.l) then
- dist=sqrt((i-xgens(k))*(i-xgens(k))+
- / (j-ygens(k))*(j-ygens(k)))/wts(k)
- distmin=sqrt((i-xgens(l))*(i-xgens(l))+
- / (j-ygens(l))*(j-ygens(l)))/wts(l)
- if (dist.le.(1.d0+eps)*distmin)
- / volrank(i,j)=volrank(i,j)+1.d0*(l+k)
- end if
- end do
- end do
- end do
- end if
-
- i = int(snrgens(1)) ! so there is no warning while compiling
-
- return
- end
-c!
diff --git a/CEP/PyBDSM/src/minpack/CMakeLists.txt b/CEP/PyBDSM/src/minpack/CMakeLists.txt
deleted file mode 100644
index 631e95994e4cd91c8e882f0afbb556ec5be0c87d..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/minpack/CMakeLists.txt
+++ /dev/null
@@ -1,6 +0,0 @@
-# $Id$
-
-# Always use -fPIC to enable linking with shared libs.
-add_library(minpack STATIC lmder.f lmpar.f qrfac.f qrsolv.f enorm.f dpmpar.f)
-set_target_properties(minpack PROPERTIES COMPILE_FLAGS "-fPIC")
-
diff --git a/CEP/PyBDSM/src/minpack/CMakeLists.txt_minpack b/CEP/PyBDSM/src/minpack/CMakeLists.txt_minpack
deleted file mode 100644
index 02cac489aca2d5f858700ec7b2a821d96ea3b2a7..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/minpack/CMakeLists.txt_minpack
+++ /dev/null
@@ -1,13 +0,0 @@
-## ----------------------------------------------------------------------
-## $Id$
-## ----------------------------------------------------------------------
-
-enable_language(Fortran)
-
-set (minpack_sources
- lmder.f lmpar.f qrfac.f qrsolv.f enorm.f dpmpar.f)
-
-add_definitions (-fPIC)
-
-add_library (minpack STATIC ${minpack_sources})
-
diff --git a/CEP/PyBDSM/src/minpack/DISCLAIMER b/CEP/PyBDSM/src/minpack/DISCLAIMER
deleted file mode 100644
index 11d8a9a6c340f8ae340b3f009de8509fcea775fd..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/minpack/DISCLAIMER
+++ /dev/null
@@ -1,52 +0,0 @@
-Minpack Copyright Notice (1999) University of Chicago. All rights reserved
-
-Redistribution and use in source and binary forms, with or
-without modification, are permitted provided that the
-following conditions are met:
-
-1. Redistributions of source code must retain the above
-copyright notice, this list of conditions and the following
-disclaimer.
-
-2. Redistributions in binary form must reproduce the above
-copyright notice, this list of conditions and the following
-disclaimer in the documentation and/or other materials
-provided with the distribution.
-
-3. The end-user documentation included with the
-redistribution, if any, must include the following
-acknowledgment:
-
- "This product includes software developed by the
- University of Chicago, as Operator of Argonne National
- Laboratory.
-
-Alternately, this acknowledgment may appear in the software
-itself, if and wherever such third-party acknowledgments
-normally appear.
-
-4. WARRANTY DISCLAIMER. THE SOFTWARE IS SUPPLIED "AS IS"
-WITHOUT WARRANTY OF ANY KIND. THE COPYRIGHT HOLDER, THE
-UNITED STATES, THE UNITED STATES DEPARTMENT OF ENERGY, AND
-THEIR EMPLOYEES: (1) DISCLAIM ANY WARRANTIES, EXPRESS OR
-IMPLIED, INCLUDING BUT NOT LIMITED TO ANY IMPLIED WARRANTIES
-OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE, TITLE
-OR NON-INFRINGEMENT, (2) DO NOT ASSUME ANY LEGAL LIABILITY
-OR RESPONSIBILITY FOR THE ACCURACY, COMPLETENESS, OR
-USEFULNESS OF THE SOFTWARE, (3) DO NOT REPRESENT THAT USE OF
-THE SOFTWARE WOULD NOT INFRINGE PRIVATELY OWNED RIGHTS, (4)
-DO NOT WARRANT THAT THE SOFTWARE WILL FUNCTION
-UNINTERRUPTED, THAT IT IS ERROR-FREE OR THAT ANY ERRORS WILL
-BE CORRECTED.
-
-5. LIMITATION OF LIABILITY. IN NO EVENT WILL THE COPYRIGHT
-HOLDER, THE UNITED STATES, THE UNITED STATES DEPARTMENT OF
-ENERGY, OR THEIR EMPLOYEES: BE LIABLE FOR ANY INDIRECT,
-INCIDENTAL, CONSEQUENTIAL, SPECIAL OR PUNITIVE DAMAGES OF
-ANY KIND OR NATURE, INCLUDING BUT NOT LIMITED TO LOSS OF
-PROFITS OR LOSS OF DATA, FOR ANY REASON WHATSOEVER, WHETHER
-SUCH LIABILITY IS ASSERTED ON THE BASIS OF CONTRACT, TORT
-(INCLUDING NEGLIGENCE OR STRICT LIABILITY), OR OTHERWISE,
-EVEN IF ANY OF SAID PARTIES HAS BEEN WARNED OF THE
-POSSIBILITY OF SUCH LOSS OR DAMAGES.
-
diff --git a/CEP/PyBDSM/src/minpack/Makefile b/CEP/PyBDSM/src/minpack/Makefile
deleted file mode 100644
index fa2df723d95c03f3a19718eb574693531073ac12..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/minpack/Makefile
+++ /dev/null
@@ -1,218 +0,0 @@
-# CMAKE generated file: DO NOT EDIT!
-# Generated by "Unix Makefiles" Generator, CMake Version 2.8
-
-# Default target executed when no arguments are given to make.
-default_target: all
-.PHONY : default_target
-
-#=============================================================================
-# Special targets provided by cmake.
-
-# Disable implicit rules so canoncical targets will work.
-.SUFFIXES:
-
-# Remove some rules from gmake that .SUFFIXES does not remove.
-SUFFIXES =
-
-.SUFFIXES: .hpux_make_needs_suffix_list
-
-# Suppress display of executed commands.
-$(VERBOSE).SILENT:
-
-# A target that is always out of date.
-cmake_force:
-.PHONY : cmake_force
-
-#=============================================================================
-# Set environment variables for the build.
-
-# The shell in which to execute make rules.
-SHELL = /bin/sh
-
-# The CMake executable.
-CMAKE_COMMAND = "/Applications/CMake 2.8-0.app/Contents/bin/cmake"
-
-# The command to remove a file.
-RM = "/Applications/CMake 2.8-0.app/Contents/bin/cmake" -E remove -f
-
-# The program to use to edit the cache.
-CMAKE_EDIT_COMMAND = "/Applications/CMake 2.8-0.app/Contents/bin/ccmake"
-
-# The top-level source directory on which CMake was run.
-CMAKE_SOURCE_DIR = /Users/mohan/lofarsoft/src/pybdsm/implement
-
-# The top-level build directory on which CMake was run.
-CMAKE_BINARY_DIR = /Users/mohan/lofarsoft/src/pybdsm/implement
-
-#=============================================================================
-# Targets provided globally by CMake.
-
-# Special rule for the target edit_cache
-edit_cache:
- @$(CMAKE_COMMAND) -E cmake_echo_color --switch=$(COLOR) --cyan "Running CMake cache editor..."
- "/Applications/CMake 2.8-0.app/Contents/bin/ccmake" -H$(CMAKE_SOURCE_DIR) -B$(CMAKE_BINARY_DIR)
-.PHONY : edit_cache
-
-# Special rule for the target edit_cache
-edit_cache/fast: edit_cache
-.PHONY : edit_cache/fast
-
-# Special rule for the target install
-install: preinstall
- @$(CMAKE_COMMAND) -E cmake_echo_color --switch=$(COLOR) --cyan "Install the project..."
- "/Applications/CMake 2.8-0.app/Contents/bin/cmake" -P cmake_install.cmake
-.PHONY : install
-
-# Special rule for the target install
-install/fast: preinstall/fast
- @$(CMAKE_COMMAND) -E cmake_echo_color --switch=$(COLOR) --cyan "Install the project..."
- "/Applications/CMake 2.8-0.app/Contents/bin/cmake" -P cmake_install.cmake
-.PHONY : install/fast
-
-# Special rule for the target install/local
-install/local: preinstall
- @$(CMAKE_COMMAND) -E cmake_echo_color --switch=$(COLOR) --cyan "Installing only the local directory..."
- "/Applications/CMake 2.8-0.app/Contents/bin/cmake" -DCMAKE_INSTALL_LOCAL_ONLY=1 -P cmake_install.cmake
-.PHONY : install/local
-
-# Special rule for the target install/local
-install/local/fast: install/local
-.PHONY : install/local/fast
-
-# Special rule for the target install/strip
-install/strip: preinstall
- @$(CMAKE_COMMAND) -E cmake_echo_color --switch=$(COLOR) --cyan "Installing the project stripped..."
- "/Applications/CMake 2.8-0.app/Contents/bin/cmake" -DCMAKE_INSTALL_DO_STRIP=1 -P cmake_install.cmake
-.PHONY : install/strip
-
-# Special rule for the target install/strip
-install/strip/fast: install/strip
-.PHONY : install/strip/fast
-
-# Special rule for the target list_install_components
-list_install_components:
- @$(CMAKE_COMMAND) -E cmake_echo_color --switch=$(COLOR) --cyan "Available install components are: \"Unspecified\""
-.PHONY : list_install_components
-
-# Special rule for the target list_install_components
-list_install_components/fast: list_install_components
-.PHONY : list_install_components/fast
-
-# Special rule for the target rebuild_cache
-rebuild_cache:
- @$(CMAKE_COMMAND) -E cmake_echo_color --switch=$(COLOR) --cyan "Running CMake to regenerate build system..."
- "/Applications/CMake 2.8-0.app/Contents/bin/cmake" -H$(CMAKE_SOURCE_DIR) -B$(CMAKE_BINARY_DIR)
-.PHONY : rebuild_cache
-
-# Special rule for the target rebuild_cache
-rebuild_cache/fast: rebuild_cache
-.PHONY : rebuild_cache/fast
-
-# The main all target
-all: cmake_check_build_system
- cd /Users/mohan/lofarsoft/src/pybdsm/implement && $(CMAKE_COMMAND) -E cmake_progress_start /Users/mohan/lofarsoft/src/pybdsm/implement/CMakeFiles /Users/mohan/lofarsoft/src/pybdsm/implement/minpack/CMakeFiles/progress.marks
- cd /Users/mohan/lofarsoft/src/pybdsm/implement && $(MAKE) -f CMakeFiles/Makefile2 minpack/all
- $(CMAKE_COMMAND) -E cmake_progress_start /Users/mohan/lofarsoft/src/pybdsm/implement/CMakeFiles 0
-.PHONY : all
-
-# The main clean target
-clean:
- cd /Users/mohan/lofarsoft/src/pybdsm/implement && $(MAKE) -f CMakeFiles/Makefile2 minpack/clean
-.PHONY : clean
-
-# The main clean target
-clean/fast: clean
-.PHONY : clean/fast
-
-# Prepare targets for installation.
-preinstall: all
- cd /Users/mohan/lofarsoft/src/pybdsm/implement && $(MAKE) -f CMakeFiles/Makefile2 minpack/preinstall
-.PHONY : preinstall
-
-# Prepare targets for installation.
-preinstall/fast:
- cd /Users/mohan/lofarsoft/src/pybdsm/implement && $(MAKE) -f CMakeFiles/Makefile2 minpack/preinstall
-.PHONY : preinstall/fast
-
-# clear depends
-depend:
- cd /Users/mohan/lofarsoft/src/pybdsm/implement && $(CMAKE_COMMAND) -H$(CMAKE_SOURCE_DIR) -B$(CMAKE_BINARY_DIR) --check-build-system CMakeFiles/Makefile.cmake 1
-.PHONY : depend
-
-# Convenience name for target.
-minpack/CMakeFiles/minpack.dir/rule:
- cd /Users/mohan/lofarsoft/src/pybdsm/implement && $(MAKE) -f CMakeFiles/Makefile2 minpack/CMakeFiles/minpack.dir/rule
-.PHONY : minpack/CMakeFiles/minpack.dir/rule
-
-# Convenience name for target.
-minpack: minpack/CMakeFiles/minpack.dir/rule
-.PHONY : minpack
-
-# fast build rule for target.
-minpack/fast:
- cd /Users/mohan/lofarsoft/src/pybdsm/implement && $(MAKE) -f minpack/CMakeFiles/minpack.dir/build.make minpack/CMakeFiles/minpack.dir/build
-.PHONY : minpack/fast
-
-# target to build an object file
-dpmpar.o:
- cd /Users/mohan/lofarsoft/src/pybdsm/implement && $(MAKE) -f minpack/CMakeFiles/minpack.dir/build.make minpack/CMakeFiles/minpack.dir/dpmpar.o
-.PHONY : dpmpar.o
-
-# target to build an object file
-enorm.o:
- cd /Users/mohan/lofarsoft/src/pybdsm/implement && $(MAKE) -f minpack/CMakeFiles/minpack.dir/build.make minpack/CMakeFiles/minpack.dir/enorm.o
-.PHONY : enorm.o
-
-# target to build an object file
-lmder.o:
- cd /Users/mohan/lofarsoft/src/pybdsm/implement && $(MAKE) -f minpack/CMakeFiles/minpack.dir/build.make minpack/CMakeFiles/minpack.dir/lmder.o
-.PHONY : lmder.o
-
-# target to build an object file
-lmpar.o:
- cd /Users/mohan/lofarsoft/src/pybdsm/implement && $(MAKE) -f minpack/CMakeFiles/minpack.dir/build.make minpack/CMakeFiles/minpack.dir/lmpar.o
-.PHONY : lmpar.o
-
-# target to build an object file
-qrfac.o:
- cd /Users/mohan/lofarsoft/src/pybdsm/implement && $(MAKE) -f minpack/CMakeFiles/minpack.dir/build.make minpack/CMakeFiles/minpack.dir/qrfac.o
-.PHONY : qrfac.o
-
-# target to build an object file
-qrsolv.o:
- cd /Users/mohan/lofarsoft/src/pybdsm/implement && $(MAKE) -f minpack/CMakeFiles/minpack.dir/build.make minpack/CMakeFiles/minpack.dir/qrsolv.o
-.PHONY : qrsolv.o
-
-# Help Target
-help:
- @echo "The following are some of the valid targets for this Makefile:"
- @echo "... all (the default if no target is provided)"
- @echo "... clean"
- @echo "... depend"
- @echo "... edit_cache"
- @echo "... install"
- @echo "... install/local"
- @echo "... install/strip"
- @echo "... list_install_components"
- @echo "... minpack"
- @echo "... rebuild_cache"
- @echo "... dpmpar.o"
- @echo "... enorm.o"
- @echo "... lmder.o"
- @echo "... lmpar.o"
- @echo "... qrfac.o"
- @echo "... qrsolv.o"
-.PHONY : help
-
-
-
-#=============================================================================
-# Special targets to cleanup operation of make.
-
-# Special rule to run CMake to check the build system integrity.
-# No rule that depends on this can have commands that come from listfiles
-# because they might be regenerated.
-cmake_check_build_system:
- cd /Users/mohan/lofarsoft/src/pybdsm/implement && $(CMAKE_COMMAND) -H$(CMAKE_SOURCE_DIR) -B$(CMAKE_BINARY_DIR) --check-build-system CMakeFiles/Makefile.cmake 0
-.PHONY : cmake_check_build_system
-
diff --git a/CEP/PyBDSM/src/minpack/README b/CEP/PyBDSM/src/minpack/README
deleted file mode 100644
index 54766912e49b9b6344673d91ba886281d66949cb..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/minpack/README
+++ /dev/null
@@ -1,18 +0,0 @@
-====== readme for minpack ======
-
-Minpack includes software for solving nonlinear equations and
-nonlinear least squares problems. Five algorithmic paths each include
-a core subroutine and an easy-to-use driver. The algorithms proceed
-either from an analytic specification of the Jacobian matrix or
-directly from the problem functions. The paths include facilities for
-systems of equations with a banded Jacobian matrix, for least squares
-problems with a large amount of data, and for checking the consistency
-of the Jacobian matrix with the functions.
-
-This directory contains the double-precision versions.
-
-Jorge More', Burt Garbow, and Ken Hillstrom at Argonne National Laboratory.
-
-For copyright information see;
-
-http://www.netlib.org/minpack/disclaimer
diff --git a/CEP/PyBDSM/src/minpack/chkder.f b/CEP/PyBDSM/src/minpack/chkder.f
deleted file mode 100644
index 29578fc41893eb5a1dbca04f63df688055146216..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/minpack/chkder.f
+++ /dev/null
@@ -1,140 +0,0 @@
- subroutine chkder(m,n,x,fvec,fjac,ldfjac,xp,fvecp,mode,err)
- integer m,n,ldfjac,mode
- double precision x(n),fvec(m),fjac(ldfjac,n),xp(n),fvecp(m),
- * err(m)
-c **********
-c
-c subroutine chkder
-c
-c this subroutine checks the gradients of m nonlinear functions
-c in n variables, evaluated at a point x, for consistency with
-c the functions themselves. the user must call chkder twice,
-c first with mode = 1 and then with mode = 2.
-c
-c mode = 1. on input, x must contain the point of evaluation.
-c on output, xp is set to a neighboring point.
-c
-c mode = 2. on input, fvec must contain the functions and the
-c rows of fjac must contain the gradients
-c of the respective functions each evaluated
-c at x, and fvecp must contain the functions
-c evaluated at xp.
-c on output, err contains measures of correctness of
-c the respective gradients.
-c
-c the subroutine does not perform reliably if cancellation or
-c rounding errors cause a severe loss of significance in the
-c evaluation of a function. therefore, none of the components
-c of x should be unusually small (in particular, zero) or any
-c other value which may cause loss of significance.
-c
-c the subroutine statement is
-c
-c subroutine chkder(m,n,x,fvec,fjac,ldfjac,xp,fvecp,mode,err)
-c
-c where
-c
-c m is a positive integer input variable set to the number
-c of functions.
-c
-c n is a positive integer input variable set to the number
-c of variables.
-c
-c x is an input array of length n.
-c
-c fvec is an array of length m. on input when mode = 2,
-c fvec must contain the functions evaluated at x.
-c
-c fjac is an m by n array. on input when mode = 2,
-c the rows of fjac must contain the gradients of
-c the respective functions evaluated at x.
-c
-c ldfjac is a positive integer input parameter not less than m
-c which specifies the leading dimension of the array fjac.
-c
-c xp is an array of length n. on output when mode = 1,
-c xp is set to a neighboring point of x.
-c
-c fvecp is an array of length m. on input when mode = 2,
-c fvecp must contain the functions evaluated at xp.
-c
-c mode is an integer input variable set to 1 on the first call
-c and 2 on the second. other values of mode are equivalent
-c to mode = 1.
-c
-c err is an array of length m. on output when mode = 2,
-c err contains measures of correctness of the respective
-c gradients. if there is no severe loss of significance,
-c then if err(i) is 1.0 the i-th gradient is correct,
-c while if err(i) is 0.0 the i-th gradient is incorrect.
-c for values of err between 0.0 and 1.0, the categorization
-c is less certain. in general, a value of err(i) greater
-c than 0.5 indicates that the i-th gradient is probably
-c correct, while a value of err(i) less than 0.5 indicates
-c that the i-th gradient is probably incorrect.
-c
-c subprograms called
-c
-c minpack supplied ... dpmpar
-c
-c fortran supplied ... dabs,dlog10,dsqrt
-c
-c argonne national laboratory. minpack project. march 1980.
-c burton s. garbow, kenneth e. hillstrom, jorge j. more
-c
-c **********
- integer i,j
- double precision eps,epsf,epslog,epsmch,factor,one,temp,zero
- double precision dpmpar
- data factor,one,zero /1.0d2,1.0d0,0.0d0/
-c
-c epsmch is the machine precision.
-c
- epsmch = dpmpar(1)
-c
- eps = dsqrt(epsmch)
-c
- if (mode .eq. 2) go to 20
-c
-c mode = 1.
-c
- do 10 j = 1, n
- temp = eps*dabs(x(j))
- if (temp .eq. zero) temp = eps
- xp(j) = x(j) + temp
- 10 continue
- go to 70
- 20 continue
-c
-c mode = 2.
-c
- epsf = factor*epsmch
- epslog = dlog10(eps)
- do 30 i = 1, m
- err(i) = zero
- 30 continue
- do 50 j = 1, n
- temp = dabs(x(j))
- if (temp .eq. zero) temp = one
- do 40 i = 1, m
- err(i) = err(i) + temp*fjac(i,j)
- 40 continue
- 50 continue
- do 60 i = 1, m
- temp = one
- if (fvec(i) .ne. zero .and. fvecp(i) .ne. zero
- * .and. dabs(fvecp(i)-fvec(i)) .ge. epsf*dabs(fvec(i)))
- * temp = eps*dabs((fvecp(i)-fvec(i))/eps-err(i))
- * /(dabs(fvec(i)) + dabs(fvecp(i)))
- err(i) = one
- if (temp .gt. epsmch .and. temp .lt. eps)
- * err(i) = (dlog10(temp) - epslog)/epslog
- if (temp .ge. eps) err(i) = zero
- 60 continue
- 70 continue
-c
- return
-c
-c last card of subroutine chkder.
-c
- end
diff --git a/CEP/PyBDSM/src/minpack/cmake_install.cmake b/CEP/PyBDSM/src/minpack/cmake_install.cmake
deleted file mode 100644
index b7dedff945689e4fd2e5eac52e048de88ba226aa..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/minpack/cmake_install.cmake
+++ /dev/null
@@ -1,29 +0,0 @@
-# Install script for directory: /Users/mohan/lofarsoft/src/pybdsm/implement/minpack
-
-# Set the install prefix
-IF(NOT DEFINED CMAKE_INSTALL_PREFIX)
- SET(CMAKE_INSTALL_PREFIX "/usr/local")
-ENDIF(NOT DEFINED CMAKE_INSTALL_PREFIX)
-STRING(REGEX REPLACE "/$" "" CMAKE_INSTALL_PREFIX "${CMAKE_INSTALL_PREFIX}")
-
-# Set the install configuration name.
-IF(NOT DEFINED CMAKE_INSTALL_CONFIG_NAME)
- IF(BUILD_TYPE)
- STRING(REGEX REPLACE "^[^A-Za-z0-9_]+" ""
- CMAKE_INSTALL_CONFIG_NAME "${BUILD_TYPE}")
- ELSE(BUILD_TYPE)
- SET(CMAKE_INSTALL_CONFIG_NAME "")
- ENDIF(BUILD_TYPE)
- MESSAGE(STATUS "Install configuration: \"${CMAKE_INSTALL_CONFIG_NAME}\"")
-ENDIF(NOT DEFINED CMAKE_INSTALL_CONFIG_NAME)
-
-# Set the component getting installed.
-IF(NOT CMAKE_INSTALL_COMPONENT)
- IF(COMPONENT)
- MESSAGE(STATUS "Install component: \"${COMPONENT}\"")
- SET(CMAKE_INSTALL_COMPONENT "${COMPONENT}")
- ELSE(COMPONENT)
- SET(CMAKE_INSTALL_COMPONENT)
- ENDIF(COMPONENT)
-ENDIF(NOT CMAKE_INSTALL_COMPONENT)
-
diff --git a/CEP/PyBDSM/src/minpack/dogleg.f b/CEP/PyBDSM/src/minpack/dogleg.f
deleted file mode 100644
index b812f1966e85f0c66a00f0f783f2118e201e5d2e..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/minpack/dogleg.f
+++ /dev/null
@@ -1,177 +0,0 @@
- subroutine dogleg(n,r,lr,diag,qtb,delta,x,wa1,wa2)
- integer n,lr
- double precision delta
- double precision r(lr),diag(n),qtb(n),x(n),wa1(n),wa2(n)
-c **********
-c
-c subroutine dogleg
-c
-c given an m by n matrix a, an n by n nonsingular diagonal
-c matrix d, an m-vector b, and a positive number delta, the
-c problem is to determine the convex combination x of the
-c gauss-newton and scaled gradient directions that minimizes
-c (a*x - b) in the least squares sense, subject to the
-c restriction that the euclidean norm of d*x be at most delta.
-c
-c this subroutine completes the solution of the problem
-c if it is provided with the necessary information from the
-c qr factorization of a. that is, if a = q*r, where q has
-c orthogonal columns and r is an upper triangular matrix,
-c then dogleg expects the full upper triangle of r and
-c the first n components of (q transpose)*b.
-c
-c the subroutine statement is
-c
-c subroutine dogleg(n,r,lr,diag,qtb,delta,x,wa1,wa2)
-c
-c where
-c
-c n is a positive integer input variable set to the order of r.
-c
-c r is an input array of length lr which must contain the upper
-c triangular matrix r stored by rows.
-c
-c lr is a positive integer input variable not less than
-c (n*(n+1))/2.
-c
-c diag is an input array of length n which must contain the
-c diagonal elements of the matrix d.
-c
-c qtb is an input array of length n which must contain the first
-c n elements of the vector (q transpose)*b.
-c
-c delta is a positive input variable which specifies an upper
-c bound on the euclidean norm of d*x.
-c
-c x is an output array of length n which contains the desired
-c convex combination of the gauss-newton direction and the
-c scaled gradient direction.
-c
-c wa1 and wa2 are work arrays of length n.
-c
-c subprograms called
-c
-c minpack-supplied ... dpmpar,enorm
-c
-c fortran-supplied ... dabs,dmax1,dmin1,dsqrt
-c
-c argonne national laboratory. minpack project. march 1980.
-c burton s. garbow, kenneth e. hillstrom, jorge j. more
-c
-c **********
- integer i,j,jj,jp1,k,l
- double precision alpha,bnorm,epsmch,gnorm,one,qnorm,sgnorm,sum,
- * temp,zero
- double precision dpmpar,enorm
- data one,zero /1.0d0,0.0d0/
-c
-c epsmch is the machine precision.
-c
- epsmch = dpmpar(1)
-c
-c first, calculate the gauss-newton direction.
-c
- jj = (n*(n + 1))/2 + 1
- do 50 k = 1, n
- j = n - k + 1
- jp1 = j + 1
- jj = jj - k
- l = jj + 1
- sum = zero
- if (n .lt. jp1) go to 20
- do 10 i = jp1, n
- sum = sum + r(l)*x(i)
- l = l + 1
- 10 continue
- 20 continue
- temp = r(jj)
- if (temp .ne. zero) go to 40
- l = j
- do 30 i = 1, j
- temp = dmax1(temp,dabs(r(l)))
- l = l + n - i
- 30 continue
- temp = epsmch*temp
- if (temp .eq. zero) temp = epsmch
- 40 continue
- x(j) = (qtb(j) - sum)/temp
- 50 continue
-c
-c test whether the gauss-newton direction is acceptable.
-c
- do 60 j = 1, n
- wa1(j) = zero
- wa2(j) = diag(j)*x(j)
- 60 continue
- qnorm = enorm(n,wa2)
- if (qnorm .le. delta) go to 140
-c
-c the gauss-newton direction is not acceptable.
-c next, calculate the scaled gradient direction.
-c
- l = 1
- do 80 j = 1, n
- temp = qtb(j)
- do 70 i = j, n
- wa1(i) = wa1(i) + r(l)*temp
- l = l + 1
- 70 continue
- wa1(j) = wa1(j)/diag(j)
- 80 continue
-c
-c calculate the norm of the scaled gradient and test for
-c the special case in which the scaled gradient is zero.
-c
- gnorm = enorm(n,wa1)
- sgnorm = zero
- alpha = delta/qnorm
- if (gnorm .eq. zero) go to 120
-c
-c calculate the point along the scaled gradient
-c at which the quadratic is minimized.
-c
- do 90 j = 1, n
- wa1(j) = (wa1(j)/gnorm)/diag(j)
- 90 continue
- l = 1
- do 110 j = 1, n
- sum = zero
- do 100 i = j, n
- sum = sum + r(l)*wa1(i)
- l = l + 1
- 100 continue
- wa2(j) = sum
- 110 continue
- temp = enorm(n,wa2)
- sgnorm = (gnorm/temp)/temp
-c
-c test whether the scaled gradient direction is acceptable.
-c
- alpha = zero
- if (sgnorm .ge. delta) go to 120
-c
-c the scaled gradient direction is not acceptable.
-c finally, calculate the point along the dogleg
-c at which the quadratic is minimized.
-c
- bnorm = enorm(n,qtb)
- temp = (bnorm/gnorm)*(bnorm/qnorm)*(sgnorm/delta)
- temp = temp - (delta/qnorm)*(sgnorm/delta)**2
- * + dsqrt((temp-(delta/qnorm))**2
- * +(one-(delta/qnorm)**2)*(one-(sgnorm/delta)**2))
- alpha = ((delta/qnorm)*(one - (sgnorm/delta)**2))/temp
- 120 continue
-c
-c form appropriate convex combination of the gauss-newton
-c direction and the scaled gradient direction.
-c
- temp = (one - alpha)*dmin1(sgnorm,delta)
- do 130 j = 1, n
- x(j) = temp*wa1(j) + alpha*x(j)
- 130 continue
- 140 continue
- return
-c
-c last card of subroutine dogleg.
-c
- end
diff --git a/CEP/PyBDSM/src/minpack/dpmpar.f b/CEP/PyBDSM/src/minpack/dpmpar.f
deleted file mode 100644
index cb6545a928c4ce5de105fb66b70fa8995d604d68..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/minpack/dpmpar.f
+++ /dev/null
@@ -1,177 +0,0 @@
- double precision function dpmpar(i)
- integer i
-c **********
-c
-c Function dpmpar
-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
-c The function statement is
-c
-c double precision function dpmpar(i)
-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
- data dmach(1) /2.22044604926d-16/
- data dmach(2) /2.22507385852d-308/
- data dmach(3) /1.79769313485d+308/
-c
- dpmpar = dmach(i)
- return
-c
-c Last card of function dpmpar.
-c
- end
diff --git a/CEP/PyBDSM/src/minpack/enorm.f b/CEP/PyBDSM/src/minpack/enorm.f
deleted file mode 100644
index 2cb5b607e173045e3fd83b6b5ebf2c4896fa4b24..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/minpack/enorm.f
+++ /dev/null
@@ -1,108 +0,0 @@
- double precision function enorm(n,x)
- integer n
- double precision x(n)
-c **********
-c
-c function enorm
-c
-c given an n-vector x, this function calculates the
-c euclidean norm of 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
-c the function statement is
-c
-c double precision function enorm(n,x)
-c
-c where
-c
-c n is a positive integer input variable.
-c
-c x is an input array of length n.
-c
-c subprograms called
-c
-c fortran-supplied ... dabs,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
-c
-c sum for small components.
-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
-c
-c sum for intermediate components.
-c
- s2 = s2 + xabs**2
- 80 continue
- 90 continue
-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
- return
-c
-c last card of function enorm.
-c
- end
diff --git a/CEP/PyBDSM/src/minpack/ex/file01 b/CEP/PyBDSM/src/minpack/ex/file01
deleted file mode 100644
index d5d0c55190b0a557639068a9b36e911d54e8ed20..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/minpack/ex/file01
+++ /dev/null
@@ -1,145 +0,0 @@
- REAL FUNCTION SPMPAR(I)
- INTEGER I
-C **********
-C
-C FUNCTION SPMPAR
-C
-C THIS FUNCTION PROVIDES SINGLE 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
-C THE FUNCTION STATEMENT IS
-C
-C REAL FUNCTION SPMPAR(I)
-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 SPMPAR(1) = B**(1 - T), THE MACHINE PRECISION,
-C
-C SPMPAR(2) = B**(EMIN - 1), THE SMALLEST MAGNITUDE,
-C
-C SPMPAR(3) = B**EMAX*(1 - B**(-T)), THE LARGEST MAGNITUDE.
-C
-C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980.
-C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE
-C
-C **********
- INTEGER MCHEPS(2)
- INTEGER MINMAG(2)
- INTEGER MAXMAG(2)
- REAL RMACH(3)
- EQUIVALENCE (RMACH(1),MCHEPS(1))
- EQUIVALENCE (RMACH(2),MINMAG(1))
- EQUIVALENCE (RMACH(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
- DATA RMACH(1) / Z3C100000 /
- DATA RMACH(2) / Z00100000 /
- DATA RMACH(3) / Z7FFFFFFF /
-C
-C MACHINE CONSTANTS FOR THE HONEYWELL 600/6000 SERIES.
-C
-C DATA RMACH(1) / O716400000000 /
-C DATA RMACH(2) / O402400000000 /
-C DATA RMACH(3) / O376777777777 /
-C
-C MACHINE CONSTANTS FOR THE CDC 6000/7000 SERIES.
-C
-C DATA RMACH(1) / 16414000000000000000B /
-C DATA RMACH(2) / 00014000000000000000B /
-C DATA RMACH(3) / 37767777777777777777B /
-C
-C MACHINE CONSTANTS FOR THE PDP-10 (KA OR KI PROCESSOR).
-C
-C DATA RMACH(1) / "147400000000 /
-C DATA RMACH(2) / "000400000000 /
-C DATA RMACH(3) / "377777777777 /
-C
-C MACHINE CONSTANTS FOR THE PDP-11 FORTRAN SUPPORTING
-C 32-BIT INTEGERS (EXPRESSED IN INTEGER AND OCTAL).
-C
-C DATA MCHEPS(1) / 889192448 /
-C DATA MINMAG(1) / 8388608 /
-C DATA MAXMAG(1) / 2147483647 /
-C
-C DATA RMACH(1) / O06500000000 /
-C DATA RMACH(2) / O00040000000 /
-C DATA RMACH(3) / O17777777777 /
-C
-C MACHINE CONSTANTS FOR THE PDP-11 FORTRAN SUPPORTING
-C 16-BIT INTEGERS (EXPRESSED IN INTEGER AND OCTAL).
-C
-C DATA MCHEPS(1),MCHEPS(2) / 13568, 0 /
-C DATA MINMAG(1),MINMAG(2) / 128, 0 /
-C DATA MAXMAG(1),MAXMAG(2) / 32767, -1 /
-C
-C DATA MCHEPS(1),MCHEPS(2) / O032400, O000000 /
-C DATA MINMAG(1),MINMAG(2) / O000200, O000000 /
-C DATA MAXMAG(1),MAXMAG(2) / O077777, O177777 /
-C
-C MACHINE CONSTANTS FOR THE BURROUGHS 5700/6700/7700 SYSTEMS.
-C
-C DATA RMACH(1) / O1301000000000000 /
-C DATA RMACH(2) / O1771000000000000 /
-C DATA RMACH(3) / O0777777777777777 /
-C
-C MACHINE CONSTANTS FOR THE BURROUGHS 1700 SYSTEM.
-C
-C DATA RMACH(1) / Z4EA800000 /
-C DATA RMACH(2) / Z400800000 /
-C DATA RMACH(3) / Z5FFFFFFFF /
-C
-C MACHINE CONSTANTS FOR THE UNIVAC 1100 SERIES.
-C
-C DATA RMACH(1) / O147400000000 /
-C DATA RMACH(2) / O000400000000 /
-C DATA RMACH(3) / O377777777777 /
-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 RMACH(3)
-C
-C DATA MINMAG/20K,0/,MAXMAG/77777K,177777K/
-C DATA MCHEPS/36020K,0/
-C
-C MACHINE CONSTANTS FOR THE HARRIS 220.
-C
-C DATA MCHEPS(1) / '20000000, '00000353 /
-C DATA MINMAG(1) / '20000000, '00000201 /
-C DATA MAXMAG(1) / '37777777, '00000177 /
-C
-C MACHINE CONSTANTS FOR THE CRAY-1.
-C
-C DATA RMACH(1) / 0377224000000000000000B /
-C DATA RMACH(2) / 0200034000000000000000B /
-C DATA RMACH(3) / 0577777777777777777776B /
-C
-C MACHINE CONSTANTS FOR THE PRIME 400.
-C
-C DATA MCHEPS(1) / :10000000153 /
-C DATA MINMAG(1) / :10000000000 /
-C DATA MAXMAG(1) / :17777777777 /
-C
-C MACHINE CONSTANTS FOR THE VAX-11.
-C
-C DATA MCHEPS(1) / 13568 /
-C DATA MINMAG(1) / 128 /
-C DATA MAXMAG(1) / -32769 /
-C
- SPMPAR = RMACH(I)
- RETURN
-C
-C LAST CARD OF FUNCTION SPMPAR.
-C
- END
diff --git a/CEP/PyBDSM/src/minpack/ex/file02 b/CEP/PyBDSM/src/minpack/ex/file02
deleted file mode 100644
index 5a3ec935ef0af1086869de28722547522f5dd4af..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/minpack/ex/file02
+++ /dev/null
@@ -1,4771 +0,0 @@
- SUBROUTINE CHKDER(M,N,X,FVEC,FJAC,LDFJAC,XP,FVECP,MODE,ERR)
- INTEGER M,N,LDFJAC,MODE
- REAL X(N),FVEC(M),FJAC(LDFJAC,N),XP(N),FVECP(M),ERR(M)
-C **********
-C
-C SUBROUTINE CHKDER
-C
-C THIS SUBROUTINE CHECKS THE GRADIENTS OF M NONLINEAR FUNCTIONS
-C IN N VARIABLES, EVALUATED AT A POINT X, FOR CONSISTENCY WITH
-C THE FUNCTIONS THEMSELVES. THE USER MUST CALL CHKDER TWICE,
-C FIRST WITH MODE = 1 AND THEN WITH MODE = 2.
-C
-C MODE = 1. ON INPUT, X MUST CONTAIN THE POINT OF EVALUATION.
-C ON OUTPUT, XP IS SET TO A NEIGHBORING POINT.
-C
-C MODE = 2. ON INPUT, FVEC MUST CONTAIN THE FUNCTIONS AND THE
-C ROWS OF FJAC MUST CONTAIN THE GRADIENTS
-C OF THE RESPECTIVE FUNCTIONS EACH EVALUATED
-C AT X, AND FVECP MUST CONTAIN THE FUNCTIONS
-C EVALUATED AT XP.
-C ON OUTPUT, ERR CONTAINS MEASURES OF CORRECTNESS OF
-C THE RESPECTIVE GRADIENTS.
-C
-C THE SUBROUTINE DOES NOT PERFORM RELIABLY IF CANCELLATION OR
-C ROUNDING ERRORS CAUSE A SEVERE LOSS OF SIGNIFICANCE IN THE
-C EVALUATION OF A FUNCTION. THEREFORE, NONE OF THE COMPONENTS
-C OF X SHOULD BE UNUSUALLY SMALL (IN PARTICULAR, ZERO) OR ANY
-C OTHER VALUE WHICH MAY CAUSE LOSS OF SIGNIFICANCE.
-C
-C THE SUBROUTINE STATEMENT IS
-C
-C SUBROUTINE CHKDER(M,N,X,FVEC,FJAC,LDFJAC,XP,FVECP,MODE,ERR)
-C
-C WHERE
-C
-C M IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER
-C OF FUNCTIONS.
-C
-C N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER
-C OF VARIABLES.
-C
-C X IS AN INPUT ARRAY OF LENGTH N.
-C
-C FVEC IS AN ARRAY OF LENGTH M. ON INPUT WHEN MODE = 2,
-C FVEC MUST CONTAIN THE FUNCTIONS EVALUATED AT X.
-C
-C FJAC IS AN M BY N ARRAY. ON INPUT WHEN MODE = 2,
-C THE ROWS OF FJAC MUST CONTAIN THE GRADIENTS OF
-C THE RESPECTIVE FUNCTIONS EVALUATED AT X.
-C
-C LDFJAC IS A POSITIVE INTEGER INPUT PARAMETER NOT LESS THAN M
-C WHICH SPECIFIES THE LEADING DIMENSION OF THE ARRAY FJAC.
-C
-C XP IS AN ARRAY OF LENGTH N. ON OUTPUT WHEN MODE = 1,
-C XP IS SET TO A NEIGHBORING POINT OF X.
-C
-C FVECP IS AN ARRAY OF LENGTH M. ON INPUT WHEN MODE = 2,
-C FVECP MUST CONTAIN THE FUNCTIONS EVALUATED AT XP.
-C
-C MODE IS AN INTEGER INPUT VARIABLE SET TO 1 ON THE FIRST CALL
-C AND 2 ON THE SECOND. OTHER VALUES OF MODE ARE EQUIVALENT
-C TO MODE = 1.
-C
-C ERR IS AN ARRAY OF LENGTH M. ON OUTPUT WHEN MODE = 2,
-C ERR CONTAINS MEASURES OF CORRECTNESS OF THE RESPECTIVE
-C GRADIENTS. IF THERE IS NO SEVERE LOSS OF SIGNIFICANCE,
-C THEN IF ERR(I) IS 1.0 THE I-TH GRADIENT IS CORRECT,
-C WHILE IF ERR(I) IS 0.0 THE I-TH GRADIENT IS INCORRECT.
-C FOR VALUES OF ERR BETWEEN 0.0 AND 1.0, THE CATEGORIZATION
-C IS LESS CERTAIN. IN GENERAL, A VALUE OF ERR(I) GREATER
-C THAN 0.5 INDICATES THAT THE I-TH GRADIENT IS PROBABLY
-C CORRECT, WHILE A VALUE OF ERR(I) LESS THAN 0.5 INDICATES
-C THAT THE I-TH GRADIENT IS PROBABLY INCORRECT.
-C
-C SUBPROGRAMS CALLED
-C
-C MINPACK SUPPLIED ... SPMPAR
-C
-C FORTRAN SUPPLIED ... ABS,ALOG10,SQRT
-C
-C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980.
-C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE
-C
-C **********
- INTEGER I,J
- REAL EPS,EPSF,EPSLOG,EPSMCH,FACTOR,ONE,TEMP,ZERO
- REAL SPMPAR
- DATA FACTOR,ONE,ZERO /1.0E2,1.0E0,0.0E0/
-C
-C EPSMCH IS THE MACHINE PRECISION.
-C
- EPSMCH = SPMPAR(1)
-C
- EPS = SQRT(EPSMCH)
-C
- IF (MODE .EQ. 2) GO TO 20
-C
-C MODE = 1.
-C
- DO 10 J = 1, N
- TEMP = EPS*ABS(X(J))
- IF (TEMP .EQ. ZERO) TEMP = EPS
- XP(J) = X(J) + TEMP
- 10 CONTINUE
- GO TO 70
- 20 CONTINUE
-C
-C MODE = 2.
-C
- EPSF = FACTOR*EPSMCH
- EPSLOG = ALOG10(EPS)
- DO 30 I = 1, M
- ERR(I) = ZERO
- 30 CONTINUE
- DO 50 J = 1, N
- TEMP = ABS(X(J))
- IF (TEMP .EQ. ZERO) TEMP = ONE
- DO 40 I = 1, M
- ERR(I) = ERR(I) + TEMP*FJAC(I,J)
- 40 CONTINUE
- 50 CONTINUE
- DO 60 I = 1, M
- TEMP = ONE
- IF (FVEC(I) .NE. ZERO .AND. FVECP(I) .NE. ZERO
- * .AND. ABS(FVECP(I)-FVEC(I)) .GE. EPSF*ABS(FVEC(I)))
- * TEMP = EPS*ABS((FVECP(I)-FVEC(I))/EPS-ERR(I))
- * /(ABS(FVEC(I)) + ABS(FVECP(I)))
- ERR(I) = ONE
- IF (TEMP .GT. EPSMCH .AND. TEMP .LT. EPS)
- * ERR(I) = (ALOG10(TEMP) - EPSLOG)/EPSLOG
- IF (TEMP .GE. EPS) ERR(I) = ZERO
- 60 CONTINUE
- 70 CONTINUE
-C
- RETURN
-C
-C LAST CARD OF SUBROUTINE CHKDER.
-C
- END
- SUBROUTINE DOGLEG(N,R,LR,DIAG,QTB,DELTA,X,WA1,WA2)
- INTEGER N,LR
- REAL DELTA
- REAL R(LR),DIAG(N),QTB(N),X(N),WA1(N),WA2(N)
-C **********
-C
-C SUBROUTINE DOGLEG
-C
-C GIVEN AN M BY N MATRIX A, AN N BY N NONSINGULAR DIAGONAL
-C MATRIX D, AN M-VECTOR B, AND A POSITIVE NUMBER DELTA, THE
-C PROBLEM IS TO DETERMINE THE CONVEX COMBINATION X OF THE
-C GAUSS-NEWTON AND SCALED GRADIENT DIRECTIONS THAT MINIMIZES
-C (A*X - B) IN THE LEAST SQUARES SENSE, SUBJECT TO THE
-C RESTRICTION THAT THE EUCLIDEAN NORM OF D*X BE AT MOST DELTA.
-C
-C THIS SUBROUTINE COMPLETES THE SOLUTION OF THE PROBLEM
-C IF IT IS PROVIDED WITH THE NECESSARY INFORMATION FROM THE
-C QR FACTORIZATION OF A. THAT IS, IF A = Q*R, WHERE Q HAS
-C ORTHOGONAL COLUMNS AND R IS AN UPPER TRIANGULAR MATRIX,
-C THEN DOGLEG EXPECTS THE FULL UPPER TRIANGLE OF R AND
-C THE FIRST N COMPONENTS OF (Q TRANSPOSE)*B.
-C
-C THE SUBROUTINE STATEMENT IS
-C
-C SUBROUTINE DOGLEG(N,R,LR,DIAG,QTB,DELTA,X,WA1,WA2)
-C
-C WHERE
-C
-C N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE ORDER OF R.
-C
-C R IS AN INPUT ARRAY OF LENGTH LR WHICH MUST CONTAIN THE UPPER
-C TRIANGULAR MATRIX R STORED BY ROWS.
-C
-C LR IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN
-C (N*(N+1))/2.
-C
-C DIAG IS AN INPUT ARRAY OF LENGTH N WHICH MUST CONTAIN THE
-C DIAGONAL ELEMENTS OF THE MATRIX D.
-C
-C QTB IS AN INPUT ARRAY OF LENGTH N WHICH MUST CONTAIN THE FIRST
-C N ELEMENTS OF THE VECTOR (Q TRANSPOSE)*B.
-C
-C DELTA IS A POSITIVE INPUT VARIABLE WHICH SPECIFIES AN UPPER
-C BOUND ON THE EUCLIDEAN NORM OF D*X.
-C
-C X IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS THE DESIRED
-C CONVEX COMBINATION OF THE GAUSS-NEWTON DIRECTION AND THE
-C SCALED GRADIENT DIRECTION.
-C
-C WA1 AND WA2 ARE WORK ARRAYS OF LENGTH N.
-C
-C SUBPROGRAMS CALLED
-C
-C MINPACK-SUPPLIED ... SPMPAR,ENORM
-C
-C FORTRAN-SUPPLIED ... ABS,AMAX1,AMIN1,SQRT
-C
-C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980.
-C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE
-C
-C **********
- INTEGER I,J,JJ,JP1,K,L
- REAL ALPHA,BNORM,EPSMCH,GNORM,ONE,QNORM,SGNORM,SUM,TEMP,ZERO
- REAL SPMPAR,ENORM
- DATA ONE,ZERO /1.0E0,0.0E0/
-C
-C EPSMCH IS THE MACHINE PRECISION.
-C
- EPSMCH = SPMPAR(1)
-C
-C FIRST, CALCULATE THE GAUSS-NEWTON DIRECTION.
-C
- JJ = (N*(N + 1))/2 + 1
- DO 50 K = 1, N
- J = N - K + 1
- JP1 = J + 1
- JJ = JJ - K
- L = JJ + 1
- SUM = ZERO
- IF (N .LT. JP1) GO TO 20
- DO 10 I = JP1, N
- SUM = SUM + R(L)*X(I)
- L = L + 1
- 10 CONTINUE
- 20 CONTINUE
- TEMP = R(JJ)
- IF (TEMP .NE. ZERO) GO TO 40
- L = J
- DO 30 I = 1, J
- TEMP = AMAX1(TEMP,ABS(R(L)))
- L = L + N - I
- 30 CONTINUE
- TEMP = EPSMCH*TEMP
- IF (TEMP .EQ. ZERO) TEMP = EPSMCH
- 40 CONTINUE
- X(J) = (QTB(J) - SUM)/TEMP
- 50 CONTINUE
-C
-C TEST WHETHER THE GAUSS-NEWTON DIRECTION IS ACCEPTABLE.
-C
- DO 60 J = 1, N
- WA1(J) = ZERO
- WA2(J) = DIAG(J)*X(J)
- 60 CONTINUE
- QNORM = ENORM(N,WA2)
- IF (QNORM .LE. DELTA) GO TO 140
-C
-C THE GAUSS-NEWTON DIRECTION IS NOT ACCEPTABLE.
-C NEXT, CALCULATE THE SCALED GRADIENT DIRECTION.
-C
- L = 1
- DO 80 J = 1, N
- TEMP = QTB(J)
- DO 70 I = J, N
- WA1(I) = WA1(I) + R(L)*TEMP
- L = L + 1
- 70 CONTINUE
- WA1(J) = WA1(J)/DIAG(J)
- 80 CONTINUE
-C
-C CALCULATE THE NORM OF THE SCALED GRADIENT AND TEST FOR
-C THE SPECIAL CASE IN WHICH THE SCALED GRADIENT IS ZERO.
-C
- GNORM = ENORM(N,WA1)
- SGNORM = ZERO
- ALPHA = DELTA/QNORM
- IF (GNORM .EQ. ZERO) GO TO 120
-C
-C CALCULATE THE POINT ALONG THE SCALED GRADIENT
-C AT WHICH THE QUADRATIC IS MINIMIZED.
-C
- DO 90 J = 1, N
- WA1(J) = (WA1(J)/GNORM)/DIAG(J)
- 90 CONTINUE
- L = 1
- DO 110 J = 1, N
- SUM = ZERO
- DO 100 I = J, N
- SUM = SUM + R(L)*WA1(I)
- L = L + 1
- 100 CONTINUE
- WA2(J) = SUM
- 110 CONTINUE
- TEMP = ENORM(N,WA2)
- SGNORM = (GNORM/TEMP)/TEMP
-C
-C TEST WHETHER THE SCALED GRADIENT DIRECTION IS ACCEPTABLE.
-C
- ALPHA = ZERO
- IF (SGNORM .GE. DELTA) GO TO 120
-C
-C THE SCALED GRADIENT DIRECTION IS NOT ACCEPTABLE.
-C FINALLY, CALCULATE THE POINT ALONG THE DOGLEG
-C AT WHICH THE QUADRATIC IS MINIMIZED.
-C
- BNORM = ENORM(N,QTB)
- TEMP = (BNORM/GNORM)*(BNORM/QNORM)*(SGNORM/DELTA)
- TEMP = TEMP - (DELTA/QNORM)*(SGNORM/DELTA)**2
- * + SQRT((TEMP-(DELTA/QNORM))**2
- * +(ONE-(DELTA/QNORM)**2)*(ONE-(SGNORM/DELTA)**2))
- ALPHA = ((DELTA/QNORM)*(ONE - (SGNORM/DELTA)**2))/TEMP
- 120 CONTINUE
-C
-C FORM APPROPRIATE CONVEX COMBINATION OF THE GAUSS-NEWTON
-C DIRECTION AND THE SCALED GRADIENT DIRECTION.
-C
- TEMP = (ONE - ALPHA)*AMIN1(SGNORM,DELTA)
- DO 130 J = 1, N
- X(J) = TEMP*WA1(J) + ALPHA*X(J)
- 130 CONTINUE
- 140 CONTINUE
- RETURN
-C
-C LAST CARD OF SUBROUTINE DOGLEG.
-C
- END
- REAL FUNCTION ENORM(N,X)
- INTEGER N
- REAL X(N)
-C **********
-C
-C FUNCTION ENORM
-C
-C GIVEN AN N-VECTOR X, THIS FUNCTION CALCULATES THE
-C EUCLIDEAN NORM OF 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
-C THE FUNCTION STATEMENT IS
-C
-C REAL FUNCTION ENORM(N,X)
-C
-C WHERE
-C
-C N IS A POSITIVE INTEGER INPUT VARIABLE.
-C
-C X IS AN INPUT ARRAY OF LENGTH N.
-C
-C SUBPROGRAMS CALLED
-C
-C FORTRAN-SUPPLIED ... ABS,SQRT
-C
-C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980.
-C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE
-C
-C **********
- INTEGER I
- REAL AGIANT,FLOATN,ONE,RDWARF,RGIANT,S1,S2,S3,XABS,X1MAX,X3MAX,
- * ZERO
- DATA ONE,ZERO,RDWARF,RGIANT /1.0E0,0.0E0,3.834E-20,1.304E19/
- S1 = ZERO
- S2 = ZERO
- S3 = ZERO
- X1MAX = ZERO
- X3MAX = ZERO
- FLOATN = N
- AGIANT = RGIANT/FLOATN
- DO 90 I = 1, N
- XABS = ABS(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
-C
-C SUM FOR SMALL COMPONENTS.
-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
-C
-C SUM FOR INTERMEDIATE COMPONENTS.
-C
- S2 = S2 + XABS**2
- 80 CONTINUE
- 90 CONTINUE
-C
-C CALCULATION OF NORM.
-C
- IF (S1 .EQ. ZERO) GO TO 100
- ENORM = X1MAX*SQRT(S1+(S2/X1MAX)/X1MAX)
- GO TO 130
- 100 CONTINUE
- IF (S2 .EQ. ZERO) GO TO 110
- IF (S2 .GE. X3MAX)
- * ENORM = SQRT(S2*(ONE+(X3MAX/S2)*(X3MAX*S3)))
- IF (S2 .LT. X3MAX)
- * ENORM = SQRT(X3MAX*((S2/X3MAX)+(X3MAX*S3)))
- GO TO 120
- 110 CONTINUE
- ENORM = X3MAX*SQRT(S3)
- 120 CONTINUE
- 130 CONTINUE
- RETURN
-C
-C LAST CARD OF FUNCTION ENORM.
-C
- END
- SUBROUTINE FDJAC1(FCN,N,X,FVEC,FJAC,LDFJAC,IFLAG,ML,MU,EPSFCN,
- * WA1,WA2)
- INTEGER N,LDFJAC,IFLAG,ML,MU
- REAL EPSFCN
- REAL X(N),FVEC(N),FJAC(LDFJAC,N),WA1(N),WA2(N)
-C **********
-C
-C SUBROUTINE FDJAC1
-C
-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 SUBROUTINE STATEMENT IS
-C
-C SUBROUTINE FDJAC1(FCN,N,X,FVEC,FJAC,LDFJAC,IFLAG,ML,MU,EPSFCN,
-C WA1,WA2)
-C
-C WHERE
-C
-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
-C SUBROUTINE FCN(N,X,FVEC,IFLAG)
-C INTEGER N,IFLAG
-C REAL X(N),FVEC(N)
-C ----------
-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 FDJAC1.
-C IN THIS CASE SET IFLAG TO A NEGATIVE INTEGER.
-C
-C N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER
-C OF FUNCTIONS AND VARIABLES.
-C
-C X IS AN INPUT ARRAY OF LENGTH N.
-C
-C FVEC IS AN INPUT ARRAY OF LENGTH N WHICH MUST CONTAIN THE
-C FUNCTIONS EVALUATED AT X.
-C
-C FJAC IS AN OUTPUT N BY N ARRAY WHICH CONTAINS THE
-C APPROXIMATION TO THE JACOBIAN MATRIX EVALUATED AT X.
-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 IFLAG IS AN INTEGER VARIABLE WHICH CAN BE USED TO TERMINATE
-C THE EXECUTION OF FDJAC1. SEE DESCRIPTION OF FCN.
-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 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 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 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 MINPACK-SUPPLIED ... SPMPAR
-C
-C FORTRAN-SUPPLIED ... ABS,AMAX1,SQRT
-C
-C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980.
-C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE
-C
-C **********
- INTEGER I,J,K,MSUM
- REAL EPS,EPSMCH,H,TEMP,ZERO
- REAL SPMPAR
- DATA ZERO /0.0E0/
-C
-C EPSMCH IS THE MACHINE PRECISION.
-C
- EPSMCH = SPMPAR(1)
-C
- EPS = SQRT(AMAX1(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*ABS(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
-C COMPUTATION OF BANDED APPROXIMATE JACOBIAN.
-C
- DO 90 K = 1, MSUM
- DO 60 J = K, N, MSUM
- WA2(J) = X(J)
- H = EPS*ABS(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*ABS(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 SUBROUTINE FDJAC1.
-C
- END
- SUBROUTINE FDJAC2(FCN,M,N,X,FVEC,FJAC,LDFJAC,IFLAG,EPSFCN,WA)
- INTEGER M,N,LDFJAC,IFLAG
- REAL EPSFCN
- REAL X(N),FVEC(M),FJAC(LDFJAC,N),WA(M)
-C **********
-C
-C SUBROUTINE FDJAC2
-C
-C THIS SUBROUTINE COMPUTES A FORWARD-DIFFERENCE APPROXIMATION
-C TO THE M BY N JACOBIAN MATRIX ASSOCIATED WITH A SPECIFIED
-C PROBLEM OF M FUNCTIONS IN N VARIABLES.
-C
-C THE SUBROUTINE STATEMENT IS
-C
-C SUBROUTINE FDJAC2(FCN,M,N,X,FVEC,FJAC,LDFJAC,IFLAG,EPSFCN,WA)
-C
-C WHERE
-C
-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
-C SUBROUTINE FCN(M,N,X,FVEC,IFLAG)
-C INTEGER M,N,IFLAG
-C REAL X(N),FVEC(M)
-C ----------
-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 FDJAC2.
-C IN THIS CASE SET IFLAG TO A NEGATIVE INTEGER.
-C
-C M IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER
-C OF FUNCTIONS.
-C
-C N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER
-C OF VARIABLES. N MUST NOT EXCEED M.
-C
-C X IS AN INPUT ARRAY OF LENGTH N.
-C
-C FVEC IS AN INPUT ARRAY OF LENGTH M WHICH MUST CONTAIN THE
-C FUNCTIONS EVALUATED AT X.
-C
-C FJAC IS AN OUTPUT M BY N ARRAY WHICH CONTAINS THE
-C APPROXIMATION TO THE JACOBIAN MATRIX EVALUATED AT X.
-C
-C LDFJAC IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN M
-C WHICH SPECIFIES THE LEADING DIMENSION OF THE ARRAY FJAC.
-C
-C IFLAG IS AN INTEGER VARIABLE WHICH CAN BE USED TO TERMINATE
-C THE EXECUTION OF FDJAC2. SEE DESCRIPTION OF FCN.
-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 WA IS A WORK ARRAY OF LENGTH M.
-C
-C SUBPROGRAMS CALLED
-C
-C USER-SUPPLIED ...... FCN
-C
-C MINPACK-SUPPLIED ... SPMPAR
-C
-C FORTRAN-SUPPLIED ... ABS,AMAX1,SQRT
-C
-C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980.
-C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE
-C
-C **********
- INTEGER I,J
- REAL EPS,EPSMCH,H,TEMP,ZERO
- REAL SPMPAR
- DATA ZERO /0.0E0/
-C
-C EPSMCH IS THE MACHINE PRECISION.
-C
- EPSMCH = SPMPAR(1)
-C
- EPS = SQRT(AMAX1(EPSFCN,EPSMCH))
- DO 20 J = 1, N
- TEMP = X(J)
- H = EPS*ABS(TEMP)
- IF (H .EQ. ZERO) H = EPS
- X(J) = TEMP + H
- CALL FCN(M,N,X,WA,IFLAG)
- IF (IFLAG .LT. 0) GO TO 30
- X(J) = TEMP
- DO 10 I = 1, M
- FJAC(I,J) = (WA(I) - FVEC(I))/H
- 10 CONTINUE
- 20 CONTINUE
- 30 CONTINUE
- RETURN
-C
-C LAST CARD OF SUBROUTINE FDJAC2.
-C
- END
- 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
- REAL XTOL,EPSFCN,FACTOR
- REAL 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 HYBRD
-C
-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. THE JACOBIAN IS
-C THEN CALCULATED BY A FORWARD-DIFFERENCE APPROXIMATION.
-C
-C THE SUBROUTINE STATEMENT IS
-C
-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. 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,IFLAG)
-C INTEGER N,IFLAG
-C REAL X(N),FVEC(N)
-C ----------
-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 HYBRD.
-C IN THIS CASE SET IFLAG TO A NEGATIVE INTEGER.
-C
-C N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER
-C OF FUNCTIONS AND VARIABLES.
-C
-C X IS AN ARRAY OF LENGTH N. ON INPUT X MUST CONTAIN
-C AN INITIAL ESTIMATE OF THE SOLUTION VECTOR. ON OUTPUT X
-C CONTAINS THE FINAL ESTIMATE OF THE SOLUTION VECTOR.
-C
-C FVEC IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS
-C THE FUNCTIONS EVALUATED AT THE OUTPUT X.
-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 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
-C MUST CONTAIN POSITIVE ENTRIES THAT SERVE AS
-C MULTIPLICATIVE SCALE FACTORS FOR THE VARIABLES.
-C
-C MODE IS AN INTEGER INPUT VARIABLE. IF MODE = 1, THE
-C VARIABLES WILL BE SCALED INTERNALLY. IF MODE = 2,
-C THE SCALING IS SPECIFIED BY THE INPUT DIAG. OTHER
-C VALUES OF MODE ARE EQUIVALENT TO MODE = 1.
-C
-C FACTOR IS A POSITIVE INPUT VARIABLE USED IN DETERMINING THE
-C INITIAL STEP BOUND. THIS BOUND IS SET TO THE PRODUCT OF
-C FACTOR AND THE EUCLIDEAN NORM OF DIAG*X IF NONZERO, OR ELSE
-C TO FACTOR ITSELF. IN MOST CASES FACTOR SHOULD LIE IN THE
-C INTERVAL (.1,100.). 100. IS A GENERALLY RECOMMENDED VALUE.
-C
-C NPRINT IS AN INTEGER INPUT VARIABLE THAT ENABLES CONTROLLED
-C PRINTING OF ITERATES IF IT IS POSITIVE. IN THIS CASE,
-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. 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)
-C VALUE OF IFLAG. SEE DESCRIPTION OF FCN. OTHERWISE,
-C INFO IS SET AS FOLLOWS.
-C
-C INFO = 0 IMPROPER INPUT PARAMETERS.
-C
-C INFO = 1 RELATIVE ERROR BETWEEN TWO CONSECUTIVE ITERATES
-C IS AT MOST XTOL.
-C
-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.
-C
-C INFO = 4 ITERATION IS NOT MAKING GOOD PROGRESS, AS
-C MEASURED BY THE IMPROVEMENT FROM THE LAST
-C FIVE JACOBIAN EVALUATIONS.
-C
-C INFO = 5 ITERATION IS NOT MAKING GOOD PROGRESS, AS
-C MEASURED BY THE IMPROVEMENT FROM THE LAST
-C TEN ITERATIONS.
-C
-C NFEV IS AN INTEGER OUTPUT VARIABLE SET TO THE NUMBER OF
-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 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
-C OF THE FINAL APPROXIMATE JACOBIAN, STORED ROWWISE.
-C
-C LR IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN
-C (N*(N+1))/2.
-C
-C QTF IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS
-C THE VECTOR (Q TRANSPOSE)*FVEC.
-C
-C WA1, WA2, WA3, AND WA4 ARE WORK ARRAYS OF LENGTH N.
-C
-C SUBPROGRAMS CALLED
-C
-C USER-SUPPLIED ...... FCN
-C
-C MINPACK-SUPPLIED ... DOGLEG,SPMPAR,ENORM,FDJAC1,
-C QFORM,QRFAC,R1MPYQ,R1UPDT
-C
-C FORTRAN-SUPPLIED ... ABS,AMAX1,AMIN1,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,MSUM,NCFAIL,NCSUC,NSLOW1,NSLOW2
- INTEGER IWA(1)
- LOGICAL JEVAL,SING
- REAL ACTRED,DELTA,EPSMCH,FNORM,FNORM1,ONE,PNORM,PRERED,P1,P5,
- * P001,P0001,RATIO,SUM,TEMP,XNORM,ZERO
- REAL SPMPAR,ENORM
- DATA ONE,P1,P5,P001,P0001,ZERO
- * /1.0E0,1.0E-1,5.0E-1,1.0E-3,1.0E-4,0.0E0/
-C
-C EPSMCH IS THE MACHINE PRECISION.
-C
- EPSMCH = SPMPAR(1)
-C
- INFO = 0
- IFLAG = 0
- NFEV = 0
-C
-C CHECK THE INPUT PARAMETERS FOR ERRORS.
-C
- 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
- 10 CONTINUE
- 20 CONTINUE
-C
-C EVALUATE THE FUNCTION AT THE STARTING POINT
-C AND CALCULATE ITS NORM.
-C
- IFLAG = 1
- 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
- NCSUC = 0
- NCFAIL = 0
- NSLOW1 = 0
- NSLOW2 = 0
-C
-C BEGINNING OF THE OUTER LOOP.
-C
- 30 CONTINUE
- JEVAL = .TRUE.
-C
-C CALCULATE THE JACOBIAN MATRIX.
-C
- IFLAG = 2
- 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.
-C
- CALL QRFAC(N,N,FJAC,LDFJAC,.FALSE.,IWA,1,WA1,WA2,WA3)
-C
-C ON THE FIRST ITERATION AND IF MODE IS 1, SCALE ACCORDING
-C TO THE NORMS OF THE COLUMNS OF THE INITIAL JACOBIAN.
-C
- IF (ITER .NE. 1) GO TO 70
- IF (MODE .EQ. 2) GO TO 50
- DO 40 J = 1, N
- DIAG(J) = WA2(J)
- IF (WA2(J) .EQ. ZERO) DIAG(J) = ONE
- 40 CONTINUE
- 50 CONTINUE
-C
-C ON THE FIRST ITERATION, CALCULATE THE NORM OF THE SCALED X
-C AND INITIALIZE THE STEP BOUND DELTA.
-C
- DO 60 J = 1, N
- WA3(J) = DIAG(J)*X(J)
- 60 CONTINUE
- XNORM = ENORM(N,WA3)
- DELTA = FACTOR*XNORM
- IF (DELTA .EQ. ZERO) DELTA = FACTOR
- 70 CONTINUE
-C
-C FORM (Q TRANSPOSE)*FVEC AND STORE IN QTF.
-C
- DO 80 I = 1, N
- QTF(I) = FVEC(I)
- 80 CONTINUE
- DO 120 J = 1, N
- IF (FJAC(J,J) .EQ. ZERO) GO TO 110
- SUM = ZERO
- DO 90 I = J, N
- SUM = SUM + FJAC(I,J)*QTF(I)
- 90 CONTINUE
- TEMP = -SUM/FJAC(J,J)
- DO 100 I = J, N
- QTF(I) = QTF(I) + FJAC(I,J)*TEMP
- 100 CONTINUE
- 110 CONTINUE
- 120 CONTINUE
-C
-C COPY THE TRIANGULAR FACTOR OF THE QR FACTORIZATION INTO R.
-C
- SING = .FALSE.
- DO 150 J = 1, N
- L = J
- JM1 = J - 1
- IF (JM1 .LT. 1) GO TO 140
- DO 130 I = 1, JM1
- R(L) = FJAC(I,J)
- L = L + N - I
- 130 CONTINUE
- 140 CONTINUE
- R(L) = WA1(J)
- IF (WA1(J) .EQ. ZERO) SING = .TRUE.
- 150 CONTINUE
-C
-C ACCUMULATE THE ORTHOGONAL FACTOR IN FJAC.
-C
- CALL QFORM(N,N,FJAC,LDFJAC,WA1)
-C
-C RESCALE IF NECESSARY.
-C
- IF (MODE .EQ. 2) GO TO 170
- DO 160 J = 1, N
- DIAG(J) = AMAX1(DIAG(J),WA2(J))
- 160 CONTINUE
- 170 CONTINUE
-C
-C BEGINNING OF THE INNER LOOP.
-C
- 180 CONTINUE
-C
-C IF REQUESTED, CALL FCN TO ENABLE PRINTING OF ITERATES.
-C
- IF (NPRINT .LE. 0) GO TO 190
- IFLAG = 0
- IF (MOD(ITER-1,NPRINT) .EQ. 0) CALL FCN(N,X,FVEC,IFLAG)
- IF (IFLAG .LT. 0) GO TO 300
- 190 CONTINUE
-C
-C DETERMINE THE DIRECTION P.
-C
- CALL DOGLEG(N,R,LR,DIAG,QTF,DELTA,WA1,WA2,WA3)
-C
-C STORE THE DIRECTION P AND X + P. CALCULATE THE NORM OF P.
-C
- DO 200 J = 1, N
- WA1(J) = -WA1(J)
- WA2(J) = X(J) + WA1(J)
- WA3(J) = DIAG(J)*WA1(J)
- 200 CONTINUE
- PNORM = ENORM(N,WA3)
-C
-C ON THE FIRST ITERATION, ADJUST THE INITIAL STEP BOUND.
-C
- IF (ITER .EQ. 1) DELTA = AMIN1(DELTA,PNORM)
-C
-C EVALUATE THE FUNCTION AT X + P AND CALCULATE ITS NORM.
-C
- IFLAG = 1
- CALL FCN(N,WA2,WA4,IFLAG)
- NFEV = NFEV + 1
- IF (IFLAG .LT. 0) GO TO 300
- FNORM1 = ENORM(N,WA4)
-C
-C COMPUTE THE SCALED ACTUAL REDUCTION.
-C
- ACTRED = -ONE
- IF (FNORM1 .LT. FNORM) ACTRED = ONE - (FNORM1/FNORM)**2
-C
-C COMPUTE THE SCALED PREDICTED REDUCTION.
-C
- L = 1
- DO 220 I = 1, N
- SUM = ZERO
- DO 210 J = I, N
- SUM = SUM + R(L)*WA1(J)
- L = L + 1
- 210 CONTINUE
- WA3(I) = QTF(I) + SUM
- 220 CONTINUE
- TEMP = ENORM(N,WA3)
- PRERED = ZERO
- IF (TEMP .LT. FNORM) PRERED = ONE - (TEMP/FNORM)**2
-C
-C COMPUTE THE RATIO OF THE ACTUAL TO THE PREDICTED
-C REDUCTION.
-C
- RATIO = ZERO
- IF (PRERED .GT. ZERO) RATIO = ACTRED/PRERED
-C
-C UPDATE THE STEP BOUND.
-C
- IF (RATIO .GE. P1) GO TO 230
- NCSUC = 0
- NCFAIL = NCFAIL + 1
- DELTA = P5*DELTA
- GO TO 240
- 230 CONTINUE
- NCFAIL = 0
- NCSUC = NCSUC + 1
- IF (RATIO .GE. P5 .OR. NCSUC .GT. 1)
- * DELTA = AMAX1(DELTA,PNORM/P5)
- IF (ABS(RATIO-ONE) .LE. P1) DELTA = PNORM/P5
- 240 CONTINUE
-C
-C TEST FOR SUCCESSFUL ITERATION.
-C
- IF (RATIO .LT. P0001) GO TO 260
-C
-C SUCCESSFUL ITERATION. UPDATE X, FVEC, AND THEIR NORMS.
-C
- DO 250 J = 1, N
- X(J) = WA2(J)
- WA2(J) = DIAG(J)*X(J)
- FVEC(J) = WA4(J)
- 250 CONTINUE
- XNORM = ENORM(N,WA2)
- FNORM = FNORM1
- ITER = ITER + 1
- 260 CONTINUE
-C
-C DETERMINE THE PROGRESS OF THE ITERATION.
-C
- NSLOW1 = NSLOW1 + 1
- IF (ACTRED .GE. P001) NSLOW1 = 0
- IF (JEVAL) NSLOW2 = NSLOW2 + 1
- IF (ACTRED .GE. P1) NSLOW2 = 0
-C
-C TEST FOR CONVERGENCE.
-C
- IF (DELTA .LE. XTOL*XNORM .OR. FNORM .EQ. ZERO) INFO = 1
- IF (INFO .NE. 0) GO TO 300
-C
-C TESTS FOR TERMINATION AND STRINGENT TOLERANCES.
-C
- IF (NFEV .GE. MAXFEV) INFO = 2
- IF (P1*AMAX1(P1*DELTA,PNORM) .LE. EPSMCH*XNORM) INFO = 3
- IF (NSLOW2 .EQ. 5) INFO = 4
- IF (NSLOW1 .EQ. 10) INFO = 5
- IF (INFO .NE. 0) GO TO 300
-C
-C CRITERION FOR RECALCULATING JACOBIAN APPROXIMATION
-C BY FORWARD DIFFERENCES.
-C
- IF (NCFAIL .EQ. 2) GO TO 290
-C
-C CALCULATE THE RANK ONE MODIFICATION TO THE JACOBIAN
-C AND UPDATE QTF IF NECESSARY.
-C
- DO 280 J = 1, N
- SUM = ZERO
- DO 270 I = 1, N
- SUM = SUM + FJAC(I,J)*WA4(I)
- 270 CONTINUE
- WA2(J) = (SUM - WA3(J))/PNORM
- WA1(J) = DIAG(J)*((DIAG(J)*WA1(J))/PNORM)
- IF (RATIO .GE. P0001) QTF(J) = SUM
- 280 CONTINUE
-C
-C COMPUTE THE QR FACTORIZATION OF THE UPDATED JACOBIAN.
-C
- CALL R1UPDT(N,N,R,LR,WA1,WA2,WA3,SING)
- CALL R1MPYQ(N,N,FJAC,LDFJAC,WA2,WA3)
- CALL R1MPYQ(1,N,QTF,1,WA2,WA3)
-C
-C END OF THE INNER LOOP.
-C
- JEVAL = .FALSE.
- GO TO 180
- 290 CONTINUE
-C
-C END OF THE OUTER LOOP.
-C
- GO TO 30
- 300 CONTINUE
-C
-C TERMINATION, EITHER NORMAL OR USER IMPOSED.
-C
- IF (IFLAG .LT. 0) INFO = IFLAG
- IFLAG = 0
- IF (NPRINT .GT. 0) CALL FCN(N,X,FVEC,IFLAG)
- RETURN
-C
-C LAST CARD OF SUBROUTINE HYBRD.
-C
- END
- SUBROUTINE HYBRD1(FCN,N,X,FVEC,TOL,INFO,WA,LWA)
- INTEGER N,INFO,LWA
- REAL TOL
- REAL X(N),FVEC(N),WA(LWA)
- EXTERNAL FCN
-C **********
-C
-C SUBROUTINE HYBRD1
-C
-C THE PURPOSE OF HYBRD1 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. THIS IS DONE BY USING THE
-C MORE GENERAL NONLINEAR EQUATION SOLVER HYBRD. THE USER
-C MUST PROVIDE A SUBROUTINE WHICH CALCULATES THE FUNCTIONS.
-C THE JACOBIAN IS THEN CALCULATED BY A FORWARD-DIFFERENCE
-C APPROXIMATION.
-C
-C THE SUBROUTINE STATEMENT IS
-C
-C SUBROUTINE HYBRD1(FCN,N,X,FVEC,TOL,INFO,WA,LWA)
-C
-C WHERE
-C
-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
-C SUBROUTINE FCN(N,X,FVEC,IFLAG)
-C INTEGER N,IFLAG
-C REAL X(N),FVEC(N)
-C ----------
-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 HYBRD1.
-C IN THIS CASE SET IFLAG TO A NEGATIVE INTEGER.
-C
-C N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER
-C OF FUNCTIONS AND VARIABLES.
-C
-C X IS AN ARRAY OF LENGTH N. ON INPUT X MUST CONTAIN
-C AN INITIAL ESTIMATE OF THE SOLUTION VECTOR. ON OUTPUT X
-C CONTAINS THE FINAL ESTIMATE OF THE SOLUTION VECTOR.
-C
-C FVEC IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS
-C THE FUNCTIONS EVALUATED AT THE OUTPUT X.
-C
-C TOL IS A NONNEGATIVE INPUT VARIABLE. TERMINATION OCCURS
-C WHEN THE ALGORITHM ESTIMATES THAT THE RELATIVE ERROR
-C BETWEEN X AND THE SOLUTION IS AT MOST TOL.
-C
-C INFO IS AN INTEGER OUTPUT VARIABLE. IF THE USER HAS
-C TERMINATED EXECUTION, INFO IS SET TO THE (NEGATIVE)
-C VALUE OF IFLAG. SEE DESCRIPTION OF FCN. OTHERWISE,
-C INFO IS SET AS FOLLOWS.
-C
-C INFO = 0 IMPROPER INPUT PARAMETERS.
-C
-C INFO = 1 ALGORITHM ESTIMATES THAT THE RELATIVE ERROR
-C BETWEEN X AND THE SOLUTION IS AT MOST TOL.
-C
-C INFO = 2 NUMBER OF CALLS TO FCN HAS REACHED OR EXCEEDED
-C 200*(N+1).
-C
-C INFO = 3 TOL IS TOO SMALL. NO FURTHER IMPROVEMENT IN
-C THE APPROXIMATE SOLUTION X IS POSSIBLE.
-C
-C INFO = 4 ITERATION IS NOT MAKING GOOD PROGRESS.
-C
-C WA IS A WORK ARRAY OF LENGTH LWA.
-C
-C LWA IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN
-C (N*(3*N+13))/2.
-C
-C SUBPROGRAMS CALLED
-C
-C USER-SUPPLIED ...... FCN
-C
-C MINPACK-SUPPLIED ... HYBRD
-C
-C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980.
-C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE
-C
-C **********
- INTEGER INDEX,J,LR,MAXFEV,ML,MODE,MU,NFEV,NPRINT
- REAL EPSFCN,FACTOR,ONE,XTOL,ZERO
- DATA FACTOR,ONE,ZERO /1.0E2,1.0E0,0.0E0/
- INFO = 0
-C
-C CHECK THE INPUT PARAMETERS FOR ERRORS.
-C
- IF (N .LE. 0 .OR. TOL .LT. ZERO .OR. LWA .LT. (N*(3*N + 13))/2)
- * GO TO 20
-C
-C CALL HYBRD.
-C
- MAXFEV = 200*(N + 1)
- XTOL = TOL
- ML = N - 1
- MU = N - 1
- EPSFCN = ZERO
- MODE = 2
- DO 10 J = 1, N
- WA(J) = ONE
- 10 CONTINUE
- NPRINT = 0
- LR = (N*(N + 1))/2
- INDEX = 6*N + LR
- CALL HYBRD(FCN,N,X,FVEC,XTOL,MAXFEV,ML,MU,EPSFCN,WA(1),MODE,
- * FACTOR,NPRINT,INFO,NFEV,WA(INDEX+1),N,WA(6*N+1),LR,
- * WA(N+1),WA(2*N+1),WA(3*N+1),WA(4*N+1),WA(5*N+1))
- IF (INFO .EQ. 5) INFO = 4
- 20 CONTINUE
- RETURN
-C
-C LAST CARD OF SUBROUTINE HYBRD1.
-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
- REAL XTOL,FACTOR
- REAL X(N),FVEC(N),FJAC(LDFJAC,N),DIAG(N),R(LR),QTF(N),WA1(N),
- * WA2(N),WA3(N),WA4(N)
-C **********
-C
-C SUBROUTINE HYBRJ
-C
-C THE PURPOSE OF HYBRJ 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
-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
-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
-C SUBROUTINE FCN(N,X,FVEC,FJAC,LDFJAC,IFLAG)
-C INTEGER N,LDFJAC,IFLAG
-C REAL X(N),FVEC(N),FJAC(LDFJAC,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 ---------
-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 IN THIS CASE SET IFLAG TO A NEGATIVE INTEGER.
-C
-C N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER
-C OF FUNCTIONS AND VARIABLES.
-C
-C X IS AN ARRAY OF LENGTH N. ON INPUT X MUST CONTAIN
-C AN INITIAL ESTIMATE OF THE SOLUTION VECTOR. ON OUTPUT X
-C CONTAINS THE FINAL ESTIMATE OF THE SOLUTION VECTOR.
-C
-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
-C DIAG IS AN ARRAY OF LENGTH N. IF MODE = 1 (SEE
-C BELOW), DIAG IS INTERNALLY SET. IF MODE = 2, DIAG
-C MUST CONTAIN POSITIVE ENTRIES THAT SERVE AS
-C MULTIPLICATIVE SCALE FACTORS FOR THE VARIABLES.
-C
-C MODE IS AN INTEGER INPUT VARIABLE. IF MODE = 1, THE
-C VARIABLES WILL BE SCALED INTERNALLY. IF MODE = 2,
-C THE SCALING IS SPECIFIED BY THE INPUT DIAG. OTHER
-C VALUES OF MODE ARE EQUIVALENT TO MODE = 1.
-C
-C FACTOR IS A POSITIVE INPUT VARIABLE USED IN DETERMINING THE
-C INITIAL STEP BOUND. THIS BOUND IS SET TO THE PRODUCT OF
-C FACTOR AND THE EUCLIDEAN NORM OF DIAG*X IF NONZERO, OR ELSE
-C TO FACTOR ITSELF. IN MOST CASES FACTOR SHOULD LIE IN THE
-C INTERVAL (.1,100.). 100. IS A GENERALLY RECOMMENDED VALUE.
-C
-C NPRINT IS AN INTEGER INPUT VARIABLE THAT ENABLES CONTROLLED
-C PRINTING OF ITERATES IF IT IS POSITIVE. IN THIS CASE,
-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
-C INFO IS AN INTEGER OUTPUT VARIABLE. IF THE USER HAS
-C TERMINATED EXECUTION, INFO IS SET TO THE (NEGATIVE)
-C VALUE OF IFLAG. SEE DESCRIPTION OF FCN. OTHERWISE,
-C INFO IS SET AS FOLLOWS.
-C
-C INFO = 0 IMPROPER INPUT PARAMETERS.
-C
-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
-C INFO = 3 XTOL IS TOO SMALL. NO FURTHER IMPROVEMENT IN
-C THE APPROXIMATE SOLUTION X IS POSSIBLE.
-C
-C INFO = 4 ITERATION IS NOT MAKING GOOD PROGRESS, AS
-C MEASURED BY THE IMPROVEMENT FROM THE LAST
-C FIVE JACOBIAN EVALUATIONS.
-C
-C INFO = 5 ITERATION IS NOT MAKING GOOD PROGRESS, AS
-C MEASURED BY THE IMPROVEMENT FROM THE LAST
-C TEN ITERATIONS.
-C
-C NFEV IS AN INTEGER OUTPUT VARIABLE SET TO THE NUMBER OF
-C CALLS TO FCN WITH IFLAG = 1.
-C
-C NJEV IS AN INTEGER OUTPUT VARIABLE SET TO THE NUMBER OF
-C CALLS TO FCN WITH IFLAG = 2.
-C
-C R IS AN OUTPUT ARRAY OF LENGTH LR WHICH CONTAINS THE
-C UPPER TRIANGULAR MATRIX PRODUCED BY THE QR FACTORIZATION
-C OF THE FINAL APPROXIMATE JACOBIAN, STORED ROWWISE.
-C
-C LR IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN
-C (N*(N+1))/2.
-C
-C QTF IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS
-C THE VECTOR (Q TRANSPOSE)*FVEC.
-C
-C WA1, WA2, WA3, AND WA4 ARE WORK ARRAYS OF LENGTH N.
-C
-C SUBPROGRAMS CALLED
-C
-C USER-SUPPLIED ...... FCN
-C
-C MINPACK-SUPPLIED ... DOGLEG,SPMPAR,ENORM,
-C QFORM,QRFAC,R1MPYQ,R1UPDT
-C
-C FORTRAN-SUPPLIED ... ABS,AMAX1,AMIN1,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 IWA(1)
- LOGICAL JEVAL,SING
- REAL ACTRED,DELTA,EPSMCH,FNORM,FNORM1,ONE,PNORM,PRERED,P1,P5,
- * P001,P0001,RATIO,SUM,TEMP,XNORM,ZERO
- REAL SPMPAR,ENORM
- DATA ONE,P1,P5,P001,P0001,ZERO
- * /1.0E0,1.0E-1,5.0E-1,1.0E-3,1.0E-4,0.0E0/
-C
-C EPSMCH IS THE MACHINE PRECISION.
-C
- EPSMCH = SPMPAR(1)
-C
- 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 (MODE .NE. 2) GO TO 20
- DO 10 J = 1, N
- IF (DIAG(J) .LE. ZERO) GO TO 300
- 10 CONTINUE
- 20 CONTINUE
-C
-C EVALUATE THE FUNCTION AT THE STARTING POINT
-C AND CALCULATE ITS NORM.
-C
- IFLAG = 1
- CALL FCN(N,X,FVEC,FJAC,LDFJAC,IFLAG)
- NFEV = 1
- IF (IFLAG .LT. 0) GO TO 300
- FNORM = ENORM(N,FVEC)
-C
-C INITIALIZE ITERATION COUNTER AND MONITORS.
-C
- ITER = 1
- NCSUC = 0
- NCFAIL = 0
- NSLOW1 = 0
- NSLOW2 = 0
-C
-C BEGINNING OF THE OUTER LOOP.
-C
- 30 CONTINUE
- JEVAL = .TRUE.
-C
-C CALCULATE THE JACOBIAN MATRIX.
-C
- IFLAG = 2
- CALL FCN(N,X,FVEC,FJAC,LDFJAC,IFLAG)
- NJEV = NJEV + 1
- IF (IFLAG .LT. 0) GO TO 300
-C
-C COMPUTE THE QR FACTORIZATION OF THE JACOBIAN.
-C
- CALL QRFAC(N,N,FJAC,LDFJAC,.FALSE.,IWA,1,WA1,WA2,WA3)
-C
-C ON THE FIRST ITERATION AND IF MODE IS 1, SCALE ACCORDING
-C TO THE NORMS OF THE COLUMNS OF THE INITIAL JACOBIAN.
-C
- IF (ITER .NE. 1) GO TO 70
- IF (MODE .EQ. 2) GO TO 50
- DO 40 J = 1, N
- DIAG(J) = WA2(J)
- IF (WA2(J) .EQ. ZERO) DIAG(J) = ONE
- 40 CONTINUE
- 50 CONTINUE
-C
-C ON THE FIRST ITERATION, CALCULATE THE NORM OF THE SCALED X
-C AND INITIALIZE THE STEP BOUND DELTA.
-C
- DO 60 J = 1, N
- WA3(J) = DIAG(J)*X(J)
- 60 CONTINUE
- XNORM = ENORM(N,WA3)
- DELTA = FACTOR*XNORM
- IF (DELTA .EQ. ZERO) DELTA = FACTOR
- 70 CONTINUE
-C
-C FORM (Q TRANSPOSE)*FVEC AND STORE IN QTF.
-C
- DO 80 I = 1, N
- QTF(I) = FVEC(I)
- 80 CONTINUE
- DO 120 J = 1, N
- IF (FJAC(J,J) .EQ. ZERO) GO TO 110
- SUM = ZERO
- DO 90 I = J, N
- SUM = SUM + FJAC(I,J)*QTF(I)
- 90 CONTINUE
- TEMP = -SUM/FJAC(J,J)
- DO 100 I = J, N
- QTF(I) = QTF(I) + FJAC(I,J)*TEMP
- 100 CONTINUE
- 110 CONTINUE
- 120 CONTINUE
-C
-C COPY THE TRIANGULAR FACTOR OF THE QR FACTORIZATION INTO R.
-C
- SING = .FALSE.
- DO 150 J = 1, N
- L = J
- JM1 = J - 1
- IF (JM1 .LT. 1) GO TO 140
- DO 130 I = 1, JM1
- R(L) = FJAC(I,J)
- L = L + N - I
- 130 CONTINUE
- 140 CONTINUE
- R(L) = WA1(J)
- IF (WA1(J) .EQ. ZERO) SING = .TRUE.
- 150 CONTINUE
-C
-C ACCUMULATE THE ORTHOGONAL FACTOR IN FJAC.
-C
- CALL QFORM(N,N,FJAC,LDFJAC,WA1)
-C
-C RESCALE IF NECESSARY.
-C
- IF (MODE .EQ. 2) GO TO 170
- DO 160 J = 1, N
- DIAG(J) = AMAX1(DIAG(J),WA2(J))
- 160 CONTINUE
- 170 CONTINUE
-C
-C BEGINNING OF THE INNER LOOP.
-C
- 180 CONTINUE
-C
-C IF REQUESTED, CALL FCN TO ENABLE PRINTING OF ITERATES.
-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 (IFLAG .LT. 0) GO TO 300
- 190 CONTINUE
-C
-C DETERMINE THE DIRECTION P.
-C
- CALL DOGLEG(N,R,LR,DIAG,QTF,DELTA,WA1,WA2,WA3)
-C
-C STORE THE DIRECTION P AND X + P. CALCULATE THE NORM OF P.
-C
- DO 200 J = 1, N
- WA1(J) = -WA1(J)
- WA2(J) = X(J) + WA1(J)
- WA3(J) = DIAG(J)*WA1(J)
- 200 CONTINUE
- PNORM = ENORM(N,WA3)
-C
-C ON THE FIRST ITERATION, ADJUST THE INITIAL STEP BOUND.
-C
- IF (ITER .EQ. 1) DELTA = AMIN1(DELTA,PNORM)
-C
-C EVALUATE THE FUNCTION AT X + P AND CALCULATE ITS NORM.
-C
- IFLAG = 1
- CALL FCN(N,WA2,WA4,FJAC,LDFJAC,IFLAG)
- NFEV = NFEV + 1
- IF (IFLAG .LT. 0) GO TO 300
- FNORM1 = ENORM(N,WA4)
-C
-C COMPUTE THE SCALED ACTUAL REDUCTION.
-C
- ACTRED = -ONE
- IF (FNORM1 .LT. FNORM) ACTRED = ONE - (FNORM1/FNORM)**2
-C
-C COMPUTE THE SCALED PREDICTED REDUCTION.
-C
- L = 1
- DO 220 I = 1, N
- SUM = ZERO
- DO 210 J = I, N
- SUM = SUM + R(L)*WA1(J)
- L = L + 1
- 210 CONTINUE
- WA3(I) = QTF(I) + SUM
- 220 CONTINUE
- TEMP = ENORM(N,WA3)
- PRERED = ZERO
- IF (TEMP .LT. FNORM) PRERED = ONE - (TEMP/FNORM)**2
-C
-C COMPUTE THE RATIO OF THE ACTUAL TO THE PREDICTED
-C REDUCTION.
-C
- RATIO = ZERO
- IF (PRERED .GT. ZERO) RATIO = ACTRED/PRERED
-C
-C UPDATE THE STEP BOUND.
-C
- IF (RATIO .GE. P1) GO TO 230
- NCSUC = 0
- NCFAIL = NCFAIL + 1
- DELTA = P5*DELTA
- GO TO 240
- 230 CONTINUE
- NCFAIL = 0
- NCSUC = NCSUC + 1
- IF (RATIO .GE. P5 .OR. NCSUC .GT. 1)
- * DELTA = AMAX1(DELTA,PNORM/P5)
- IF (ABS(RATIO-ONE) .LE. P1) DELTA = PNORM/P5
- 240 CONTINUE
-C
-C TEST FOR SUCCESSFUL ITERATION.
-C
- IF (RATIO .LT. P0001) GO TO 260
-C
-C SUCCESSFUL ITERATION. UPDATE X, FVEC, AND THEIR NORMS.
-C
- DO 250 J = 1, N
- X(J) = WA2(J)
- WA2(J) = DIAG(J)*X(J)
- FVEC(J) = WA4(J)
- 250 CONTINUE
- XNORM = ENORM(N,WA2)
- FNORM = FNORM1
- ITER = ITER + 1
- 260 CONTINUE
-C
-C DETERMINE THE PROGRESS OF THE ITERATION.
-C
- NSLOW1 = NSLOW1 + 1
- IF (ACTRED .GE. P001) NSLOW1 = 0
- IF (JEVAL) NSLOW2 = NSLOW2 + 1
- IF (ACTRED .GE. P1) NSLOW2 = 0
-C
-C TEST FOR CONVERGENCE.
-C
- IF (DELTA .LE. XTOL*XNORM .OR. FNORM .EQ. ZERO) INFO = 1
- IF (INFO .NE. 0) GO TO 300
-C
-C TESTS FOR TERMINATION AND STRINGENT TOLERANCES.
-C
- IF (NFEV .GE. MAXFEV) INFO = 2
- IF (P1*AMAX1(P1*DELTA,PNORM) .LE. EPSMCH*XNORM) INFO = 3
- IF (NSLOW2 .EQ. 5) INFO = 4
- IF (NSLOW1 .EQ. 10) INFO = 5
- IF (INFO .NE. 0) GO TO 300
-C
-C CRITERION FOR RECALCULATING JACOBIAN.
-C
- IF (NCFAIL .EQ. 2) GO TO 290
-C
-C CALCULATE THE RANK ONE MODIFICATION TO THE JACOBIAN
-C AND UPDATE QTF IF NECESSARY.
-C
- DO 280 J = 1, N
- SUM = ZERO
- DO 270 I = 1, N
- SUM = SUM + FJAC(I,J)*WA4(I)
- 270 CONTINUE
- WA2(J) = (SUM - WA3(J))/PNORM
- WA1(J) = DIAG(J)*((DIAG(J)*WA1(J))/PNORM)
- IF (RATIO .GE. P0001) QTF(J) = SUM
- 280 CONTINUE
-C
-C COMPUTE THE QR FACTORIZATION OF THE UPDATED JACOBIAN.
-C
- CALL R1UPDT(N,N,R,LR,WA1,WA2,WA3,SING)
- CALL R1MPYQ(N,N,FJAC,LDFJAC,WA2,WA3)
- CALL R1MPYQ(1,N,QTF,1,WA2,WA3)
-C
-C END OF THE INNER LOOP.
-C
- JEVAL = .FALSE.
- GO TO 180
- 290 CONTINUE
-C
-C END OF THE OUTER LOOP.
-C
- GO TO 30
- 300 CONTINUE
-C
-C TERMINATION, EITHER NORMAL OR USER IMPOSED.
-C
- IF (IFLAG .LT. 0) INFO = IFLAG
- IFLAG = 0
- IF (NPRINT .GT. 0) CALL FCN(N,X,FVEC,FJAC,LDFJAC,IFLAG)
- RETURN
-C
-C LAST CARD OF SUBROUTINE HYBRJ.
-C
- END
- SUBROUTINE HYBRJ1(FCN,N,X,FVEC,FJAC,LDFJAC,TOL,INFO,WA,LWA)
- INTEGER N,LDFJAC,INFO,LWA
- REAL TOL
- REAL X(N),FVEC(N),FJAC(LDFJAC,N),WA(LWA)
- EXTERNAL FCN
-C **********
-C
-C SUBROUTINE HYBRJ1
-C
-C THE PURPOSE OF HYBRJ1 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. THIS IS DONE BY USING THE
-C MORE GENERAL NONLINEAR EQUATION SOLVER HYBRJ. THE USER
-C MUST PROVIDE A SUBROUTINE WHICH CALCULATES THE FUNCTIONS
-C AND THE JACOBIAN.
-C
-C THE SUBROUTINE STATEMENT IS
-C
-C SUBROUTINE HYBRJ1(FCN,N,X,FVEC,FJAC,LDFJAC,TOL,INFO,WA,LWA)
-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
-C SUBROUTINE FCN(N,X,FVEC,FJAC,LDFJAC,IFLAG)
-C INTEGER N,LDFJAC,IFLAG
-C REAL X(N),FVEC(N),FJAC(LDFJAC,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 ---------
-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 HYBRJ1.
-C IN THIS CASE SET IFLAG TO A NEGATIVE INTEGER.
-C
-C N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER
-C OF FUNCTIONS AND VARIABLES.
-C
-C X IS AN ARRAY OF LENGTH N. ON INPUT X MUST CONTAIN
-C AN INITIAL ESTIMATE OF THE SOLUTION VECTOR. ON OUTPUT X
-C CONTAINS THE FINAL ESTIMATE OF THE SOLUTION VECTOR.
-C
-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 TOL IS A NONNEGATIVE INPUT VARIABLE. TERMINATION OCCURS
-C WHEN THE ALGORITHM ESTIMATES THAT THE RELATIVE ERROR
-C BETWEEN X AND THE SOLUTION IS AT MOST TOL.
-C
-C INFO IS AN INTEGER OUTPUT VARIABLE. IF THE USER HAS
-C TERMINATED EXECUTION, INFO IS SET TO THE (NEGATIVE)
-C VALUE OF IFLAG. SEE DESCRIPTION OF FCN. OTHERWISE,
-C INFO IS SET AS FOLLOWS.
-C
-C INFO = 0 IMPROPER INPUT PARAMETERS.
-C
-C INFO = 1 ALGORITHM ESTIMATES THAT THE RELATIVE ERROR
-C BETWEEN X AND THE SOLUTION IS AT MOST TOL.
-C
-C INFO = 2 NUMBER OF CALLS TO FCN WITH IFLAG = 1 HAS
-C REACHED 100*(N+1).
-C
-C INFO = 3 TOL IS TOO SMALL. NO FURTHER IMPROVEMENT IN
-C THE APPROXIMATE SOLUTION X IS POSSIBLE.
-C
-C INFO = 4 ITERATION IS NOT MAKING GOOD PROGRESS.
-C
-C WA IS A WORK ARRAY OF LENGTH LWA.
-C
-C LWA IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN
-C (N*(N+13))/2.
-C
-C SUBPROGRAMS CALLED
-C
-C USER-SUPPLIED ...... FCN
-C
-C MINPACK-SUPPLIED ... HYBRJ
-C
-C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980.
-C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE
-C
-C **********
- INTEGER J,LR,MAXFEV,MODE,NFEV,NJEV,NPRINT
- REAL FACTOR,ONE,XTOL,ZERO
- DATA FACTOR,ONE,ZERO /1.0E2,1.0E0,0.0E0/
- INFO = 0
-C
-C CHECK THE INPUT PARAMETERS FOR ERRORS.
-C
- IF (N .LE. 0 .OR. LDFJAC .LT. N .OR. TOL .LT. ZERO
- * .OR. LWA .LT. (N*(N + 13))/2) GO TO 20
-C
-C CALL HYBRJ.
-C
- MAXFEV = 100*(N + 1)
- XTOL = TOL
- MODE = 2
- DO 10 J = 1, N
- WA(J) = ONE
- 10 CONTINUE
- NPRINT = 0
- LR = (N*(N + 1))/2
- CALL HYBRJ(FCN,N,X,FVEC,FJAC,LDFJAC,XTOL,MAXFEV,WA(1),MODE,
- * FACTOR,NPRINT,INFO,NFEV,NJEV,WA(6*N+1),LR,WA(N+1),
- * WA(2*N+1),WA(3*N+1),WA(4*N+1),WA(5*N+1))
- IF (INFO .EQ. 5) INFO = 4
- 20 CONTINUE
- RETURN
-C
-C LAST CARD OF SUBROUTINE HYBRJ1.
-C
- END
- SUBROUTINE LMDER(FCN,M,N,X,FVEC,FJAC,LDFJAC,FTOL,XTOL,GTOL,
- * MAXFEV,DIAG,MODE,FACTOR,NPRINT,INFO,NFEV,NJEV,
- * IPVT,QTF,WA1,WA2,WA3,WA4)
- INTEGER M,N,LDFJAC,MAXFEV,MODE,NPRINT,INFO,NFEV,NJEV
- INTEGER IPVT(N)
- REAL FTOL,XTOL,GTOL,FACTOR
- REAL X(N),FVEC(M),FJAC(LDFJAC,N),DIAG(N),QTF(N),WA1(N),WA2(N),
- * WA3(N),WA4(M)
-C **********
-C
-C SUBROUTINE LMDER
-C
-C THE PURPOSE OF LMDER IS TO MINIMIZE THE SUM OF THE SQUARES OF
-C M NONLINEAR FUNCTIONS IN N VARIABLES BY A MODIFICATION OF
-C THE LEVENBERG-MARQUARDT ALGORITHM. THE USER MUST PROVIDE A
-C SUBROUTINE WHICH CALCULATES THE FUNCTIONS AND THE JACOBIAN.
-C
-C THE SUBROUTINE STATEMENT IS
-C
-C SUBROUTINE LMDER(FCN,M,N,X,FVEC,FJAC,LDFJAC,FTOL,XTOL,GTOL,
-C MAXFEV,DIAG,MODE,FACTOR,NPRINT,INFO,NFEV,
-C NJEV,IPVT,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
-C SUBROUTINE FCN(M,N,X,FVEC,FJAC,LDFJAC,IFLAG)
-C INTEGER M,N,LDFJAC,IFLAG
-C REAL X(N),FVEC(M),FJAC(LDFJAC,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 ----------
-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 LMDER.
-C IN THIS CASE SET IFLAG TO A NEGATIVE INTEGER.
-C
-C M IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER
-C OF FUNCTIONS.
-C
-C N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER
-C OF VARIABLES. N MUST NOT EXCEED M.
-C
-C X IS AN ARRAY OF LENGTH N. ON INPUT X MUST CONTAIN
-C AN INITIAL ESTIMATE OF THE SOLUTION VECTOR. ON OUTPUT X
-C CONTAINS THE FINAL ESTIMATE OF THE SOLUTION VECTOR.
-C
-C FVEC IS AN OUTPUT ARRAY OF LENGTH M WHICH CONTAINS
-C THE FUNCTIONS EVALUATED AT THE OUTPUT X.
-C
-C FJAC IS AN OUTPUT M BY N ARRAY. THE UPPER N BY N SUBMATRIX
-C OF FJAC CONTAINS AN UPPER TRIANGULAR MATRIX R WITH
-C DIAGONAL ELEMENTS OF NONINCREASING MAGNITUDE SUCH THAT
-C
-C T T T
-C P *(JAC *JAC)*P = R *R,
-C
-C WHERE P IS A PERMUTATION MATRIX AND JAC IS THE FINAL
-C CALCULATED JACOBIAN. COLUMN J OF P IS COLUMN IPVT(J)
-C (SEE BELOW) OF THE IDENTITY MATRIX. THE LOWER TRAPEZOIDAL
-C PART OF FJAC CONTAINS INFORMATION GENERATED DURING
-C THE COMPUTATION OF R.
-C
-C LDFJAC IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN M
-C WHICH SPECIFIES THE LEADING DIMENSION OF THE ARRAY FJAC.
-C
-C FTOL IS A NONNEGATIVE INPUT VARIABLE. TERMINATION
-C OCCURS WHEN BOTH THE ACTUAL AND PREDICTED RELATIVE
-C REDUCTIONS IN THE SUM OF SQUARES ARE AT MOST FTOL.
-C THEREFORE, FTOL MEASURES THE RELATIVE ERROR DESIRED
-C IN THE SUM OF SQUARES.
-C
-C XTOL IS A NONNEGATIVE INPUT VARIABLE. TERMINATION
-C OCCURS WHEN THE RELATIVE ERROR BETWEEN TWO CONSECUTIVE
-C ITERATES IS AT MOST XTOL. THEREFORE, XTOL MEASURES THE
-C RELATIVE ERROR DESIRED IN THE APPROXIMATE SOLUTION.
-C
-C GTOL IS A NONNEGATIVE INPUT VARIABLE. TERMINATION
-C OCCURS WHEN THE COSINE OF THE ANGLE BETWEEN FVEC AND
-C ANY COLUMN OF THE JACOBIAN IS AT MOST GTOL IN ABSOLUTE
-C VALUE. THEREFORE, GTOL MEASURES THE ORTHOGONALITY
-C DESIRED BETWEEN THE FUNCTION VECTOR AND THE COLUMNS
-C OF THE JACOBIAN.
-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
-C DIAG IS AN ARRAY OF LENGTH N. IF MODE = 1 (SEE
-C BELOW), DIAG IS INTERNALLY SET. IF MODE = 2, DIAG
-C MUST CONTAIN POSITIVE ENTRIES THAT SERVE AS
-C MULTIPLICATIVE SCALE FACTORS FOR THE VARIABLES.
-C
-C MODE IS AN INTEGER INPUT VARIABLE. IF MODE = 1, THE
-C VARIABLES WILL BE SCALED INTERNALLY. IF MODE = 2,
-C THE SCALING IS SPECIFIED BY THE INPUT DIAG. OTHER
-C VALUES OF MODE ARE EQUIVALENT TO MODE = 1.
-C
-C FACTOR IS A POSITIVE INPUT VARIABLE USED IN DETERMINING THE
-C INITIAL STEP BOUND. THIS BOUND IS SET TO THE PRODUCT OF
-C FACTOR AND THE EUCLIDEAN NORM OF DIAG*X IF NONZERO, OR ELSE
-C TO FACTOR ITSELF. IN MOST CASES FACTOR SHOULD LIE IN THE
-C INTERVAL (.1,100.). 100. IS A GENERALLY RECOMMENDED VALUE.
-C
-C NPRINT IS AN INTEGER INPUT VARIABLE THAT ENABLES CONTROLLED
-C PRINTING OF ITERATES IF IT IS POSITIVE. IN THIS CASE,
-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, FVEC, AND FJAC
-C AVAILABLE FOR PRINTING. FVEC AND FJAC SHOULD NOT BE
-C ALTERED. 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)
-C VALUE OF IFLAG. SEE DESCRIPTION OF FCN. OTHERWISE,
-C INFO IS SET AS FOLLOWS.
-C
-C INFO = 0 IMPROPER INPUT PARAMETERS.
-C
-C INFO = 1 BOTH ACTUAL AND PREDICTED RELATIVE REDUCTIONS
-C IN THE SUM OF SQUARES ARE AT MOST FTOL.
-C
-C INFO = 2 RELATIVE ERROR BETWEEN TWO CONSECUTIVE ITERATES
-C IS AT MOST XTOL.
-C
-C INFO = 3 CONDITIONS FOR INFO = 1 AND INFO = 2 BOTH HOLD.
-C
-C INFO = 4 THE COSINE OF THE ANGLE BETWEEN FVEC AND ANY
-C COLUMN OF THE JACOBIAN IS AT MOST GTOL IN
-C ABSOLUTE VALUE.
-C
-C INFO = 5 NUMBER OF CALLS TO FCN WITH IFLAG = 1 HAS
-C REACHED MAXFEV.
-C
-C INFO = 6 FTOL IS TOO SMALL. NO FURTHER REDUCTION IN
-C THE SUM OF SQUARES IS POSSIBLE.
-C
-C INFO = 7 XTOL IS TOO SMALL. NO FURTHER IMPROVEMENT IN
-C THE APPROXIMATE SOLUTION X IS POSSIBLE.
-C
-C INFO = 8 GTOL IS TOO SMALL. FVEC IS ORTHOGONAL TO THE
-C COLUMNS OF THE JACOBIAN TO MACHINE PRECISION.
-C
-C NFEV IS AN INTEGER OUTPUT VARIABLE SET TO THE NUMBER OF
-C CALLS TO FCN WITH IFLAG = 1.
-C
-C NJEV IS AN INTEGER OUTPUT VARIABLE SET TO THE NUMBER OF
-C CALLS TO FCN WITH IFLAG = 2.
-C
-C IPVT IS AN INTEGER OUTPUT ARRAY OF LENGTH N. IPVT
-C DEFINES A PERMUTATION MATRIX P SUCH THAT JAC*P = Q*R,
-C WHERE JAC IS THE FINAL CALCULATED JACOBIAN, Q IS
-C ORTHOGONAL (NOT STORED), AND R IS UPPER TRIANGULAR
-C WITH DIAGONAL ELEMENTS OF NONINCREASING MAGNITUDE.
-C COLUMN J OF P IS COLUMN IPVT(J) OF THE IDENTITY MATRIX.
-C
-C QTF IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS
-C THE FIRST N ELEMENTS OF THE VECTOR (Q TRANSPOSE)*FVEC.
-C
-C WA1, WA2, AND WA3 ARE WORK ARRAYS OF LENGTH N.
-C
-C WA4 IS A WORK ARRAY OF LENGTH M.
-C
-C SUBPROGRAMS CALLED
-C
-C USER-SUPPLIED ...... FCN
-C
-C MINPACK-SUPPLIED ... SPMPAR,ENORM,LMPAR,QRFAC
-C
-C FORTRAN-SUPPLIED ... ABS,AMAX1,AMIN1,SQRT,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,L
- REAL ACTRED,DELTA,DIRDER,EPSMCH,FNORM,FNORM1,GNORM,ONE,PAR,
- * PNORM,PRERED,P1,P5,P25,P75,P0001,RATIO,SUM,TEMP,TEMP1,
- * TEMP2,XNORM,ZERO
- REAL SPMPAR,ENORM
- DATA ONE,P1,P5,P25,P75,P0001,ZERO
- * /1.0E0,1.0E-1,5.0E-1,2.5E-1,7.5E-1,1.0E-4,0.0E0/
-C
-C EPSMCH IS THE MACHINE PRECISION.
-C
- EPSMCH = SPMPAR(1)
-C
- INFO = 0
- IFLAG = 0
- NFEV = 0
- NJEV = 0
-C
-C CHECK THE INPUT PARAMETERS FOR ERRORS.
-C
- IF (N .LE. 0 .OR. M .LT. N .OR. LDFJAC .LT. M
- * .OR. FTOL .LT. ZERO .OR. XTOL .LT. ZERO .OR. GTOL .LT. ZERO
- * .OR. MAXFEV .LE. 0 .OR. FACTOR .LE. ZERO) GO TO 300
- IF (MODE .NE. 2) GO TO 20
- DO 10 J = 1, N
- IF (DIAG(J) .LE. ZERO) GO TO 300
- 10 CONTINUE
- 20 CONTINUE
-C
-C EVALUATE THE FUNCTION AT THE STARTING POINT
-C AND CALCULATE ITS NORM.
-C
- IFLAG = 1
- CALL FCN(M,N,X,FVEC,FJAC,LDFJAC,IFLAG)
- NFEV = 1
- IF (IFLAG .LT. 0) GO TO 300
- FNORM = ENORM(M,FVEC)
-C
-C INITIALIZE LEVENBERG-MARQUARDT PARAMETER AND ITERATION COUNTER.
-C
- PAR = ZERO
- ITER = 1
-C
-C BEGINNING OF THE OUTER LOOP.
-C
- 30 CONTINUE
-C
-C CALCULATE THE JACOBIAN MATRIX.
-C
- IFLAG = 2
- CALL FCN(M,N,X,FVEC,FJAC,LDFJAC,IFLAG)
- NJEV = NJEV + 1
- IF (IFLAG .LT. 0) GO TO 300
-C
-C IF REQUESTED, CALL FCN TO ENABLE PRINTING OF ITERATES.
-C
- IF (NPRINT .LE. 0) GO TO 40
- IFLAG = 0
- IF (MOD(ITER-1,NPRINT) .EQ. 0)
- * CALL FCN(M,N,X,FVEC,FJAC,LDFJAC,IFLAG)
- IF (IFLAG .LT. 0) GO TO 300
- 40 CONTINUE
-C
-C COMPUTE THE QR FACTORIZATION OF THE JACOBIAN.
-C
- CALL QRFAC(M,N,FJAC,LDFJAC,.TRUE.,IPVT,N,WA1,WA2,WA3)
-C
-C ON THE FIRST ITERATION AND IF MODE IS 1, SCALE ACCORDING
-C TO THE NORMS OF THE COLUMNS OF THE INITIAL JACOBIAN.
-C
- IF (ITER .NE. 1) GO TO 80
- IF (MODE .EQ. 2) GO TO 60
- DO 50 J = 1, N
- DIAG(J) = WA2(J)
- IF (WA2(J) .EQ. ZERO) DIAG(J) = ONE
- 50 CONTINUE
- 60 CONTINUE
-C
-C ON THE FIRST ITERATION, CALCULATE THE NORM OF THE SCALED X
-C AND INITIALIZE THE STEP BOUND DELTA.
-C
- DO 70 J = 1, N
- WA3(J) = DIAG(J)*X(J)
- 70 CONTINUE
- XNORM = ENORM(N,WA3)
- DELTA = FACTOR*XNORM
- IF (DELTA .EQ. ZERO) DELTA = FACTOR
- 80 CONTINUE
-C
-C FORM (Q TRANSPOSE)*FVEC AND STORE THE FIRST N COMPONENTS IN
-C QTF.
-C
- DO 90 I = 1, M
- WA4(I) = FVEC(I)
- 90 CONTINUE
- DO 130 J = 1, N
- IF (FJAC(J,J) .EQ. ZERO) GO TO 120
- SUM = ZERO
- DO 100 I = J, M
- SUM = SUM + FJAC(I,J)*WA4(I)
- 100 CONTINUE
- TEMP = -SUM/FJAC(J,J)
- DO 110 I = J, M
- WA4(I) = WA4(I) + FJAC(I,J)*TEMP
- 110 CONTINUE
- 120 CONTINUE
- FJAC(J,J) = WA1(J)
- QTF(J) = WA4(J)
- 130 CONTINUE
-C
-C COMPUTE THE NORM OF THE SCALED GRADIENT.
-C
- GNORM = ZERO
- IF (FNORM .EQ. ZERO) GO TO 170
- DO 160 J = 1, N
- L = IPVT(J)
- IF (WA2(L) .EQ. ZERO) GO TO 150
- SUM = ZERO
- DO 140 I = 1, J
- SUM = SUM + FJAC(I,J)*(QTF(I)/FNORM)
- 140 CONTINUE
- GNORM = AMAX1(GNORM,ABS(SUM/WA2(L)))
- 150 CONTINUE
- 160 CONTINUE
- 170 CONTINUE
-C
-C TEST FOR CONVERGENCE OF THE GRADIENT NORM.
-C
- IF (GNORM .LE. GTOL) INFO = 4
- IF (INFO .NE. 0) GO TO 300
-C
-C RESCALE IF NECESSARY.
-C
- IF (MODE .EQ. 2) GO TO 190
- DO 180 J = 1, N
- DIAG(J) = AMAX1(DIAG(J),WA2(J))
- 180 CONTINUE
- 190 CONTINUE
-C
-C BEGINNING OF THE INNER LOOP.
-C
- 200 CONTINUE
-C
-C DETERMINE THE LEVENBERG-MARQUARDT PARAMETER.
-C
- CALL LMPAR(N,FJAC,LDFJAC,IPVT,DIAG,QTF,DELTA,PAR,WA1,WA2,
- * WA3,WA4)
-C
-C STORE THE DIRECTION P AND X + P. CALCULATE THE NORM OF P.
-C
- DO 210 J = 1, N
- WA1(J) = -WA1(J)
- WA2(J) = X(J) + WA1(J)
- WA3(J) = DIAG(J)*WA1(J)
- 210 CONTINUE
- PNORM = ENORM(N,WA3)
-C
-C ON THE FIRST ITERATION, ADJUST THE INITIAL STEP BOUND.
-C
- IF (ITER .EQ. 1) DELTA = AMIN1(DELTA,PNORM)
-C
-C EVALUATE THE FUNCTION AT X + P AND CALCULATE ITS NORM.
-C
- IFLAG = 1
- CALL FCN(M,N,WA2,WA4,FJAC,LDFJAC,IFLAG)
- NFEV = NFEV + 1
- IF (IFLAG .LT. 0) GO TO 300
- FNORM1 = ENORM(M,WA4)
-C
-C COMPUTE THE SCALED ACTUAL REDUCTION.
-C
- ACTRED = -ONE
- IF (P1*FNORM1 .LT. FNORM) ACTRED = ONE - (FNORM1/FNORM)**2
-C
-C COMPUTE THE SCALED PREDICTED REDUCTION AND
-C THE SCALED DIRECTIONAL DERIVATIVE.
-C
- DO 230 J = 1, N
- WA3(J) = ZERO
- L = IPVT(J)
- TEMP = WA1(L)
- DO 220 I = 1, J
- WA3(I) = WA3(I) + FJAC(I,J)*TEMP
- 220 CONTINUE
- 230 CONTINUE
- TEMP1 = ENORM(N,WA3)/FNORM
- TEMP2 = (SQRT(PAR)*PNORM)/FNORM
- PRERED = TEMP1**2 + TEMP2**2/P5
- DIRDER = -(TEMP1**2 + TEMP2**2)
-C
-C COMPUTE THE RATIO OF THE ACTUAL TO THE PREDICTED
-C REDUCTION.
-C
- RATIO = ZERO
- IF (PRERED .NE. ZERO) RATIO = ACTRED/PRERED
-C
-C UPDATE THE STEP BOUND.
-C
- IF (RATIO .GT. P25) GO TO 240
- IF (ACTRED .GE. ZERO) TEMP = P5
- IF (ACTRED .LT. ZERO)
- * TEMP = P5*DIRDER/(DIRDER + P5*ACTRED)
- IF (P1*FNORM1 .GE. FNORM .OR. TEMP .LT. P1) TEMP = P1
- DELTA = TEMP*AMIN1(DELTA,PNORM/P1)
- PAR = PAR/TEMP
- GO TO 260
- 240 CONTINUE
- IF (PAR .NE. ZERO .AND. RATIO .LT. P75) GO TO 250
- DELTA = PNORM/P5
- PAR = P5*PAR
- 250 CONTINUE
- 260 CONTINUE
-C
-C TEST FOR SUCCESSFUL ITERATION.
-C
- IF (RATIO .LT. P0001) GO TO 290
-C
-C SUCCESSFUL ITERATION. UPDATE X, FVEC, AND THEIR NORMS.
-C
- DO 270 J = 1, N
- X(J) = WA2(J)
- WA2(J) = DIAG(J)*X(J)
- 270 CONTINUE
- DO 280 I = 1, M
- FVEC(I) = WA4(I)
- 280 CONTINUE
- XNORM = ENORM(N,WA2)
- FNORM = FNORM1
- ITER = ITER + 1
- 290 CONTINUE
-C
-C TESTS FOR CONVERGENCE.
-C
- IF (ABS(ACTRED) .LE. FTOL .AND. PRERED .LE. FTOL
- * .AND. P5*RATIO .LE. ONE) INFO = 1
- IF (DELTA .LE. XTOL*XNORM) INFO = 2
- IF (ABS(ACTRED) .LE. FTOL .AND. PRERED .LE. FTOL
- * .AND. P5*RATIO .LE. ONE .AND. INFO .EQ. 2) INFO = 3
- IF (INFO .NE. 0) GO TO 300
-C
-C TESTS FOR TERMINATION AND STRINGENT TOLERANCES.
-C
- IF (NFEV .GE. MAXFEV) INFO = 5
- IF (ABS(ACTRED) .LE. EPSMCH .AND. PRERED .LE. EPSMCH
- * .AND. P5*RATIO .LE. ONE) INFO = 6
- IF (DELTA .LE. EPSMCH*XNORM) INFO = 7
- IF (GNORM .LE. EPSMCH) INFO = 8
- IF (INFO .NE. 0) GO TO 300
-C
-C END OF THE INNER LOOP. REPEAT IF ITERATION UNSUCCESSFUL.
-C
- IF (RATIO .LT. P0001) GO TO 200
-C
-C END OF THE OUTER LOOP.
-C
- GO TO 30
- 300 CONTINUE
-C
-C TERMINATION, EITHER NORMAL OR USER IMPOSED.
-C
- IF (IFLAG .LT. 0) INFO = IFLAG
- IFLAG = 0
- IF (NPRINT .GT. 0) CALL FCN(M,N,X,FVEC,FJAC,LDFJAC,IFLAG)
- RETURN
-C
-C LAST CARD OF SUBROUTINE LMDER.
-C
- END
- SUBROUTINE LMDER1(FCN,M,N,X,FVEC,FJAC,LDFJAC,TOL,INFO,IPVT,WA,
- * LWA)
- INTEGER M,N,LDFJAC,INFO,LWA
- INTEGER IPVT(N)
- REAL TOL
- REAL X(N),FVEC(M),FJAC(LDFJAC,N),WA(LWA)
- EXTERNAL FCN
-C **********
-C
-C SUBROUTINE LMDER1
-C
-C THE PURPOSE OF LMDER1 IS TO MINIMIZE THE SUM OF THE SQUARES OF
-C M NONLINEAR FUNCTIONS IN N VARIABLES BY A MODIFICATION OF THE
-C LEVENBERG-MARQUARDT ALGORITHM. THIS IS DONE BY USING THE MORE
-C GENERAL LEAST-SQUARES SOLVER LMDER. THE USER MUST PROVIDE A
-C SUBROUTINE WHICH CALCULATES THE FUNCTIONS AND THE JACOBIAN.
-C
-C THE SUBROUTINE STATEMENT IS
-C
-C SUBROUTINE LMDER1(FCN,M,N,X,FVEC,FJAC,LDFJAC,TOL,INFO,
-C IPVT,WA,LWA)
-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
-C SUBROUTINE FCN(M,N,X,FVEC,FJAC,LDFJAC,IFLAG)
-C INTEGER M,N,LDFJAC,IFLAG
-C REAL X(N),FVEC(M),FJAC(LDFJAC,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 ----------
-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 LMDER1.
-C IN THIS CASE SET IFLAG TO A NEGATIVE INTEGER.
-C
-C M IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER
-C OF FUNCTIONS.
-C
-C N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER
-C OF VARIABLES. N MUST NOT EXCEED M.
-C
-C X IS AN ARRAY OF LENGTH N. ON INPUT X MUST CONTAIN
-C AN INITIAL ESTIMATE OF THE SOLUTION VECTOR. ON OUTPUT X
-C CONTAINS THE FINAL ESTIMATE OF THE SOLUTION VECTOR.
-C
-C FVEC IS AN OUTPUT ARRAY OF LENGTH M WHICH CONTAINS
-C THE FUNCTIONS EVALUATED AT THE OUTPUT X.
-C
-C FJAC IS AN OUTPUT M BY N ARRAY. THE UPPER N BY N SUBMATRIX
-C OF FJAC CONTAINS AN UPPER TRIANGULAR MATRIX R WITH
-C DIAGONAL ELEMENTS OF NONINCREASING MAGNITUDE SUCH THAT
-C
-C T T T
-C P *(JAC *JAC)*P = R *R,
-C
-C WHERE P IS A PERMUTATION MATRIX AND JAC IS THE FINAL
-C CALCULATED JACOBIAN. COLUMN J OF P IS COLUMN IPVT(J)
-C (SEE BELOW) OF THE IDENTITY MATRIX. THE LOWER TRAPEZOIDAL
-C PART OF FJAC CONTAINS INFORMATION GENERATED DURING
-C THE COMPUTATION OF R.
-C
-C LDFJAC IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN M
-C WHICH SPECIFIES THE LEADING DIMENSION OF THE ARRAY FJAC.
-C
-C TOL IS A NONNEGATIVE INPUT VARIABLE. TERMINATION OCCURS
-C WHEN THE ALGORITHM ESTIMATES EITHER THAT THE RELATIVE
-C ERROR IN THE SUM OF SQUARES IS AT MOST TOL OR THAT
-C THE RELATIVE ERROR BETWEEN X AND THE SOLUTION IS AT
-C MOST TOL.
-C
-C INFO IS AN INTEGER OUTPUT VARIABLE. IF THE USER HAS
-C TERMINATED EXECUTION, INFO IS SET TO THE (NEGATIVE)
-C VALUE OF IFLAG. SEE DESCRIPTION OF FCN. OTHERWISE,
-C INFO IS SET AS FOLLOWS.
-C
-C INFO = 0 IMPROPER INPUT PARAMETERS.
-C
-C INFO = 1 ALGORITHM ESTIMATES THAT THE RELATIVE ERROR
-C IN THE SUM OF SQUARES IS AT MOST TOL.
-C
-C INFO = 2 ALGORITHM ESTIMATES THAT THE RELATIVE ERROR
-C BETWEEN X AND THE SOLUTION IS AT MOST TOL.
-C
-C INFO = 3 CONDITIONS FOR INFO = 1 AND INFO = 2 BOTH HOLD.
-C
-C INFO = 4 FVEC IS ORTHOGONAL TO THE COLUMNS OF THE
-C JACOBIAN TO MACHINE PRECISION.
-C
-C INFO = 5 NUMBER OF CALLS TO FCN WITH IFLAG = 1 HAS
-C REACHED 100*(N+1).
-C
-C INFO = 6 TOL IS TOO SMALL. NO FURTHER REDUCTION IN
-C THE SUM OF SQUARES IS POSSIBLE.
-C
-C INFO = 7 TOL IS TOO SMALL. NO FURTHER IMPROVEMENT IN
-C THE APPROXIMATE SOLUTION X IS POSSIBLE.
-C
-C IPVT IS AN INTEGER OUTPUT ARRAY OF LENGTH N. IPVT
-C DEFINES A PERMUTATION MATRIX P SUCH THAT JAC*P = Q*R,
-C WHERE JAC IS THE FINAL CALCULATED JACOBIAN, Q IS
-C ORTHOGONAL (NOT STORED), AND R IS UPPER TRIANGULAR
-C WITH DIAGONAL ELEMENTS OF NONINCREASING MAGNITUDE.
-C COLUMN J OF P IS COLUMN IPVT(J) OF THE IDENTITY MATRIX.
-C
-C WA IS A WORK ARRAY OF LENGTH LWA.
-C
-C LWA IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN 5*N+M.
-C
-C SUBPROGRAMS CALLED
-C
-C USER-SUPPLIED ...... FCN
-C
-C MINPACK-SUPPLIED ... LMDER
-C
-C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980.
-C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE
-C
-C **********
- INTEGER MAXFEV,MODE,NFEV,NJEV,NPRINT
- REAL FACTOR,FTOL,GTOL,XTOL,ZERO
- DATA FACTOR,ZERO /1.0E2,0.0E0/
- INFO = 0
-C
-C CHECK THE INPUT PARAMETERS FOR ERRORS.
-C
- IF (N .LE. 0 .OR. M .LT. N .OR. LDFJAC .LT. M .OR. TOL .LT. ZERO
- * .OR. LWA .LT. 5*N + M) GO TO 10
-C
-C CALL LMDER.
-C
- MAXFEV = 100*(N + 1)
- FTOL = TOL
- XTOL = TOL
- GTOL = ZERO
- MODE = 1
- NPRINT = 0
- CALL LMDER(FCN,M,N,X,FVEC,FJAC,LDFJAC,FTOL,XTOL,GTOL,MAXFEV,
- * WA(1),MODE,FACTOR,NPRINT,INFO,NFEV,NJEV,IPVT,WA(N+1),
- * WA(2*N+1),WA(3*N+1),WA(4*N+1),WA(5*N+1))
- IF (INFO .EQ. 8) INFO = 4
- 10 CONTINUE
- RETURN
-C
-C LAST CARD OF SUBROUTINE LMDER1.
-C
- END
- SUBROUTINE LMDIF(FCN,M,N,X,FVEC,FTOL,XTOL,GTOL,MAXFEV,EPSFCN,
- * DIAG,MODE,FACTOR,NPRINT,INFO,NFEV,FJAC,LDFJAC,
- * IPVT,QTF,WA1,WA2,WA3,WA4)
- INTEGER M,N,MAXFEV,MODE,NPRINT,INFO,NFEV,LDFJAC
- INTEGER IPVT(N)
- REAL FTOL,XTOL,GTOL,EPSFCN,FACTOR
- REAL X(N),FVEC(M),DIAG(N),FJAC(LDFJAC,N),QTF(N),WA1(N),WA2(N),
- * WA3(N),WA4(M)
- EXTERNAL FCN
-C **********
-C
-C SUBROUTINE LMDIF
-C
-C THE PURPOSE OF LMDIF IS TO MINIMIZE THE SUM OF THE SQUARES OF
-C M NONLINEAR FUNCTIONS IN N VARIABLES BY A MODIFICATION OF
-C THE LEVENBERG-MARQUARDT ALGORITHM. THE USER MUST PROVIDE A
-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 LMDIF(FCN,M,N,X,FVEC,FTOL,XTOL,GTOL,MAXFEV,EPSFCN,
-C DIAG,MODE,FACTOR,NPRINT,INFO,NFEV,FJAC,
-C LDFJAC,IPVT,QTF,WA1,WA2,WA3,WA4)
-C
-C WHERE
-C
-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
-C SUBROUTINE FCN(M,N,X,FVEC,IFLAG)
-C INTEGER M,N,IFLAG
-C REAL X(N),FVEC(M)
-C ----------
-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 LMDIF.
-C IN THIS CASE SET IFLAG TO A NEGATIVE INTEGER.
-C
-C M IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER
-C OF FUNCTIONS.
-C
-C N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER
-C OF VARIABLES. N MUST NOT EXCEED M.
-C
-C X IS AN ARRAY OF LENGTH N. ON INPUT X MUST CONTAIN
-C AN INITIAL ESTIMATE OF THE SOLUTION VECTOR. ON OUTPUT X
-C CONTAINS THE FINAL ESTIMATE OF THE SOLUTION VECTOR.
-C
-C FVEC IS AN OUTPUT ARRAY OF LENGTH M WHICH CONTAINS
-C THE FUNCTIONS EVALUATED AT THE OUTPUT X.
-C
-C FTOL IS A NONNEGATIVE INPUT VARIABLE. TERMINATION
-C OCCURS WHEN BOTH THE ACTUAL AND PREDICTED RELATIVE
-C REDUCTIONS IN THE SUM OF SQUARES ARE AT MOST FTOL.
-C THEREFORE, FTOL MEASURES THE RELATIVE ERROR DESIRED
-C IN THE SUM OF SQUARES.
-C
-C XTOL IS A NONNEGATIVE INPUT VARIABLE. TERMINATION
-C OCCURS WHEN THE RELATIVE ERROR BETWEEN TWO CONSECUTIVE
-C ITERATES IS AT MOST XTOL. THEREFORE, XTOL MEASURES THE
-C RELATIVE ERROR DESIRED IN THE APPROXIMATE SOLUTION.
-C
-C GTOL IS A NONNEGATIVE INPUT VARIABLE. TERMINATION
-C OCCURS WHEN THE COSINE OF THE ANGLE BETWEEN FVEC AND
-C ANY COLUMN OF THE JACOBIAN IS AT MOST GTOL IN ABSOLUTE
-C VALUE. THEREFORE, GTOL MEASURES THE ORTHOGONALITY
-C DESIRED BETWEEN THE FUNCTION VECTOR AND THE COLUMNS
-C OF THE JACOBIAN.
-C
-C MAXFEV IS A POSITIVE INTEGER INPUT VARIABLE. TERMINATION
-C OCCURS WHEN THE NUMBER OF CALLS TO FCN IS AT LEAST
-C MAXFEV BY THE END OF AN ITERATION.
-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
-C MUST CONTAIN POSITIVE ENTRIES THAT SERVE AS
-C MULTIPLICATIVE SCALE FACTORS FOR THE VARIABLES.
-C
-C MODE IS AN INTEGER INPUT VARIABLE. IF MODE = 1, THE
-C VARIABLES WILL BE SCALED INTERNALLY. IF MODE = 2,
-C THE SCALING IS SPECIFIED BY THE INPUT DIAG. OTHER
-C VALUES OF MODE ARE EQUIVALENT TO MODE = 1.
-C
-C FACTOR IS A POSITIVE INPUT VARIABLE USED IN DETERMINING THE
-C INITIAL STEP BOUND. THIS BOUND IS SET TO THE PRODUCT OF
-C FACTOR AND THE EUCLIDEAN NORM OF DIAG*X IF NONZERO, OR ELSE
-C TO FACTOR ITSELF. IN MOST CASES FACTOR SHOULD LIE IN THE
-C INTERVAL (.1,100.). 100. IS A GENERALLY RECOMMENDED VALUE.
-C
-C NPRINT IS AN INTEGER INPUT VARIABLE THAT ENABLES CONTROLLED
-C PRINTING OF ITERATES IF IT IS POSITIVE. IN THIS CASE,
-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. 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)
-C VALUE OF IFLAG. SEE DESCRIPTION OF FCN. OTHERWISE,
-C INFO IS SET AS FOLLOWS.
-C
-C INFO = 0 IMPROPER INPUT PARAMETERS.
-C
-C INFO = 1 BOTH ACTUAL AND PREDICTED RELATIVE REDUCTIONS
-C IN THE SUM OF SQUARES ARE AT MOST FTOL.
-C
-C INFO = 2 RELATIVE ERROR BETWEEN TWO CONSECUTIVE ITERATES
-C IS AT MOST XTOL.
-C
-C INFO = 3 CONDITIONS FOR INFO = 1 AND INFO = 2 BOTH HOLD.
-C
-C INFO = 4 THE COSINE OF THE ANGLE BETWEEN FVEC AND ANY
-C COLUMN OF THE JACOBIAN IS AT MOST GTOL IN
-C ABSOLUTE VALUE.
-C
-C INFO = 5 NUMBER OF CALLS TO FCN HAS REACHED OR
-C EXCEEDED MAXFEV.
-C
-C INFO = 6 FTOL IS TOO SMALL. NO FURTHER REDUCTION IN
-C THE SUM OF SQUARES IS POSSIBLE.
-C
-C INFO = 7 XTOL IS TOO SMALL. NO FURTHER IMPROVEMENT IN
-C THE APPROXIMATE SOLUTION X IS POSSIBLE.
-C
-C INFO = 8 GTOL IS TOO SMALL. FVEC IS ORTHOGONAL TO THE
-C COLUMNS OF THE JACOBIAN TO MACHINE PRECISION.
-C
-C NFEV IS AN INTEGER OUTPUT VARIABLE SET TO THE NUMBER OF
-C CALLS TO FCN.
-C
-C FJAC IS AN OUTPUT M BY N ARRAY. THE UPPER N BY N SUBMATRIX
-C OF FJAC CONTAINS AN UPPER TRIANGULAR MATRIX R WITH
-C DIAGONAL ELEMENTS OF NONINCREASING MAGNITUDE SUCH THAT
-C
-C T T T
-C P *(JAC *JAC)*P = R *R,
-C
-C WHERE P IS A PERMUTATION MATRIX AND JAC IS THE FINAL
-C CALCULATED JACOBIAN. COLUMN J OF P IS COLUMN IPVT(J)
-C (SEE BELOW) OF THE IDENTITY MATRIX. THE LOWER TRAPEZOIDAL
-C PART OF FJAC CONTAINS INFORMATION GENERATED DURING
-C THE COMPUTATION OF R.
-C
-C LDFJAC IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN M
-C WHICH SPECIFIES THE LEADING DIMENSION OF THE ARRAY FJAC.
-C
-C IPVT IS AN INTEGER OUTPUT ARRAY OF LENGTH N. IPVT
-C DEFINES A PERMUTATION MATRIX P SUCH THAT JAC*P = Q*R,
-C WHERE JAC IS THE FINAL CALCULATED JACOBIAN, Q IS
-C ORTHOGONAL (NOT STORED), AND R IS UPPER TRIANGULAR
-C WITH DIAGONAL ELEMENTS OF NONINCREASING MAGNITUDE.
-C COLUMN J OF P IS COLUMN IPVT(J) OF THE IDENTITY MATRIX.
-C
-C QTF IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS
-C THE FIRST N ELEMENTS OF THE VECTOR (Q TRANSPOSE)*FVEC.
-C
-C WA1, WA2, AND WA3 ARE WORK ARRAYS OF LENGTH N.
-C
-C WA4 IS A WORK ARRAY OF LENGTH M.
-C
-C SUBPROGRAMS CALLED
-C
-C USER-SUPPLIED ...... FCN
-C
-C MINPACK-SUPPLIED ... SPMPAR,ENORM,FDJAC2,LMPAR,QRFAC
-C
-C FORTRAN-SUPPLIED ... ABS,AMAX1,AMIN1,SQRT,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,L
- REAL ACTRED,DELTA,DIRDER,EPSMCH,FNORM,FNORM1,GNORM,ONE,PAR,
- * PNORM,PRERED,P1,P5,P25,P75,P0001,RATIO,SUM,TEMP,TEMP1,
- * TEMP2,XNORM,ZERO
- REAL SPMPAR,ENORM
- DATA ONE,P1,P5,P25,P75,P0001,ZERO
- * /1.0E0,1.0E-1,5.0E-1,2.5E-1,7.5E-1,1.0E-4,0.0E0/
-C
-C EPSMCH IS THE MACHINE PRECISION.
-C
- EPSMCH = SPMPAR(1)
-C
- INFO = 0
- IFLAG = 0
- NFEV = 0
-C
-C CHECK THE INPUT PARAMETERS FOR ERRORS.
-C
- IF (N .LE. 0 .OR. M .LT. N .OR. LDFJAC .LT. M
- * .OR. FTOL .LT. ZERO .OR. XTOL .LT. ZERO .OR. GTOL .LT. ZERO
- * .OR. MAXFEV .LE. 0 .OR. FACTOR .LE. ZERO) GO TO 300
- IF (MODE .NE. 2) GO TO 20
- DO 10 J = 1, N
- IF (DIAG(J) .LE. ZERO) GO TO 300
- 10 CONTINUE
- 20 CONTINUE
-C
-C EVALUATE THE FUNCTION AT THE STARTING POINT
-C AND CALCULATE ITS NORM.
-C
- IFLAG = 1
- CALL FCN(M,N,X,FVEC,IFLAG)
- NFEV = 1
- IF (IFLAG .LT. 0) GO TO 300
- FNORM = ENORM(M,FVEC)
-C
-C INITIALIZE LEVENBERG-MARQUARDT PARAMETER AND ITERATION COUNTER.
-C
- PAR = ZERO
- ITER = 1
-C
-C BEGINNING OF THE OUTER LOOP.
-C
- 30 CONTINUE
-C
-C CALCULATE THE JACOBIAN MATRIX.
-C
- IFLAG = 2
- CALL FDJAC2(FCN,M,N,X,FVEC,FJAC,LDFJAC,IFLAG,EPSFCN,WA4)
- NFEV = NFEV + N
- IF (IFLAG .LT. 0) GO TO 300
-C
-C IF REQUESTED, CALL FCN TO ENABLE PRINTING OF ITERATES.
-C
- IF (NPRINT .LE. 0) GO TO 40
- IFLAG = 0
- IF (MOD(ITER-1,NPRINT) .EQ. 0) CALL FCN(M,N,X,FVEC,IFLAG)
- IF (IFLAG .LT. 0) GO TO 300
- 40 CONTINUE
-C
-C COMPUTE THE QR FACTORIZATION OF THE JACOBIAN.
-C
- CALL QRFAC(M,N,FJAC,LDFJAC,.TRUE.,IPVT,N,WA1,WA2,WA3)
-C
-C ON THE FIRST ITERATION AND IF MODE IS 1, SCALE ACCORDING
-C TO THE NORMS OF THE COLUMNS OF THE INITIAL JACOBIAN.
-C
- IF (ITER .NE. 1) GO TO 80
- IF (MODE .EQ. 2) GO TO 60
- DO 50 J = 1, N
- DIAG(J) = WA2(J)
- IF (WA2(J) .EQ. ZERO) DIAG(J) = ONE
- 50 CONTINUE
- 60 CONTINUE
-C
-C ON THE FIRST ITERATION, CALCULATE THE NORM OF THE SCALED X
-C AND INITIALIZE THE STEP BOUND DELTA.
-C
- DO 70 J = 1, N
- WA3(J) = DIAG(J)*X(J)
- 70 CONTINUE
- XNORM = ENORM(N,WA3)
- DELTA = FACTOR*XNORM
- IF (DELTA .EQ. ZERO) DELTA = FACTOR
- 80 CONTINUE
-C
-C FORM (Q TRANSPOSE)*FVEC AND STORE THE FIRST N COMPONENTS IN
-C QTF.
-C
- DO 90 I = 1, M
- WA4(I) = FVEC(I)
- 90 CONTINUE
- DO 130 J = 1, N
- IF (FJAC(J,J) .EQ. ZERO) GO TO 120
- SUM = ZERO
- DO 100 I = J, M
- SUM = SUM + FJAC(I,J)*WA4(I)
- 100 CONTINUE
- TEMP = -SUM/FJAC(J,J)
- DO 110 I = J, M
- WA4(I) = WA4(I) + FJAC(I,J)*TEMP
- 110 CONTINUE
- 120 CONTINUE
- FJAC(J,J) = WA1(J)
- QTF(J) = WA4(J)
- 130 CONTINUE
-C
-C COMPUTE THE NORM OF THE SCALED GRADIENT.
-C
- GNORM = ZERO
- IF (FNORM .EQ. ZERO) GO TO 170
- DO 160 J = 1, N
- L = IPVT(J)
- IF (WA2(L) .EQ. ZERO) GO TO 150
- SUM = ZERO
- DO 140 I = 1, J
- SUM = SUM + FJAC(I,J)*(QTF(I)/FNORM)
- 140 CONTINUE
- GNORM = AMAX1(GNORM,ABS(SUM/WA2(L)))
- 150 CONTINUE
- 160 CONTINUE
- 170 CONTINUE
-C
-C TEST FOR CONVERGENCE OF THE GRADIENT NORM.
-C
- IF (GNORM .LE. GTOL) INFO = 4
- IF (INFO .NE. 0) GO TO 300
-C
-C RESCALE IF NECESSARY.
-C
- IF (MODE .EQ. 2) GO TO 190
- DO 180 J = 1, N
- DIAG(J) = AMAX1(DIAG(J),WA2(J))
- 180 CONTINUE
- 190 CONTINUE
-C
-C BEGINNING OF THE INNER LOOP.
-C
- 200 CONTINUE
-C
-C DETERMINE THE LEVENBERG-MARQUARDT PARAMETER.
-C
- CALL LMPAR(N,FJAC,LDFJAC,IPVT,DIAG,QTF,DELTA,PAR,WA1,WA2,
- * WA3,WA4)
-C
-C STORE THE DIRECTION P AND X + P. CALCULATE THE NORM OF P.
-C
- DO 210 J = 1, N
- WA1(J) = -WA1(J)
- WA2(J) = X(J) + WA1(J)
- WA3(J) = DIAG(J)*WA1(J)
- 210 CONTINUE
- PNORM = ENORM(N,WA3)
-C
-C ON THE FIRST ITERATION, ADJUST THE INITIAL STEP BOUND.
-C
- IF (ITER .EQ. 1) DELTA = AMIN1(DELTA,PNORM)
-C
-C EVALUATE THE FUNCTION AT X + P AND CALCULATE ITS NORM.
-C
- IFLAG = 1
- CALL FCN(M,N,WA2,WA4,IFLAG)
- NFEV = NFEV + 1
- IF (IFLAG .LT. 0) GO TO 300
- FNORM1 = ENORM(M,WA4)
-C
-C COMPUTE THE SCALED ACTUAL REDUCTION.
-C
- ACTRED = -ONE
- IF (P1*FNORM1 .LT. FNORM) ACTRED = ONE - (FNORM1/FNORM)**2
-C
-C COMPUTE THE SCALED PREDICTED REDUCTION AND
-C THE SCALED DIRECTIONAL DERIVATIVE.
-C
- DO 230 J = 1, N
- WA3(J) = ZERO
- L = IPVT(J)
- TEMP = WA1(L)
- DO 220 I = 1, J
- WA3(I) = WA3(I) + FJAC(I,J)*TEMP
- 220 CONTINUE
- 230 CONTINUE
- TEMP1 = ENORM(N,WA3)/FNORM
- TEMP2 = (SQRT(PAR)*PNORM)/FNORM
- PRERED = TEMP1**2 + TEMP2**2/P5
- DIRDER = -(TEMP1**2 + TEMP2**2)
-C
-C COMPUTE THE RATIO OF THE ACTUAL TO THE PREDICTED
-C REDUCTION.
-C
- RATIO = ZERO
- IF (PRERED .NE. ZERO) RATIO = ACTRED/PRERED
-C
-C UPDATE THE STEP BOUND.
-C
- IF (RATIO .GT. P25) GO TO 240
- IF (ACTRED .GE. ZERO) TEMP = P5
- IF (ACTRED .LT. ZERO)
- * TEMP = P5*DIRDER/(DIRDER + P5*ACTRED)
- IF (P1*FNORM1 .GE. FNORM .OR. TEMP .LT. P1) TEMP = P1
- DELTA = TEMP*AMIN1(DELTA,PNORM/P1)
- PAR = PAR/TEMP
- GO TO 260
- 240 CONTINUE
- IF (PAR .NE. ZERO .AND. RATIO .LT. P75) GO TO 250
- DELTA = PNORM/P5
- PAR = P5*PAR
- 250 CONTINUE
- 260 CONTINUE
-C
-C TEST FOR SUCCESSFUL ITERATION.
-C
- IF (RATIO .LT. P0001) GO TO 290
-C
-C SUCCESSFUL ITERATION. UPDATE X, FVEC, AND THEIR NORMS.
-C
- DO 270 J = 1, N
- X(J) = WA2(J)
- WA2(J) = DIAG(J)*X(J)
- 270 CONTINUE
- DO 280 I = 1, M
- FVEC(I) = WA4(I)
- 280 CONTINUE
- XNORM = ENORM(N,WA2)
- FNORM = FNORM1
- ITER = ITER + 1
- 290 CONTINUE
-C
-C TESTS FOR CONVERGENCE.
-C
- IF (ABS(ACTRED) .LE. FTOL .AND. PRERED .LE. FTOL
- * .AND. P5*RATIO .LE. ONE) INFO = 1
- IF (DELTA .LE. XTOL*XNORM) INFO = 2
- IF (ABS(ACTRED) .LE. FTOL .AND. PRERED .LE. FTOL
- * .AND. P5*RATIO .LE. ONE .AND. INFO .EQ. 2) INFO = 3
- IF (INFO .NE. 0) GO TO 300
-C
-C TESTS FOR TERMINATION AND STRINGENT TOLERANCES.
-C
- IF (NFEV .GE. MAXFEV) INFO = 5
- IF (ABS(ACTRED) .LE. EPSMCH .AND. PRERED .LE. EPSMCH
- * .AND. P5*RATIO .LE. ONE) INFO = 6
- IF (DELTA .LE. EPSMCH*XNORM) INFO = 7
- IF (GNORM .LE. EPSMCH) INFO = 8
- IF (INFO .NE. 0) GO TO 300
-C
-C END OF THE INNER LOOP. REPEAT IF ITERATION UNSUCCESSFUL.
-C
- IF (RATIO .LT. P0001) GO TO 200
-C
-C END OF THE OUTER LOOP.
-C
- GO TO 30
- 300 CONTINUE
-C
-C TERMINATION, EITHER NORMAL OR USER IMPOSED.
-C
- IF (IFLAG .LT. 0) INFO = IFLAG
- IFLAG = 0
- IF (NPRINT .GT. 0) CALL FCN(M,N,X,FVEC,IFLAG)
- RETURN
-C
-C LAST CARD OF SUBROUTINE LMDIF.
-C
- END
- SUBROUTINE LMDIF1(FCN,M,N,X,FVEC,TOL,INFO,IWA,WA,LWA)
- INTEGER M,N,INFO,LWA
- INTEGER IWA(N)
- REAL TOL
- REAL X(N),FVEC(M),WA(LWA)
- EXTERNAL FCN
-C **********
-C
-C SUBROUTINE LMDIF1
-C
-C THE PURPOSE OF LMDIF1 IS TO MINIMIZE THE SUM OF THE SQUARES OF
-C M NONLINEAR FUNCTIONS IN N VARIABLES BY A MODIFICATION OF THE
-C LEVENBERG-MARQUARDT ALGORITHM. THIS IS DONE BY USING THE MORE
-C GENERAL LEAST-SQUARES SOLVER LMDIF. THE USER MUST PROVIDE A
-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 LMDIF1(FCN,M,N,X,FVEC,TOL,INFO,IWA,WA,LWA)
-C
-C WHERE
-C
-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
-C SUBROUTINE FCN(M,N,X,FVEC,IFLAG)
-C INTEGER M,N,IFLAG
-C REAL X(N),FVEC(M)
-C ----------
-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 LMDIF1.
-C IN THIS CASE SET IFLAG TO A NEGATIVE INTEGER.
-C
-C M IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER
-C OF FUNCTIONS.
-C
-C N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER
-C OF VARIABLES. N MUST NOT EXCEED M.
-C
-C X IS AN ARRAY OF LENGTH N. ON INPUT X MUST CONTAIN
-C AN INITIAL ESTIMATE OF THE SOLUTION VECTOR. ON OUTPUT X
-C CONTAINS THE FINAL ESTIMATE OF THE SOLUTION VECTOR.
-C
-C FVEC IS AN OUTPUT ARRAY OF LENGTH M WHICH CONTAINS
-C THE FUNCTIONS EVALUATED AT THE OUTPUT X.
-C
-C TOL IS A NONNEGATIVE INPUT VARIABLE. TERMINATION OCCURS
-C WHEN THE ALGORITHM ESTIMATES EITHER THAT THE RELATIVE
-C ERROR IN THE SUM OF SQUARES IS AT MOST TOL OR THAT
-C THE RELATIVE ERROR BETWEEN X AND THE SOLUTION IS AT
-C MOST TOL.
-C
-C INFO IS AN INTEGER OUTPUT VARIABLE. IF THE USER HAS
-C TERMINATED EXECUTION, INFO IS SET TO THE (NEGATIVE)
-C VALUE OF IFLAG. SEE DESCRIPTION OF FCN. OTHERWISE,
-C INFO IS SET AS FOLLOWS.
-C
-C INFO = 0 IMPROPER INPUT PARAMETERS.
-C
-C INFO = 1 ALGORITHM ESTIMATES THAT THE RELATIVE ERROR
-C IN THE SUM OF SQUARES IS AT MOST TOL.
-C
-C INFO = 2 ALGORITHM ESTIMATES THAT THE RELATIVE ERROR
-C BETWEEN X AND THE SOLUTION IS AT MOST TOL.
-C
-C INFO = 3 CONDITIONS FOR INFO = 1 AND INFO = 2 BOTH HOLD.
-C
-C INFO = 4 FVEC IS ORTHOGONAL TO THE COLUMNS OF THE
-C JACOBIAN TO MACHINE PRECISION.
-C
-C INFO = 5 NUMBER OF CALLS TO FCN HAS REACHED OR
-C EXCEEDED 200*(N+1).
-C
-C INFO = 6 TOL IS TOO SMALL. NO FURTHER REDUCTION IN
-C THE SUM OF SQUARES IS POSSIBLE.
-C
-C INFO = 7 TOL IS TOO SMALL. NO FURTHER IMPROVEMENT IN
-C THE APPROXIMATE SOLUTION X IS POSSIBLE.
-C
-C IWA IS AN INTEGER WORK ARRAY OF LENGTH N.
-C
-C WA IS A WORK ARRAY OF LENGTH LWA.
-C
-C LWA IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN
-C M*N+5*N+M.
-C
-C SUBPROGRAMS CALLED
-C
-C USER-SUPPLIED ...... FCN
-C
-C MINPACK-SUPPLIED ... LMDIF
-C
-C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980.
-C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE
-C
-C **********
- INTEGER MAXFEV,MODE,MP5N,NFEV,NPRINT
- REAL EPSFCN,FACTOR,FTOL,GTOL,XTOL,ZERO
- DATA FACTOR,ZERO /1.0E2,0.0E0/
- INFO = 0
-C
-C CHECK THE INPUT PARAMETERS FOR ERRORS.
-C
- IF (N .LE. 0 .OR. M .LT. N .OR. TOL .LT. ZERO
- * .OR. LWA .LT. M*N + 5*N + M) GO TO 10
-C
-C CALL LMDIF.
-C
- MAXFEV = 200*(N + 1)
- FTOL = TOL
- XTOL = TOL
- GTOL = ZERO
- EPSFCN = ZERO
- MODE = 1
- NPRINT = 0
- MP5N = M + 5*N
- CALL LMDIF(FCN,M,N,X,FVEC,FTOL,XTOL,GTOL,MAXFEV,EPSFCN,WA(1),
- * MODE,FACTOR,NPRINT,INFO,NFEV,WA(MP5N+1),M,IWA,
- * WA(N+1),WA(2*N+1),WA(3*N+1),WA(4*N+1),WA(5*N+1))
- IF (INFO .EQ. 8) INFO = 4
- 10 CONTINUE
- RETURN
-C
-C LAST CARD OF SUBROUTINE LMDIF1.
-C
- END
- SUBROUTINE LMPAR(N,R,LDR,IPVT,DIAG,QTB,DELTA,PAR,X,SDIAG,WA1,
- * WA2)
- INTEGER N,LDR
- INTEGER IPVT(N)
- REAL DELTA,PAR
- REAL R(LDR,N),DIAG(N),QTB(N),X(N),SDIAG(N),WA1(N),WA2(N)
-C **********
-C
-C SUBROUTINE LMPAR
-C
-C GIVEN AN M BY N MATRIX A, AN N BY N NONSINGULAR DIAGONAL
-C MATRIX D, AN M-VECTOR B, AND A POSITIVE NUMBER DELTA,
-C THE PROBLEM IS TO DETERMINE A VALUE FOR THE PARAMETER
-C PAR SUCH THAT IF X SOLVES THE SYSTEM
-C
-C A*X = B , SQRT(PAR)*D*X = 0 ,
-C
-C IN THE LEAST SQUARES SENSE, AND DXNORM IS THE EUCLIDEAN
-C NORM OF D*X, THEN EITHER PAR IS ZERO AND
-C
-C (DXNORM-DELTA) .LE. 0.1*DELTA ,
-C
-C OR PAR IS POSITIVE AND
-C
-C ABS(DXNORM-DELTA) .LE. 0.1*DELTA .
-C
-C THIS SUBROUTINE COMPLETES THE SOLUTION OF THE PROBLEM
-C IF IT IS PROVIDED WITH THE NECESSARY INFORMATION FROM THE
-C QR FACTORIZATION, WITH COLUMN PIVOTING, OF A. THAT IS, IF
-C A*P = Q*R, WHERE P IS A PERMUTATION MATRIX, Q HAS ORTHOGONAL
-C COLUMNS, AND R IS AN UPPER TRIANGULAR MATRIX WITH DIAGONAL
-C ELEMENTS OF NONINCREASING MAGNITUDE, THEN LMPAR EXPECTS
-C THE FULL UPPER TRIANGLE OF R, THE PERMUTATION MATRIX P,
-C AND THE FIRST N COMPONENTS OF (Q TRANSPOSE)*B. ON OUTPUT
-C LMPAR ALSO PROVIDES AN UPPER TRIANGULAR MATRIX S SUCH THAT
-C
-C T T T
-C P *(A *A + PAR*D*D)*P = S *S .
-C
-C S IS EMPLOYED WITHIN LMPAR AND MAY BE OF SEPARATE INTEREST.
-C
-C ONLY A FEW ITERATIONS ARE GENERALLY NEEDED FOR CONVERGENCE
-C OF THE ALGORITHM. IF, HOWEVER, THE LIMIT OF 10 ITERATIONS
-C IS REACHED, THEN THE OUTPUT PAR WILL CONTAIN THE BEST
-C VALUE OBTAINED SO FAR.
-C
-C THE SUBROUTINE STATEMENT IS
-C
-C SUBROUTINE LMPAR(N,R,LDR,IPVT,DIAG,QTB,DELTA,PAR,X,SDIAG,
-C WA1,WA2)
-C
-C WHERE
-C
-C N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE ORDER OF R.
-C
-C R IS AN N BY N ARRAY. ON INPUT THE FULL UPPER TRIANGLE
-C MUST CONTAIN THE FULL UPPER TRIANGLE OF THE MATRIX R.
-C ON OUTPUT THE FULL UPPER TRIANGLE IS UNALTERED, AND THE
-C STRICT LOWER TRIANGLE CONTAINS THE STRICT UPPER TRIANGLE
-C (TRANSPOSED) OF THE UPPER TRIANGULAR MATRIX S.
-C
-C LDR IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN N
-C WHICH SPECIFIES THE LEADING DIMENSION OF THE ARRAY R.
-C
-C IPVT IS AN INTEGER INPUT ARRAY OF LENGTH N WHICH DEFINES THE
-C PERMUTATION MATRIX P SUCH THAT A*P = Q*R. COLUMN J OF P
-C IS COLUMN IPVT(J) OF THE IDENTITY MATRIX.
-C
-C DIAG IS AN INPUT ARRAY OF LENGTH N WHICH MUST CONTAIN THE
-C DIAGONAL ELEMENTS OF THE MATRIX D.
-C
-C QTB IS AN INPUT ARRAY OF LENGTH N WHICH MUST CONTAIN THE FIRST
-C N ELEMENTS OF THE VECTOR (Q TRANSPOSE)*B.
-C
-C DELTA IS A POSITIVE INPUT VARIABLE WHICH SPECIFIES AN UPPER
-C BOUND ON THE EUCLIDEAN NORM OF D*X.
-C
-C PAR IS A NONNEGATIVE VARIABLE. ON INPUT PAR CONTAINS AN
-C INITIAL ESTIMATE OF THE LEVENBERG-MARQUARDT PARAMETER.
-C ON OUTPUT PAR CONTAINS THE FINAL ESTIMATE.
-C
-C X IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS THE LEAST
-C SQUARES SOLUTION OF THE SYSTEM A*X = B, SQRT(PAR)*D*X = 0,
-C FOR THE OUTPUT PAR.
-C
-C SDIAG IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS THE
-C DIAGONAL ELEMENTS OF THE UPPER TRIANGULAR MATRIX S.
-C
-C WA1 AND WA2 ARE WORK ARRAYS OF LENGTH N.
-C
-C SUBPROGRAMS CALLED
-C
-C MINPACK-SUPPLIED ... SPMPAR,ENORM,QRSOLV
-C
-C FORTRAN-SUPPLIED ... ABS,AMAX1,AMIN1,SQRT
-C
-C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980.
-C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE
-C
-C **********
- INTEGER I,ITER,J,JM1,JP1,K,L,NSING
- REAL DXNORM,DWARF,FP,GNORM,PARC,PARL,PARU,P1,P001,SUM,TEMP,ZERO
- REAL SPMPAR,ENORM
- DATA P1,P001,ZERO /1.0E-1,1.0E-3,0.0E0/
-C
-C DWARF IS THE SMALLEST POSITIVE MAGNITUDE.
-C
- DWARF = SPMPAR(2)
-C
-C COMPUTE AND STORE IN X THE GAUSS-NEWTON DIRECTION. IF THE
-C JACOBIAN IS RANK-DEFICIENT, OBTAIN A LEAST SQUARES SOLUTION.
-C
- NSING = N
- DO 10 J = 1, N
- WA1(J) = QTB(J)
- IF (R(J,J) .EQ. ZERO .AND. NSING .EQ. N) NSING = J - 1
- IF (NSING .LT. N) WA1(J) = ZERO
- 10 CONTINUE
- IF (NSING .LT. 1) GO TO 50
- DO 40 K = 1, NSING
- J = NSING - K + 1
- WA1(J) = WA1(J)/R(J,J)
- TEMP = WA1(J)
- JM1 = J - 1
- IF (JM1 .LT. 1) GO TO 30
- DO 20 I = 1, JM1
- WA1(I) = WA1(I) - R(I,J)*TEMP
- 20 CONTINUE
- 30 CONTINUE
- 40 CONTINUE
- 50 CONTINUE
- DO 60 J = 1, N
- L = IPVT(J)
- X(L) = WA1(J)
- 60 CONTINUE
-C
-C INITIALIZE THE ITERATION COUNTER.
-C EVALUATE THE FUNCTION AT THE ORIGIN, AND TEST
-C FOR ACCEPTANCE OF THE GAUSS-NEWTON DIRECTION.
-C
- ITER = 0
- DO 70 J = 1, N
- WA2(J) = DIAG(J)*X(J)
- 70 CONTINUE
- DXNORM = ENORM(N,WA2)
- FP = DXNORM - DELTA
- IF (FP .LE. P1*DELTA) GO TO 220
-C
-C IF THE JACOBIAN IS NOT RANK DEFICIENT, THE NEWTON
-C STEP PROVIDES A LOWER BOUND, PARL, FOR THE ZERO OF
-C THE FUNCTION. OTHERWISE SET THIS BOUND TO ZERO.
-C
- PARL = ZERO
- IF (NSING .LT. N) GO TO 120
- DO 80 J = 1, N
- L = IPVT(J)
- WA1(J) = DIAG(L)*(WA2(L)/DXNORM)
- 80 CONTINUE
- DO 110 J = 1, N
- SUM = ZERO
- JM1 = J - 1
- IF (JM1 .LT. 1) GO TO 100
- DO 90 I = 1, JM1
- SUM = SUM + R(I,J)*WA1(I)
- 90 CONTINUE
- 100 CONTINUE
- WA1(J) = (WA1(J) - SUM)/R(J,J)
- 110 CONTINUE
- TEMP = ENORM(N,WA1)
- PARL = ((FP/DELTA)/TEMP)/TEMP
- 120 CONTINUE
-C
-C CALCULATE AN UPPER BOUND, PARU, FOR THE ZERO OF THE FUNCTION.
-C
- DO 140 J = 1, N
- SUM = ZERO
- DO 130 I = 1, J
- SUM = SUM + R(I,J)*QTB(I)
- 130 CONTINUE
- L = IPVT(J)
- WA1(J) = SUM/DIAG(L)
- 140 CONTINUE
- GNORM = ENORM(N,WA1)
- PARU = GNORM/DELTA
- IF (PARU .EQ. ZERO) PARU = DWARF/AMIN1(DELTA,P1)
-C
-C IF THE INPUT PAR LIES OUTSIDE OF THE INTERVAL (PARL,PARU),
-C SET PAR TO THE CLOSER ENDPOINT.
-C
- PAR = AMAX1(PAR,PARL)
- PAR = AMIN1(PAR,PARU)
- IF (PAR .EQ. ZERO) PAR = GNORM/DXNORM
-C
-C BEGINNING OF AN ITERATION.
-C
- 150 CONTINUE
- ITER = ITER + 1
-C
-C EVALUATE THE FUNCTION AT THE CURRENT VALUE OF PAR.
-C
- IF (PAR .EQ. ZERO) PAR = AMAX1(DWARF,P001*PARU)
- TEMP = SQRT(PAR)
- DO 160 J = 1, N
- WA1(J) = TEMP*DIAG(J)
- 160 CONTINUE
- CALL QRSOLV(N,R,LDR,IPVT,WA1,QTB,X,SDIAG,WA2)
- DO 170 J = 1, N
- WA2(J) = DIAG(J)*X(J)
- 170 CONTINUE
- DXNORM = ENORM(N,WA2)
- TEMP = FP
- FP = DXNORM - DELTA
-C
-C IF THE FUNCTION IS SMALL ENOUGH, ACCEPT THE CURRENT VALUE
-C OF PAR. ALSO TEST FOR THE EXCEPTIONAL CASES WHERE PARL
-C IS ZERO OR THE NUMBER OF ITERATIONS HAS REACHED 10.
-C
- IF (ABS(FP) .LE. P1*DELTA
- * .OR. PARL .EQ. ZERO .AND. FP .LE. TEMP
- * .AND. TEMP .LT. ZERO .OR. ITER .EQ. 10) GO TO 220
-C
-C COMPUTE THE NEWTON CORRECTION.
-C
- DO 180 J = 1, N
- L = IPVT(J)
- WA1(J) = DIAG(L)*(WA2(L)/DXNORM)
- 180 CONTINUE
- DO 210 J = 1, N
- WA1(J) = WA1(J)/SDIAG(J)
- TEMP = WA1(J)
- JP1 = J + 1
- IF (N .LT. JP1) GO TO 200
- DO 190 I = JP1, N
- WA1(I) = WA1(I) - R(I,J)*TEMP
- 190 CONTINUE
- 200 CONTINUE
- 210 CONTINUE
- TEMP = ENORM(N,WA1)
- PARC = ((FP/DELTA)/TEMP)/TEMP
-C
-C DEPENDING ON THE SIGN OF THE FUNCTION, UPDATE PARL OR PARU.
-C
- IF (FP .GT. ZERO) PARL = AMAX1(PARL,PAR)
- IF (FP .LT. ZERO) PARU = AMIN1(PARU,PAR)
-C
-C COMPUTE AN IMPROVED ESTIMATE FOR PAR.
-C
- PAR = AMAX1(PARL,PAR+PARC)
-C
-C END OF AN ITERATION.
-C
- GO TO 150
- 220 CONTINUE
-C
-C TERMINATION.
-C
- IF (ITER .EQ. 0) PAR = ZERO
- RETURN
-C
-C LAST CARD OF SUBROUTINE LMPAR.
-C
- END
- SUBROUTINE LMSTR(FCN,M,N,X,FVEC,FJAC,LDFJAC,FTOL,XTOL,GTOL,
- * MAXFEV,DIAG,MODE,FACTOR,NPRINT,INFO,NFEV,NJEV,
- * IPVT,QTF,WA1,WA2,WA3,WA4)
- INTEGER M,N,LDFJAC,MAXFEV,MODE,NPRINT,INFO,NFEV,NJEV
- INTEGER IPVT(N)
- LOGICAL SING
- REAL FTOL,XTOL,GTOL,FACTOR
- REAL X(N),FVEC(M),FJAC(LDFJAC,N),DIAG(N),QTF(N),WA1(N),WA2(N),
- * WA3(N),WA4(M)
-C **********
-C
-C SUBROUTINE LMSTR
-C
-C THE PURPOSE OF LMSTR IS TO MINIMIZE THE SUM OF THE SQUARES OF
-C M NONLINEAR FUNCTIONS IN N VARIABLES BY A MODIFICATION OF
-C THE LEVENBERG-MARQUARDT ALGORITHM WHICH USES MINIMAL STORAGE.
-C THE USER MUST PROVIDE A SUBROUTINE WHICH CALCULATES THE
-C FUNCTIONS AND THE ROWS OF THE JACOBIAN.
-C
-C THE SUBROUTINE STATEMENT IS
-C
-C SUBROUTINE LMSTR(FCN,M,N,X,FVEC,FJAC,LDFJAC,FTOL,XTOL,GTOL,
-C MAXFEV,DIAG,MODE,FACTOR,NPRINT,INFO,NFEV,
-C NJEV,IPVT,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 ROWS OF THE JACOBIAN.
-C FCN MUST BE DECLARED IN AN EXTERNAL STATEMENT IN THE
-C USER CALLING PROGRAM, AND SHOULD BE WRITTEN AS FOLLOWS.
-C
-C SUBROUTINE FCN(M,N,X,FVEC,FJROW,IFLAG)
-C INTEGER M,N,IFLAG
-C REAL X(N),FVEC(M),FJROW(N)
-C ----------
-C IF IFLAG = 1 CALCULATE THE FUNCTIONS AT X AND
-C RETURN THIS VECTOR IN FVEC.
-C IF IFLAG = I CALCULATE THE (I-1)-ST ROW OF THE
-C JACOBIAN AT X AND RETURN THIS VECTOR IN FJROW.
-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 LMSTR.
-C IN THIS CASE SET IFLAG TO A NEGATIVE INTEGER.
-C
-C M IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER
-C OF FUNCTIONS.
-C
-C N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER
-C OF VARIABLES. N MUST NOT EXCEED M.
-C
-C X IS AN ARRAY OF LENGTH N. ON INPUT X MUST CONTAIN
-C AN INITIAL ESTIMATE OF THE SOLUTION VECTOR. ON OUTPUT X
-C CONTAINS THE FINAL ESTIMATE OF THE SOLUTION VECTOR.
-C
-C FVEC IS AN OUTPUT ARRAY OF LENGTH M WHICH CONTAINS
-C THE FUNCTIONS EVALUATED AT THE OUTPUT X.
-C
-C FJAC IS AN OUTPUT N BY N ARRAY. THE UPPER TRIANGLE OF FJAC
-C CONTAINS AN UPPER TRIANGULAR MATRIX R SUCH THAT
-C
-C T T T
-C P *(JAC *JAC)*P = R *R,
-C
-C WHERE P IS A PERMUTATION MATRIX AND JAC IS THE FINAL
-C CALCULATED JACOBIAN. COLUMN J OF P IS COLUMN IPVT(J)
-C (SEE BELOW) OF THE IDENTITY MATRIX. THE LOWER TRIANGULAR
-C PART OF FJAC CONTAINS INFORMATION GENERATED DURING
-C THE COMPUTATION OF R.
-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 FTOL IS A NONNEGATIVE INPUT VARIABLE. TERMINATION
-C OCCURS WHEN BOTH THE ACTUAL AND PREDICTED RELATIVE
-C REDUCTIONS IN THE SUM OF SQUARES ARE AT MOST FTOL.
-C THEREFORE, FTOL MEASURES THE RELATIVE ERROR DESIRED
-C IN THE SUM OF SQUARES.
-C
-C XTOL IS A NONNEGATIVE INPUT VARIABLE. TERMINATION
-C OCCURS WHEN THE RELATIVE ERROR BETWEEN TWO CONSECUTIVE
-C ITERATES IS AT MOST XTOL. THEREFORE, XTOL MEASURES THE
-C RELATIVE ERROR DESIRED IN THE APPROXIMATE SOLUTION.
-C
-C GTOL IS A NONNEGATIVE INPUT VARIABLE. TERMINATION
-C OCCURS WHEN THE COSINE OF THE ANGLE BETWEEN FVEC AND
-C ANY COLUMN OF THE JACOBIAN IS AT MOST GTOL IN ABSOLUTE
-C VALUE. THEREFORE, GTOL MEASURES THE ORTHOGONALITY
-C DESIRED BETWEEN THE FUNCTION VECTOR AND THE COLUMNS
-C OF THE JACOBIAN.
-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
-C DIAG IS AN ARRAY OF LENGTH N. IF MODE = 1 (SEE
-C BELOW), DIAG IS INTERNALLY SET. IF MODE = 2, DIAG
-C MUST CONTAIN POSITIVE ENTRIES THAT SERVE AS
-C MULTIPLICATIVE SCALE FACTORS FOR THE VARIABLES.
-C
-C MODE IS AN INTEGER INPUT VARIABLE. IF MODE = 1, THE
-C VARIABLES WILL BE SCALED INTERNALLY. IF MODE = 2,
-C THE SCALING IS SPECIFIED BY THE INPUT DIAG. OTHER
-C VALUES OF MODE ARE EQUIVALENT TO MODE = 1.
-C
-C FACTOR IS A POSITIVE INPUT VARIABLE USED IN DETERMINING THE
-C INITIAL STEP BOUND. THIS BOUND IS SET TO THE PRODUCT OF
-C FACTOR AND THE EUCLIDEAN NORM OF DIAG*X IF NONZERO, OR ELSE
-C TO FACTOR ITSELF. IN MOST CASES FACTOR SHOULD LIE IN THE
-C INTERVAL (.1,100.). 100. IS A GENERALLY RECOMMENDED VALUE.
-C
-C NPRINT IS AN INTEGER INPUT VARIABLE THAT ENABLES CONTROLLED
-C PRINTING OF ITERATES IF IT IS POSITIVE. IN THIS CASE,
-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. 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)
-C VALUE OF IFLAG. SEE DESCRIPTION OF FCN. OTHERWISE,
-C INFO IS SET AS FOLLOWS.
-C
-C INFO = 0 IMPROPER INPUT PARAMETERS.
-C
-C INFO = 1 BOTH ACTUAL AND PREDICTED RELATIVE REDUCTIONS
-C IN THE SUM OF SQUARES ARE AT MOST FTOL.
-C
-C INFO = 2 RELATIVE ERROR BETWEEN TWO CONSECUTIVE ITERATES
-C IS AT MOST XTOL.
-C
-C INFO = 3 CONDITIONS FOR INFO = 1 AND INFO = 2 BOTH HOLD.
-C
-C INFO = 4 THE COSINE OF THE ANGLE BETWEEN FVEC AND ANY
-C COLUMN OF THE JACOBIAN IS AT MOST GTOL IN
-C ABSOLUTE VALUE.
-C
-C INFO = 5 NUMBER OF CALLS TO FCN WITH IFLAG = 1 HAS
-C REACHED MAXFEV.
-C
-C INFO = 6 FTOL IS TOO SMALL. NO FURTHER REDUCTION IN
-C THE SUM OF SQUARES IS POSSIBLE.
-C
-C INFO = 7 XTOL IS TOO SMALL. NO FURTHER IMPROVEMENT IN
-C THE APPROXIMATE SOLUTION X IS POSSIBLE.
-C
-C INFO = 8 GTOL IS TOO SMALL. FVEC IS ORTHOGONAL TO THE
-C COLUMNS OF THE JACOBIAN TO MACHINE PRECISION.
-C
-C NFEV IS AN INTEGER OUTPUT VARIABLE SET TO THE NUMBER OF
-C CALLS TO FCN WITH IFLAG = 1.
-C
-C NJEV IS AN INTEGER OUTPUT VARIABLE SET TO THE NUMBER OF
-C CALLS TO FCN WITH IFLAG = 2.
-C
-C IPVT IS AN INTEGER OUTPUT ARRAY OF LENGTH N. IPVT
-C DEFINES A PERMUTATION MATRIX P SUCH THAT JAC*P = Q*R,
-C WHERE JAC IS THE FINAL CALCULATED JACOBIAN, Q IS
-C ORTHOGONAL (NOT STORED), AND R IS UPPER TRIANGULAR.
-C COLUMN J OF P IS COLUMN IPVT(J) OF THE IDENTITY MATRIX.
-C
-C QTF IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS
-C THE FIRST N ELEMENTS OF THE VECTOR (Q TRANSPOSE)*FVEC.
-C
-C WA1, WA2, AND WA3 ARE WORK ARRAYS OF LENGTH N.
-C
-C WA4 IS A WORK ARRAY OF LENGTH M.
-C
-C SUBPROGRAMS CALLED
-C
-C USER-SUPPLIED ...... FCN
-C
-C MINPACK-SUPPLIED ... SPMPAR,ENORM,LMPAR,QRFAC,RWUPDT
-C
-C FORTRAN-SUPPLIED ... ABS,AMAX1,AMIN1,SQRT,MOD
-C
-C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980.
-C BURTON S. GARBOW, DUDLEY V. GOETSCHEL, KENNETH E. HILLSTROM,
-C JORGE J. MORE
-C
-C **********
- INTEGER I,IFLAG,ITER,J,L
- REAL ACTRED,DELTA,DIRDER,EPSMCH,FNORM,FNORM1,GNORM,ONE,PAR,
- * PNORM,PRERED,P1,P5,P25,P75,P0001,RATIO,SUM,TEMP,TEMP1,
- * TEMP2,XNORM,ZERO
- REAL SPMPAR,ENORM
- DATA ONE,P1,P5,P25,P75,P0001,ZERO
- * /1.0E0,1.0E-1,5.0E-1,2.5E-1,7.5E-1,1.0E-4,0.0E0/
-C
-C EPSMCH IS THE MACHINE PRECISION.
-C
- EPSMCH = SPMPAR(1)
-C
- INFO = 0
- IFLAG = 0
- NFEV = 0
- NJEV = 0
-C
-C CHECK THE INPUT PARAMETERS FOR ERRORS.
-C
- IF (N .LE. 0 .OR. M .LT. N .OR. LDFJAC .LT. N
- * .OR. FTOL .LT. ZERO .OR. XTOL .LT. ZERO .OR. GTOL .LT. ZERO
- * .OR. MAXFEV .LE. 0 .OR. FACTOR .LE. ZERO) GO TO 340
- IF (MODE .NE. 2) GO TO 20
- DO 10 J = 1, N
- IF (DIAG(J) .LE. ZERO) GO TO 340
- 10 CONTINUE
- 20 CONTINUE
-C
-C EVALUATE THE FUNCTION AT THE STARTING POINT
-C AND CALCULATE ITS NORM.
-C
- IFLAG = 1
- CALL FCN(M,N,X,FVEC,WA3,IFLAG)
- NFEV = 1
- IF (IFLAG .LT. 0) GO TO 340
- FNORM = ENORM(M,FVEC)
-C
-C INITIALIZE LEVENBERG-MARQUARDT PARAMETER AND ITERATION COUNTER.
-C
- PAR = ZERO
- ITER = 1
-C
-C BEGINNING OF THE OUTER LOOP.
-C
- 30 CONTINUE
-C
-C IF REQUESTED, CALL FCN TO ENABLE PRINTING OF ITERATES.
-C
- IF (NPRINT .LE. 0) GO TO 40
- IFLAG = 0
- IF (MOD(ITER-1,NPRINT) .EQ. 0) CALL FCN(M,N,X,FVEC,WA3,IFLAG)
- IF (IFLAG .LT. 0) GO TO 340
- 40 CONTINUE
-C
-C COMPUTE THE QR FACTORIZATION OF THE JACOBIAN MATRIX
-C CALCULATED ONE ROW AT A TIME, WHILE SIMULTANEOUSLY
-C FORMING (Q TRANSPOSE)*FVEC AND STORING THE FIRST
-C N COMPONENTS IN QTF.
-C
- DO 60 J = 1, N
- QTF(J) = ZERO
- DO 50 I = 1, N
- FJAC(I,J) = ZERO
- 50 CONTINUE
- 60 CONTINUE
- IFLAG = 2
- DO 70 I = 1, M
- CALL FCN(M,N,X,FVEC,WA3,IFLAG)
- IF (IFLAG .LT. 0) GO TO 340
- TEMP = FVEC(I)
- CALL RWUPDT(N,FJAC,LDFJAC,WA3,QTF,TEMP,WA1,WA2)
- IFLAG = IFLAG + 1
- 70 CONTINUE
- NJEV = NJEV + 1
-C
-C IF THE JACOBIAN IS RANK DEFICIENT, CALL QRFAC TO
-C REORDER ITS COLUMNS AND UPDATE THE COMPONENTS OF QTF.
-C
- SING = .FALSE.
- DO 80 J = 1, N
- IF (FJAC(J,J) .EQ. ZERO) SING = .TRUE.
- IPVT(J) = J
- WA2(J) = ENORM(J,FJAC(1,J))
- 80 CONTINUE
- IF (.NOT.SING) GO TO 130
- CALL QRFAC(N,N,FJAC,LDFJAC,.TRUE.,IPVT,N,WA1,WA2,WA3)
- DO 120 J = 1, N
- IF (FJAC(J,J) .EQ. ZERO) GO TO 110
- SUM = ZERO
- DO 90 I = J, N
- SUM = SUM + FJAC(I,J)*QTF(I)
- 90 CONTINUE
- TEMP = -SUM/FJAC(J,J)
- DO 100 I = J, N
- QTF(I) = QTF(I) + FJAC(I,J)*TEMP
- 100 CONTINUE
- 110 CONTINUE
- FJAC(J,J) = WA1(J)
- 120 CONTINUE
- 130 CONTINUE
-C
-C ON THE FIRST ITERATION AND IF MODE IS 1, SCALE ACCORDING
-C TO THE NORMS OF THE COLUMNS OF THE INITIAL JACOBIAN.
-C
- IF (ITER .NE. 1) GO TO 170
- IF (MODE .EQ. 2) GO TO 150
- DO 140 J = 1, N
- DIAG(J) = WA2(J)
- IF (WA2(J) .EQ. ZERO) DIAG(J) = ONE
- 140 CONTINUE
- 150 CONTINUE
-C
-C ON THE FIRST ITERATION, CALCULATE THE NORM OF THE SCALED X
-C AND INITIALIZE THE STEP BOUND DELTA.
-C
- DO 160 J = 1, N
- WA3(J) = DIAG(J)*X(J)
- 160 CONTINUE
- XNORM = ENORM(N,WA3)
- DELTA = FACTOR*XNORM
- IF (DELTA .EQ. ZERO) DELTA = FACTOR
- 170 CONTINUE
-C
-C COMPUTE THE NORM OF THE SCALED GRADIENT.
-C
- GNORM = ZERO
- IF (FNORM .EQ. ZERO) GO TO 210
- DO 200 J = 1, N
- L = IPVT(J)
- IF (WA2(L) .EQ. ZERO) GO TO 190
- SUM = ZERO
- DO 180 I = 1, J
- SUM = SUM + FJAC(I,J)*(QTF(I)/FNORM)
- 180 CONTINUE
- GNORM = AMAX1(GNORM,ABS(SUM/WA2(L)))
- 190 CONTINUE
- 200 CONTINUE
- 210 CONTINUE
-C
-C TEST FOR CONVERGENCE OF THE GRADIENT NORM.
-C
- IF (GNORM .LE. GTOL) INFO = 4
- IF (INFO .NE. 0) GO TO 340
-C
-C RESCALE IF NECESSARY.
-C
- IF (MODE .EQ. 2) GO TO 230
- DO 220 J = 1, N
- DIAG(J) = AMAX1(DIAG(J),WA2(J))
- 220 CONTINUE
- 230 CONTINUE
-C
-C BEGINNING OF THE INNER LOOP.
-C
- 240 CONTINUE
-C
-C DETERMINE THE LEVENBERG-MARQUARDT PARAMETER.
-C
- CALL LMPAR(N,FJAC,LDFJAC,IPVT,DIAG,QTF,DELTA,PAR,WA1,WA2,
- * WA3,WA4)
-C
-C STORE THE DIRECTION P AND X + P. CALCULATE THE NORM OF P.
-C
- DO 250 J = 1, N
- WA1(J) = -WA1(J)
- WA2(J) = X(J) + WA1(J)
- WA3(J) = DIAG(J)*WA1(J)
- 250 CONTINUE
- PNORM = ENORM(N,WA3)
-C
-C ON THE FIRST ITERATION, ADJUST THE INITIAL STEP BOUND.
-C
- IF (ITER .EQ. 1) DELTA = AMIN1(DELTA,PNORM)
-C
-C EVALUATE THE FUNCTION AT X + P AND CALCULATE ITS NORM.
-C
- IFLAG = 1
- CALL FCN(M,N,WA2,WA4,WA3,IFLAG)
- NFEV = NFEV + 1
- IF (IFLAG .LT. 0) GO TO 340
- FNORM1 = ENORM(M,WA4)
-C
-C COMPUTE THE SCALED ACTUAL REDUCTION.
-C
- ACTRED = -ONE
- IF (P1*FNORM1 .LT. FNORM) ACTRED = ONE - (FNORM1/FNORM)**2
-C
-C COMPUTE THE SCALED PREDICTED REDUCTION AND
-C THE SCALED DIRECTIONAL DERIVATIVE.
-C
- DO 270 J = 1, N
- WA3(J) = ZERO
- L = IPVT(J)
- TEMP = WA1(L)
- DO 260 I = 1, J
- WA3(I) = WA3(I) + FJAC(I,J)*TEMP
- 260 CONTINUE
- 270 CONTINUE
- TEMP1 = ENORM(N,WA3)/FNORM
- TEMP2 = (SQRT(PAR)*PNORM)/FNORM
- PRERED = TEMP1**2 + TEMP2**2/P5
- DIRDER = -(TEMP1**2 + TEMP2**2)
-C
-C COMPUTE THE RATIO OF THE ACTUAL TO THE PREDICTED
-C REDUCTION.
-C
- RATIO = ZERO
- IF (PRERED .NE. ZERO) RATIO = ACTRED/PRERED
-C
-C UPDATE THE STEP BOUND.
-C
- IF (RATIO .GT. P25) GO TO 280
- IF (ACTRED .GE. ZERO) TEMP = P5
- IF (ACTRED .LT. ZERO)
- * TEMP = P5*DIRDER/(DIRDER + P5*ACTRED)
- IF (P1*FNORM1 .GE. FNORM .OR. TEMP .LT. P1) TEMP = P1
- DELTA = TEMP*AMIN1(DELTA,PNORM/P1)
- PAR = PAR/TEMP
- GO TO 300
- 280 CONTINUE
- IF (PAR .NE. ZERO .AND. RATIO .LT. P75) GO TO 290
- DELTA = PNORM/P5
- PAR = P5*PAR
- 290 CONTINUE
- 300 CONTINUE
-C
-C TEST FOR SUCCESSFUL ITERATION.
-C
- IF (RATIO .LT. P0001) GO TO 330
-C
-C SUCCESSFUL ITERATION. UPDATE X, FVEC, AND THEIR NORMS.
-C
- DO 310 J = 1, N
- X(J) = WA2(J)
- WA2(J) = DIAG(J)*X(J)
- 310 CONTINUE
- DO 320 I = 1, M
- FVEC(I) = WA4(I)
- 320 CONTINUE
- XNORM = ENORM(N,WA2)
- FNORM = FNORM1
- ITER = ITER + 1
- 330 CONTINUE
-C
-C TESTS FOR CONVERGENCE.
-C
- IF (ABS(ACTRED) .LE. FTOL .AND. PRERED .LE. FTOL
- * .AND. P5*RATIO .LE. ONE) INFO = 1
- IF (DELTA .LE. XTOL*XNORM) INFO = 2
- IF (ABS(ACTRED) .LE. FTOL .AND. PRERED .LE. FTOL
- * .AND. P5*RATIO .LE. ONE .AND. INFO .EQ. 2) INFO = 3
- IF (INFO .NE. 0) GO TO 340
-C
-C TESTS FOR TERMINATION AND STRINGENT TOLERANCES.
-C
- IF (NFEV .GE. MAXFEV) INFO = 5
- IF (ABS(ACTRED) .LE. EPSMCH .AND. PRERED .LE. EPSMCH
- * .AND. P5*RATIO .LE. ONE) INFO = 6
- IF (DELTA .LE. EPSMCH*XNORM) INFO = 7
- IF (GNORM .LE. EPSMCH) INFO = 8
- IF (INFO .NE. 0) GO TO 340
-C
-C END OF THE INNER LOOP. REPEAT IF ITERATION UNSUCCESSFUL.
-C
- IF (RATIO .LT. P0001) GO TO 240
-C
-C END OF THE OUTER LOOP.
-C
- GO TO 30
- 340 CONTINUE
-C
-C TERMINATION, EITHER NORMAL OR USER IMPOSED.
-C
- IF (IFLAG .LT. 0) INFO = IFLAG
- IFLAG = 0
- IF (NPRINT .GT. 0) CALL FCN(M,N,X,FVEC,WA3,IFLAG)
- RETURN
-C
-C LAST CARD OF SUBROUTINE LMSTR.
-C
- END
- SUBROUTINE LMSTR1(FCN,M,N,X,FVEC,FJAC,LDFJAC,TOL,INFO,IPVT,WA,
- * LWA)
- INTEGER M,N,LDFJAC,INFO,LWA
- INTEGER IPVT(N)
- REAL TOL
- REAL X(N),FVEC(M),FJAC(LDFJAC,N),WA(LWA)
- EXTERNAL FCN
-C **********
-C
-C SUBROUTINE LMSTR1
-C
-C THE PURPOSE OF LMSTR1 IS TO MINIMIZE THE SUM OF THE SQUARES OF
-C M NONLINEAR FUNCTIONS IN N VARIABLES BY A MODIFICATION OF
-C THE LEVENBERG-MARQUARDT ALGORITHM WHICH USES MINIMAL STORAGE.
-C THIS IS DONE BY USING THE MORE GENERAL LEAST-SQUARES SOLVER
-C LMSTR. THE USER MUST PROVIDE A SUBROUTINE WHICH CALCULATES
-C THE FUNCTIONS AND THE ROWS OF THE JACOBIAN.
-C
-C THE SUBROUTINE STATEMENT IS
-C
-C SUBROUTINE LMSTR1(FCN,M,N,X,FVEC,FJAC,LDFJAC,TOL,INFO,
-C IPVT,WA,LWA)
-C
-C WHERE
-C
-C FCN IS THE NAME OF THE USER-SUPPLIED SUBROUTINE WHICH
-C CALCULATES THE FUNCTIONS AND THE ROWS OF THE JACOBIAN.
-C FCN MUST BE DECLARED IN AN EXTERNAL STATEMENT IN THE
-C USER CALLING PROGRAM, AND SHOULD BE WRITTEN AS FOLLOWS.
-C
-C SUBROUTINE FCN(M,N,X,FVEC,FJROW,IFLAG)
-C INTEGER M,N,IFLAG
-C REAL X(N),FVEC(M),FJROW(N)
-C ----------
-C IF IFLAG = 1 CALCULATE THE FUNCTIONS AT X AND
-C RETURN THIS VECTOR IN FVEC.
-C IF IFLAG = I CALCULATE THE (I-1)-ST ROW OF THE
-C JACOBIAN AT X AND RETURN THIS VECTOR IN FJROW.
-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 LMSTR1.
-C IN THIS CASE SET IFLAG TO A NEGATIVE INTEGER.
-C
-C M IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER
-C OF FUNCTIONS.
-C
-C N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER
-C OF VARIABLES. N MUST NOT EXCEED M.
-C
-C X IS AN ARRAY OF LENGTH N. ON INPUT X MUST CONTAIN
-C AN INITIAL ESTIMATE OF THE SOLUTION VECTOR. ON OUTPUT X
-C CONTAINS THE FINAL ESTIMATE OF THE SOLUTION VECTOR.
-C
-C FVEC IS AN OUTPUT ARRAY OF LENGTH M WHICH CONTAINS
-C THE FUNCTIONS EVALUATED AT THE OUTPUT X.
-C
-C FJAC IS AN OUTPUT N BY N ARRAY. THE UPPER TRIANGLE OF FJAC
-C CONTAINS AN UPPER TRIANGULAR MATRIX R SUCH THAT
-C
-C T T T
-C P *(JAC *JAC)*P = R *R,
-C
-C WHERE P IS A PERMUTATION MATRIX AND JAC IS THE FINAL
-C CALCULATED JACOBIAN. COLUMN J OF P IS COLUMN IPVT(J)
-C (SEE BELOW) OF THE IDENTITY MATRIX. THE LOWER TRIANGULAR
-C PART OF FJAC CONTAINS INFORMATION GENERATED DURING
-C THE COMPUTATION OF R.
-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 TOL IS A NONNEGATIVE INPUT VARIABLE. TERMINATION OCCURS
-C WHEN THE ALGORITHM ESTIMATES EITHER THAT THE RELATIVE
-C ERROR IN THE SUM OF SQUARES IS AT MOST TOL OR THAT
-C THE RELATIVE ERROR BETWEEN X AND THE SOLUTION IS AT
-C MOST TOL.
-C
-C INFO IS AN INTEGER OUTPUT VARIABLE. IF THE USER HAS
-C TERMINATED EXECUTION, INFO IS SET TO THE (NEGATIVE)
-C VALUE OF IFLAG. SEE DESCRIPTION OF FCN. OTHERWISE,
-C INFO IS SET AS FOLLOWS.
-C
-C INFO = 0 IMPROPER INPUT PARAMETERS.
-C
-C INFO = 1 ALGORITHM ESTIMATES THAT THE RELATIVE ERROR
-C IN THE SUM OF SQUARES IS AT MOST TOL.
-C
-C INFO = 2 ALGORITHM ESTIMATES THAT THE RELATIVE ERROR
-C BETWEEN X AND THE SOLUTION IS AT MOST TOL.
-C
-C INFO = 3 CONDITIONS FOR INFO = 1 AND INFO = 2 BOTH HOLD.
-C
-C INFO = 4 FVEC IS ORTHOGONAL TO THE COLUMNS OF THE
-C JACOBIAN TO MACHINE PRECISION.
-C
-C INFO = 5 NUMBER OF CALLS TO FCN WITH IFLAG = 1 HAS
-C REACHED 100*(N+1).
-C
-C INFO = 6 TOL IS TOO SMALL. NO FURTHER REDUCTION IN
-C THE SUM OF SQUARES IS POSSIBLE.
-C
-C INFO = 7 TOL IS TOO SMALL. NO FURTHER IMPROVEMENT IN
-C THE APPROXIMATE SOLUTION X IS POSSIBLE.
-C
-C IPVT IS AN INTEGER OUTPUT ARRAY OF LENGTH N. IPVT
-C DEFINES A PERMUTATION MATRIX P SUCH THAT JAC*P = Q*R,
-C WHERE JAC IS THE FINAL CALCULATED JACOBIAN, Q IS
-C ORTHOGONAL (NOT STORED), AND R IS UPPER TRIANGULAR.
-C COLUMN J OF P IS COLUMN IPVT(J) OF THE IDENTITY MATRIX.
-C
-C WA IS A WORK ARRAY OF LENGTH LWA.
-C
-C LWA IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN 5*N+M.
-C
-C SUBPROGRAMS CALLED
-C
-C USER-SUPPLIED ...... FCN
-C
-C MINPACK-SUPPLIED ... LMSTR
-C
-C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980.
-C BURTON S. GARBOW, DUDLEY V. GOETSCHEL, KENNETH E. HILLSTROM,
-C JORGE J. MORE
-C
-C **********
- INTEGER MAXFEV,MODE,NFEV,NJEV,NPRINT
- REAL FACTOR,FTOL,GTOL,XTOL,ZERO
- DATA FACTOR,ZERO /1.0E2,0.0E0/
- INFO = 0
-C
-C CHECK THE INPUT PARAMETERS FOR ERRORS.
-C
- IF (N .LE. 0 .OR. M .LT. N .OR. LDFJAC .LT. N .OR. TOL .LT. ZERO
- * .OR. LWA .LT. 5*N + M) GO TO 10
-C
-C CALL LMSTR.
-C
- MAXFEV = 100*(N + 1)
- FTOL = TOL
- XTOL = TOL
- GTOL = ZERO
- MODE = 1
- NPRINT = 0
- CALL LMSTR(FCN,M,N,X,FVEC,FJAC,LDFJAC,FTOL,XTOL,GTOL,MAXFEV,
- * WA(1),MODE,FACTOR,NPRINT,INFO,NFEV,NJEV,IPVT,WA(N+1),
- * WA(2*N+1),WA(3*N+1),WA(4*N+1),WA(5*N+1))
- IF (INFO .EQ. 8) INFO = 4
- 10 CONTINUE
- RETURN
-C
-C LAST CARD OF SUBROUTINE LMSTR1.
-C
- END
- SUBROUTINE QFORM(M,N,Q,LDQ,WA)
- INTEGER M,N,LDQ
- REAL Q(LDQ,M),WA(M)
-C **********
-C
-C SUBROUTINE QFORM
-C
-C THIS SUBROUTINE PROCEEDS FROM THE COMPUTED QR FACTORIZATION OF
-C AN M BY N MATRIX A TO ACCUMULATE THE M BY M ORTHOGONAL MATRIX
-C Q FROM ITS FACTORED FORM.
-C
-C THE SUBROUTINE STATEMENT IS
-C
-C SUBROUTINE QFORM(M,N,Q,LDQ,WA)
-C
-C WHERE
-C
-C M IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER
-C OF ROWS OF A AND THE ORDER OF Q.
-C
-C N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER
-C OF COLUMNS OF A.
-C
-C Q IS AN M BY M ARRAY. ON INPUT THE FULL LOWER TRAPEZOID IN
-C THE FIRST MIN(M,N) COLUMNS OF Q CONTAINS THE FACTORED FORM.
-C ON OUTPUT Q HAS BEEN ACCUMULATED INTO A SQUARE MATRIX.
-C
-C LDQ IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN M
-C WHICH SPECIFIES THE LEADING DIMENSION OF THE ARRAY Q.
-C
-C WA IS A WORK ARRAY OF LENGTH M.
-C
-C SUBPROGRAMS CALLED
-C
-C FORTRAN-SUPPLIED ... 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,JM1,K,L,MINMN,NP1
- REAL ONE,SUM,TEMP,ZERO
- DATA ONE,ZERO /1.0E0,0.0E0/
-C
-C ZERO OUT UPPER TRIANGLE OF Q IN THE FIRST MIN(M,N) COLUMNS.
-C
- MINMN = MIN0(M,N)
- IF (MINMN .LT. 2) GO TO 30
- DO 20 J = 2, MINMN
- JM1 = J - 1
- DO 10 I = 1, JM1
- Q(I,J) = ZERO
- 10 CONTINUE
- 20 CONTINUE
- 30 CONTINUE
-C
-C INITIALIZE REMAINING COLUMNS TO THOSE OF THE IDENTITY MATRIX.
-C
- NP1 = N + 1
- IF (M .LT. NP1) GO TO 60
- DO 50 J = NP1, M
- DO 40 I = 1, M
- Q(I,J) = ZERO
- 40 CONTINUE
- Q(J,J) = ONE
- 50 CONTINUE
- 60 CONTINUE
-C
-C ACCUMULATE Q FROM ITS FACTORED FORM.
-C
- DO 120 L = 1, MINMN
- K = MINMN - L + 1
- DO 70 I = K, M
- WA(I) = Q(I,K)
- Q(I,K) = ZERO
- 70 CONTINUE
- Q(K,K) = ONE
- IF (WA(K) .EQ. ZERO) GO TO 110
- DO 100 J = K, M
- SUM = ZERO
- DO 80 I = K, M
- SUM = SUM + Q(I,J)*WA(I)
- 80 CONTINUE
- TEMP = SUM/WA(K)
- DO 90 I = K, M
- Q(I,J) = Q(I,J) - TEMP*WA(I)
- 90 CONTINUE
- 100 CONTINUE
- 110 CONTINUE
- 120 CONTINUE
- 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
- REAL 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 ... SPMPAR,ENORM
-C
-C FORTRAN-SUPPLIED ... AMAX1,SQRT,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
- REAL AJNORM,EPSMCH,ONE,P05,SUM,TEMP,ZERO
- REAL SPMPAR,ENORM
- DATA ONE,P05,ZERO /1.0E0,5.0E-2,0.0E0/
-C
-C EPSMCH IS THE MACHINE PRECISION.
-C
- EPSMCH = SPMPAR(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)*SQRT(AMAX1(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 QRSOLV(N,R,LDR,IPVT,DIAG,QTB,X,SDIAG,WA)
- INTEGER N,LDR
- INTEGER IPVT(N)
- REAL R(LDR,N),DIAG(N),QTB(N),X(N),SDIAG(N),WA(N)
-C **********
-C
-C SUBROUTINE QRSOLV
-C
-C GIVEN AN M BY N MATRIX A, AN N BY N DIAGONAL MATRIX D,
-C AND AN M-VECTOR B, THE PROBLEM IS TO DETERMINE AN X WHICH
-C SOLVES THE SYSTEM
-C
-C A*X = B , D*X = 0 ,
-C
-C IN THE LEAST SQUARES SENSE.
-C
-C THIS SUBROUTINE COMPLETES THE SOLUTION OF THE PROBLEM
-C IF IT IS PROVIDED WITH THE NECESSARY INFORMATION FROM THE
-C QR FACTORIZATION, WITH COLUMN PIVOTING, OF A. THAT IS, IF
-C A*P = Q*R, WHERE P IS A PERMUTATION MATRIX, Q HAS ORTHOGONAL
-C COLUMNS, AND R IS AN UPPER TRIANGULAR MATRIX WITH DIAGONAL
-C ELEMENTS OF NONINCREASING MAGNITUDE, THEN QRSOLV EXPECTS
-C THE FULL UPPER TRIANGLE OF R, THE PERMUTATION MATRIX P,
-C AND THE FIRST N COMPONENTS OF (Q TRANSPOSE)*B. THE SYSTEM
-C A*X = B, D*X = 0, IS THEN EQUIVALENT TO
-C
-C T T
-C R*Z = Q *B , P *D*P*Z = 0 ,
-C
-C WHERE X = P*Z. IF THIS SYSTEM DOES NOT HAVE FULL RANK,
-C THEN A LEAST SQUARES SOLUTION IS OBTAINED. ON OUTPUT QRSOLV
-C ALSO PROVIDES AN UPPER TRIANGULAR MATRIX S SUCH THAT
-C
-C T T T
-C P *(A *A + D*D)*P = S *S .
-C
-C S IS COMPUTED WITHIN QRSOLV AND MAY BE OF SEPARATE INTEREST.
-C
-C THE SUBROUTINE STATEMENT IS
-C
-C SUBROUTINE QRSOLV(N,R,LDR,IPVT,DIAG,QTB,X,SDIAG,WA)
-C
-C WHERE
-C
-C N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE ORDER OF R.
-C
-C R IS AN N BY N ARRAY. ON INPUT THE FULL UPPER TRIANGLE
-C MUST CONTAIN THE FULL UPPER TRIANGLE OF THE MATRIX R.
-C ON OUTPUT THE FULL UPPER TRIANGLE IS UNALTERED, AND THE
-C STRICT LOWER TRIANGLE CONTAINS THE STRICT UPPER TRIANGLE
-C (TRANSPOSED) OF THE UPPER TRIANGULAR MATRIX S.
-C
-C LDR IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN N
-C WHICH SPECIFIES THE LEADING DIMENSION OF THE ARRAY R.
-C
-C IPVT IS AN INTEGER INPUT ARRAY OF LENGTH N WHICH DEFINES THE
-C PERMUTATION MATRIX P SUCH THAT A*P = Q*R. COLUMN J OF P
-C IS COLUMN IPVT(J) OF THE IDENTITY MATRIX.
-C
-C DIAG IS AN INPUT ARRAY OF LENGTH N WHICH MUST CONTAIN THE
-C DIAGONAL ELEMENTS OF THE MATRIX D.
-C
-C QTB IS AN INPUT ARRAY OF LENGTH N WHICH MUST CONTAIN THE FIRST
-C N ELEMENTS OF THE VECTOR (Q TRANSPOSE)*B.
-C
-C X IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS THE LEAST
-C SQUARES SOLUTION OF THE SYSTEM A*X = B, D*X = 0.
-C
-C SDIAG IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS THE
-C DIAGONAL ELEMENTS OF THE UPPER TRIANGULAR MATRIX S.
-C
-C WA IS A WORK ARRAY OF LENGTH N.
-C
-C SUBPROGRAMS CALLED
-C
-C FORTRAN-SUPPLIED ... ABS,SQRT
-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,KP1,L,NSING
- REAL COS,COTAN,P5,P25,QTBPJ,SIN,SUM,TAN,TEMP,ZERO
- DATA P5,P25,ZERO /5.0E-1,2.5E-1,0.0E0/
-C
-C COPY R AND (Q TRANSPOSE)*B TO PRESERVE INPUT AND INITIALIZE S.
-C IN PARTICULAR, SAVE THE DIAGONAL ELEMENTS OF R IN X.
-C
- DO 20 J = 1, N
- DO 10 I = J, N
- R(I,J) = R(J,I)
- 10 CONTINUE
- X(J) = R(J,J)
- WA(J) = QTB(J)
- 20 CONTINUE
-C
-C ELIMINATE THE DIAGONAL MATRIX D USING A GIVENS ROTATION.
-C
- DO 100 J = 1, N
-C
-C PREPARE THE ROW OF D TO BE ELIMINATED, LOCATING THE
-C DIAGONAL ELEMENT USING P FROM THE QR FACTORIZATION.
-C
- L = IPVT(J)
- IF (DIAG(L) .EQ. ZERO) GO TO 90
- DO 30 K = J, N
- SDIAG(K) = ZERO
- 30 CONTINUE
- SDIAG(J) = DIAG(L)
-C
-C THE TRANSFORMATIONS TO ELIMINATE THE ROW OF D
-C MODIFY ONLY A SINGLE ELEMENT OF (Q TRANSPOSE)*B
-C BEYOND THE FIRST N, WHICH IS INITIALLY ZERO.
-C
- QTBPJ = ZERO
- DO 80 K = J, N
-C
-C DETERMINE A GIVENS ROTATION WHICH ELIMINATES THE
-C APPROPRIATE ELEMENT IN THE CURRENT ROW OF D.
-C
- IF (SDIAG(K) .EQ. ZERO) GO TO 70
- IF (ABS(R(K,K)) .GE. ABS(SDIAG(K))) GO TO 40
- COTAN = R(K,K)/SDIAG(K)
- SIN = P5/SQRT(P25+P25*COTAN**2)
- COS = SIN*COTAN
- GO TO 50
- 40 CONTINUE
- TAN = SDIAG(K)/R(K,K)
- COS = P5/SQRT(P25+P25*TAN**2)
- SIN = COS*TAN
- 50 CONTINUE
-C
-C COMPUTE THE MODIFIED DIAGONAL ELEMENT OF R AND
-C THE MODIFIED ELEMENT OF ((Q TRANSPOSE)*B,0).
-C
- R(K,K) = COS*R(K,K) + SIN*SDIAG(K)
- TEMP = COS*WA(K) + SIN*QTBPJ
- QTBPJ = -SIN*WA(K) + COS*QTBPJ
- WA(K) = TEMP
-C
-C ACCUMULATE THE TRANFORMATION IN THE ROW OF S.
-C
- KP1 = K + 1
- IF (N .LT. KP1) GO TO 70
- DO 60 I = KP1, N
- TEMP = COS*R(I,K) + SIN*SDIAG(I)
- SDIAG(I) = -SIN*R(I,K) + COS*SDIAG(I)
- R(I,K) = TEMP
- 60 CONTINUE
- 70 CONTINUE
- 80 CONTINUE
- 90 CONTINUE
-C
-C STORE THE DIAGONAL ELEMENT OF S AND RESTORE
-C THE CORRESPONDING DIAGONAL ELEMENT OF R.
-C
- SDIAG(J) = R(J,J)
- R(J,J) = X(J)
- 100 CONTINUE
-C
-C SOLVE THE TRIANGULAR SYSTEM FOR Z. IF THE SYSTEM IS
-C SINGULAR, THEN OBTAIN A LEAST SQUARES SOLUTION.
-C
- NSING = N
- DO 110 J = 1, N
- IF (SDIAG(J) .EQ. ZERO .AND. NSING .EQ. N) NSING = J - 1
- IF (NSING .LT. N) WA(J) = ZERO
- 110 CONTINUE
- IF (NSING .LT. 1) GO TO 150
- DO 140 K = 1, NSING
- J = NSING - K + 1
- SUM = ZERO
- JP1 = J + 1
- IF (NSING .LT. JP1) GO TO 130
- DO 120 I = JP1, NSING
- SUM = SUM + R(I,J)*WA(I)
- 120 CONTINUE
- 130 CONTINUE
- WA(J) = (WA(J) - SUM)/SDIAG(J)
- 140 CONTINUE
- 150 CONTINUE
-C
-C PERMUTE THE COMPONENTS OF Z BACK TO COMPONENTS OF X.
-C
- DO 160 J = 1, N
- L = IPVT(J)
- X(L) = WA(J)
- 160 CONTINUE
- RETURN
-C
-C LAST CARD OF SUBROUTINE QRSOLV.
-C
- END
- SUBROUTINE RWUPDT(N,R,LDR,W,B,ALPHA,COS,SIN)
- INTEGER N,LDR
- REAL ALPHA
- REAL R(LDR,N),W(N),B(N),COS(N),SIN(N)
-C **********
-C
-C SUBROUTINE RWUPDT
-C
-C GIVEN AN N BY N UPPER TRIANGULAR MATRIX R, THIS SUBROUTINE
-C COMPUTES THE QR DECOMPOSITION OF THE MATRIX FORMED WHEN A ROW
-C IS ADDED TO R. IF THE ROW IS SPECIFIED BY THE VECTOR W, THEN
-C RWUPDT DETERMINES AN ORTHOGONAL MATRIX Q SUCH THAT WHEN THE
-C N+1 BY N MATRIX COMPOSED OF R AUGMENTED BY W IS PREMULTIPLIED
-C BY (Q TRANSPOSE), THE RESULTING MATRIX IS UPPER TRAPEZOIDAL.
-C THE MATRIX (Q TRANSPOSE) IS THE PRODUCT OF N TRANSFORMATIONS
-C
-C G(N)*G(N-1)* ... *G(1)
-C
-C WHERE G(I) IS A GIVENS ROTATION IN THE (I,N+1) PLANE WHICH
-C ELIMINATES ELEMENTS IN THE (N+1)-ST PLANE. RWUPDT ALSO
-C COMPUTES THE PRODUCT (Q TRANSPOSE)*C WHERE C IS THE
-C (N+1)-VECTOR (B,ALPHA). Q ITSELF IS NOT ACCUMULATED, RATHER
-C THE INFORMATION TO RECOVER THE G ROTATIONS IS SUPPLIED.
-C
-C THE SUBROUTINE STATEMENT IS
-C
-C SUBROUTINE RWUPDT(N,R,LDR,W,B,ALPHA,COS,SIN)
-C
-C WHERE
-C
-C N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE ORDER OF R.
-C
-C R IS AN N BY N ARRAY. ON INPUT THE UPPER TRIANGULAR PART OF
-C R MUST CONTAIN THE MATRIX TO BE UPDATED. ON OUTPUT R
-C CONTAINS THE UPDATED TRIANGULAR MATRIX.
-C
-C LDR IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN N
-C WHICH SPECIFIES THE LEADING DIMENSION OF THE ARRAY R.
-C
-C W IS AN INPUT ARRAY OF LENGTH N WHICH MUST CONTAIN THE ROW
-C VECTOR TO BE ADDED TO R.
-C
-C B IS AN ARRAY OF LENGTH N. ON INPUT B MUST CONTAIN THE
-C FIRST N ELEMENTS OF THE VECTOR C. ON OUTPUT B CONTAINS
-C THE FIRST N ELEMENTS OF THE VECTOR (Q TRANSPOSE)*C.
-C
-C ALPHA IS A VARIABLE. ON INPUT ALPHA MUST CONTAIN THE
-C (N+1)-ST ELEMENT OF THE VECTOR C. ON OUTPUT ALPHA CONTAINS
-C THE (N+1)-ST ELEMENT OF THE VECTOR (Q TRANSPOSE)*C.
-C
-C COS IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS THE
-C COSINES OF THE TRANSFORMING GIVENS ROTATIONS.
-C
-C SIN IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS THE
-C SINES OF THE TRANSFORMING GIVENS ROTATIONS.
-C
-C SUBPROGRAMS CALLED
-C
-C FORTRAN-SUPPLIED ... ABS,SQRT
-C
-C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980.
-C BURTON S. GARBOW, DUDLEY V. GOETSCHEL, KENNETH E. HILLSTROM,
-C JORGE J. MORE
-C
-C **********
- INTEGER I,J,JM1
- REAL COTAN,ONE,P5,P25,ROWJ,TAN,TEMP,ZERO
- DATA ONE,P5,P25,ZERO /1.0E0,5.0E-1,2.5E-1,0.0E0/
-C
- DO 60 J = 1, N
- ROWJ = W(J)
- JM1 = J - 1
-C
-C APPLY THE PREVIOUS TRANSFORMATIONS TO
-C R(I,J), I=1,2,...,J-1, AND TO W(J).
-C
- IF (JM1 .LT. 1) GO TO 20
- DO 10 I = 1, JM1
- TEMP = COS(I)*R(I,J) + SIN(I)*ROWJ
- ROWJ = -SIN(I)*R(I,J) + COS(I)*ROWJ
- R(I,J) = TEMP
- 10 CONTINUE
- 20 CONTINUE
-C
-C DETERMINE A GIVENS ROTATION WHICH ELIMINATES W(J).
-C
- COS(J) = ONE
- SIN(J) = ZERO
- IF (ROWJ .EQ. ZERO) GO TO 50
- IF (ABS(R(J,J)) .GE. ABS(ROWJ)) GO TO 30
- COTAN = R(J,J)/ROWJ
- SIN(J) = P5/SQRT(P25+P25*COTAN**2)
- COS(J) = SIN(J)*COTAN
- GO TO 40
- 30 CONTINUE
- TAN = ROWJ/R(J,J)
- COS(J) = P5/SQRT(P25+P25*TAN**2)
- SIN(J) = COS(J)*TAN
- 40 CONTINUE
-C
-C APPLY THE CURRENT TRANSFORMATION TO R(J,J), B(J), AND ALPHA.
-C
- R(J,J) = COS(J)*R(J,J) + SIN(J)*ROWJ
- TEMP = COS(J)*B(J) + SIN(J)*ALPHA
- ALPHA = -SIN(J)*B(J) + COS(J)*ALPHA
- B(J) = TEMP
- 50 CONTINUE
- 60 CONTINUE
- RETURN
-C
-C LAST CARD OF SUBROUTINE RWUPDT.
-C
- END
- SUBROUTINE R1MPYQ(M,N,A,LDA,V,W)
- INTEGER M,N,LDA
- REAL A(LDA,N),V(N),W(N)
-C **********
-C
-C SUBROUTINE R1MPYQ
-C
-C GIVEN AN M BY N MATRIX A, THIS SUBROUTINE COMPUTES A*Q WHERE
-C Q IS THE PRODUCT OF 2*(N - 1) TRANSFORMATIONS
-C
-C GV(N-1)*...*GV(1)*GW(1)*...*GW(N-1)
-C
-C AND GV(I), GW(I) ARE GIVENS ROTATIONS IN THE (I,N) PLANE WHICH
-C ELIMINATE ELEMENTS IN THE I-TH AND N-TH PLANES, RESPECTIVELY.
-C Q ITSELF IS NOT GIVEN, RATHER THE INFORMATION TO RECOVER THE
-C GV, GW ROTATIONS IS SUPPLIED.
-C
-C THE SUBROUTINE STATEMENT IS
-C
-C SUBROUTINE R1MPYQ(M,N,A,LDA,V,W)
-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 MUST CONTAIN THE MATRIX
-C TO BE POSTMULTIPLIED BY THE ORTHOGONAL MATRIX Q
-C DESCRIBED ABOVE. ON OUTPUT A*Q HAS REPLACED A.
-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 V IS AN INPUT ARRAY OF LENGTH N. V(I) MUST CONTAIN THE
-C INFORMATION NECESSARY TO RECOVER THE GIVENS ROTATION GV(I)
-C DESCRIBED ABOVE.
-C
-C W IS AN INPUT ARRAY OF LENGTH N. W(I) MUST CONTAIN THE
-C INFORMATION NECESSARY TO RECOVER THE GIVENS ROTATION GW(I)
-C DESCRIBED ABOVE.
-C
-C SUBROUTINES CALLED
-C
-C FORTRAN-SUPPLIED ... ABS,SQRT
-C
-C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980.
-C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE
-C
-C **********
- INTEGER I,J,NMJ,NM1
- REAL COS,ONE,SIN,TEMP
- DATA ONE /1.0E0/
-C
-C APPLY THE FIRST SET OF GIVENS ROTATIONS TO A.
-C
- NM1 = N - 1
- IF (NM1 .LT. 1) GO TO 50
- DO 20 NMJ = 1, NM1
- J = N - NMJ
- IF (ABS(V(J)) .GT. ONE) COS = ONE/V(J)
- IF (ABS(V(J)) .GT. ONE) SIN = SQRT(ONE-COS**2)
- IF (ABS(V(J)) .LE. ONE) SIN = V(J)
- IF (ABS(V(J)) .LE. ONE) COS = SQRT(ONE-SIN**2)
- DO 10 I = 1, M
- TEMP = COS*A(I,J) - SIN*A(I,N)
- A(I,N) = SIN*A(I,J) + COS*A(I,N)
- A(I,J) = TEMP
- 10 CONTINUE
- 20 CONTINUE
-C
-C APPLY THE SECOND SET OF GIVENS ROTATIONS TO A.
-C
- DO 40 J = 1, NM1
- IF (ABS(W(J)) .GT. ONE) COS = ONE/W(J)
- IF (ABS(W(J)) .GT. ONE) SIN = SQRT(ONE-COS**2)
- IF (ABS(W(J)) .LE. ONE) SIN = W(J)
- IF (ABS(W(J)) .LE. ONE) COS = SQRT(ONE-SIN**2)
- DO 30 I = 1, M
- TEMP = COS*A(I,J) + SIN*A(I,N)
- A(I,N) = -SIN*A(I,J) + COS*A(I,N)
- A(I,J) = TEMP
- 30 CONTINUE
- 40 CONTINUE
- 50 CONTINUE
- RETURN
-C
-C LAST CARD OF SUBROUTINE R1MPYQ.
-C
- END
- SUBROUTINE R1UPDT(M,N,S,LS,U,V,W,SING)
- INTEGER M,N,LS
- LOGICAL SING
- REAL S(LS),U(M),V(N),W(M)
-C **********
-C
-C SUBROUTINE R1UPDT
-C
-C GIVEN AN M BY N LOWER TRAPEZOIDAL MATRIX S, AN M-VECTOR U,
-C AND AN N-VECTOR V, THE PROBLEM IS TO DETERMINE AN
-C ORTHOGONAL MATRIX Q SUCH THAT
-C
-C T
-C (S + U*V )*Q
-C
-C IS AGAIN LOWER TRAPEZOIDAL.
-C
-C THIS SUBROUTINE DETERMINES Q AS THE PRODUCT OF 2*(N - 1)
-C TRANSFORMATIONS
-C
-C GV(N-1)*...*GV(1)*GW(1)*...*GW(N-1)
-C
-C WHERE GV(I), GW(I) ARE GIVENS ROTATIONS IN THE (I,N) PLANE
-C WHICH ELIMINATE ELEMENTS IN THE I-TH AND N-TH PLANES,
-C RESPECTIVELY. Q ITSELF IS NOT ACCUMULATED, RATHER THE
-C INFORMATION TO RECOVER THE GV, GW ROTATIONS IS RETURNED.
-C
-C THE SUBROUTINE STATEMENT IS
-C
-C SUBROUTINE R1UPDT(M,N,S,LS,U,V,W,SING)
-C
-C WHERE
-C
-C M IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER
-C OF ROWS OF S.
-C
-C N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER
-C OF COLUMNS OF S. N MUST NOT EXCEED M.
-C
-C S IS AN ARRAY OF LENGTH LS. ON INPUT S MUST CONTAIN THE LOWER
-C TRAPEZOIDAL MATRIX S STORED BY COLUMNS. ON OUTPUT S CONTAINS
-C THE LOWER TRAPEZOIDAL MATRIX PRODUCED AS DESCRIBED ABOVE.
-C
-C LS IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN
-C (N*(2*M-N+1))/2.
-C
-C U IS AN INPUT ARRAY OF LENGTH M WHICH MUST CONTAIN THE
-C VECTOR U.
-C
-C V IS AN ARRAY OF LENGTH N. ON INPUT V MUST CONTAIN THE VECTOR
-C V. ON OUTPUT V(I) CONTAINS THE INFORMATION NECESSARY TO
-C RECOVER THE GIVENS ROTATION GV(I) DESCRIBED ABOVE.
-C
-C W IS AN OUTPUT ARRAY OF LENGTH M. W(I) CONTAINS INFORMATION
-C NECESSARY TO RECOVER THE GIVENS ROTATION GW(I) DESCRIBED
-C ABOVE.
-C
-C SING IS A LOGICAL OUTPUT VARIABLE. SING IS SET TRUE IF ANY
-C OF THE DIAGONAL ELEMENTS OF THE OUTPUT S ARE ZERO. OTHERWISE
-C SING IS SET FALSE.
-C
-C SUBPROGRAMS CALLED
-C
-C MINPACK-SUPPLIED ... SPMPAR
-C
-C FORTRAN-SUPPLIED ... ABS,SQRT
-C
-C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980.
-C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE,
-C JOHN L. NAZARETH
-C
-C **********
- INTEGER I,J,JJ,L,NMJ,NM1
- REAL COS,COTAN,GIANT,ONE,P5,P25,SIN,TAN,TAU,TEMP,ZERO
- REAL SPMPAR
- DATA ONE,P5,P25,ZERO /1.0E0,5.0E-1,2.5E-1,0.0E0/
-C
-C GIANT IS THE LARGEST MAGNITUDE.
-C
- GIANT = SPMPAR(3)
-C
-C INITIALIZE THE DIAGONAL ELEMENT POINTER.
-C
- JJ = (N*(2*M - N + 1))/2 - (M - N)
-C
-C MOVE THE NONTRIVIAL PART OF THE LAST COLUMN OF S INTO W.
-C
- L = JJ
- DO 10 I = N, M
- W(I) = S(L)
- L = L + 1
- 10 CONTINUE
-C
-C ROTATE THE VECTOR V INTO A MULTIPLE OF THE N-TH UNIT VECTOR
-C IN SUCH A WAY THAT A SPIKE IS INTRODUCED INTO W.
-C
- NM1 = N - 1
- IF (NM1 .LT. 1) GO TO 70
- DO 60 NMJ = 1, NM1
- J = N - NMJ
- JJ = JJ - (M - J + 1)
- W(J) = ZERO
- IF (V(J) .EQ. ZERO) GO TO 50
-C
-C DETERMINE A GIVENS ROTATION WHICH ELIMINATES THE
-C J-TH ELEMENT OF V.
-C
- IF (ABS(V(N)) .GE. ABS(V(J))) GO TO 20
- COTAN = V(N)/V(J)
- SIN = P5/SQRT(P25+P25*COTAN**2)
- COS = SIN*COTAN
- TAU = ONE
- IF (ABS(COS)*GIANT .GT. ONE) TAU = ONE/COS
- GO TO 30
- 20 CONTINUE
- TAN = V(J)/V(N)
- COS = P5/SQRT(P25+P25*TAN**2)
- SIN = COS*TAN
- TAU = SIN
- 30 CONTINUE
-C
-C APPLY THE TRANSFORMATION TO V AND STORE THE INFORMATION
-C NECESSARY TO RECOVER THE GIVENS ROTATION.
-C
- V(N) = SIN*V(J) + COS*V(N)
- V(J) = TAU
-C
-C APPLY THE TRANSFORMATION TO S AND EXTEND THE SPIKE IN W.
-C
- L = JJ
- DO 40 I = J, M
- TEMP = COS*S(L) - SIN*W(I)
- W(I) = SIN*S(L) + COS*W(I)
- S(L) = TEMP
- L = L + 1
- 40 CONTINUE
- 50 CONTINUE
- 60 CONTINUE
- 70 CONTINUE
-C
-C ADD THE SPIKE FROM THE RANK 1 UPDATE TO W.
-C
- DO 80 I = 1, M
- W(I) = W(I) + V(N)*U(I)
- 80 CONTINUE
-C
-C ELIMINATE THE SPIKE.
-C
- SING = .FALSE.
- IF (NM1 .LT. 1) GO TO 140
- DO 130 J = 1, NM1
- IF (W(J) .EQ. ZERO) GO TO 120
-C
-C DETERMINE A GIVENS ROTATION WHICH ELIMINATES THE
-C J-TH ELEMENT OF THE SPIKE.
-C
- IF (ABS(S(JJ)) .GE. ABS(W(J))) GO TO 90
- COTAN = S(JJ)/W(J)
- SIN = P5/SQRT(P25+P25*COTAN**2)
- COS = SIN*COTAN
- TAU = ONE
- IF (ABS(COS)*GIANT .GT. ONE) TAU = ONE/COS
- GO TO 100
- 90 CONTINUE
- TAN = W(J)/S(JJ)
- COS = P5/SQRT(P25+P25*TAN**2)
- SIN = COS*TAN
- TAU = SIN
- 100 CONTINUE
-C
-C APPLY THE TRANSFORMATION TO S AND REDUCE THE SPIKE IN W.
-C
- L = JJ
- DO 110 I = J, M
- TEMP = COS*S(L) + SIN*W(I)
- W(I) = -SIN*S(L) + COS*W(I)
- S(L) = TEMP
- L = L + 1
- 110 CONTINUE
-C
-C STORE THE INFORMATION NECESSARY TO RECOVER THE
-C GIVENS ROTATION.
-C
- W(J) = TAU
- 120 CONTINUE
-C
-C TEST FOR ZERO DIAGONAL ELEMENTS IN THE OUTPUT S.
-C
- IF (S(JJ) .EQ. ZERO) SING = .TRUE.
- JJ = JJ + (M - J + 1)
- 130 CONTINUE
- 140 CONTINUE
-C
-C MOVE W BACK INTO THE LAST COLUMN OF THE OUTPUT S.
-C
- L = JJ
- DO 150 I = N, M
- S(L) = W(I)
- L = L + 1
- 150 CONTINUE
- IF (S(JJ) .EQ. ZERO) SING = .TRUE.
- RETURN
-C
-C LAST CARD OF SUBROUTINE R1UPDT.
-C
- END
diff --git a/CEP/PyBDSM/src/minpack/ex/file03 b/CEP/PyBDSM/src/minpack/ex/file03
deleted file mode 100644
index bd737ec6f46eb52c200338bc0b8df9d888e9328d..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/minpack/ex/file03
+++ /dev/null
@@ -1,3526 +0,0 @@
-1
-0 Page
-0 Documentation for MINPACK subroutine HYBRD1
-0 Single precision version
-0 Argonne National Laboratory
-0 Burton S. Garbow, Kenneth E. Hillstrom, Jorge J. More
-0 March 1980
-0
- 1. Purpose.
-0 The purpose of HYBRD1 is to find a zero of a system of N non-
- linear functions in N variables by a modification of the Powell
- hybrid method. This is done by using the more general nonlinea
- equation solver HYBRD. The user must provide a subroutine whic
- calculates the functions. The Jacobian is then calculated by a
- forward-difference approximation.
-0
- 2. Subroutine and type statements.
-0 SUBROUTINE HYBRD1(FCN,N,X,FVEC,TOL,INFO,WA,LWA)
- INTEGER N,INFO,LWA
- REAL TOL
- REAL X(N),FVEC(N),WA(LWA)
- EXTERNAL FCN
-0
- 3. Parameters.
-0 Parameters designated as input parameters must be specified on
- entry to HYBRD1 and are not changed on exit, while parameters
- designated as output parameters need not be specified on entry
- and are set to appropriate values on exit from HYBRD1.
-0 FCN is the name of the user-supplied subroutine which calculate
- the functions. FCN must be declared in an EXTERNAL statement
- in the user calling program, and should be written as follows
-0 SUBROUTINE FCN(N,X,FVEC,IFLAG)
- INTEGER N,IFLAG
- REAL X(N),FVEC(N)
- ----------
- CALCULATE THE FUNCTIONS AT X AND
- RETURN THIS VECTOR IN FVEC.
- ----------
- RETURN
- END
-0 The value of IFLAG should not be changed by FCN unless the
- user wants to terminate execution of HYBRD1. In this case se
- IFLAG to a negative integer.
-1
-0 Page
-0 N is a positive integer input variable set to the number of
- functions and variables.
-0 X is an array of length N. On input X must contain an initial
- estimate of the solution vector. On output X contains the
- final estimate of the solution vector.
-0 FVEC is an output array of length N which contains the function
- evaluated at the output X.
-0 TOL is a nonnegative input variable. Termination occurs when
- the algorithm estimates that the relative error between X and
- the solution is at most TOL. Section 4 contains more details
- about TOL.
-0 INFO is an integer output variable. If the user has terminated
- execution, INFO is set to the (negative) value of IFLAG. See
- description of FCN. Otherwise, INFO is set as follows.
-0 INFO = 0 Improper input parameters.
-0 INFO = 1 Algorithm estimates that the relative error between
- X and the solution is at most TOL.
-0 INFO = 2 Number of calls to FCN has reached or exceeded
- 200*(N+1).
-0 INFO = 3 TOL is too small. No further improvement in the
- approximate solution X is possible.
-0 INFO = 4 Iteration is not making good progress.
-0 Sections 4 and 5 contain more details about INFO.
-0 WA is a work array of length LWA.
-0 LWA is a positive integer input variable not less than
- (N*(3*N+13))/2.
-0
- 4. Successful completion.
-0 The accuracy of HYBRD1 is controlled by the convergence parame-
- ter TOL. This parameter is used in a test which makes a compar
- ison between the approximation X and a solution XSOL. HYBRD1
- terminates when the test is satisfied. If TOL is less than the
- machine precision (as defined by the MINPACK function
- SPMPAR(1)), then HYBRD1 only attempts to satisfy the test
- defined by the machine precision. Further progress is not usu-
- ally possible. Unless high precision solutions are required,
- the recommended value for TOL is the square root of the machine
- precision.
-0 The test assumes that the functions are reasonably well behaved
-1
-0 Page
-0 If this condition is not satisfied, then HYBRD1 may incorrectly
- indicate convergence. The validity of the answer can be
- checked, for example, by rerunning HYBRD1 with a tighter toler-
- ance.
-0 Convergence test. If ENORM(Z) denotes the Euclidean norm of a
- vector Z, then this test attempts to guarantee that
-0 ENORM(X-XSOL) .LE. TOL*ENORM(XSOL).
-0 If this condition is satisfied with TOL = 10**(-K), then the
- larger components of X have K significant decimal digits and
- INFO is set to 1. There is a danger that the smaller compo-
- nents of X may have large relative errors, but the fast rate
- of convergence of HYBRD1 usually avoids this possibility.
-0
- 5. Unsuccessful completion.
-0 Unsuccessful termination of HYBRD1 can be due to improper input
- parameters, arithmetic interrupts, an excessive number of func-
- tion evaluations, errors in the functions, or lack of good prog
- ress.
-0 Improper input parameters. INFO is set to 0 if N .LE. 0, or
- TOL .LT. 0.E0, or LWA .LT. (N*(3*N+13))/2.
-0 Arithmetic interrupts. If these interrupts occur in the FCN
- subroutine during an early stage of the computation, they may
- be caused by an unacceptable choice of X by HYBRD1. In this
- case, it may be possible to remedy the situation by not evalu
- ating the functions here, but instead setting the components
- of FVEC to numbers that exceed those in the initial FVEC,
- thereby indirectly reducing the step length. The step length
- can be more directly controlled by using instead HYBRD, which
- includes in its calling sequence the step-length- governing
- parameter FACTOR.
-0 Excessive number of function evaluations. If the number of
- calls to FCN reaches 200*(N+1), then this indicates that the
- routine is converging very slowly as measured by the progress
- of FVEC, and INFO is set to 2. This situation should be unu-
- sual because, as indicated below, lack of good progress is
- usually diagnosed earlier by HYBRD1, causing termination with
- INFO = 4.
-0 Errors in the functions. The choice of step length in the for-
- ward-difference approximation to the Jacobian assumes that th
- relative errors in the functions are of the order of the
- machine precision. If this is not the case, HYBRD1 may fail
- (usually with INFO = 4). The user should then use HYBRD
- instead, or one of the programs which require the analytic
- Jacobian (HYBRJ1 and HYBRJ).
-1
-0 Page
-0 Lack of good progress. HYBRD1 searches for a zero of the syste
- by minimizing the sum of the squares of the functions. In so
- doing, it can become trapped in a region where the minimum
- does not correspond to a zero of the system and, in this situ
- ation, the iteration eventually fails to make good progress.
- In particular, this will happen if the system does not have a
- zero. If the system has a zero, rerunning HYBRD1 from a dif-
- ferent starting point may be helpful.
-0
- 6. Characteristics of the algorithm.
-0 HYBRD1 is a modification of the Powell hybrid method. Two of
- its main characteristics involve the choice of the correction a
- a convex combination of the Newton and scaled gradient direc-
- tions, and the updating of the Jacobian by the rank-1 method of
- Broyden. The choice of the correction guarantees (under reason
- able conditions) global convergence for starting points far fro
- the solution and a fast rate of convergence. The Jacobian is
- approximated by forward differences at the starting point, but
- forward differences are not used again until the rank-1 method
- fails to produce satisfactory progress.
-0 Timing. The time required by HYBRD1 to solve a given problem
- depends on N, the behavior of the functions, the accuracy
- requested, and the starting point. The number of arithmetic
- operations needed by HYBRD1 is about 11.5*(N**2) to process
- each call to FCN. Unless FCN can be evaluated quickly, the
- timing of HYBRD1 will be strongly influenced by the time spen
- in FCN.
-0 Storage. HYBRD1 requires (3*N**2 + 17*N)/2 single precision
- storage locations, in addition to the storage required by the
- program. There are no internally declared storage arrays.
-0
- 7. Subprograms required.
-0 USER-supplied ...... FCN
-0 MINPACK-supplied ... DOGLEG,SPMPAR,ENORM,FDJAC1,HYBRD,
- QFORM,QRFAC,R1MPYQ,R1UPDT
-0 FORTRAN-supplied ... ABS,AMAX1,AMIN1,SQRT,MIN0,MOD
-0
- 8. References.
-0 M. J. D. Powell, A Hybrid Method for Nonlinear Equations.
- Numerical Methods for Nonlinear Algebraic Equations,
- P. Rabinowitz, editor. Gordon and Breach, 1970.
-0
- 9. Example.
-1
-0 Page
-0 The problem is to determine the values of x(1), x(2), ..., x(9)
- which solve the system of tridiagonal equations
-0 (3-2*x(1))*x(1) -2*x(2) = -1
- -x(i-1) + (3-2*x(i))*x(i) -2*x(i+1) = -1, i=2-8
- -x(8) + (3-2*x(9))*x(9) = -1
-0 C **********
- C
- C DRIVER FOR HYBRD1 EXAMPLE.
- C SINGLE PRECISION VERSION
- C
- C **********
- INTEGER J,N,INFO,LWA,NWRITE
- REAL TOL,FNORM
- REAL X(9),FVEC(9),WA(180)
- REAL ENORM,SPMPAR
- EXTERNAL FCN
- C
- C LOGICAL OUTPUT UNIT IS ASSUMED TO BE NUMBER 6.
- C
- DATA NWRITE /6/
- C
- N = 9
- C
- C THE FOLLOWING STARTING VALUES PROVIDE A ROUGH SOLUTION.
- C
- DO 10 J = 1, 9
- X(J) = -1.E0
- 10 CONTINUE
- C
- LWA = 180
- C
- C SET TOL TO THE SQUARE ROOT OF THE MACHINE PRECISION.
- C UNLESS HIGH PRECISION SOLUTIONS ARE REQUIRED,
- C THIS IS THE RECOMMENDED SETTING.
- C
- TOL = SQRT(SPMPAR(1))
- C
- CALL HYBRD1(FCN,N,X,FVEC,TOL,INFO,WA,LWA)
- FNORM = ENORM(N,FVEC)
- WRITE (NWRITE,1000) FNORM,INFO,(X(J),J=1,N)
- STOP
- 1000 FORMAT (5X,31H FINAL L2 NORM OF THE RESIDUALS,E15.7 //
- * 5X,15H EXIT PARAMETER,16X,I10 //
- * 5X,27H FINAL APPROXIMATE SOLUTION // (5X,3E15.7))
- C
- C LAST CARD OF DRIVER FOR HYBRD1 EXAMPLE.
- C
- END
- SUBROUTINE FCN(N,X,FVEC,IFLAG)
- INTEGER N,IFLAG
- REAL X(N),FVEC(N)
- C
-1
-0 Page
-0 C SUBROUTINE FCN FOR HYBRD1 EXAMPLE.
- C
- INTEGER K
- REAL ONE,TEMP,TEMP1,TEMP2,THREE,TWO,ZERO
- DATA ZERO,ONE,TWO,THREE /0.E0,1.E0,2.E0,3.E0/
- C
- DO 10 K = 1, N
- TEMP = (THREE - TWO*X(K))*X(K)
- TEMP1 = ZERO
- IF (K .NE. 1) TEMP1 = X(K-1)
- TEMP2 = ZERO
- IF (K .NE. N) TEMP2 = X(K+1)
- FVEC(K) = TEMP - TEMP1 - TWO*TEMP2 + ONE
- 10 CONTINUE
- RETURN
- C
- C LAST CARD OF SUBROUTINE FCN.
- C
- END
-0 Results obtained with different compilers or machines
- may be slightly different.
-0 FINAL L2 NORM OF THE RESIDUALS 0.1192636E-07
-0 EXIT PARAMETER 1
-0 FINAL APPROXIMATE SOLUTION
-0 -0.5706545E+00 -0.6816283E+00 -0.7017325E+00
- -0.7042129E+00 -0.7013690E+00 -0.6918656E+00
- -0.6657920E+00 -0.5960342E+00 -0.4164121E+00
-1
-0
-1
-0 Page
-0 Documentation for MINPACK subroutine HYBRD
-0 Single precision version
-0 Argonne National Laboratory
-0 Burton S. Garbow, Kenneth E. Hillstrom, Jorge J. More
-0 March 1980
-0
- 1. Purpose.
-0 The purpose of HYBRD is to find a zero of a system of N non-
- linear functions in N variables by a modification of the Powell
- hybrid method. The user must provide a subroutine which calcu-
- lates the functions. The Jacobian is then calculated by a for-
- ward-difference approximation.
-0
- 2. Subroutine and type statements.
-0 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
- REAL XTOL,EPSFCN,FACTOR
- REAL X(N),FVEC(N),DIAG(N),FJAC(LDFJAC,N),R(LR),QTF(N),
- * WA1(N),WA2(N),WA3(N),WA4(N)
- EXTERNAL FCN
-0
- 3. Parameters.
-0 Parameters designated as input parameters must be specified on
- entry to HYBRD and are not changed on exit, while parameters
- designated as output parameters need not be specified on entry
- and are set to appropriate values on exit from HYBRD.
-0 FCN is the name of the user-supplied subroutine which calculate
- the functions. FCN must be declared in an EXTERNAL statement
- in the user calling program, and should be written as follows
-0 SUBROUTINE FCN(N,X,FVEC,IFLAG)
- INTEGER N,IFLAG
- REAL X(N),FVEC(N)
- ----------
- CALCULATE THE FUNCTIONS AT X AND
- RETURN THIS VECTOR IN FVEC.
- ----------
- RETURN
- END
-0 The value of IFLAG should not be changed by FCN unless the
-1
-0 Page
-0 user wants to terminate execution of HYBRD. In this case set
- IFLAG to a negative integer.
-0 N is a positive integer input variable set to the number of
- functions and variables.
-0 X is an array of length N. On input X must contain an initial
- estimate of the solution vector. On output X contains the
- final estimate of the solution vector.
-0 FVEC is an output array of length N which contains the function
- evaluated at the output X.
-0 XTOL is a nonnegative input variable. Termination occurs when
- the relative error between two consecutive iterates is at mos
- XTOL. Therefore, XTOL measures the relative error desired in
- the approximate solution. Section 4 contains more details
- about XTOL.
-0 MAXFEV is a positive integer input variable. Termination occur
- when the number of calls to FCN is at least MAXFEV by the end
- of an iteration.
-0 ML is a nonnegative integer input variable which specifies the
- number of subdiagonals within the band of the Jacobian matrix
- If the Jacobian is not banded, set ML to at least N - 1.
-0 MU is a nonnegative integer input variable which specifies the
- number of superdiagonals within the band of the Jacobian
- matrix. If the Jacobian is not banded, set MU to at least
- N - 1.
-0 EPSFCN is an input variable used in determining a suitable step
- for the forward-difference approximation. This approximation
- assumes that the relative errors in the functions are of the
- order of EPSFCN. If EPSFCN is less than the machine preci-
- sion, it is assumed that the relative errors in the functions
- are of the order of the machine precision.
-0 DIAG is an array of length N. If MODE = 1 (see below), DIAG is
- internally set. If MODE = 2, DIAG must contain positive
- entries that serve as multiplicative scale factors for the
- variables.
-0 MODE is an integer input variable. If MODE = 1, the variables
- will be scaled internally. If MODE = 2, the scaling is speci
- fied by the input DIAG. Other values of MODE are equivalent
- to MODE = 1.
-0 FACTOR is a positive input variable used in determining the ini
- tial step bound. This bound is set to the product of FACTOR
- and the Euclidean norm of DIAG*X if nonzero, or else to FACTO
- itself. In most cases FACTOR should lie in the interval
- (.1,100.). 100. is a generally recommended value.
-1
-0 Page
-0 NPRINT is an integer input variable that enables controlled
- printing of iterates if it is positive. In this case, FCN is
- called with IFLAG = 0 at the beginning of the first iteration
- and every NPRINT iterations thereafter and immediately prior
- to return, with X and FVEC available for printing. If NPRINT
- is not positive, no special calls of FCN with IFLAG = 0 are
- made.
-0 INFO is an integer output variable. If the user has terminated
- execution, INFO is set to the (negative) value of IFLAG. See
- description of FCN. Otherwise, INFO is set as follows.
-0 INFO = 0 Improper input parameters.
-0 INFO = 1 Relative error between two consecutive iterates is
- at most XTOL.
-0 INFO = 2 Number of calls to FCN has reached or exceeded
- MAXFEV.
-0 INFO = 3 XTOL is too small. No further improvement in the
- approximate solution X is possible.
-0 INFO = 4 Iteration is not making good progress, as measured
- by the improvement from the last five Jacobian eval
- uations.
-0 INFO = 5 Iteration is not making good progress, as measured
- by the improvement from the last ten iterations.
-0 Sections 4 and 5 contain more details about INFO.
-0 NFEV is an integer output variable set to the number of calls t
- FCN.
-0 FJAC is an output N by N array which contains the orthogonal
- matrix Q produced by the QR factorization of the final approx
- imate Jacobian.
-0 LDFJAC is a positive integer input variable not less than N
- which specifies the leading dimension of the array FJAC.
-0 R is an output array of length LR which contains the upper
- triangular matrix produced by the QR factorization of the
- final approximate Jacobian, stored rowwise.
-0 LR is a positive integer input variable not less than
- (N*(N+1))/2.
-0 QTF is an output array of length N which contains the vector
- (Q transpose)*FVEC.
-0 WA1, WA2, WA3, and WA4 are work arrays of length N.
-1
-0 Page
-0
- 4. Successful completion.
-0 The accuracy of HYBRD is controlled by the convergence paramete
- XTOL. This parameter is used in a test which makes a compariso
- between the approximation X and a solution XSOL. HYBRD termi-
- nates when the test is satisfied. If the convergence parameter
- is less than the machine precision (as defined by the MINPACK
- function SPMPAR(1)), then HYBRD only attempts to satisfy the
- test defined by the machine precision. Further progress is not
- usually possible.
-0 The test assumes that the functions are reasonably well behaved
- If this condition is not satisfied, then HYBRD may incorrectly
- indicate convergence. The validity of the answer can be
- checked, for example, by rerunning HYBRD with a tighter toler-
- ance.
-0 Convergence test. If ENORM(Z) denotes the Euclidean norm of a
- vector Z and D is the diagonal matrix whose entries are
- defined by the array DIAG, then this test attempts to guaran-
- tee that
-0 ENORM(D*(X-XSOL)) .LE. XTOL*ENORM(D*XSOL).
-0 If this condition is satisfied with XTOL = 10**(-K), then the
- larger components of D*X have K significant decimal digits an
- INFO is set to 1. There is a danger that the smaller compo-
- nents of D*X may have large relative errors, but the fast rat
- of convergence of HYBRD usually avoids this possibility.
- Unless high precision solutions are required, the recommended
- value for XTOL is the square root of the machine precision.
-0
- 5. Unsuccessful completion.
-0 Unsuccessful termination of HYBRD can be due to improper input
- parameters, arithmetic interrupts, an excessive number of func-
- tion evaluations, or lack of good progress.
-0 Improper input parameters. INFO is set to 0 if N .LE. 0, or
- XTOL .LT. 0.E0, or MAXFEV .LE. 0, or ML .LT. 0, or MU .LT. 0,
- or FACTOR .LE. 0.E0, or LDFJAC .LT. N, or LR .LT. (N*(N+1))/2
-0 Arithmetic interrupts. If these interrupts occur in the FCN
- subroutine during an early stage of the computation, they may
- be caused by an unacceptable choice of X by HYBRD. In this
- case, it may be possible to remedy the situation by rerunning
- HYBRD with a smaller value of FACTOR.
-0 Excessive number of function evaluations. A reasonable value
- for MAXFEV is 200*(N+1). If the number of calls to FCN
- reaches MAXFEV, then this indicates that the routine is con-
- verging very slowly as measured by the progress of FVEC, and
-1
-0 Page
-0 INFO is set to 2. This situation should be unusual because,
- as indicated below, lack of good progress is usually diagnose
- earlier by HYBRD, causing termination with INFO = 4 or
- INFO = 5.
-0 Lack of good progress. HYBRD searches for a zero of the system
- by minimizing the sum of the squares of the functions. In so
- doing, it can become trapped in a region where the minimum
- does not correspond to a zero of the system and, in this situ
- ation, the iteration eventually fails to make good progress.
- In particular, this will happen if the system does not have a
- zero. If the system has a zero, rerunning HYBRD from a dif-
- ferent starting point may be helpful.
-0
- 6. Characteristics of the algorithm.
-0 HYBRD is a modification of the Powell hybrid method. Two of it
- main characteristics involve the choice of the correction as a
- convex combination of the Newton and scaled gradient directions
- and the updating of the Jacobian by the rank-1 method of Broy-
- den. The choice of the correction guarantees (under reasonable
- conditions) global convergence for starting points far from the
- solution and a fast rate of convergence. The Jacobian is
- approximated by forward differences at the starting point, but
- forward differences are not used again until the rank-1 method
- fails to produce satisfactory progress.
-0 Timing. The time required by HYBRD to solve a given problem
- depends on N, the behavior of the functions, the accuracy
- requested, and the starting point. The number of arithmetic
- operations needed by HYBRD is about 11.5*(N**2) to process
- each call to FCN. Unless FCN can be evaluated quickly, the
- timing of HYBRD will be strongly influenced by the time spent
- in FCN.
-0 Storage. HYBRD requires (3*N**2 + 17*N)/2 single precision
- storage locations, in addition to the storage required by the
- program. There are no internally declared storage arrays.
-0
- 7. Subprograms required.
-0 USER-supplied ...... FCN
-0 MINPACK-supplied ... DOGLEG,SPMPAR,ENORM,FDJAC1,
- QFORM,QRFAC,R1MPYQ,R1UPDT
-0 FORTRAN-supplied ... ABS,AMAX1,AMIN1,SQRT,MIN0,MOD
-0
- 8. References.
-0 M. J. D. Powell, A Hybrid Method for Nonlinear Equations.
-1
-0 Page
-0 Numerical Methods for Nonlinear Algebraic Equations,
- P. Rabinowitz, editor. Gordon and Breach, 1970.
-0
- 9. Example.
-0 The problem is to determine the values of x(1), x(2), ..., x(9)
- which solve the system of tridiagonal equations
-0 (3-2*x(1))*x(1) -2*x(2) = -1
- -x(i-1) + (3-2*x(i))*x(i) -2*x(i+1) = -1, i=2-8
- -x(8) + (3-2*x(9))*x(9) = -1
-0 C **********
- C
- C DRIVER FOR HYBRD EXAMPLE.
- C SINGLE PRECISION VERSION
- C
- C **********
- INTEGER J,N,MAXFEV,ML,MU,MODE,NPRINT,INFO,NFEV,LDFJAC,LR,NWRITE
- REAL XTOL,EPSFCN,FACTOR,FNORM
- REAL X(9),FVEC(9),DIAG(9),FJAC(9,9),R(45),QTF(9),
- * WA1(9),WA2(9),WA3(9),WA4(9)
- REAL ENORM,SPMPAR
- EXTERNAL FCN
- C
- C LOGICAL OUTPUT UNIT IS ASSUMED TO BE NUMBER 6.
- C
- DATA NWRITE /6/
- C
- N = 9
- C
- C THE FOLLOWING STARTING VALUES PROVIDE A ROUGH SOLUTION.
- C
- DO 10 J = 1, 9
- X(J) = -1.E0
- 10 CONTINUE
- C
- LDFJAC = 9
- LR = 45
- C
- C SET XTOL TO THE SQUARE ROOT OF THE MACHINE PRECISION.
- C UNLESS HIGH PRECISION SOLUTIONS ARE REQUIRED,
- C THIS IS THE RECOMMENDED SETTING.
- C
- XTOL = SQRT(SPMPAR(1))
- C
- MAXFEV = 2000
- ML = 1
- MU = 1
- EPSFCN = 0.E0
- MODE = 2
- DO 20 J = 1, 9
- DIAG(J) = 1.E0
-1
-0 Page
-0 20 CONTINUE
- FACTOR = 1.E2
- NPRINT = 0
- C
- CALL 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)
- FNORM = ENORM(N,FVEC)
- WRITE (NWRITE,1000) FNORM,NFEV,INFO,(X(J),J=1,N)
- STOP
- 1000 FORMAT (5X,31H FINAL L2 NORM OF THE RESIDUALS,E15.7 //
- * 5X,31H NUMBER OF FUNCTION EVALUATIONS,I10 //
- * 5X,15H EXIT PARAMETER,16X,I10 //
- * 5X,27H FINAL APPROXIMATE SOLUTION // (5X,3E15.7))
- C
- C LAST CARD OF DRIVER FOR HYBRD EXAMPLE.
- C
- END
- SUBROUTINE FCN(N,X,FVEC,IFLAG)
- INTEGER N,IFLAG
- REAL X(N),FVEC(N)
- C
- C SUBROUTINE FCN FOR HYBRD EXAMPLE.
- C
- INTEGER K
- REAL ONE,TEMP,TEMP1,TEMP2,THREE,TWO,ZERO
- DATA ZERO,ONE,TWO,THREE /0.E0,1.E0,2.E0,3.E0/
- C
- IF (IFLAG .NE. 0) GO TO 5
- C
- C INSERT PRINT STATEMENTS HERE WHEN NPRINT IS POSITIVE.
- C
- RETURN
- 5 CONTINUE
- DO 10 K = 1, N
- TEMP = (THREE - TWO*X(K))*X(K)
- TEMP1 = ZERO
- IF (K .NE. 1) TEMP1 = X(K-1)
- TEMP2 = ZERO
- IF (K .NE. N) TEMP2 = X(K+1)
- FVEC(K) = TEMP - TEMP1 - TWO*TEMP2 + ONE
- 10 CONTINUE
- RETURN
- C
- C LAST CARD OF SUBROUTINE FCN.
- C
- END
-0 Results obtained with different compilers or machines
- may be slightly different.
-0 FINAL L2 NORM OF THE RESIDUALS 0.1192636E-07
-0 NUMBER OF FUNCTION EVALUATIONS 14
-1
-0 Page
-0 EXIT PARAMETER 1
-0 FINAL APPROXIMATE SOLUTION
-0 -0.5706545E+00 -0.6816283E+00 -0.7017325E+00
- -0.7042129E+00 -0.7013690E+00 -0.6918656E+00
- -0.6657920E+00 -0.5960342E+00 -0.4164121E+00
-1
-0
-1
-0 Page
-0 Documentation for MINPACK subroutine HYBRJ1
-0 Single precision version
-0 Argonne National Laboratory
-0 Burton S. Garbow, Kenneth E. Hillstrom, Jorge J. More
-0 March 1980
-0
- 1. Purpose.
-0 The purpose of HYBRJ1 is to find a zero of a system of N non-
- linear functions in N variables by a modification of the Powell
- hybrid method. This is done by using the more general nonlinea
- equation solver HYBRJ. The user must provide a subroutine whic
- calculates the functions and the Jacobian.
-0
- 2. Subroutine and type statements.
-0 SUBROUTINE HYBRJ1(FCN,N,X,FVEC,FJAC,LDFJAC,TOL,INFO,WA,LWA)
- INTEGER N,LDFJAC,INFO,LWA
- REAL TOL
- REAL X(N),FVEC(N),FJAC(LDFJAC,N),WA(LWA)
- EXTERNAL FCN
-0
- 3. Parameters.
-0 Parameters designated as input parameters must be specified on
- entry to HYBRJ1 and are not changed on exit, while parameters
- designated as output parameters need not be specified on entry
- and are set to appropriate values on exit from HYBRJ1.
-0 FCN is the name of the user-supplied subroutine which calculate
- the functions and the Jacobian. FCN must be declared in an
- EXTERNAL statement in the user calling program, and should be
- written as follows.
-0 SUBROUTINE FCN(N,X,FVEC,FJAC,LDFJAC,IFLAG)
- INTEGER N,LDFJAC,IFLAG
- REAL X(N),FVEC(N),FJAC(LDFJAC,N)
- ----------
- IF IFLAG = 1 CALCULATE THE FUNCTIONS AT X AND
- RETURN THIS VECTOR IN FVEC. DO NOT ALTER FJAC.
- IF IFLAG = 2 CALCULATE THE JACOBIAN AT X AND
- RETURN THIS MATRIX IN FJAC. DO NOT ALTER FVEC.
- ----------
- RETURN
- END
-0 The value of IFLAG should not be changed by FCN unless the
-1
-0 Page
-0 user wants to terminate execution of HYBRJ1. In this case se
- IFLAG to a negative integer.
-0 N is a positive integer input variable set to the number of
- functions and variables.
-0 X is an array of length N. On input X must contain an initial
- estimate of the solution vector. On output X contains the
- final estimate of the solution vector.
-0 FVEC is an output array of length N which contains the function
- evaluated at the output X.
-0 FJAC is an output N by N array which contains the orthogonal
- matrix Q produced by the QR factorization of the final approx
- imate Jacobian. Section 6 contains more details about the
- approximation to the Jacobian.
-0 LDFJAC is a positive integer input variable not less than N
- which specifies the leading dimension of the array FJAC.
-0 TOL is a nonnegative input variable. Termination occurs when
- the algorithm estimates that the relative error between X and
- the solution is at most TOL. Section 4 contains more details
- about TOL.
-0 INFO is an integer output variable. If the user has terminated
- execution, INFO is set to the (negative) value of IFLAG. See
- description of FCN. Otherwise, INFO is set as follows.
-0 INFO = 0 Improper input parameters.
-0 INFO = 1 Algorithm estimates that the relative error between
- X and the solution is at most TOL.
-0 INFO = 2 Number of calls to FCN with IFLAG = 1 has reached
- 100*(N+1).
-0 INFO = 3 TOL is too small. No further improvement in the
- approximate solution X is possible.
-0 INFO = 4 Iteration is not making good progress.
-0 Sections 4 and 5 contain more details about INFO.
-0 WA is a work array of length LWA.
-0 LWA is a positive integer input variable not less than
- (N*(N+13))/2.
-0
- 4. Successful completion.
-0 The accuracy of HYBRJ1 is controlled by the convergence
-1
-0 Page
-0 parameter TOL. This parameter is used in a test which makes a
- comparison between the approximation X and a solution XSOL.
- HYBRJ1 terminates when the test is satisfied. If TOL is less
- than the machine precision (as defined by the MINPACK function
- SPMPAR(1)), then HYBRJ1 only attempts to satisfy the test
- defined by the machine precision. Further progress is not usu-
- ally possible. Unless high precision solutions are required,
- the recommended value for TOL is the square root of the machine
- precision.
-0 The test assumes that the functions and the Jacobian are coded
- consistently, and that the functions are reasonably well
- behaved. If these conditions are not satisfied, then HYBRJ1 ma
- incorrectly indicate convergence. The coding of the Jacobian
- can be checked by the MINPACK subroutine CHKDER. If the Jaco-
- bian is coded correctly, then the validity of the answer can be
- checked, for example, by rerunning HYBRJ1 with a tighter toler-
- ance.
-0 Convergence test. If ENORM(Z) denotes the Euclidean norm of a
- vector Z, then this test attempts to guarantee that
-0 ENORM(X-XSOL) .LE. TOL*ENORM(XSOL).
-0 If this condition is satisfied with TOL = 10**(-K), then the
- larger components of X have K significant decimal digits and
- INFO is set to 1. There is a danger that the smaller compo-
- nents of X may have large relative errors, but the fast rate
- of convergence of HYBRJ1 usually avoids this possibility.
-0
- 5. Unsuccessful completion.
-0 Unsuccessful termination of HYBRJ1 can be due to improper input
- parameters, arithmetic interrupts, an excessive number of func-
- tion evaluations, or lack of good progress.
-0 Improper input parameters. INFO is set to 0 if N .LE. 0, or
- LDFJAC .LT. N, or TOL .LT. 0.E0, or LWA .LT. (N*(N+13))/2.
-0 Arithmetic interrupts. If these interrupts occur in the FCN
- subroutine during an early stage of the computation, they may
- be caused by an unacceptable choice of X by HYBRJ1. In this
- case, it may be possible to remedy the situation by not evalu
- ating the functions here, but instead setting the components
- of FVEC to numbers that exceed those in the initial FVEC,
- thereby indirectly reducing the step length. The step length
- can be more directly controlled by using instead HYBRJ, which
- includes in its calling sequence the step-length- governing
- parameter FACTOR.
-0 Excessive number of function evaluations. If the number of
- calls to FCN with IFLAG = 1 reaches 100*(N+1), then this indi
- cates that the routine is converging very slowly as measured
-1
-0 Page
-0 by the progress of FVEC, and INFO is set to 2. This situatio
- should be unusual because, as indicated below, lack of good
- progress is usually diagnosed earlier by HYBRJ1, causing ter-
- mination with INFO = 4.
-0 Lack of good progress. HYBRJ1 searches for a zero of the syste
- by minimizing the sum of the squares of the functions. In so
- doing, it can become trapped in a region where the minimum
- does not correspond to a zero of the system and, in this situ
- ation, the iteration eventually fails to make good progress.
- In particular, this will happen if the system does not have a
- zero. If the system has a zero, rerunning HYBRJ1 from a dif-
- ferent starting point may be helpful.
-0
- 6. Characteristics of the algorithm.
-0 HYBRJ1 is a modification of the Powell hybrid method. Two of
- its main characteristics involve the choice of the correction a
- a convex combination of the Newton and scaled gradient direc-
- tions, and the updating of the Jacobian by the rank-1 method of
- Broyden. The choice of the correction guarantees (under reason
- able conditions) global convergence for starting points far fro
- the solution and a fast rate of convergence. The Jacobian is
- calculated at the starting point, but it is not recalculated
- until the rank-1 method fails to produce satisfactory progress.
-0 Timing. The time required by HYBRJ1 to solve a given problem
- depends on N, the behavior of the functions, the accuracy
- requested, and the starting point. The number of arithmetic
- operations needed by HYBRJ1 is about 11.5*(N**2) to process
- each evaluation of the functions (call to FCN with IFLAG = 1)
- and 1.3*(N**3) to process each evaluation of the Jacobian
- (call to FCN with IFLAG = 2). Unless FCN can be evaluated
- quickly, the timing of HYBRJ1 will be strongly influenced by
- the time spent in FCN.
-0 Storage. HYBRJ1 requires (3*N**2 + 17*N)/2 single precision
- storage locations, in addition to the storage required by the
- program. There are no internally declared storage arrays.
-0
- 7. Subprograms required.
-0 USER-supplied ...... FCN
-0 MINPACK-supplied ... DOGLEG,SPMPAR,ENORM,HYBRJ,
- QFORM,QRFAC,R1MPYQ,R1UPDT
-0 FORTRAN-supplied ... ABS,AMAX1,AMIN1,SQRT,MIN0,MOD
-0
- 8. References.
-1
-0 Page
-0 M. J. D. Powell, A Hybrid Method for Nonlinear Equations.
- Numerical Methods for Nonlinear Algebraic Equations,
- P. Rabinowitz, editor. Gordon and Breach, 1970.
-0
- 9. Example.
-0 The problem is to determine the values of x(1), x(2), ..., x(9)
- which solve the system of tridiagonal equations
-0 (3-2*x(1))*x(1) -2*x(2) = -1
- -x(i-1) + (3-2*x(i))*x(i) -2*x(i+1) = -1, i=2-8
- -x(8) + (3-2*x(9))*x(9) = -1
-0 C **********
- C
- C DRIVER FOR HYBRJ1 EXAMPLE.
- C SINGLE PRECISION VERSION
- C
- C **********
- INTEGER J,N,LDFJAC,INFO,LWA,NWRITE
- REAL TOL,FNORM
- REAL X(9),FVEC(9),FJAC(9,9),WA(99)
- REAL ENORM,SPMPAR
- EXTERNAL FCN
- C
- C LOGICAL OUTPUT UNIT IS ASSUMED TO BE NUMBER 6.
- C
- DATA NWRITE /6/
- C
- N = 9
- C
- C THE FOLLOWING STARTING VALUES PROVIDE A ROUGH SOLUTION.
- C
- DO 10 J = 1, 9
- X(J) = -1.E0
- 10 CONTINUE
- C
- LDFJAC = 9
- LWA = 99
- C
- C SET TOL TO THE SQUARE ROOT OF THE MACHINE PRECISION.
- C UNLESS HIGH PRECISION SOLUTIONS ARE REQUIRED,
- C THIS IS THE RECOMMENDED SETTING.
- C
- TOL = SQRT(SPMPAR(1))
- C
- CALL HYBRJ1(FCN,N,X,FVEC,FJAC,LDFJAC,TOL,INFO,WA,LWA)
- FNORM = ENORM(N,FVEC)
- WRITE (NWRITE,1000) FNORM,INFO,(X(J),J=1,N)
- STOP
- 1000 FORMAT (5X,31H FINAL L2 NORM OF THE RESIDUALS,E15.7 //
- * 5X,15H EXIT PARAMETER,16X,I10 //
- * 5X,27H FINAL APPROXIMATE SOLUTION // (5X,3E15.7))
-1
-0 Page
-0 C
- C LAST CARD OF DRIVER FOR HYBRJ1 EXAMPLE.
- C
- END
- SUBROUTINE FCN(N,X,FVEC,FJAC,LDFJAC,IFLAG)
- INTEGER N,LDFJAC,IFLAG
- REAL X(N),FVEC(N),FJAC(LDFJAC,N)
- C
- C SUBROUTINE FCN FOR HYBRJ1 EXAMPLE.
- C
- INTEGER J,K
- REAL ONE,TEMP,TEMP1,TEMP2,THREE,TWO,ZERO
- DATA ZERO,ONE,TWO,THREE,FOUR /0.E0,1.E0,2.E0,3.E0,4.E0/
- C
- IF (IFLAG .EQ. 2) GO TO 20
- DO 10 K = 1, N
- TEMP = (THREE - TWO*X(K))*X(K)
- TEMP1 = ZERO
- IF (K .NE. 1) TEMP1 = X(K-1)
- TEMP2 = ZERO
- IF (K .NE. N) TEMP2 = X(K+1)
- FVEC(K) = TEMP - TEMP1 - TWO*TEMP2 + ONE
- 10 CONTINUE
- GO TO 50
- 20 CONTINUE
- DO 40 K = 1, N
- DO 30 J = 1, N
- FJAC(K,J) = ZERO
- 30 CONTINUE
- FJAC(K,K) = THREE - FOUR*X(K)
- IF (K .NE. 1) FJAC(K,K-1) = -ONE
- IF (K .NE. N) FJAC(K,K+1) = -TWO
- 40 CONTINUE
- 50 CONTINUE
- RETURN
- C
- C LAST CARD OF SUBROUTINE FCN.
- C
- END
-0 Results obtained with different compilers or machines
- may be slightly different.
-0 FINAL L2 NORM OF THE RESIDUALS 0.1192636E-07
-0 EXIT PARAMETER 1
-0 FINAL APPROXIMATE SOLUTION
-0 -0.5706545E+00 -0.6816283E+00 -0.7017325E+00
- -0.7042129E+00 -0.7013690E+00 -0.6918656E+00
- -0.6657920E+00 -0.5960342E+00 -0.4164121E+00
-1
-0
-1
-0 Page
-0 Documentation for MINPACK subroutine HYBRJ
-0 Single precision version
-0 Argonne National Laboratory
-0 Burton S. Garbow, Kenneth E. Hillstrom, Jorge J. More
-0 March 1980
-0
- 1. Purpose.
-0 The purpose of HYBRJ is to find a zero of a system of N non-
- linear functions in N variables by a modification of the Powell
- hybrid method. The user must provide a subroutine which calcu-
- lates the functions and the Jacobian.
-0
- 2. Subroutine and type statements.
-0 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
- REAL XTOL,FACTOR
- REAL X(N),FVEC(N),FJAC(LDFJAC,N),DIAG(N),R(LR),QTF(N),
- * WA1(N),WA2(N),WA3(N),WA4(N)
-0
- 3. Parameters.
-0 Parameters designated as input parameters must be specified on
- entry to HYBRJ and are not changed on exit, while parameters
- designated as output parameters need not be specified on entry
- and are set to appropriate values on exit from HYBRJ.
-0 FCN is the name of the user-supplied subroutine which calculate
- the functions and the Jacobian. FCN must be declared in an
- EXTERNAL statement in the user calling program, and should be
- written as follows.
-0 SUBROUTINE FCN(N,X,FVEC,FJAC,LDFJAC,IFLAG)
- INTEGER N,LDFJAC,IFLAG
- REAL X(N),FVEC(N),FJAC(LDFJAC,N)
- ----------
- IF IFLAG = 1 CALCULATE THE FUNCTIONS AT X AND
- RETURN THIS VECTOR IN FVEC. DO NOT ALTER FJAC.
- IF IFLAG = 2 CALCULATE THE JACOBIAN AT X AND
- RETURN THIS MATRIX IN FJAC. DO NOT ALTER FVEC.
- ----------
- RETURN
- END
-1
-0 Page
-0 The value of IFLAG should not be changed by FCN unless the
- user wants to terminate execution of HYBRJ. In this case set
- IFLAG to a negative integer.
-0 N is a positive integer input variable set to the number of
- functions and variables.
-0 X is an array of length N. On input X must contain an initial
- estimate of the solution vector. On output X contains the
- final estimate of the solution vector.
-0 FVEC is an output array of length N which contains the function
- evaluated at the output X.
-0 FJAC is an output N by N array which contains the orthogonal
- matrix Q produced by the QR factorization of the final approx
- imate Jacobian. Section 6 contains more details about the
- approximation to the Jacobian.
-0 LDFJAC is a positive integer input variable not less than N
- which specifies the leading dimension of the array FJAC.
-0 XTOL is a nonnegative input variable. Termination occurs when
- the relative error between two consecutive iterates is at mos
- XTOL. Therefore, XTOL measures the relative error desired in
- the approximate solution. Section 4 contains more details
- about XTOL.
-0 MAXFEV is a positive integer input variable. Termination occur
- when the number of calls to FCN with IFLAG = 1 has reached
- MAXFEV.
-0 DIAG is an array of length N. If MODE = 1 (see below), DIAG is
- internally set. If MODE = 2, DIAG must contain positive
- entries that serve as multiplicative scale factors for the
- variables.
-0 MODE is an integer input variable. If MODE = 1, the variables
- will be scaled internally. If MODE = 2, the scaling is speci
- fied by the input DIAG. Other values of MODE are equivalent
- to MODE = 1.
-0 FACTOR is a positive input variable used in determining the ini
- tial step bound. This bound is set to the product of FACTOR
- and the Euclidean norm of DIAG*X if nonzero, or else to FACTO
- itself. In most cases FACTOR should lie in the interval
- (.1,100.). 100. is a generally recommended value.
-0 NPRINT is an integer input variable that enables controlled
- printing of iterates if it is positive. In this case, FCN is
- called with IFLAG = 0 at the beginning of the first iteration
- and every NPRINT iterations thereafter and immediately prior
- to return, with X and FVEC available for printing. FVEC and
- FJAC should not be altered. If NPRINT is not positive, no
-1
-0 Page
-0 special calls of FCN with IFLAG = 0 are made.
-0 INFO is an integer output variable. If the user has terminated
- execution, INFO is set to the (negative) value of IFLAG. See
- description of FCN. Otherwise, INFO is set as follows.
-0 INFO = 0 Improper input parameters.
-0 INFO = 1 Relative error between two consecutive iterates is
- at most XTOL.
-0 INFO = 2 Number of calls to FCN with IFLAG = 1 has reached
- MAXFEV.
-0 INFO = 3 XTOL is too small. No further improvement in the
- approximate solution X is possible.
-0 INFO = 4 Iteration is not making good progress, as measured
- by the improvement from the last five Jacobian eval
- uations.
-0 INFO = 5 Iteration is not making good progress, as measured
- by the improvement from the last ten iterations.
-0 Sections 4 and 5 contain more details about INFO.
-0 NFEV is an integer output variable set to the number of calls t
- FCN with IFLAG = 1.
-0 NJEV is an integer output variable set to the number of calls t
- FCN with IFLAG = 2.
-0 R is an output array of length LR which contains the upper
- triangular matrix produced by the QR factorization of the
- final approximate Jacobian, stored rowwise.
-0 LR is a positive integer input variable not less than
- (N*(N+1))/2.
-0 QTF is an output array of length N which contains the vector
- (Q transpose)*FVEC.
-0 WA1, WA2, WA3, and WA4 are work arrays of length N.
-0
- 4. Successful completion.
-0 The accuracy of HYBRJ is controlled by the convergence paramete
- XTOL. This parameter is used in a test which makes a compariso
- between the approximation X and a solution XSOL. HYBRJ termi-
- nates when the test is satisfied. If the convergence parameter
- is less than the machine precision (as defined by the MINPACK
- function SPMPAR(1)), then HYBRJ only attempts to satisfy the
- test defined by the machine precision. Further progress is not
-1
-0 Page
-0 usually possible.
-0 The test assumes that the functions and the Jacobian are coded
- consistently, and that the functions are reasonably well
- behaved. If these conditions are not satisfied, then HYBRJ may
- incorrectly indicate convergence. The coding of the Jacobian
- can be checked by the MINPACK subroutine CHKDER. If the Jaco-
- bian is coded correctly, then the validity of the answer can be
- checked, for example, by rerunning HYBRJ with a tighter toler-
- ance.
-0 Convergence test. If ENORM(Z) denotes the Euclidean norm of a
- vector Z and D is the diagonal matrix whose entries are
- defined by the array DIAG, then this test attempts to guaran-
- tee that
-0 ENORM(D*(X-XSOL)) .LE. XTOL*ENORM(D*XSOL).
-0 If this condition is satisfied with XTOL = 10**(-K), then the
- larger components of D*X have K significant decimal digits an
- INFO is set to 1. There is a danger that the smaller compo-
- nents of D*X may have large relative errors, but the fast rat
- of convergence of HYBRJ usually avoids this possibility.
- Unless high precision solutions are required, the recommended
- value for XTOL is the square root of the machine precision.
-0
- 5. Unsuccessful completion.
-0 Unsuccessful termination of HYBRJ can be due to improper input
- parameters, arithmetic interrupts, an excessive number of func-
- tion evaluations, or lack of good progress.
-0 Improper input parameters. INFO is set to 0 if N .LE. 0, or
- LDFJAC .LT. N, or XTOL .LT. 0.E0, or MAXFEV .LE. 0, or
- FACTOR .LE. 0.E0, or LR .LT. (N*(N+1))/2.
-0 Arithmetic interrupts. If these interrupts occur in the FCN
- subroutine during an early stage of the computation, they may
- be caused by an unacceptable choice of X by HYBRJ. In this
- case, it may be possible to remedy the situation by rerunning
- HYBRJ with a smaller value of FACTOR.
-0 Excessive number of function evaluations. A reasonable value
- for MAXFEV is 100*(N+1). If the number of calls to FCN with
- IFLAG = 1 reaches MAXFEV, then this indicates that the routin
- is converging very slowly as measured by the progress of FVEC
- and INFO is set to 2. This situation should be unusual
- because, as indicated below, lack of good progress is usually
- diagnosed earlier by HYBRJ, causing termination with INFO = 4
- or INFO = 5.
-0 Lack of good progress. HYBRJ searches for a zero of the system
- by minimizing the sum of the squares of the functions. In so
-1
-0 Page
-0 doing, it can become trapped in a region where the minimum
- does not correspond to a zero of the system and, in this situ
- ation, the iteration eventually fails to make good progress.
- In particular, this will happen if the system does not have a
- zero. If the system has a zero, rerunning HYBRJ from a dif-
- ferent starting point may be helpful.
-0
- 6. Characteristics of the algorithm.
-0 HYBRJ is a modification of the Powell hybrid method. Two of it
- main characteristics involve the choice of the correction as a
- convex combination of the Newton and scaled gradient directions
- and the updating of the Jacobian by the rank-1 method of Broy-
- den. The choice of the correction guarantees (under reasonable
- conditions) global convergence for starting points far from the
- solution and a fast rate of convergence. The Jacobian is calcu
- lated at the starting point, but it is not recalculated until
- the rank-1 method fails to produce satisfactory progress.
-0 Timing. The time required by HYBRJ to solve a given problem
- depends on N, the behavior of the functions, the accuracy
- requested, and the starting point. The number of arithmetic
- operations needed by HYBRJ is about 11.5*(N**2) to process
- each evaluation of the functions (call to FCN with IFLAG = 1)
- and 1.3*(N**3) to process each evaluation of the Jacobian
- (call to FCN with IFLAG = 2). Unless FCN can be evaluated
- quickly, the timing of HYBRJ will be strongly influenced by
- the time spent in FCN.
-0 Storage. HYBRJ requires (3*N**2 + 17*N)/2 single precision
- storage locations, in addition to the storage required by the
- program. There are no internally declared storage arrays.
-0
- 7. Subprograms required.
-0 USER-supplied ...... FCN
-0 MINPACK-supplied ... DOGLEG,SPMPAR,ENORM,
- QFORM,QRFAC,R1MPYQ,R1UPDT
-0 FORTRAN-supplied ... ABS,AMAX1,AMIN1,SQRT,MIN0,MOD
-0
- 8. References.
-0 M. J. D. Powell, A Hybrid Method for Nonlinear Equations.
- Numerical Methods for Nonlinear Algebraic Equations,
- P. Rabinowitz, editor. Gordon and Breach, 1970.
-0
- 9. Example.
-1
-0 Page
-0 The problem is to determine the values of x(1), x(2), ..., x(9)
- which solve the system of tridiagonal equations
-0 (3-2*x(1))*x(1) -2*x(2) = -1
- -x(i-1) + (3-2*x(i))*x(i) -2*x(i+1) = -1, i=2-8
- -x(8) + (3-2*x(9))*x(9) = -1
-0 C **********
- C
- C DRIVER FOR HYBRJ EXAMPLE.
- C SINGLE PRECISION VERSION
- C
- C **********
- INTEGER J,N,LDFJAC,MAXFEV,MODE,NPRINT,INFO,NFEV,NJEV,LR,NWRITE
- REAL XTOL,FACTOR,FNORM
- REAL X(9),FVEC(9),FJAC(9,9),DIAG(9),R(45),QTF(9),
- * WA1(9),WA2(9),WA3(9),WA4(9)
- REAL ENORM,SPMPAR
- EXTERNAL FCN
- C
- C LOGICAL OUTPUT UNIT IS ASSUMED TO BE NUMBER 6.
- C
- DATA NWRITE /6/
- C
- N = 9
- C
- C THE FOLLOWING STARTING VALUES PROVIDE A ROUGH SOLUTION.
- C
- DO 10 J = 1, 9
- X(J) = -1.E0
- 10 CONTINUE
- C
- LDFJAC = 9
- LR = 45
- C
- C SET XTOL TO THE SQUARE ROOT OF THE MACHINE PRECISION.
- C UNLESS HIGH PRECISION SOLUTIONS ARE REQUIRED,
- C THIS IS THE RECOMMENDED SETTING.
- C
- XTOL = SQRT(SPMPAR(1))
- C
- MAXFEV = 1000
- MODE = 2
- DO 20 J = 1, 9
- DIAG(J) = 1.E0
- 20 CONTINUE
- FACTOR = 1.E2
- NPRINT = 0
- C
- CALL HYBRJ(FCN,N,X,FVEC,FJAC,LDFJAC,XTOL,MAXFEV,DIAG,
- * MODE,FACTOR,NPRINT,INFO,NFEV,NJEV,R,LR,QTF,
- * WA1,WA2,WA3,WA4)
- FNORM = ENORM(N,FVEC)
- WRITE (NWRITE,1000) FNORM,NFEV,NJEV,INFO,(X(J),J=1,N)
-1
-0 Page
-0 STOP
- 1000 FORMAT (5X,31H FINAL L2 NORM OF THE RESIDUALS,E15.7 //
- * 5X,31H NUMBER OF FUNCTION EVALUATIONS,I10 //
- * 5X,31H NUMBER OF JACOBIAN EVALUATIONS,I10 //
- * 5X,15H EXIT PARAMETER,16X,I10 //
- * 5X,27H FINAL APPROXIMATE SOLUTION // (5X,3E15.7))
- C
- C LAST CARD OF DRIVER FOR HYBRJ EXAMPLE.
- C
- END
- SUBROUTINE FCN(N,X,FVEC,FJAC,LDFJAC,IFLAG)
- INTEGER N,LDFJAC,IFLAG
- REAL X(N),FVEC(N),FJAC(LDFJAC,N)
- C
- C SUBROUTINE FCN FOR HYBRJ EXAMPLE.
- C
- INTEGER J,K
- REAL ONE,TEMP,TEMP1,TEMP2,THREE,TWO,ZERO
- DATA ZERO,ONE,TWO,THREE,FOUR /0.E0,1.E0,2.E0,3.E0,4.E0/
- C
- IF (IFLAG .NE. 0) GO TO 5
- C
- C INSERT PRINT STATEMENTS HERE WHEN NPRINT IS POSITIVE.
- C
- RETURN
- 5 CONTINUE
- IF (IFLAG .EQ. 2) GO TO 20
- DO 10 K = 1, N
- TEMP = (THREE - TWO*X(K))*X(K)
- TEMP1 = ZERO
- IF (K .NE. 1) TEMP1 = X(K-1)
- TEMP2 = ZERO
- IF (K .NE. N) TEMP2 = X(K+1)
- FVEC(K) = TEMP - TEMP1 - TWO*TEMP2 + ONE
- 10 CONTINUE
- GO TO 50
- 20 CONTINUE
- DO 40 K = 1, N
- DO 30 J = 1, N
- FJAC(K,J) = ZERO
- 30 CONTINUE
- FJAC(K,K) = THREE - FOUR*X(K)
- IF (K .NE. 1) FJAC(K,K-1) = -ONE
- IF (K .NE. N) FJAC(K,K+1) = -TWO
- 40 CONTINUE
- 50 CONTINUE
- RETURN
- C
- C LAST CARD OF SUBROUTINE FCN.
- C
- END
-0 Results obtained with different compilers or machines
- may be slightly different.
-1
-0 Page
-0 FINAL L2 NORM OF THE RESIDUALS 0.1192636E-07
-0 NUMBER OF FUNCTION EVALUATIONS 11
-0 NUMBER OF JACOBIAN EVALUATIONS 1
-0 EXIT PARAMETER 1
-0 FINAL APPROXIMATE SOLUTION
-0 -0.5706545E+00 -0.6816283E+00 -0.7017325E+00
- -0.7042129E+00 -0.7013690E+00 -0.6918656E+00
- -0.6657920E+00 -0.5960342E+00 -0.4164121E+00
-1
-0
-1
-0 Page
-0 Documentation for MINPACK subroutine LMDER1
-0 Single precision version
-0 Argonne National Laboratory
-0 Burton S. Garbow, Kenneth E. Hillstrom, Jorge J. More
-0 March 1980
-0
- 1. Purpose.
-0 The purpose of LMDER1 is to minimize the sum of the squares of
- nonlinear functions in N variables by a modification of the
- Levenberg-Marquardt algorithm. This is done by using the more
- general least-squares solver LMDER. The user must provide a
- subroutine which calculates the functions and the Jacobian.
-0
- 2. Subroutine and type statements.
-0 SUBROUTINE LMDER1(FCN,M,N,X,FVEC,FJAC,LDFJAC,TOL,
- * INFO,IPVT,WA,LWA)
- INTEGER M,N,LDFJAC,INFO,LWA
- INTEGER IPVT(N)
- REAL TOL
- REAL X(N),FVEC(M),FJAC(LDFJAC,N),WA(LWA)
- EXTERNAL FCN
-0
- 3. Parameters.
-0 Parameters designated as input parameters must be specified on
- entry to LMDER1 and are not changed on exit, while parameters
- designated as output parameters need not be specified on entry
- and are set to appropriate values on exit from LMDER1.
-0 FCN is the name of the user-supplied subroutine which calculate
- the functions and the Jacobian. FCN must be declared in an
- EXTERNAL statement in the user calling program, and should be
- written as follows.
-0 SUBROUTINE FCN(M,N,X,FVEC,FJAC,LDFJAC,IFLAG)
- INTEGER M,N,LDFJAC,IFLAG
- REAL X(N),FVEC(M),FJAC(LDFJAC,N)
- ----------
- IF IFLAG = 1 CALCULATE THE FUNCTIONS AT X AND
- RETURN THIS VECTOR IN FVEC. DO NOT ALTER FJAC.
- IF IFLAG = 2 CALCULATE THE JACOBIAN AT X AND
- RETURN THIS MATRIX IN FJAC. DO NOT ALTER FVEC.
- ----------
- RETURN
- END
-1
-0 Page
-0 The value of IFLAG should not be changed by FCN unless the
- user wants to terminate execution of LMDER1. In this case se
- IFLAG to a negative integer.
-0 M is a positive integer input variable set to the number of
- functions.
-0 N is a positive integer input variable set to the number of
- variables. N must not exceed M.
-0 X is an array of length N. On input X must contain an initial
- estimate of the solution vector. On output X contains the
- final estimate of the solution vector.
-0 FVEC is an output array of length M which contains the function
- evaluated at the output X.
-0 FJAC is an output M by N array. The upper N by N submatrix of
- FJAC contains an upper triangular matrix R with diagonal ele-
- ments of nonincreasing magnitude such that
-0 T T T
- P *(JAC *JAC)*P = R *R,
-0 where P is a permutation matrix and JAC is the final calcu-
- lated Jacobian. Column j of P is column IPVT(j) (see below)
- of the identity matrix. The lower trapezoidal part of FJAC
- contains information generated during the computation of R.
-0 LDFJAC is a positive integer input variable not less than M
- which specifies the leading dimension of the array FJAC.
-0 TOL is a nonnegative input variable. Termination occurs when
- the algorithm estimates either that the relative error in the
- sum of squares is at most TOL or that the relative error
- between X and the solution is at most TOL. Section 4 contain
- more details about TOL.
-0 INFO is an integer output variable. If the user has terminated
- execution, INFO is set to the (negative) value of IFLAG. See
- description of FCN. Otherwise, INFO is set as follows.
-0 INFO = 0 Improper input parameters.
-0 INFO = 1 Algorithm estimates that the relative error in the
- sum of squares is at most TOL.
-0 INFO = 2 Algorithm estimates that the relative error between
- X and the solution is at most TOL.
-0 INFO = 3 Conditions for INFO = 1 and INFO = 2 both hold.
-0 INFO = 4 FVEC is orthogonal to the columns of the Jacobian t
- machine precision.
-1
-0 Page
-0 INFO = 5 Number of calls to FCN with IFLAG = 1 has reached
- 100*(N+1).
-0 INFO = 6 TOL is too small. No further reduction in the sum
- of squares is possible.
-0 INFO = 7 TOL is too small. No further improvement in the
- approximate solution X is possible.
-0 Sections 4 and 5 contain more details about INFO.
-0 IPVT is an integer output array of length N. IPVT defines a
- permutation matrix P such that JAC*P = Q*R, where JAC is the
- final calculated Jacobian, Q is orthogonal (not stored), and
- is upper triangular with diagonal elements of nonincreasing
- magnitude. Column j of P is column IPVT(j) of the identity
- matrix.
-0 WA is a work array of length LWA.
-0 LWA is a positive integer input variable not less than 5*N+M.
-0
- 4. Successful completion.
-0 The accuracy of LMDER1 is controlled by the convergence parame-
- ter TOL. This parameter is used in tests which make three type
- of comparisons between the approximation X and a solution XSOL.
- LMDER1 terminates when any of the tests is satisfied. If TOL i
- less than the machine precision (as defined by the MINPACK func
- tion SPMPAR(1)), then LMDER1 only attempts to satisfy the test
- defined by the machine precision. Further progress is not usu-
- ally possible. Unless high precision solutions are required,
- the recommended value for TOL is the square root of the machine
- precision.
-0 The tests assume that the functions and the Jacobian are coded
- consistently, and that the functions are reasonably well
- behaved. If these conditions are not satisfied, then LMDER1 ma
- incorrectly indicate convergence. The coding of the Jacobian
- can be checked by the MINPACK subroutine CHKDER. If the Jaco-
- bian is coded correctly, then the validity of the answer can be
- checked, for example, by rerunning LMDER1 with a tighter toler-
- ance.
-0 First convergence test. If ENORM(Z) denotes the Euclidean norm
- of a vector Z, then this test attempts to guarantee that
-0 ENORM(FVEC) .LE. (1+TOL)*ENORM(FVECS),
-0 where FVECS denotes the functions evaluated at XSOL. If this
- condition is satisfied with TOL = 10**(-K), then the final
- residual norm ENORM(FVEC) has K significant decimal digits an
- INFO is set to 1 (or to 3 if the second test is also
-1
-0 Page
-0 satisfied).
-0 Second convergence test. If D is a diagonal matrix (implicitly
- generated by LMDER1) whose entries contain scale factors for
- the variables, then this test attempts to guarantee that
-0 ENORM(D*(X-XSOL)) .LE. TOL*ENORM(D*XSOL).
-0 If this condition is satisfied with TOL = 10**(-K), then the
- larger components of D*X have K significant decimal digits an
- INFO is set to 2 (or to 3 if the first test is also satis-
- fied). There is a danger that the smaller components of D*X
- may have large relative errors, but the choice of D is such
- that the accuracy of the components of X is usually related t
- their sensitivity.
-0 Third convergence test. This test is satisfied when FVEC is
- orthogonal to the columns of the Jacobian to machine preci-
- sion. There is no clear relationship between this test and
- the accuracy of LMDER1, and furthermore, the test is equally
- well satisfied at other critical points, namely maximizers an
- saddle points. Therefore, termination caused by this test
- (INFO = 4) should be examined carefully.
-0
- 5. Unsuccessful completion.
-0 Unsuccessful termination of LMDER1 can be due to improper input
- parameters, arithmetic interrupts, or an excessive number of
- function evaluations.
-0 Improper input parameters. INFO is set to 0 if N .LE. 0, or
- M .LT. N, or LDFJAC .LT. M, or TOL .LT. 0.E0, or
- LWA .LT. 5*N+M.
-0 Arithmetic interrupts. If these interrupts occur in the FCN
- subroutine during an early stage of the computation, they may
- be caused by an unacceptable choice of X by LMDER1. In this
- case, it may be possible to remedy the situation by not evalu
- ating the functions here, but instead setting the components
- of FVEC to numbers that exceed those in the initial FVEC,
- thereby indirectly reducing the step length. The step length
- can be more directly controlled by using instead LMDER, which
- includes in its calling sequence the step-length- governing
- parameter FACTOR.
-0 Excessive number of function evaluations. If the number of
- calls to FCN with IFLAG = 1 reaches 100*(N+1), then this indi
- cates that the routine is converging very slowly as measured
- by the progress of FVEC, and INFO is set to 5. In this case,
- it may be helpful to restart LMDER1, thereby forcing it to
- disregard old (and possibly harmful) information.
-0
-1
-0 Page
-0 6. Characteristics of the algorithm.
-0 LMDER1 is a modification of the Levenberg-Marquardt algorithm.
- Two of its main characteristics involve the proper use of
- implicitly scaled variables and an optimal choice for the cor-
- rection. The use of implicitly scaled variables achieves scale
- invariance of LMDER1 and limits the size of the correction in
- any direction where the functions are changing rapidly. The
- optimal choice of the correction guarantees (under reasonable
- conditions) global convergence from starting points far from th
- solution and a fast rate of convergence for problems with small
- residuals.
-0 Timing. The time required by LMDER1 to solve a given problem
- depends on M and N, the behavior of the functions, the accu-
- racy requested, and the starting point. The number of arith-
- metic operations needed by LMDER1 is about N**3 to process
- each evaluation of the functions (call to FCN with IFLAG = 1)
- and M*(N**2) to process each evaluation of the Jacobian (call
- to FCN with IFLAG = 2). Unless FCN can be evaluated quickly,
- the timing of LMDER1 will be strongly influenced by the time
- spent in FCN.
-0 Storage. LMDER1 requires M*N + 2*M + 6*N single precision sto-
- rage locations and N integer storage locations, in addition t
- the storage required by the program. There are no internally
- declared storage arrays.
-0
- 7. Subprograms required.
-0 USER-supplied ...... FCN
-0 MINPACK-supplied ... SPMPAR,ENORM,LMDER,LMPAR,QRFAC,QRSOLV
-0 FORTRAN-supplied ... ABS,AMAX1,AMIN1,SQRT,MOD
-0
- 8. References.
-0 Jorge J. More, The Levenberg-Marquardt Algorithm, Implementatio
- and Theory. Numerical Analysis, G. A. Watson, editor.
- Lecture Notes in Mathematics 630, Springer-Verlag, 1977.
-0
- 9. Example.
-0 The problem is to determine the values of x(1), x(2), and x(3)
- which provide the best fit (in the least squares sense) of
-0 x(1) + u(i)/(v(i)*x(2) + w(i)*x(3)), i = 1, 15
-0 to the data
-1
-0 Page
-0 y = (0.14,0.18,0.22,0.25,0.29,0.32,0.35,0.39,
- 0.37,0.58,0.73,0.96,1.34,2.10,4.39),
-0 where u(i) = i, v(i) = 16 - i, and w(i) = min(u(i),v(i)). The
- i-th component of FVEC is thus defined by
-0 y(i) - (x(1) + u(i)/(v(i)*x(2) + w(i)*x(3))).
-0 C **********
- C
- C DRIVER FOR LMDER1 EXAMPLE.
- C SINGLE PRECISION VERSION
- C
- C **********
- INTEGER J,M,N,LDFJAC,INFO,LWA,NWRITE
- INTEGER IPVT(3)
- REAL TOL,FNORM
- REAL X(3),FVEC(15),FJAC(15,3),WA(30)
- REAL ENORM,SPMPAR
- EXTERNAL FCN
- C
- C LOGICAL OUTPUT UNIT IS ASSUMED TO BE NUMBER 6.
- C
- DATA NWRITE /6/
- C
- M = 15
- N = 3
- C
- C THE FOLLOWING STARTING VALUES PROVIDE A ROUGH FIT.
- C
- X(1) = 1.E0
- X(2) = 1.E0
- X(3) = 1.E0
- C
- LDFJAC = 15
- LWA = 30
- C
- C SET TOL TO THE SQUARE ROOT OF THE MACHINE PRECISION.
- C UNLESS HIGH PRECISION SOLUTIONS ARE REQUIRED,
- C THIS IS THE RECOMMENDED SETTING.
- C
- TOL = SQRT(SPMPAR(1))
- C
- CALL LMDER1(FCN,M,N,X,FVEC,FJAC,LDFJAC,TOL,
- * INFO,IPVT,WA,LWA)
- FNORM = ENORM(M,FVEC)
- WRITE (NWRITE,1000) FNORM,INFO,(X(J),J=1,N)
- STOP
- 1000 FORMAT (5X,31H FINAL L2 NORM OF THE RESIDUALS,E15.7 //
- * 5X,15H EXIT PARAMETER,16X,I10 //
- * 5X,27H FINAL APPROXIMATE SOLUTION // 5X,3E15.7)
- C
- C LAST CARD OF DRIVER FOR LMDER1 EXAMPLE.
- C
-1
-0 Page
-0 END
- SUBROUTINE FCN(M,N,X,FVEC,FJAC,LDFJAC,IFLAG)
- INTEGER M,N,LDFJAC,IFLAG
- REAL X(N),FVEC(M),FJAC(LDFJAC,N)
- C
- C SUBROUTINE FCN FOR LMDER1 EXAMPLE.
- C
- INTEGER I
- REAL TMP1,TMP2,TMP3,TMP4
- REAL Y(15)
- DATA Y(1),Y(2),Y(3),Y(4),Y(5),Y(6),Y(7),Y(8),
- * Y(9),Y(10),Y(11),Y(12),Y(13),Y(14),Y(15)
- * /1.4E-1,1.8E-1,2.2E-1,2.5E-1,2.9E-1,3.2E-1,3.5E-1,3.9E-1,
- * 3.7E-1,5.8E-1,7.3E-1,9.6E-1,1.34E0,2.1E0,4.39E0/
- C
- IF (IFLAG .EQ. 2) GO TO 20
- DO 10 I = 1, 15
- TMP1 = I
- TMP2 = 16 - I
- TMP3 = TMP1
- IF (I .GT. 8) TMP3 = TMP2
- FVEC(I) = Y(I) - (X(1) + TMP1/(X(2)*TMP2 + X(3)*TMP3))
- 10 CONTINUE
- GO TO 40
- 20 CONTINUE
- DO 30 I = 1, 15
- TMP1 = I
- TMP2 = 16 - I
- TMP3 = TMP1
- IF (I .GT. 8) TMP3 = TMP2
- TMP4 = (X(2)*TMP2 + X(3)*TMP3)**2
- FJAC(I,1) = -1.E0
- FJAC(I,2) = TMP1*TMP2/TMP4
- FJAC(I,3) = TMP1*TMP3/TMP4
- 30 CONTINUE
- 40 CONTINUE
- RETURN
- C
- C LAST CARD OF SUBROUTINE FCN.
- C
- END
-0 Results obtained with different compilers or machines
- may be slightly different.
-0 FINAL L2 NORM OF THE RESIDUALS 0.9063596E-01
-0 EXIT PARAMETER 1
-0 FINAL APPROXIMATE SOLUTION
-0 0.8241058E-01 0.1133037E+01 0.2343695E+01
-1
-0
-1
-0 Page
-0 Documentation for MINPACK subroutine LMDER
-0 Single precision version
-0 Argonne National Laboratory
-0 Burton S. Garbow, Kenneth E. Hillstrom, Jorge J. More
-0 March 1980
-0
- 1. Purpose.
-0 The purpose of LMDER is to minimize the sum of the squares of M
- nonlinear functions in N variables by a modification of the
- Levenberg-Marquardt algorithm. The user must provide a subrou-
- tine which calculates the functions and the Jacobian.
-0
- 2. Subroutine and type statements.
-0 SUBROUTINE LMDER(FCN,M,N,X,FVEC,FJAC,LDFJAC,FTOL,XTOL,GTOL,
- * MAXFEV,DIAG,MODE,FACTOR,NPRINT,INFO,NFEV,NJEV,
- * IPVT,QTF,WA1,WA2,WA3,WA4)
- INTEGER M,N,LDFJAC,MAXFEV,MODE,NPRINT,INFO,NFEV,NJEV
- INTEGER IPVT(N)
- REAL FTOL,XTOL,GTOL,FACTOR
- REAL X(N),FVEC(M),FJAC(LDFJAC,N),DIAG(N),QTF(N),
- * WA1(N),WA2(N),WA3(N),WA4(M)
-0
- 3. Parameters.
-0 Parameters designated as input parameters must be specified on
- entry to LMDER and are not changed on exit, while parameters
- designated as output parameters need not be specified on entry
- and are set to appropriate values on exit from LMDER.
-0 FCN is the name of the user-supplied subroutine which calculate
- the functions and the Jacobian. FCN must be declared in an
- EXTERNAL statement in the user calling program, and should be
- written as follows.
-0 SUBROUTINE FCN(M,N,X,FVEC,FJAC,LDFJAC,IFLAG)
- INTEGER M,N,LDFJAC,IFLAG
- REAL X(N),FVEC(M),FJAC(LDFJAC,N)
- ----------
- IF IFLAG = 1 CALCULATE THE FUNCTIONS AT X AND
- RETURN THIS VECTOR IN FVEC. DO NOT ALTER FJAC.
- IF IFLAG = 2 CALCULATE THE JACOBIAN AT X AND
- RETURN THIS MATRIX IN FJAC. DO NOT ALTER FVEC.
- ----------
- RETURN
- END
-1
-0 Page
-0 The value of IFLAG should not be changed by FCN unless the
- user wants to terminate execution of LMDER. In this case set
- IFLAG to a negative integer.
-0 M is a positive integer input variable set to the number of
- functions.
-0 N is a positive integer input variable set to the number of
- variables. N must not exceed M.
-0 X is an array of length N. On input X must contain an initial
- estimate of the solution vector. On output X contains the
- final estimate of the solution vector.
-0 FVEC is an output array of length M which contains the function
- evaluated at the output X.
-0 FJAC is an output M by N array. The upper N by N submatrix of
- FJAC contains an upper triangular matrix R with diagonal ele-
- ments of nonincreasing magnitude such that
-0 T T T
- P *(JAC *JAC)*P = R *R,
-0 where P is a permutation matrix and JAC is the final calcu-
- lated Jacobian. Column j of P is column IPVT(j) (see below)
- of the identity matrix. The lower trapezoidal part of FJAC
- contains information generated during the computation of R.
-0 LDFJAC is a positive integer input variable not less than M
- which specifies the leading dimension of the array FJAC.
-0 FTOL is a nonnegative input variable. Termination occurs when
- both the actual and predicted relative reductions in the sum
- of squares are at most FTOL. Therefore, FTOL measures the
- relative error desired in the sum of squares. Section 4 con-
- tains more details about FTOL.
-0 XTOL is a nonnegative input variable. Termination occurs when
- the relative error between two consecutive iterates is at mos
- XTOL. Therefore, XTOL measures the relative error desired in
- the approximate solution. Section 4 contains more details
- about XTOL.
-0 GTOL is a nonnegative input variable. Termination occurs when
- the cosine of the angle between FVEC and any column of the
- Jacobian is at most GTOL in absolute value. Therefore, GTOL
- measures the orthogonality desired between the function vecto
- and the columns of the Jacobian. Section 4 contains more
- details about GTOL.
-0 MAXFEV is a positive integer input variable. Termination occur
- when the number of calls to FCN with IFLAG = 1 has reached
- MAXFEV.
-1
-0 Page
-0 DIAG is an array of length N. If MODE = 1 (see below), DIAG is
- internally set. If MODE = 2, DIAG must contain positive
- entries that serve as multiplicative scale factors for the
- variables.
-0 MODE is an integer input variable. If MODE = 1, the variables
- will be scaled internally. If MODE = 2, the scaling is speci
- fied by the input DIAG. Other values of MODE are equivalent
- to MODE = 1.
-0 FACTOR is a positive input variable used in determining the ini
- tial step bound. This bound is set to the product of FACTOR
- and the Euclidean norm of DIAG*X if nonzero, or else to FACTO
- itself. In most cases FACTOR should lie in the interval
- (.1,100.). 100. is a generally recommended value.
-0 NPRINT is an integer input variable that enables controlled
- printing of iterates if it is positive. In this case, FCN is
- called with IFLAG = 0 at the beginning of the first iteration
- and every NPRINT iterations thereafter and immediately prior
- to return, with X, FVEC, and FJAC available for printing.
- FVEC and FJAC should not be altered. If NPRINT is not posi-
- tive, no special calls of FCN with IFLAG = 0 are made.
-0 INFO is an integer output variable. If the user has terminated
- execution, INFO is set to the (negative) value of IFLAG. See
- description of FCN. Otherwise, INFO is set as follows.
-0 INFO = 0 Improper input parameters.
-0 INFO = 1 Both actual and predicted relative reductions in th
- sum of squares are at most FTOL.
-0 INFO = 2 Relative error between two consecutive iterates is
- at most XTOL.
-0 INFO = 3 Conditions for INFO = 1 and INFO = 2 both hold.
-0 INFO = 4 The cosine of the angle between FVEC and any column
- of the Jacobian is at most GTOL in absolute value.
-0 INFO = 5 Number of calls to FCN with IFLAG = 1 has reached
- MAXFEV.
-0 INFO = 6 FTOL is too small. No further reduction in the sum
- of squares is possible.
-0 INFO = 7 XTOL is too small. No further improvement in the
- approximate solution X is possible.
-0 INFO = 8 GTOL is too small. FVEC is orthogonal to the
- columns of the Jacobian to machine precision.
-0 Sections 4 and 5 contain more details about INFO.
-1
-0 Page
-0 NFEV is an integer output variable set to the number of calls t
- FCN with IFLAG = 1.
-0 NJEV is an integer output variable set to the number of calls t
- FCN with IFLAG = 2.
-0 IPVT is an integer output array of length N. IPVT defines a
- permutation matrix P such that JAC*P = Q*R, where JAC is the
- final calculated Jacobian, Q is orthogonal (not stored), and
- is upper triangular with diagonal elements of nonincreasing
- magnitude. Column j of P is column IPVT(j) of the identity
- matrix.
-0 QTF is an output array of length N which contains the first N
- elements of the vector (Q transpose)*FVEC.
-0 WA1, WA2, and WA3 are work arrays of length N.
-0 WA4 is a work array of length M.
-0
- 4. Successful completion.
-0 The accuracy of LMDER is controlled by the convergence parame-
- ters FTOL, XTOL, and GTOL. These parameters are used in tests
- which make three types of comparisons between the approximation
- X and a solution XSOL. LMDER terminates when any of the tests
- is satisfied. If any of the convergence parameters is less tha
- the machine precision (as defined by the MINPACK function
- SPMPAR(1)), then LMDER only attempts to satisfy the test define
- by the machine precision. Further progress is not usually pos-
- sible.
-0 The tests assume that the functions and the Jacobian are coded
- consistently, and that the functions are reasonably well
- behaved. If these conditions are not satisfied, then LMDER may
- incorrectly indicate convergence. The coding of the Jacobian
- can be checked by the MINPACK subroutine CHKDER. If the Jaco-
- bian is coded correctly, then the validity of the answer can be
- checked, for example, by rerunning LMDER with tighter toler-
- ances.
-0 First convergence test. If ENORM(Z) denotes the Euclidean norm
- of a vector Z, then this test attempts to guarantee that
-0 ENORM(FVEC) .LE. (1+FTOL)*ENORM(FVECS),
-0 where FVECS denotes the functions evaluated at XSOL. If this
- condition is satisfied with FTOL = 10**(-K), then the final
- residual norm ENORM(FVEC) has K significant decimal digits an
- INFO is set to 1 (or to 3 if the second test is also satis-
- fied). Unless high precision solutions are required, the
- recommended value for FTOL is the square root of the machine
- precision.
-1
-0 Page
-0 Second convergence test. If D is the diagonal matrix whose
- entries are defined by the array DIAG, then this test attempt
- to guarantee that
-0 ENORM(D*(X-XSOL)) .LE. XTOL*ENORM(D*XSOL).
-0 If this condition is satisfied with XTOL = 10**(-K), then the
- larger components of D*X have K significant decimal digits an
- INFO is set to 2 (or to 3 if the first test is also satis-
- fied). There is a danger that the smaller components of D*X
- may have large relative errors, but if MODE = 1, then the
- accuracy of the components of X is usually related to their
- sensitivity. Unless high precision solutions are required,
- the recommended value for XTOL is the square root of the
- machine precision.
-0 Third convergence test. This test is satisfied when the cosine
- of the angle between FVEC and any column of the Jacobian at X
- is at most GTOL in absolute value. There is no clear rela-
- tionship between this test and the accuracy of LMDER, and
- furthermore, the test is equally well satisfied at other crit
- ical points, namely maximizers and saddle points. Therefore,
- termination caused by this test (INFO = 4) should be examined
- carefully. The recommended value for GTOL is zero.
-0
- 5. Unsuccessful completion.
-0 Unsuccessful termination of LMDER can be due to improper input
- parameters, arithmetic interrupts, or an excessive number of
- function evaluations.
-0 Improper input parameters. INFO is set to 0 if N .LE. 0, or
- M .LT. N, or LDFJAC .LT. M, or FTOL .LT. 0.E0, or
- XTOL .LT. 0.E0, or GTOL .LT. 0.E0, or MAXFEV .LE. 0, or
- FACTOR .LE. 0.E0.
-0 Arithmetic interrupts. If these interrupts occur in the FCN
- subroutine during an early stage of the computation, they may
- be caused by an unacceptable choice of X by LMDER. In this
- case, it may be possible to remedy the situation by rerunning
- LMDER with a smaller value of FACTOR.
-0 Excessive number of function evaluations. A reasonable value
- for MAXFEV is 100*(N+1). If the number of calls to FCN with
- IFLAG = 1 reaches MAXFEV, then this indicates that the routin
- is converging very slowly as measured by the progress of FVEC
- and INFO is set to 5. In this case, it may be helpful to
- restart LMDER with MODE set to 1.
-0
- 6. Characteristics of the algorithm.
-0 LMDER is a modification of the Levenberg-Marquardt algorithm.
-1
-0 Page
-0 Two of its main characteristics involve the proper use of
- implicitly scaled variables (if MODE = 1) and an optimal choice
- for the correction. The use of implicitly scaled variables
- achieves scale invariance of LMDER and limits the size of the
- correction in any direction where the functions are changing
- rapidly. The optimal choice of the correction guarantees (unde
- reasonable conditions) global convergence from starting points
- far from the solution and a fast rate of convergence for prob-
- lems with small residuals.
-0 Timing. The time required by LMDER to solve a given problem
- depends on M and N, the behavior of the functions, the accu-
- racy requested, and the starting point. The number of arith-
- metic operations needed by LMDER is about N**3 to process eac
- evaluation of the functions (call to FCN with IFLAG = 1) and
- M*(N**2) to process each evaluation of the Jacobian (call to
- FCN with IFLAG = 2). Unless FCN can be evaluated quickly, th
- timing of LMDER will be strongly influenced by the time spent
- in FCN.
-0 Storage. LMDER requires M*N + 2*M + 6*N single precision sto-
- rage locations and N integer storage locations, in addition t
- the storage required by the program. There are no internally
- declared storage arrays.
-0
- 7. Subprograms required.
-0 USER-supplied ...... FCN
-0 MINPACK-supplied ... SPMPAR,ENORM,LMPAR,QRFAC,QRSOLV
-0 FORTRAN-supplied ... ABS,AMAX1,AMIN1,SQRT,MOD
-0
- 8. References.
-0 Jorge J. More, The Levenberg-Marquardt Algorithm, Implementatio
- and Theory. Numerical Analysis, G. A. Watson, editor.
- Lecture Notes in Mathematics 630, Springer-Verlag, 1977.
-0
- 9. Example.
-0 The problem is to determine the values of x(1), x(2), and x(3)
- which provide the best fit (in the least squares sense) of
-0 x(1) + u(i)/(v(i)*x(2) + w(i)*x(3)), i = 1, 15
-0 to the data
-0 y = (0.14,0.18,0.22,0.25,0.29,0.32,0.35,0.39,
- 0.37,0.58,0.73,0.96,1.34,2.10,4.39),
-1
-0 Page
-0 where u(i) = i, v(i) = 16 - i, and w(i) = min(u(i),v(i)). The
- i-th component of FVEC is thus defined by
-0 y(i) - (x(1) + u(i)/(v(i)*x(2) + w(i)*x(3))).
-0 C **********
- C
- C DRIVER FOR LMDER EXAMPLE.
- C SINGLE PRECISION VERSION
- C
- C **********
- INTEGER J,M,N,LDFJAC,MAXFEV,MODE,NPRINT,INFO,NFEV,NJEV,NWRITE
- INTEGER IPVT(3)
- REAL FTOL,XTOL,GTOL,FACTOR,FNORM
- REAL X(3),FVEC(15),FJAC(15,3),DIAG(3),QTF(3),
- * WA1(3),WA2(3),WA3(3),WA4(15)
- REAL ENORM,SPMPAR
- EXTERNAL FCN
- C
- C LOGICAL OUTPUT UNIT IS ASSUMED TO BE NUMBER 6.
- C
- DATA NWRITE /6/
- C
- M = 15
- N = 3
- C
- C THE FOLLOWING STARTING VALUES PROVIDE A ROUGH FIT.
- C
- X(1) = 1.E0
- X(2) = 1.E0
- X(3) = 1.E0
- C
- LDFJAC = 15
- C
- C SET FTOL AND XTOL TO THE SQUARE ROOT OF THE MACHINE PRECISION
- C AND GTOL TO ZERO. UNLESS HIGH PRECISION SOLUTIONS ARE
- C REQUIRED, THESE ARE THE RECOMMENDED SETTINGS.
- C
- FTOL = SQRT(SPMPAR(1))
- XTOL = SQRT(SPMPAR(1))
- GTOL = 0.E0
- C
- MAXFEV = 400
- MODE = 1
- FACTOR = 1.E2
- NPRINT = 0
- C
- CALL LMDER(FCN,M,N,X,FVEC,FJAC,LDFJAC,FTOL,XTOL,GTOL,
- * MAXFEV,DIAG,MODE,FACTOR,NPRINT,INFO,NFEV,NJEV,
- * IPVT,QTF,WA1,WA2,WA3,WA4)
- FNORM = ENORM(M,FVEC)
- WRITE (NWRITE,1000) FNORM,NFEV,NJEV,INFO,(X(J),J=1,N)
- STOP
- 1000 FORMAT (5X,31H FINAL L2 NORM OF THE RESIDUALS,E15.7 //
-1
-0 Page
-0 * 5X,31H NUMBER OF FUNCTION EVALUATIONS,I10 //
- * 5X,31H NUMBER OF JACOBIAN EVALUATIONS,I10 //
- * 5X,15H EXIT PARAMETER,16X,I10 //
- * 5X,27H FINAL APPROXIMATE SOLUTION // 5X,3E15.7)
- C
- C LAST CARD OF DRIVER FOR LMDER EXAMPLE.
- C
- END
- SUBROUTINE FCN(M,N,X,FVEC,FJAC,LDFJAC,IFLAG)
- INTEGER M,N,LDFJAC,IFLAG
- REAL X(N),FVEC(M),FJAC(LDFJAC,N)
- C
- C SUBROUTINE FCN FOR LMDER EXAMPLE.
- C
- INTEGER I
- REAL TMP1,TMP2,TMP3,TMP4
- REAL Y(15)
- DATA Y(1),Y(2),Y(3),Y(4),Y(5),Y(6),Y(7),Y(8),
- * Y(9),Y(10),Y(11),Y(12),Y(13),Y(14),Y(15)
- * /1.4E-1,1.8E-1,2.2E-1,2.5E-1,2.9E-1,3.2E-1,3.5E-1,3.9E-1,
- * 3.7E-1,5.8E-1,7.3E-1,9.6E-1,1.34E0,2.1E0,4.39E0/
- C
- IF (IFLAG .NE. 0) GO TO 5
- C
- C INSERT PRINT STATEMENTS HERE WHEN NPRINT IS POSITIVE.
- C
- RETURN
- 5 CONTINUE
- IF (IFLAG .EQ. 2) GO TO 20
- DO 10 I = 1, 15
- TMP1 = I
- TMP2 = 16 - I
- TMP3 = TMP1
- IF (I .GT. 8) TMP3 = TMP2
- FVEC(I) = Y(I) - (X(1) + TMP1/(X(2)*TMP2 + X(3)*TMP3))
- 10 CONTINUE
- GO TO 40
- 20 CONTINUE
- DO 30 I = 1, 15
- TMP1 = I
- TMP2 = 16 - I
- TMP3 = TMP1
- IF (I .GT. 8) TMP3 = TMP2
- TMP4 = (X(2)*TMP2 + X(3)*TMP3)**2
- FJAC(I,1) = -1.E0
- FJAC(I,2) = TMP1*TMP2/TMP4
- FJAC(I,3) = TMP1*TMP3/TMP4
- 30 CONTINUE
- 40 CONTINUE
- RETURN
- C
- C LAST CARD OF SUBROUTINE FCN.
- C
- END
-1
-0 Page
-0 Results obtained with different compilers or machines
- may be slightly different.
-0 FINAL L2 NORM OF THE RESIDUALS 0.9063596E-01
-0 NUMBER OF FUNCTION EVALUATIONS 6
-0 NUMBER OF JACOBIAN EVALUATIONS 5
-0 EXIT PARAMETER 1
-0 FINAL APPROXIMATE SOLUTION
-0 0.8241058E-01 0.1133037E+01 0.2343695E+01
-1
-0
-1
-0 Page
-0 Documentation for MINPACK subroutine LMSTR1
-0 Single precision version
-0 Argonne National Laboratory
-0 Burton S. Garbow, Kenneth E. Hillstrom, Jorge J. More
-0 March 1980
-0
- 1. Purpose.
-0 The purpose of LMSTR1 is to minimize the sum of the squares of
- nonlinear functions in N variables by a modification of the
- Levenberg-Marquardt algorithm which uses minimal storage. This
- is done by using the more general least-squares solver LMSTR.
- The user must provide a subroutine which calculates the func-
- tions and the rows of the Jacobian.
-0
- 2. Subroutine and type statements.
-0 SUBROUTINE LMSTR1(FCN,M,N,X,FVEC,FJAC,LDFJAC,TOL,
- * INFO,IPVT,WA,LWA)
- INTEGER M,N,LDFJAC,INFO,LWA
- INTEGER IPVT(N)
- REAL TOL
- REAL X(N),FVEC(M),FJAC(LDFJAC,N),WA(LWA)
- EXTERNAL FCN
-0
- 3. Parameters.
-0 Parameters designated as input parameters must be specified on
- entry to LMSTR1 and are not changed on exit, while parameters
- designated as output parameters need not be specified on entry
- and are set to appropriate values on exit from LMSTR1.
-0 FCN is the name of the user-supplied subroutine which calculate
- the functions and the rows of the Jacobian. FCN must be
- declared in an EXTERNAL statement in the user calling program
- and should be written as follows.
-0 SUBROUTINE FCN(M,N,X,FVEC,FJROW,IFLAG)
- INTEGER M,N,IFLAG
- REAL X(N),FVEC(M),FJROW(N)
- ----------
- IF IFLAG = 1 CALCULATE THE FUNCTIONS AT X AND
- RETURN THIS VECTOR IN FVEC.
- IF IFLAG = I CALCULATE THE (I-1)-ST ROW OF THE
- JACOBIAN AT X AND RETURN THIS VECTOR IN FJROW.
- ----------
- RETURN
-1
-0 Page
-0 END
-0 The value of IFLAG should not be changed by FCN unless the
- user wants to terminate execution of LMSTR1. In this case se
- IFLAG to a negative integer.
-0 M is a positive integer input variable set to the number of
- functions.
-0 N is a positive integer input variable set to the number of
- variables. N must not exceed M.
-0 X is an array of length N. On input X must contain an initial
- estimate of the solution vector. On output X contains the
- final estimate of the solution vector.
-0 FVEC is an output array of length M which contains the function
- evaluated at the output X.
-0 FJAC is an output N by N array. The upper triangle of FJAC con
- tains an upper triangular matrix R such that
-0 T T T
- P *(JAC *JAC)*P = R *R,
-0 where P is a permutation matrix and JAC is the final calcu-
- lated Jacobian. Column j of P is column IPVT(j) (see below)
- of the identity matrix. The lower triangular part of FJAC
- contains information generated during the computation of R.
-0 LDFJAC is a positive integer input variable not less than N
- which specifies the leading dimension of the array FJAC.
-0 TOL is a nonnegative input variable. Termination occurs when
- the algorithm estimates either that the relative error in the
- sum of squares is at most TOL or that the relative error
- between X and the solution is at most TOL. Section 4 contain
- more details about TOL.
-0 INFO is an integer output variable. If the user has terminated
- execution, INFO is set to the (negative) value of IFLAG. See
- description of FCN. Otherwise, INFO is set as follows.
-0 INFO = 0 Improper input parameters.
-0 INFO = 1 Algorithm estimates that the relative error in the
- sum of squares is at most TOL.
-0 INFO = 2 Algorithm estimates that the relative error between
- X and the solution is at most TOL.
-0 INFO = 3 Conditions for INFO = 1 and INFO = 2 both hold.
-0 INFO = 4 FVEC is orthogonal to the columns of the Jacobian t
-1
-0 Page
-0 machine precision.
-0 INFO = 5 Number of calls to FCN with IFLAG = 1 has reached
- 100*(N+1).
-0 INFO = 6 TOL is too small. No further reduction in the sum
- of squares is possible.
-0 INFO = 7 TOL is too small. No further improvement in the
- approximate solution X is possible.
-0 Sections 4 and 5 contain more details about INFO.
-0 IPVT is an integer output array of length N. IPVT defines a
- permutation matrix P such that JAC*P = Q*R, where JAC is the
- final calculated Jacobian, Q is orthogonal (not stored), and
- is upper triangular. Column j of P is column IPVT(j) of the
- identity matrix.
-0 WA is a work array of length LWA.
-0 LWA is a positive integer input variable not less than 5*N+M.
-0
- 4. Successful completion.
-0 The accuracy of LMSTR1 is controlled by the convergence parame-
- ter TOL. This parameter is used in tests which make three type
- of comparisons between the approximation X and a solution XSOL.
- LMSTR1 terminates when any of the tests is satisfied. If TOL i
- less than the machine precision (as defined by the MINPACK func
- tion SPMPAR(1)), then LMSTR1 only attempts to satisfy the test
- defined by the machine precision. Further progress is not usu-
- ally possible. Unless high precision solutions are required,
- the recommended value for TOL is the square root of the machine
- precision.
-0 The tests assume that the functions and the Jacobian are coded
- consistently, and that the functions are reasonably well
- behaved. If these conditions are not satisfied, then LMSTR1 ma
- incorrectly indicate convergence. The coding of the Jacobian
- can be checked by the MINPACK subroutine CHKDER. If the Jaco-
- bian is coded correctly, then the validity of the answer can be
- checked, for example, by rerunning LMSTR1 with a tighter toler-
- ance.
-0 First convergence test. If ENORM(Z) denotes the Euclidean norm
- of a vector Z, then this test attempts to guarantee that
-0 ENORM(FVEC) .LE. (1+TOL)*ENORM(FVECS),
-0 where FVECS denotes the functions evaluated at XSOL. If this
- condition is satisfied with TOL = 10**(-K), then the final
- residual norm ENORM(FVEC) has K significant decimal digits an
-1
-0 Page
-0 INFO is set to 1 (or to 3 if the second test is also satis-
- fied).
-0 Second convergence test. If D is a diagonal matrix (implicitly
- generated by LMSTR1) whose entries contain scale factors for
- the variables, then this test attempts to guarantee that
-0 ENORM(D*(X-XSOL)) .LE. TOL*ENORM(D*XSOL).
-0 If this condition is satisfied with TOL = 10**(-K), then the
- larger components of D*X have K significant decimal digits an
- INFO is set to 2 (or to 3 if the first test is also satis-
- fied). There is a danger that the smaller components of D*X
- may have large relative errors, but the choice of D is such
- that the accuracy of the components of X is usually related t
- their sensitivity.
-0 Third convergence test. This test is satisfied when FVEC is
- orthogonal to the columns of the Jacobian to machine preci-
- sion. There is no clear relationship between this test and
- the accuracy of LMSTR1, and furthermore, the test is equally
- well satisfied at other critical points, namely maximizers an
- saddle points. Therefore, termination caused by this test
- (INFO = 4) should be examined carefully.
-0
- 5. Unsuccessful completion.
-0 Unsuccessful termination of LMSTR1 can be due to improper input
- parameters, arithmetic interrupts, or an excessive number of
- function evaluations.
-0 Improper input parameters. INFO is set to 0 if N .LE. 0, or
- M .LT. N, or LDFJAC .LT. N, or TOL .LT. 0.E0, or
- LWA .LT. 5*N+M.
-0 Arithmetic interrupts. If these interrupts occur in the FCN
- subroutine during an early stage of the computation, they may
- be caused by an unacceptable choice of X by LMSTR1. In this
- case, it may be possible to remedy the situation by not evalu
- ating the functions here, but instead setting the components
- of FVEC to numbers that exceed those in the initial FVEC,
- thereby indirectly reducing the step length. The step length
- can be more directly controlled by using instead LMSTR, which
- includes in its calling sequence the step-length- governing
- parameter FACTOR.
-0 Excessive number of function evaluations. If the number of
- calls to FCN with IFLAG = 1 reaches 100*(N+1), then this indi
- cates that the routine is converging very slowly as measured
- by the progress of FVEC, and INFO is set to 5. In this case,
- it may be helpful to restart LMSTR1, thereby forcing it to
- disregard old (and possibly harmful) information.
-1
-0 Page
-0
- 6. Characteristics of the algorithm.
-0 LMSTR1 is a modification of the Levenberg-Marquardt algorithm.
- Two of its main characteristics involve the proper use of
- implicitly scaled variables and an optimal choice for the cor-
- rection. The use of implicitly scaled variables achieves scale
- invariance of LMSTR1 and limits the size of the correction in
- any direction where the functions are changing rapidly. The
- optimal choice of the correction guarantees (under reasonable
- conditions) global convergence from starting points far from th
- solution and a fast rate of convergence for problems with small
- residuals.
-0 Timing. The time required by LMSTR1 to solve a given problem
- depends on M and N, the behavior of the functions, the accu-
- racy requested, and the starting point. The number of arith-
- metic operations needed by LMSTR1 is about N**3 to process
- each evaluation of the functions (call to FCN with IFLAG = 1)
- and 1.5*(N**2) to process each row of the Jacobian (call to
- FCN with IFLAG .GE. 2). Unless FCN can be evaluated quickly,
- the timing of LMSTR1 will be strongly influenced by the time
- spent in FCN.
-0 Storage. LMSTR1 requires N**2 + 2*M + 6*N single precision sto
- rage locations and N integer storage locations, in addition t
- the storage required by the program. There are no internally
- declared storage arrays.
-0
- 7. Subprograms required.
-0 USER-supplied ...... FCN
-0 MINPACK-supplied ... SPMPAR,ENORM,LMSTR,LMPAR,QRFAC,QRSOLV,
- RWUPDT
-0 FORTRAN-supplied ... ABS,AMAX1,AMIN1,SQRT,MOD
-0
- 8. References.
-0 Jorge J. More, The Levenberg-Marquardt Algorithm, Implementatio
- and Theory. Numerical Analysis, G. A. Watson, editor.
- Lecture Notes in Mathematics 630, Springer-Verlag, 1977.
-0
- 9. Example.
-0 The problem is to determine the values of x(1), x(2), and x(3)
- which provide the best fit (in the least squares sense) of
-0 x(1) + u(i)/(v(i)*x(2) + w(i)*x(3)), i = 1, 15
-1
-0 Page
-0 to the data
-0 y = (0.14,0.18,0.22,0.25,0.29,0.32,0.35,0.39,
- 0.37,0.58,0.73,0.96,1.34,2.10,4.39),
-0 where u(i) = i, v(i) = 16 - i, and w(i) = min(u(i),v(i)). The
- i-th component of FVEC is thus defined by
-0 y(i) - (x(1) + u(i)/(v(i)*x(2) + w(i)*x(3))).
-0 C **********
- C
- C DRIVER FOR LMSTR1 EXAMPLE.
- C SINGLE PRECISION VERSION
- C
- C **********
- INTEGER J,M,N,LDFJAC,INFO,LWA,NWRITE
- INTEGER IPVT(3)
- REAL TOL,FNORM
- REAL X(3),FVEC(15),FJAC(3,3),WA(30)
- REAL ENORM,SPMPAR
- EXTERNAL FCN
- C
- C LOGICAL OUTPUT UNIT IS ASSUMED TO BE NUMBER 6.
- C
- DATA NWRITE /6/
- C
- M = 15
- N = 3
- C
- C THE FOLLOWING STARTING VALUES PROVIDE A ROUGH FIT.
- C
- X(1) = 1.E0
- X(2) = 1.E0
- X(3) = 1.E0
- C
- LDFJAC = 3
- LWA = 30
- C
- C SET TOL TO THE SQUARE ROOT OF THE MACHINE PRECISION.
- C UNLESS HIGH PRECISION SOLUTIONS ARE REQUIRED,
- C THIS IS THE RECOMMENDED SETTING.
- C
- TOL = SQRT(SPMPAR(1))
- C
- CALL LMSTR1(FCN,M,N,X,FVEC,FJAC,LDFJAC,TOL,
- * INFO,IPVT,WA,LWA)
- FNORM = ENORM(M,FVEC)
- WRITE (NWRITE,1000) FNORM,INFO,(X(J),J=1,N)
- STOP
- 1000 FORMAT (5X,31H FINAL L2 NORM OF THE RESIDUALS,E15.7 //
- * 5X,15H EXIT PARAMETER,16X,I10 //
- * 5X,27H FINAL APPROXIMATE SOLUTION // 5X,3E15.7)
- C
-1
-0 Page
-0 C LAST CARD OF DRIVER FOR LMSTR1 EXAMPLE.
- C
- END
- SUBROUTINE FCN(M,N,X,FVEC,FJROW,IFLAG)
- INTEGER M,N,IFLAG
- REAL X(N),FVEC(M),FJROW(N)
- C
- C SUBROUTINE FCN FOR LMSTR1 EXAMPLE.
- C
- INTEGER I
- REAL TMP1,TMP2,TMP3,TMP4
- REAL Y(15)
- DATA Y(1),Y(2),Y(3),Y(4),Y(5),Y(6),Y(7),Y(8),
- * Y(9),Y(10),Y(11),Y(12),Y(13),Y(14),Y(15)
- * /1.4E-1,1.8E-1,2.2E-1,2.5E-1,2.9E-1,3.2E-1,3.5E-1,3.9E-1,
- * 3.7E-1,5.8E-1,7.3E-1,9.6E-1,1.34E0,2.1E0,4.39E0/
- C
- IF (IFLAG .GE. 2) GO TO 20
- DO 10 I = 1, 15
- TMP1 = I
- TMP2 = 16 - I
- TMP3 = TMP1
- IF (I .GT. 8) TMP3 = TMP2
- FVEC(I) = Y(I) - (X(1) + TMP1/(X(2)*TMP2 + X(3)*TMP3))
- 10 CONTINUE
- GO TO 40
- 20 CONTINUE
- I = IFLAG - 1
- TMP1 = I
- TMP2 = 16 - I
- TMP3 = TMP1
- IF (I .GT. 8) TMP3 = TMP2
- TMP4 = (X(2)*TMP2 + X(3)*TMP3)**2
- FJROW(1) = -1.E0
- FJROW(2) = TMP1*TMP2/TMP4
- FJROW(3) = TMP1*TMP3/TMP4
- 30 CONTINUE
- 40 CONTINUE
- RETURN
- C
- C LAST CARD OF SUBROUTINE FCN.
- C
- END
-0 Results obtained with different compilers or machines
- may be slightly different.
-0 FINAL L2 NORM OF THE RESIDUALS 0.9063596E-01
-0 EXIT PARAMETER 1
-0 FINAL APPROXIMATE SOLUTION
-0 0.8241058E-01 0.1133037E+01 0.2343695E+01
-1
-0
-1
-0 Page
-0 Documentation for MINPACK subroutine LMSTR
-0 Single precision version
-0 Argonne National Laboratory
-0 Burton S. Garbow, Kenneth E. Hillstrom, Jorge J. More
-0 March 1980
-0
- 1. Purpose.
-0 The purpose of LMSTR is to minimize the sum of the squares of M
- nonlinear functions in N variables by a modification of the
- Levenberg-Marquardt algorithm which uses minimal storage. The
- user must provide a subroutine which calculates the functions
- and the rows of the Jacobian.
-0
- 2. Subroutine and type statements.
-0 SUBROUTINE LMSTR(FCN,M,N,X,FVEC,FJAC,LDFJAC,FTOL,XTOL,GTOL,
- * MAXFEV,DIAG,MODE,FACTOR,NPRINT,INFO,NFEV,NJEV,
- * IPVT,QTF,WA1,WA2,WA3,WA4)
- INTEGER M,N,LDFJAC,MAXFEV,MODE,NPRINT,INFO,NFEV,NJEV
- INTEGER IPVT(N)
- REAL FTOL,XTOL,GTOL,FACTOR
- REAL X(N),FVEC(M),FJAC(LDFJAC,N),DIAG(N),QTF(N),
- * WA1(N),WA2(N),WA3(N),WA4(M)
-0
- 3. Parameters.
-0 Parameters designated as input parameters must be specified on
- entry to LMSTR and are not changed on exit, while parameters
- designated as output parameters need not be specified on entry
- and are set to appropriate values on exit from LMSTR.
-0 FCN is the name of the user-supplied subroutine which calculate
- the functions and the rows of the Jacobian. FCN must be
- declared in an EXTERNAL statement in the user calling program
- and should be written as follows.
-0 SUBROUTINE FCN(M,N,X,FVEC,FJROW,IFLAG)
- INTEGER M,N,IFLAG
- REAL X(N),FVEC(M),FJROW(N)
- ----------
- IF IFLAG = 1 CALCULATE THE FUNCTIONS AT X AND
- RETURN THIS VECTOR IN FVEC.
- IF IFLAG = I CALCULATE THE (I-1)-ST ROW OF THE
- JACOBIAN AT X AND RETURN THIS VECTOR IN FJROW.
- ----------
- RETURN
-1
-0 Page
-0 END
-0 The value of IFLAG should not be changed by FCN unless the
- user wants to terminate execution of LMSTR. In this case set
- IFLAG to a negative integer.
-0 M is a positive integer input variable set to the number of
- functions.
-0 N is a positive integer input variable set to the number of
- variables. N must not exceed M.
-0 X is an array of length N. On input X must contain an initial
- estimate of the solution vector. On output X contains the
- final estimate of the solution vector.
-0 FVEC is an output array of length M which contains the function
- evaluated at the output X.
-0 FJAC is an output N by N array. The upper triangle of FJAC con
- tains an upper triangular matrix R such that
-0 T T T
- P *(JAC *JAC)*P = R *R,
-0 where P is a permutation matrix and JAC is the final calcu-
- lated Jacobian. Column j of P is column IPVT(j) (see below)
- of the identity matrix. The lower triangular part of FJAC
- contains information generated during the computation of R.
-0 LDFJAC is a positive integer input variable not less than N
- which specifies the leading dimension of the array FJAC.
-0 FTOL is a nonnegative input variable. Termination occurs when
- both the actual and predicted relative reductions in the sum
- of squares are at most FTOL. Therefore, FTOL measures the
- relative error desired in the sum of squares. Section 4 con-
- tains more details about FTOL.
-0 XTOL is a nonnegative input variable. Termination occurs when
- the relative error between two consecutive iterates is at mos
- XTOL. Therefore, XTOL measures the relative error desired in
- the approximate solution. Section 4 contains more details
- about XTOL.
-0 GTOL is a nonnegative input variable. Termination occurs when
- the cosine of the angle between FVEC and any column of the
- Jacobian is at most GTOL in absolute value. Therefore, GTOL
- measures the orthogonality desired between the function vecto
- and the columns of the Jacobian. Section 4 contains more
- details about GTOL.
-0 MAXFEV is a positive integer input variable. Termination occur
- when the number of calls to FCN with IFLAG = 1 has reached
-1
-0 Page
-0 MAXFEV.
-0 DIAG is an array of length N. If MODE = 1 (see below), DIAG is
- internally set. If MODE = 2, DIAG must contain positive
- entries that serve as multiplicative scale factors for the
- variables.
-0 MODE is an integer input variable. If MODE = 1, the variables
- will be scaled internally. If MODE = 2, the scaling is speci
- fied by the input DIAG. Other values of MODE are equivalent
- to MODE = 1.
-0 FACTOR is a positive input variable used in determining the ini
- tial step bound. This bound is set to the product of FACTOR
- and the Euclidean norm of DIAG*X if nonzero, or else to FACTO
- itself. In most cases FACTOR should lie in the interval
- (.1,100.). 100. is a generally recommended value.
-0 NPRINT is an integer input variable that enables controlled
- printing of iterates if it is positive. In this case, FCN is
- called with IFLAG = 0 at the beginning of the first iteration
- and every NPRINT iterations thereafter and immediately prior
- to return, with X and FVEC available for printing. If NPRINT
- is not positive, no special calls of FCN with IFLAG = 0 are
- made.
-0 INFO is an integer output variable. If the user has terminated
- execution, INFO is set to the (negative) value of IFLAG. See
- description of FCN. Otherwise, INFO is set as follows.
-0 INFO = 0 Improper input parameters.
-0 INFO = 1 Both actual and predicted relative reductions in th
- sum of squares are at most FTOL.
-0 INFO = 2 Relative error between two consecutive iterates is
- at most XTOL.
-0 INFO = 3 Conditions for INFO = 1 and INFO = 2 both hold.
-0 INFO = 4 The cosine of the angle between FVEC and any column
- of the Jacobian is at most GTOL in absolute value.
-0 INFO = 5 Number of calls to FCN with IFLAG = 1 has reached
- MAXFEV.
-0 INFO = 6 FTOL is too small. No further reduction in the sum
- of squares is possible.
-0 INFO = 7 XTOL is too small. No further improvement in the
- approximate solution X is possible.
-0 INFO = 8 GTOL is too small. FVEC is orthogonal to the
- columns of the Jacobian to machine precision.
-1
-0 Page
-0 Sections 4 and 5 contain more details about INFO.
-0 NFEV is an integer output variable set to the number of calls t
- FCN with IFLAG = 1.
-0 NJEV is an integer output variable set to the number of calls t
- FCN with IFLAG = 2.
-0 IPVT is an integer output array of length N. IPVT defines a
- permutation matrix P such that JAC*P = Q*R, where JAC is the
- final calculated Jacobian, Q is orthogonal (not stored), and
- is upper triangular. Column j of P is column IPVT(j) of the
- identity matrix.
-0 QTF is an output array of length N which contains the first N
- elements of the vector (Q transpose)*FVEC.
-0 WA1, WA2, and WA3 are work arrays of length N.
-0 WA4 is a work array of length M.
-0
- 4. Successful completion.
-0 The accuracy of LMSTR is controlled by the convergence parame-
- ters FTOL, XTOL, and GTOL. These parameters are used in tests
- which make three types of comparisons between the approximation
- X and a solution XSOL. LMSTR terminates when any of the tests
- is satisfied. If any of the convergence parameters is less tha
- the machine precision (as defined by the MINPACK function
- SPMPAR(1)), then LMSTR only attempts to satisfy the test define
- by the machine precision. Further progress is not usually pos-
- sible.
-0 The tests assume that the functions and the Jacobian are coded
- consistently, and that the functions are reasonably well
- behaved. If these conditions are not satisfied, then LMSTR may
- incorrectly indicate convergence. The coding of the Jacobian
- can be checked by the MINPACK subroutine CHKDER. If the Jaco-
- bian is coded correctly, then the validity of the answer can be
- checked, for example, by rerunning LMSTR with tighter toler-
- ances.
-0 First convergence test. If ENORM(Z) denotes the Euclidean norm
- of a vector Z, then this test attempts to guarantee that
-0 ENORM(FVEC) .LE. (1+FTOL)*ENORM(FVECS),
-0 where FVECS denotes the functions evaluated at XSOL. If this
- condition is satisfied with FTOL = 10**(-K), then the final
- residual norm ENORM(FVEC) has K significant decimal digits an
- INFO is set to 1 (or to 3 if the second test is also satis-
- fied). Unless high precision solutions are required, the
- recommended value for FTOL is the square root of the machine
-1
-0 Page
-0 precision.
-0 Second convergence test. If D is the diagonal matrix whose
- entries are defined by the array DIAG, then this test attempt
- to guarantee that
-0 ENORM(D*(X-XSOL)) .LE. XTOL*ENORM(D*XSOL).
-0 If this condition is satisfied with XTOL = 10**(-K), then the
- larger components of D*X have K significant decimal digits an
- INFO is set to 2 (or to 3 if the first test is also satis-
- fied). There is a danger that the smaller components of D*X
- may have large relative errors, but if MODE = 1, then the
- accuracy of the components of X is usually related to their
- sensitivity. Unless high precision solutions are required,
- the recommended value for XTOL is the square root of the
- machine precision.
-0 Third convergence test. This test is satisfied when the cosine
- of the angle between FVEC and any column of the Jacobian at X
- is at most GTOL in absolute value. There is no clear rela-
- tionship between this test and the accuracy of LMSTR, and
- furthermore, the test is equally well satisfied at other crit
- ical points, namely maximizers and saddle points. Therefore,
- termination caused by this test (INFO = 4) should be examined
- carefully. The recommended value for GTOL is zero.
-0
- 5. Unsuccessful completion.
-0 Unsuccessful termination of LMSTR can be due to improper input
- parameters, arithmetic interrupts, or an excessive number of
- function evaluations.
-0 Improper input parameters. INFO is set to 0 if N .LE. 0, or
- M .LT. N, or LDFJAC .LT. N, or FTOL .LT. 0.E0, or
- XTOL .LT. 0.E0, or GTOL .LT. 0.E0, or MAXFEV .LE. 0, or
- FACTOR .LE. 0.E0.
-0 Arithmetic interrupts. If these interrupts occur in the FCN
- subroutine during an early stage of the computation, they may
- be caused by an unacceptable choice of X by LMSTR. In this
- case, it may be possible to remedy the situation by rerunning
- LMSTR with a smaller value of FACTOR.
-0 Excessive number of function evaluations. A reasonable value
- for MAXFEV is 100*(N+1). If the number of calls to FCN with
- IFLAG = 1 reaches MAXFEV, then this indicates that the routin
- is converging very slowly as measured by the progress of FVEC
- and INFO is set to 5. In this case, it may be helpful to
- restart LMSTR with MODE set to 1.
-0
- 6. Characteristics of the algorithm.
-1
-0 Page
-0 LMSTR is a modification of the Levenberg-Marquardt algorithm.
- Two of its main characteristics involve the proper use of
- implicitly scaled variables (if MODE = 1) and an optimal choice
- for the correction. The use of implicitly scaled variables
- achieves scale invariance of LMSTR and limits the size of the
- correction in any direction where the functions are changing
- rapidly. The optimal choice of the correction guarantees (unde
- reasonable conditions) global convergence from starting points
- far from the solution and a fast rate of convergence for prob-
- lems with small residuals.
-0 Timing. The time required by LMSTR to solve a given problem
- depends on M and N, the behavior of the functions, the accu-
- racy requested, and the starting point. The number of arith-
- metic operations needed by LMSTR is about N**3 to process eac
- evaluation of the functions (call to FCN with IFLAG = 1) and
- 1.5*(N**2) to process each row of the Jacobian (call to FCN
- with IFLAG .GE. 2). Unless FCN can be evaluated quickly, the
- timing of LMSTR will be strongly influenced by the time spent
- in FCN.
-0 Storage. LMSTR requires N**2 + 2*M + 6*N single precision sto-
- rage locations and N integer storage locations, in addition t
- the storage required by the program. There are no internally
- declared storage arrays.
-0
- 7. Subprograms required.
-0 USER-supplied ...... FCN
-0 MINPACK-supplied ... SPMPAR,ENORM,LMPAR,QRFAC,QRSOLV,RWUPDT
-0 FORTRAN-supplied ... ABS,AMAX1,AMIN1,SQRT,MOD
-0
- 8. References.
-0 Jorge J. More, The Levenberg-Marquardt Algorithm, Implementatio
- and Theory. Numerical Analysis, G. A. Watson, editor.
- Lecture Notes in Mathematics 630, Springer-Verlag, 1977.
-0
- 9. Example.
-0 The problem is to determine the values of x(1), x(2), and x(3)
- which provide the best fit (in the least squares sense) of
-0 x(1) + u(i)/(v(i)*x(2) + w(i)*x(3)), i = 1, 15
-0 to the data
-0 y = (0.14,0.18,0.22,0.25,0.29,0.32,0.35,0.39,
- 0.37,0.58,0.73,0.96,1.34,2.10,4.39),
-1
-0 Page
-0 where u(i) = i, v(i) = 16 - i, and w(i) = min(u(i),v(i)). The
- i-th component of FVEC is thus defined by
-0 y(i) - (x(1) + u(i)/(v(i)*x(2) + w(i)*x(3))).
-0 C **********
- C
- C DRIVER FOR LMSTR EXAMPLE.
- C SINGLE PRECISION VERSION
- C
- C **********
- INTEGER J,M,N,LDFJAC,MAXFEV,MODE,NPRINT,INFO,NFEV,NJEV,NWRITE
- INTEGER IPVT(3)
- REAL FTOL,XTOL,GTOL,FACTOR,FNORM
- REAL X(3),FVEC(15),FJAC(3,3),DIAG(3),QTF(3),
- * WA1(3),WA2(3),WA3(3),WA4(15)
- REAL ENORM,SPMPAR
- EXTERNAL FCN
- C
- C LOGICAL OUTPUT UNIT IS ASSUMED TO BE NUMBER 6.
- C
- DATA NWRITE /6/
- C
- M = 15
- N = 3
- C
- C THE FOLLOWING STARTING VALUES PROVIDE A ROUGH FIT.
- C
- X(1) = 1.E0
- X(2) = 1.E0
- X(3) = 1.E0
- C
- LDFJAC = 3
- C
- C SET FTOL AND XTOL TO THE SQUARE ROOT OF THE MACHINE PRECISION
- C AND GTOL TO ZERO. UNLESS HIGH PRECISION SOLUTIONS ARE
- C REQUIRED, THESE ARE THE RECOMMENDED SETTINGS.
- C
- FTOL = SQRT(SPMPAR(1))
- XTOL = SQRT(SPMPAR(1))
- GTOL = 0.E0
- C
- MAXFEV = 400
- MODE = 1
- FACTOR = 1.E2
- NPRINT = 0
- C
- CALL LMSTR(FCN,M,N,X,FVEC,FJAC,LDFJAC,FTOL,XTOL,GTOL,
- * MAXFEV,DIAG,MODE,FACTOR,NPRINT,INFO,NFEV,NJEV,
- * IPVT,QTF,WA1,WA2,WA3,WA4)
- FNORM = ENORM(M,FVEC)
- WRITE (NWRITE,1000) FNORM,NFEV,NJEV,INFO,(X(J),J=1,N)
- STOP
- 1000 FORMAT (5X,31H FINAL L2 NORM OF THE RESIDUALS,E15.7 //
-1
-0 Page
-0 * 5X,31H NUMBER OF FUNCTION EVALUATIONS,I10 //
- * 5X,31H NUMBER OF JACOBIAN EVALUATIONS,I10 //
- * 5X,15H EXIT PARAMETER,16X,I10 //
- * 5X,27H FINAL APPROXIMATE SOLUTION // 5X,3E15.7)
- C
- C LAST CARD OF DRIVER FOR LMSTR EXAMPLE.
- C
- END
- SUBROUTINE FCN(M,N,X,FVEC,FJROW,IFLAG)
- INTEGER M,N,IFLAG
- REAL X(N),FVEC(M),FJROW(N)
- C
- C SUBROUTINE FCN FOR LMSTR EXAMPLE.
- C
- INTEGER I
- REAL TMP1,TMP2,TMP3,TMP4
- REAL Y(15)
- DATA Y(1),Y(2),Y(3),Y(4),Y(5),Y(6),Y(7),Y(8),
- * Y(9),Y(10),Y(11),Y(12),Y(13),Y(14),Y(15)
- * /1.4E-1,1.8E-1,2.2E-1,2.5E-1,2.9E-1,3.2E-1,3.5E-1,3.9E-1,
- * 3.7E-1,5.8E-1,7.3E-1,9.6E-1,1.34E0,2.1E0,4.39E0/
- C
- IF (IFLAG .NE. 0) GO TO 5
- C
- C INSERT PRINT STATEMENTS HERE WHEN NPRINT IS POSITIVE.
- C
- RETURN
- 5 CONTINUE
- IF (IFLAG .GE. 2) GO TO 20
- DO 10 I = 1, 15
- TMP1 = I
- TMP2 = 16 - I
- TMP3 = TMP1
- IF (I .GT. 8) TMP3 = TMP2
- FVEC(I) = Y(I) - (X(1) + TMP1/(X(2)*TMP2 + X(3)*TMP3))
- 10 CONTINUE
- GO TO 40
- 20 CONTINUE
- I = IFLAG - 1
- TMP1 = I
- TMP2 = 16 - I
- TMP3 = TMP1
- IF (I .GT. 8) TMP3 = TMP2
- TMP4 = (X(2)*TMP2 + X(3)*TMP3)**2
- FJROW(1) = -1.E0
- FJROW(2) = TMP1*TMP2/TMP4
- FJROW(3) = TMP1*TMP3/TMP4
- 30 CONTINUE
- 40 CONTINUE
- RETURN
- C
- C LAST CARD OF SUBROUTINE FCN.
- C
- END
-1
-0 Page
-0 Results obtained with different compilers or machines
- may be slightly different.
-0 FINAL L2 NORM OF THE RESIDUALS 0.9063596E-01
-0 NUMBER OF FUNCTION EVALUATIONS 6
-0 NUMBER OF JACOBIAN EVALUATIONS 5
-0 EXIT PARAMETER 1
-0 FINAL APPROXIMATE SOLUTION
-0 0.8241058E-01 0.1133037E+01 0.2343695E+01
-1
-0
-1
-0 Page
-0 Documentation for MINPACK subroutine LMDIF1
-0 Single precision version
-0 Argonne National Laboratory
-0 Burton S. Garbow, Kenneth E. Hillstrom, Jorge J. More
-0 March 1980
-0
- 1. Purpose.
-0 The purpose of LMDIF1 is to minimize the sum of the squares of
- nonlinear functions in N variables by a modification of the
- Levenberg-Marquardt algorithm. This is done by using the more
- general least-squares solver LMDIF. The user must provide a
- subroutine which calculates the functions. The Jacobian is the
- calculated by a forward-difference approximation.
-0
- 2. Subroutine and type statements.
-0 SUBROUTINE LMDIF1(FCN,M,N,X,FVEC,TOL,INFO,IWA,WA,LWA)
- INTEGER M,N,INFO,LWA
- INTEGER IWA(N)
- REAL TOL
- REAL X(N),FVEC(M),WA(LWA)
- EXTERNAL FCN
-0
- 3. Parameters.
-0 Parameters designated as input parameters must be specified on
- entry to LMDIF1 and are not changed on exit, while parameters
- designated as output parameters need not be specified on entry
- and are set to appropriate values on exit from LMDIF1.
-0 FCN is the name of the user-supplied subroutine which calculate
- the functions. FCN must be declared in an EXTERNAL statement
- in the user calling program, and should be written as follows
-0 SUBROUTINE FCN(M,N,X,FVEC,IFLAG)
- INTEGER M,N,IFLAG
- REAL X(N),FVEC(M)
- ----------
- CALCULATE THE FUNCTIONS AT X AND
- RETURN THIS VECTOR IN FVEC.
- ----------
- RETURN
- END
-0 The value of IFLAG should not be changed by FCN unless the
- user wants to terminate execution of LMDIF1. In this case se
-1
-0 Page
-0 IFLAG to a negative integer.
-0 M is a positive integer input variable set to the number of
- functions.
-0 N is a positive integer input variable set to the number of
- variables. N must not exceed M.
-0 X is an array of length N. On input X must contain an initial
- estimate of the solution vector. On output X contains the
- final estimate of the solution vector.
-0 FVEC is an output array of length M which contains the function
- evaluated at the output X.
-0 TOL is a nonnegative input variable. Termination occurs when
- the algorithm estimates either that the relative error in the
- sum of squares is at most TOL or that the relative error
- between X and the solution is at most TOL. Section 4 contain
- more details about TOL.
-0 INFO is an integer output variable. If the user has terminated
- execution, INFO is set to the (negative) value of IFLAG. See
- description of FCN. Otherwise, INFO is set as follows.
-0 INFO = 0 Improper input parameters.
-0 INFO = 1 Algorithm estimates that the relative error in the
- sum of squares is at most TOL.
-0 INFO = 2 Algorithm estimates that the relative error between
- X and the solution is at most TOL.
-0 INFO = 3 Conditions for INFO = 1 and INFO = 2 both hold.
-0 INFO = 4 FVEC is orthogonal to the columns of the Jacobian t
- machine precision.
-0 INFO = 5 Number of calls to FCN has reached or exceeded
- 200*(N+1).
-0 INFO = 6 TOL is too small. No further reduction in the sum
- of squares is possible.
-0 INFO = 7 TOL is too small. No further improvement in the
- approximate solution X is possible.
-0 Sections 4 and 5 contain more details about INFO.
-0 IWA is an integer work array of length N.
-0 WA is a work array of length LWA.
-0 LWA is a positive integer input variable not less than
-1
-0 Page
-0 M*N+5*N+M.
-0
- 4. Successful completion.
-0 The accuracy of LMDIF1 is controlled by the convergence parame-
- ter TOL. This parameter is used in tests which make three type
- of comparisons between the approximation X and a solution XSOL.
- LMDIF1 terminates when any of the tests is satisfied. If TOL i
- less than the machine precision (as defined by the MINPACK func
- tion SPMPAR(1)), then LMDIF1 only attempts to satisfy the test
- defined by the machine precision. Further progress is not usu-
- ally possible. Unless high precision solutions are required,
- the recommended value for TOL is the square root of the machine
- precision.
-0 The tests assume that the functions are reasonably well behaved
- If this condition is not satisfied, then LMDIF1 may incorrectly
- indicate convergence. The validity of the answer can be
- checked, for example, by rerunning LMDIF1 with a tighter toler-
- ance.
-0 First convergence test. If ENORM(Z) denotes the Euclidean norm
- of a vector Z, then this test attempts to guarantee that
-0 ENORM(FVEC) .LE. (1+TOL)*ENORM(FVECS),
-0 where FVECS denotes the functions evaluated at XSOL. If this
- condition is satisfied with TOL = 10**(-K), then the final
- residual norm ENORM(FVEC) has K significant decimal digits an
- INFO is set to 1 (or to 3 if the second test is also satis-
- fied).
-0 Second convergence test. If D is a diagonal matrix (implicitly
- generated by LMDIF1) whose entries contain scale factors for
- the variables, then this test attempts to guarantee that
-0 ENORM(D*(X-XSOL)) .LE. TOL*ENORM(D*XSOL).
-0 If this condition is satisfied with TOL = 10**(-K), then the
- larger components of D*X have K significant decimal digits an
- INFO is set to 2 (or to 3 if the first test is also satis-
- fied). There is a danger that the smaller components of D*X
- may have large relative errors, but the choice of D is such
- that the accuracy of the components of X is usually related t
- their sensitivity.
-0 Third convergence test. This test is satisfied when FVEC is
- orthogonal to the columns of the Jacobian to machine preci-
- sion. There is no clear relationship between this test and
- the accuracy of LMDIF1, and furthermore, the test is equally
- well satisfied at other critical points, namely maximizers an
- saddle points. Also, errors in the functions (see below) may
- result in the test being satisfied at a point not close to th
-1
-0 Page
-0 minimum. Therefore, termination caused by this test
- (INFO = 4) should be examined carefully.
-0
- 5. Unsuccessful completion.
-0 Unsuccessful termination of LMDIF1 can be due to improper input
- parameters, arithmetic interrupts, an excessive number of func-
- tion evaluations, or errors in the functions.
-0 Improper input parameters. INFO is set to 0 if N .LE. 0, or
- M .LT. N, or TOL .LT. 0.E0, or LWA .LT. M*N+5*N+M.
-0 Arithmetic interrupts. If these interrupts occur in the FCN
- subroutine during an early stage of the computation, they may
- be caused by an unacceptable choice of X by LMDIF1. In this
- case, it may be possible to remedy the situation by not evalu
- ating the functions here, but instead setting the components
- of FVEC to numbers that exceed those in the initial FVEC,
- thereby indirectly reducing the step length. The step length
- can be more directly controlled by using instead LMDIF, which
- includes in its calling sequence the step-length-governing
- parameter FACTOR.
-0 Excessive number of function evaluations. If the number of
- calls to FCN reaches 200*(N+1), then this indicates that the
- routine is converging very slowly as measured by the progress
- of FVEC, and INFO is set to 5. In this case, it may be help-
- ful to restart LMDIF1, thereby forcing it to disregard old
- (and possibly harmful) information.
-0 Errors in the functions. The choice of step length in the for-
- ward-difference approximation to the Jacobian assumes that th
- relative errors in the functions are of the order of the
- machine precision. If this is not the case, LMDIF1 may fail
- (usually with INFO = 4). The user should then use LMDIF
- instead, or one of the programs which require the analytic
- Jacobian (LMDER1 and LMDER).
-0
- 6. Characteristics of the algorithm.
-0 LMDIF1 is a modification of the Levenberg-Marquardt algorithm.
- Two of its main characteristics involve the proper use of
- implicitly scaled variables and an optimal choice for the cor-
- rection. The use of implicitly scaled variables achieves scale
- invariance of LMDIF1 and limits the size of the correction in
- any direction where the functions are changing rapidly. The
- optimal choice of the correction guarantees (under reasonable
- conditions) global convergence from starting points far from th
- solution and a fast rate of convergence for problems with small
- residuals.
-0 Timing. The time required by LMDIF1 to solve a given problem
-1
-0 Page
-0 depends on M and N, the behavior of the functions, the accu-
- racy requested, and the starting point. The number of arith-
- metic operations needed by LMDIF1 is about N**3 to process
- each evaluation of the functions (one call to FCN) and
- M*(N**2) to process each approximation to the Jacobian (N
- calls to FCN). Unless FCN can be evaluated quickly, the tim-
- ing of LMDIF1 will be strongly influenced by the time spent i
- FCN.
-0 Storage. LMDIF1 requires M*N + 2*M + 6*N single precision sto-
- rage locations and N integer storage locations, in addition t
- the storage required by the program. There are no internally
- declared storage arrays.
-0
- 7. Subprograms required.
-0 USER-supplied ...... FCN
-0 MINPACK-supplied ... SPMPAR,ENORM,FDJAC2,LMDIF,LMPAR,
- QRFAC,QRSOLV
-0 FORTRAN-supplied ... ABS,AMAX1,AMIN1,SQRT,MOD
-0
- 8. References.
-0 Jorge J. More, The Levenberg-Marquardt Algorithm, Implementatio
- and Theory. Numerical Analysis, G. A. Watson, editor.
- Lecture Notes in Mathematics 630, Springer-Verlag, 1977.
-0
- 9. Example.
-0 The problem is to determine the values of x(1), x(2), and x(3)
- which provide the best fit (in the least squares sense) of
-0 x(1) + u(i)/(v(i)*x(2) + w(i)*x(3)), i = 1, 15
-0 to the data
-0 y = (0.14,0.18,0.22,0.25,0.29,0.32,0.35,0.39,
- 0.37,0.58,0.73,0.96,1.34,2.10,4.39),
-0 where u(i) = i, v(i) = 16 - i, and w(i) = min(u(i),v(i)). The
- i-th component of FVEC is thus defined by
-0 y(i) - (x(1) + u(i)/(v(i)*x(2) + w(i)*x(3))).
-0 C **********
- C
- C DRIVER FOR LMDIF1 EXAMPLE.
- C SINGLE PRECISION VERSION
- C
-1
-0 Page
-0 C **********
- INTEGER J,M,N,INFO,LWA,NWRITE
- INTEGER IWA(3)
- REAL TOL,FNORM
- REAL X(3),FVEC(15),WA(75)
- REAL ENORM,SPMPAR
- EXTERNAL FCN
- C
- C LOGICAL OUTPUT UNIT IS ASSUMED TO BE NUMBER 6.
- C
- DATA NWRITE /6/
- C
- M = 15
- N = 3
- C
- C THE FOLLOWING STARTING VALUES PROVIDE A ROUGH FIT.
- C
- X(1) = 1.E0
- X(2) = 1.E0
- X(3) = 1.E0
- C
- LWA = 75
- C
- C SET TOL TO THE SQUARE ROOT OF THE MACHINE PRECISION.
- C UNLESS HIGH PRECISION SOLUTIONS ARE REQUIRED,
- C THIS IS THE RECOMMENDED SETTING.
- C
- TOL = SQRT(SPMPAR(1))
- C
- CALL LMDIF1(FCN,M,N,X,FVEC,TOL,INFO,IWA,WA,LWA)
- FNORM = ENORM(M,FVEC)
- WRITE (NWRITE,1000) FNORM,INFO,(X(J),J=1,N)
- STOP
- 1000 FORMAT (5X,31H FINAL L2 NORM OF THE RESIDUALS,E15.7 //
- * 5X,15H EXIT PARAMETER,16X,I10 //
- * 5X,27H FINAL APPROXIMATE SOLUTION // 5X,3E15.7)
- C
- C LAST CARD OF DRIVER FOR LMDIF1 EXAMPLE.
- C
- END
- SUBROUTINE FCN(M,N,X,FVEC,IFLAG)
- INTEGER M,N,IFLAG
- REAL X(N),FVEC(M)
- C
- C SUBROUTINE FCN FOR LMDIF1 EXAMPLE.
- C
- INTEGER I
- REAL TMP1,TMP2,TMP3
- REAL Y(15)
- DATA Y(1),Y(2),Y(3),Y(4),Y(5),Y(6),Y(7),Y(8),
- * Y(9),Y(10),Y(11),Y(12),Y(13),Y(14),Y(15)
- * /1.4E-1,1.8E-1,2.2E-1,2.5E-1,2.9E-1,3.2E-1,3.5E-1,3.9E-1,
- * 3.7E-1,5.8E-1,7.3E-1,9.6E-1,1.34E0,2.1E0,4.39E0/
- C
-1
-0 Page
-0 DO 10 I = 1, 15
- TMP1 = I
- TMP2 = 16 - I
- TMP3 = TMP1
- IF (I .GT. 8) TMP3 = TMP2
- FVEC(I) = Y(I) - (X(1) + TMP1/(X(2)*TMP2 + X(3)*TMP3))
- 10 CONTINUE
- RETURN
- C
- C LAST CARD OF SUBROUTINE FCN.
- C
- END
-0 Results obtained with different compilers or machines
- may be slightly different.
-0 FINAL L2 NORM OF THE RESIDUALS 0.9063596E-01
-0 EXIT PARAMETER 1
-0 FINAL APPROXIMATE SOLUTION
-0 0.8241057E-01 0.1133037E+01 0.2343695E+01
-1
-0
-1
-0 Page
-0 Documentation for MINPACK subroutine LMDIF
-0 Single precision version
-0 Argonne National Laboratory
-0 Burton S. Garbow, Kenneth E. Hillstrom, Jorge J. More
-0 March 1980
-0
- 1. Purpose.
-0 The purpose of LMDIF is to minimize the sum of the squares of M
- nonlinear functions in N variables by a modification of the
- Levenberg-Marquardt algorithm. The user must provide a subrou-
- tine which calculates the functions. The Jacobian is then cal-
- culated by a forward-difference approximation.
-0
- 2. Subroutine and type statements.
-0 SUBROUTINE LMDIF(FCN,M,N,X,FVEC,FTOL,XTOL,GTOL,MAXFEV,EPSFCN,
- * DIAG,MODE,FACTOR,NPRINT,INFO,NFEV,FJAC,LDFJAC,
- * IPVT,QTF,WA1,WA2,WA3,WA4)
- INTEGER M,N,MAXFEV,MODE,NPRINT,INFO,NFEV,LDFJAC
- INTEGER IPVT(N)
- REAL FTOL,XTOL,GTOL,EPSFCN,FACTOR
- REAL X(N),FVEC(M),DIAG(N),FJAC(LDFJAC,N),QTF(N),
- * WA1(N),WA2(N),WA3(N),WA4(M)
- EXTERNAL FCN
-0
- 3. Parameters.
-0 Parameters designated as input parameters must be specified on
- entry to LMDIF and are not changed on exit, while parameters
- designated as output parameters need not be specified on entry
- and are set to appropriate values on exit from LMDIF.
-0 FCN is the name of the user-supplied subroutine which calculate
- the functions. FCN must be declared in an EXTERNAL statement
- in the user calling program, and should be written as follows
-0 SUBROUTINE FCN(M,N,X,FVEC,IFLAG)
- INTEGER M,N,IFLAG
- REAL X(N),FVEC(M)
- ----------
- CALCULATE THE FUNCTIONS AT X AND
- RETURN THIS VECTOR IN FVEC.
- ----------
- RETURN
- END
-1
-0 Page
-0 The value of IFLAG should not be changed by FCN unless the
- user wants to terminate execution of LMDIF. In this case set
- IFLAG to a negative integer.
-0 M is a positive integer input variable set to the number of
- functions.
-0 N is a positive integer input variable set to the number of
- variables. N must not exceed M.
-0 X is an array of length N. On input X must contain an initial
- estimate of the solution vector. On output X contains the
- final estimate of the solution vector.
-0 FVEC is an output array of length M which contains the function
- evaluated at the output X.
-0 FTOL is a nonnegative input variable. Termination occurs when
- both the actual and predicted relative reductions in the sum
- of squares are at most FTOL. Therefore, FTOL measures the
- relative error desired in the sum of squares. Section 4 con-
- tains more details about FTOL.
-0 XTOL is a nonnegative input variable. Termination occurs when
- the relative error between two consecutive iterates is at mos
- XTOL. Therefore, XTOL measures the relative error desired in
- the approximate solution. Section 4 contains more details
- about XTOL.
-0 GTOL is a nonnegative input variable. Termination occurs when
- the cosine of the angle between FVEC and any column of the
- Jacobian is at most GTOL in absolute value. Therefore, GTOL
- measures the orthogonality desired between the function vecto
- and the columns of the Jacobian. Section 4 contains more
- details about GTOL.
-0 MAXFEV is a positive integer input variable. Termination occur
- when the number of calls to FCN is at least MAXFEV by the end
- of an iteration.
-0 EPSFCN is an input variable used in determining a suitable step
- for the forward-difference approximation. This approximation
- assumes that the relative errors in the functions are of the
- order of EPSFCN. If EPSFCN is less than the machine preci-
- sion, it is assumed that the relative errors in the functions
- are of the order of the machine precision.
-0 DIAG is an array of length N. If MODE = 1 (see below), DIAG is
- internally set. If MODE = 2, DIAG must contain positive
- entries that serve as multiplicative scale factors for the
- variables.
-0 MODE is an integer input variable. If MODE = 1, the variables
- will be scaled internally. If MODE = 2, the scaling is
-1
-0 Page
-0 specified by the input DIAG. Other values of MODE are equiva
- lent to MODE = 1.
-0 FACTOR is a positive input variable used in determining the ini
- tial step bound. This bound is set to the product of FACTOR
- and the Euclidean norm of DIAG*X if nonzero, or else to FACTO
- itself. In most cases FACTOR should lie in the interval
- (.1,100.). 100. is a generally recommended value.
-0 NPRINT is an integer input variable that enables controlled
- printing of iterates if it is positive. In this case, FCN is
- called with IFLAG = 0 at the beginning of the first iteration
- and every NPRINT iterations thereafter and immediately prior
- to return, with X and FVEC available for printing. If NPRINT
- is not positive, no special calls of FCN with IFLAG = 0 are
- made.
-0 INFO is an integer output variable. If the user has terminated
- execution, INFO is set to the (negative) value of IFLAG. See
- description of FCN. Otherwise, INFO is set as follows.
-0 INFO = 0 Improper input parameters.
-0 INFO = 1 Both actual and predicted relative reductions in th
- sum of squares are at most FTOL.
-0 INFO = 2 Relative error between two consecutive iterates is
- at most XTOL.
-0 INFO = 3 Conditions for INFO = 1 and INFO = 2 both hold.
-0 INFO = 4 The cosine of the angle between FVEC and any column
- of the Jacobian is at most GTOL in absolute value.
-0 INFO = 5 Number of calls to FCN has reached or exceeded
- MAXFEV.
-0 INFO = 6 FTOL is too small. No further reduction in the sum
- of squares is possible.
-0 INFO = 7 XTOL is too small. No further improvement in the
- approximate solution X is possible.
-0 INFO = 8 GTOL is too small. FVEC is orthogonal to the
- columns of the Jacobian to machine precision.
-0 Sections 4 and 5 contain more details about INFO.
-0 NFEV is an integer output variable set to the number of calls t
- FCN.
-0 FJAC is an output M by N array. The upper N by N submatrix of
- FJAC contains an upper triangular matrix R with diagonal ele-
- ments of nonincreasing magnitude such that
-1
-0 Page
-0 T T T
- P *(JAC *JAC)*P = R *R,
-0 where P is a permutation matrix and JAC is the final calcu-
- lated Jacobian. Column j of P is column IPVT(j) (see below)
- of the identity matrix. The lower trapezoidal part of FJAC
- contains information generated during the computation of R.
-0 LDFJAC is a positive integer input variable not less than M
- which specifies the leading dimension of the array FJAC.
-0 IPVT is an integer output array of length N. IPVT defines a
- permutation matrix P such that JAC*P = Q*R, where JAC is the
- final calculated Jacobian, Q is orthogonal (not stored), and
- is upper triangular with diagonal elements of nonincreasing
- magnitude. Column j of P is column IPVT(j) of the identity
- matrix.
-0 QTF is an output array of length N which contains the first N
- elements of the vector (Q transpose)*FVEC.
-0 WA1, WA2, and WA3 are work arrays of length N.
-0 WA4 is a work array of length M.
-0
- 4. Successful completion.
-0 The accuracy of LMDIF is controlled by the convergence parame-
- ters FTOL, XTOL, and GTOL. These parameters are used in tests
- which make three types of comparisons between the approximation
- X and a solution XSOL. LMDIF terminates when any of the tests
- is satisfied. If any of the convergence parameters is less tha
- the machine precision (as defined by the MINPACK function
- SPMPAR(1)), then LMDIF only attempts to satisfy the test define
- by the machine precision. Further progress is not usually pos-
- sible.
-0 The tests assume that the functions are reasonably well behaved
- If this condition is not satisfied, then LMDIF may incorrectly
- indicate convergence. The validity of the answer can be
- checked, for example, by rerunning LMDIF with tighter toler-
- ances.
-0 First convergence test. If ENORM(Z) denotes the Euclidean norm
- of a vector Z, then this test attempts to guarantee that
-0 ENORM(FVEC) .LE. (1+FTOL)*ENORM(FVECS),
-0 where FVECS denotes the functions evaluated at XSOL. If this
- condition is satisfied with FTOL = 10**(-K), then the final
- residual norm ENORM(FVEC) has K significant decimal digits an
- INFO is set to 1 (or to 3 if the second test is also satis-
- fied). Unless high precision solutions are required, the
-1
-0 Page
-0 recommended value for FTOL is the square root of the machine
- precision.
-0 Second convergence test. If D is the diagonal matrix whose
- entries are defined by the array DIAG, then this test attempt
- to guarantee that
-0 ENORM(D*(X-XSOL)) .LE. XTOL*ENORM(D*XSOL).
-0 If this condition is satisfied with XTOL = 10**(-K), then the
- larger components of D*X have K significant decimal digits an
- INFO is set to 2 (or to 3 if the first test is also satis-
- fied). There is a danger that the smaller components of D*X
- may have large relative errors, but if MODE = 1, then the
- accuracy of the components of X is usually related to their
- sensitivity. Unless high precision solutions are required,
- the recommended value for XTOL is the square root of the
- machine precision.
-0 Third convergence test. This test is satisfied when the cosine
- of the angle between FVEC and any column of the Jacobian at X
- is at most GTOL in absolute value. There is no clear rela-
- tionship between this test and the accuracy of LMDIF, and
- furthermore, the test is equally well satisfied at other crit
- ical points, namely maximizers and saddle points. Therefore,
- termination caused by this test (INFO = 4) should be examined
- carefully. The recommended value for GTOL is zero.
-0
- 5. Unsuccessful completion.
-0 Unsuccessful termination of LMDIF can be due to improper input
- parameters, arithmetic interrupts, or an excessive number of
- function evaluations.
-0 Improper input parameters. INFO is set to 0 if N .LE. 0, or
- M .LT. N, or LDFJAC .LT. M, or FTOL .LT. 0.E0, or
- XTOL .LT. 0.E0, or GTOL .LT. 0.E0, or MAXFEV .LE. 0, or
- FACTOR .LE. 0.E0.
-0 Arithmetic interrupts. If these interrupts occur in the FCN
- subroutine during an early stage of the computation, they may
- be caused by an unacceptable choice of X by LMDIF. In this
- case, it may be possible to remedy the situation by rerunning
- LMDIF with a smaller value of FACTOR.
-0 Excessive number of function evaluations. A reasonable value
- for MAXFEV is 200*(N+1). If the number of calls to FCN
- reaches MAXFEV, then this indicates that the routine is con-
- verging very slowly as measured by the progress of FVEC, and
- INFO is set to 5. In this case, it may be helpful to restart
- LMDIF with MODE set to 1.
-0
-1
-0 Page
-0 6. Characteristics of the algorithm.
-0 LMDIF is a modification of the Levenberg-Marquardt algorithm.
- Two of its main characteristics involve the proper use of
- implicitly scaled variables (if MODE = 1) and an optimal choice
- for the correction. The use of implicitly scaled variables
- achieves scale invariance of LMDIF and limits the size of the
- correction in any direction where the functions are changing
- rapidly. The optimal choice of the correction guarantees (unde
- reasonable conditions) global convergence from starting points
- far from the solution and a fast rate of convergence for prob-
- lems with small residuals.
-0 Timing. The time required by LMDIF to solve a given problem
- depends on M and N, the behavior of the functions, the accu-
- racy requested, and the starting point. The number of arith-
- metic operations needed by LMDIF is about N**3 to process eac
- evaluation of the functions (one call to FCN) and M*(N**2) to
- process each approximation to the Jacobian (N calls to FCN).
- Unless FCN can be evaluated quickly, the timing of LMDIF will
- be strongly influenced by the time spent in FCN.
-0 Storage. LMDIF requires M*N + 2*M + 6*N single precision sto-
- rage locations and N integer storage locations, in addition t
- the storage required by the program. There are no internally
- declared storage arrays.
-0
- 7. Subprograms required.
-0 USER-supplied ...... FCN
-0 MINPACK-supplied ... SPMPAR,ENORM,FDJAC2,LMPAR,QRFAC,QRSOLV
-0 FORTRAN-supplied ... ABS,AMAX1,AMIN1,SQRT,MOD
-0
- 8. References.
-0 Jorge J. More, The Levenberg-Marquardt Algorithm, Implementatio
- and Theory. Numerical Analysis, G. A. Watson, editor.
- Lecture Notes in Mathematics 630, Springer-Verlag, 1977.
-0
- 9. Example.
-0 The problem is to determine the values of x(1), x(2), and x(3)
- which provide the best fit (in the least squares sense) of
-0 x(1) + u(i)/(v(i)*x(2) + w(i)*x(3)), i = 1, 15
-0 to the data
-1
-0 Page
-0 y = (0.14,0.18,0.22,0.25,0.29,0.32,0.35,0.39,
- 0.37,0.58,0.73,0.96,1.34,2.10,4.39),
-0 where u(i) = i, v(i) = 16 - i, and w(i) = min(u(i),v(i)). The
- i-th component of FVEC is thus defined by
-0 y(i) - (x(1) + u(i)/(v(i)*x(2) + w(i)*x(3))).
-0 C **********
- C
- C DRIVER FOR LMDIF EXAMPLE.
- C SINGLE PRECISION VERSION
- C
- C **********
- INTEGER J,M,N,MAXFEV,MODE,NPRINT,INFO,NFEV,LDFJAC,NWRITE
- INTEGER IPVT(3)
- REAL FTOL,XTOL,GTOL,EPSFCN,FACTOR,FNORM
- REAL X(3),FVEC(15),DIAG(3),FJAC(15,3),QTF(3),
- * WA1(3),WA2(3),WA3(3),WA4(15)
- REAL ENORM,SPMPAR
- EXTERNAL FCN
- C
- C LOGICAL OUTPUT UNIT IS ASSUMED TO BE NUMBER 6.
- C
- DATA NWRITE /6/
- C
- M = 15
- N = 3
- C
- C THE FOLLOWING STARTING VALUES PROVIDE A ROUGH FIT.
- C
- X(1) = 1.E0
- X(2) = 1.E0
- X(3) = 1.E0
- C
- LDFJAC = 15
- C
- C SET FTOL AND XTOL TO THE SQUARE ROOT OF THE MACHINE PRECISION
- C AND GTOL TO ZERO. UNLESS HIGH PRECISION SOLUTIONS ARE
- C REQUIRED, THESE ARE THE RECOMMENDED SETTINGS.
- C
- FTOL = SQRT(SPMPAR(1))
- XTOL = SQRT(SPMPAR(1))
- GTOL = 0.E0
- C
- MAXFEV = 800
- EPSFCN = 0.E0
- MODE = 1
- FACTOR = 1.E2
- NPRINT = 0
- C
- CALL LMDIF(FCN,M,N,X,FVEC,FTOL,XTOL,GTOL,MAXFEV,EPSFCN,
- * DIAG,MODE,FACTOR,NPRINT,INFO,NFEV,FJAC,LDFJAC,
- * IPVT,QTF,WA1,WA2,WA3,WA4)
-1
-0 Page
-0 FNORM = ENORM(M,FVEC)
- WRITE (NWRITE,1000) FNORM,NFEV,INFO,(X(J),J=1,N)
- STOP
- 1000 FORMAT (5X,31H FINAL L2 NORM OF THE RESIDUALS,E15.7 //
- * 5X,31H NUMBER OF FUNCTION EVALUATIONS,I10 //
- * 5X,15H EXIT PARAMETER,16X,I10 //
- * 5X,27H FINAL APPROXIMATE SOLUTION // 5X,3E15.7)
- C
- C LAST CARD OF DRIVER FOR LMDIF EXAMPLE.
- C
- END
- SUBROUTINE FCN(M,N,X,FVEC,IFLAG)
- INTEGER M,N,IFLAG
- REAL X(N),FVEC(M)
- C
- C SUBROUTINE FCN FOR LMDIF EXAMPLE.
- C
- INTEGER I
- REAL TMP1,TMP2,TMP3
- REAL Y(15)
- DATA Y(1),Y(2),Y(3),Y(4),Y(5),Y(6),Y(7),Y(8),
- * Y(9),Y(10),Y(11),Y(12),Y(13),Y(14),Y(15)
- * /1.4E-1,1.8E-1,2.2E-1,2.5E-1,2.9E-1,3.2E-1,3.5E-1,3.9E-1,
- * 3.7E-1,5.8E-1,7.3E-1,9.6E-1,1.34E0,2.1E0,4.39E0/
- C
- IF (IFLAG .NE. 0) GO TO 5
- C
- C INSERT PRINT STATEMENTS HERE WHEN NPRINT IS POSITIVE.
- C
- RETURN
- 5 CONTINUE
- DO 10 I = 1, 15
- TMP1 = I
- TMP2 = 16 - I
- TMP3 = TMP1
- IF (I .GT. 8) TMP3 = TMP2
- FVEC(I) = Y(I) - (X(1) + TMP1/(X(2)*TMP2 + X(3)*TMP3))
- 10 CONTINUE
- RETURN
- C
- C LAST CARD OF SUBROUTINE FCN.
- C
- END
-0 Results obtained with different compilers or machines
- may be slightly different.
-0 FINAL L2 NORM OF THE RESIDUALS 0.9063596E-01
-0 NUMBER OF FUNCTION EVALUATIONS 21
-0 EXIT PARAMETER 1
-0 FINAL APPROXIMATE SOLUTION
-1
-0 Page
-0 0.8241057E-01 0.1133037E+01 0.2343695E+01
-1
-0
-1
-0 Page
-0 Documentation for MINPACK subroutine CHKDER
-0 Single precision version
-0 Argonne National Laboratory
-0 Burton S. Garbow, Kenneth E. Hillstrom, Jorge J. More
-0 March 1980
-0
- 1. Purpose.
-0 The purpose of CHKDER is to check the gradients of M nonlinear
- functions in N variables, evaluated at a point X, for consis-
- tency with the functions themselves. The user must call CHKDER
- twice, first with MODE = 1 and then with MODE = 2.
-0
- 2. Subroutine and type statements.
-0 SUBROUTINE CHKDER(M,N,X,FVEC,FJAC,LDFJAC,XP,FVECP,MODE,ERR)
- INTEGER M,N,LDFJAC,MODE
- REAL X(N),FVEC(M),FJAC(LDFJAC,N),XP(N),FVECP(M),ERR(M)
-0
- 3. Parameters.
-0 Parameters designated as input parameters must be specified on
- entry to CHKDER and are not changed on exit, while parameters
- designated as output parameters need not be specified on entry
- and are set to appropriate values on exit from CHKDER.
-0 M is a positive integer input variable set to the number of
- functions.
-0 N is a positive integer input variable set to the number of
- variables.
-0 X is an input array of length N.
-0 FVEC is an array of length M. On input when MODE = 2, FVEC mus
- contain the functions evaluated at X.
-0 FJAC is an M by N array. On input when MODE = 2, the rows of
- FJAC must contain the gradients of the respective functions
- evaluated at X.
-0 LDFJAC is a positive integer input variable not less than M
- which specifies the leading dimension of the array FJAC.
-0 XP is an array of length N. On output when MODE = 1, XP is set
- to a neighboring point of X.
-1
-0 Page
-0 FVECP is an array of length M. On input when MODE = 2, FVECP
- must contain the functions evaluated at XP.
-0 MODE is an integer input variable set to 1 on the first call an
- 2 on the second. Other values of MODE are equivalent to
- MODE = 1.
-0 ERR is an array of length M. On output when MODE = 2, ERR con-
- tains measures of correctness of the respective gradients. I
- there is no severe loss of significance, then if ERR(I) is 1.
- the I-th gradient is correct, while if ERR(I) is 0.0 the I-th
- gradient is incorrect. For values of ERR between 0.0 and 1.0
- the categorization is less certain. In general, a value of
- ERR(I) greater than 0.5 indicates that the I-th gradient is
- probably correct, while a value of ERR(I) less than 0.5 indi-
- cates that the I-th gradient is probably incorrect.
-0
- 4. Successful completion.
-0 CHKDER usually guarantees that if ERR(I) is 1.0, then the I-th
- gradient at X is consistent with the I-th function. This sug-
- gests that the input X be such that consistency of the gradient
- at X implies consistency of the gradient at all points of inter
- est. If all the components of X are distinct and the fractiona
- part of each one has two nonzero digits, then X is likely to be
- a satisfactory choice.
-0 If ERR(I) is not 1.0 but is greater than 0.5, then the I-th gra
- dient is probably consistent with the I-th function (the more s
- the larger ERR(I) is), but the conditions for ERR(I) to be 1.0
- have not been completely satisfied. In this case, it is recom-
- mended that CHKDER be rerun with other input values of X. If
- ERR(I) is always greater than 0.5, then the I-th gradient is
- consistent with the I-th function.
-0
- 5. Unsuccessful completion.
-0 CHKDER does not perform reliably if cancellation or rounding
- errors cause a severe loss of significance in the evaluation of
- a function. Therefore, none of the components of X should be
- unusually small (in particular, zero) or any other value which
- may cause loss of significance. The relative differences
- between corresponding elements of FVECP and FVEC should be at
- least two orders of magnitude greater than the machine precisio
- (as defined by the MINPACK function SPMPAR(1)). If there is a
- severe loss of significance in the evaluation of the I-th func-
- tion, then ERR(I) may be 0.0 and yet the I-th gradient could be
- correct.
-0 If ERR(I) is not 0.0 but is less than 0.5, then the I-th gra-
- dient is probably not consistent with the I-th function (the
- more so the smaller ERR(I) is), but the conditions for ERR(I) t
-1
-0 Page
-0 be 0.0 have not been completely satisfied. In this case, it is
- recommended that CHKDER be rerun with other input values of X.
- If ERR(I) is always less than 0.5 and if there is no severe los
- of significance, then the I-th gradient is not consistent with
- the I-th function.
-0
- 6. Characteristics of the algorithm.
-0 CHKDER checks the I-th gradient for consistency with the I-th
- function by computing a forward-difference approximation along
- suitably chosen direction and comparing this approximation with
- the user-supplied gradient along the same direction. The prin-
- cipal characteristic of CHKDER is its invariance to changes in
- scale of the variables or functions.
-0 Timing. The time required by CHKDER depends only on M and N.
- The number of arithmetic operations needed by CHKDER is about
- N when MODE = 1 and M*N when MODE = 2.
-0 Storage. CHKDER requires M*N + 3*M + 2*N single precision stor
- age locations, in addition to the storage required by the pro
- gram. There are no internally declared storage arrays.
-0
- 7. Subprograms required.
-0 MINPACK-supplied ... SPMPAR
-0 FORTRAN-supplied ... ABS,ALOG10,SQRT
-0
- 8. References.
-0 None.
-0
- 9. Example.
-0 This example checks the Jacobian matrix for the problem that
- determines the values of x(1), x(2), and x(3) which provide the
- best fit (in the least squares sense) of
-0 x(1) + u(i)/(v(i)*x(2) + w(i)*x(3)), i = 1, 15
-0 to the data
-0 y = (0.14,0.18,0.22,0.25,0.29,0.32,0.35,0.39,
- 0.37,0.58,0.73,0.96,1.34,2.10,4.39),
-0 where u(i) = i, v(i) = 16 - i, and w(i) = min(u(i),v(i)). The
- i-th component of FVEC is thus defined by
-0 y(i) - (x(1) + u(i)/(v(i)*x(2) + w(i)*x(3))).
-1
-0 Page
-0 C **********
- C
- C DRIVER FOR CHKDER EXAMPLE.
- C SINGLE PRECISION VERSION
- C
- C **********
- INTEGER I,M,N,LDFJAC,MODE,NWRITE
- REAL X(3),FVEC(15),FJAC(15,3),XP(3),FVECP(15),ERR(15)
- C
- C LOGICAL OUTPUT UNIT IS ASSUMED TO BE NUMBER 6.
- C
- DATA NWRITE /6/
- C
- M = 15
- N = 3
- C
- C THE FOLLOWING VALUES SHOULD BE SUITABLE FOR
- C CHECKING THE JACOBIAN MATRIX.
- C
- X(1) = 9.2E-1
- X(2) = 1.3E-1
- X(3) = 5.4E-1
- C
- LDFJAC = 15
- C
- MODE = 1
- CALL CHKDER(M,N,X,FVEC,FJAC,LDFJAC,XP,FVECP,MODE,ERR)
- MODE = 2
- CALL FCN(M,N,X,FVEC,FJAC,LDFJAC,1)
- CALL FCN(M,N,X,FVEC,FJAC,LDFJAC,2)
- CALL FCN(M,N,XP,FVECP,FJAC,LDFJAC,1)
- CALL CHKDER(M,N,X,FVEC,FJAC,LDFJAC,XP,FVECP,MODE,ERR)
- C
- DO 10 I = 1, M
- FVECP(I) = FVECP(I) - FVEC(I)
- 10 CONTINUE
- WRITE (NWRITE,1000) (FVEC(I),I=1,M)
- WRITE (NWRITE,2000) (FVECP(I),I=1,M)
- WRITE (NWRITE,3000) (ERR(I),I=1,M)
- STOP
- 1000 FORMAT (/5X,5H FVEC // (5X,3E15.7))
- 2000 FORMAT (/5X,13H FVECP - FVEC // (5X,3E15.7))
- 3000 FORMAT (/5X,4H ERR // (5X,3E15.7))
- C
- C LAST CARD OF DRIVER FOR CHKDER EXAMPLE.
- C
- END
- SUBROUTINE FCN(M,N,X,FVEC,FJAC,LDFJAC,IFLAG)
- INTEGER M,N,LDFJAC,IFLAG
- REAL X(N),FVEC(M),FJAC(LDFJAC,N)
- C
- C SUBROUTINE FCN FOR CHKDER EXAMPLE.
- C
- INTEGER I
-1
-0 Page
-0 REAL TMP1,TMP2,TMP3,TMP4
- REAL Y(15)
- DATA Y(1),Y(2),Y(3),Y(4),Y(5),Y(6),Y(7),Y(8),
- * Y(9),Y(10),Y(11),Y(12),Y(13),Y(14),Y(15)
- * /1.4E-1,1.8E-1,2.2E-1,2.5E-1,2.9E-1,3.2E-1,3.5E-1,3.9E-1,
- * 3.7E-1,5.8E-1,7.3E-1,9.6E-1,1.34E0,2.1E0,4.39E0/
- C
- IF (IFLAG .EQ. 2) GO TO 20
- DO 10 I = 1, 15
- TMP1 = I
- TMP2 = 16 - I
- TMP3 = TMP1
- IF (I .GT. 8) TMP3 = TMP2
- FVEC(I) = Y(I) - (X(1) + TMP1/(X(2)*TMP2 + X(3)*TMP3))
- 10 CONTINUE
- GO TO 40
- 20 CONTINUE
- DO 30 I = 1, 15
- TMP1 = I
- TMP2 = 16 - I
- C
- C ERROR INTRODUCED INTO NEXT STATEMENT FOR ILLUSTRATION.
- C CORRECTED STATEMENT SHOULD READ TMP3 = TMP1 .
- C
- TMP3 = TMP2
- IF (I .GT. 8) TMP3 = TMP2
- TMP4 = (X(2)*TMP2 + X(3)*TMP3)**2
- FJAC(I,1) = -1.E0
- FJAC(I,2) = TMP1*TMP2/TMP4
- FJAC(I,3) = TMP1*TMP3/TMP4
- 30 CONTINUE
- 40 CONTINUE
- RETURN
- C
- C LAST CARD OF SUBROUTINE FCN.
- C
- END
-0 Results obtained with different compilers or machines
- may be different. In particular, the differences
- FVECP - FVEC are machine dependent.
-0 FVEC
-0 -0.1181606E+01 -0.1429655E+01 -0.1606344E+01
- -0.1745269E+01 -0.1840654E+01 -0.1921586E+01
- -0.1984141E+01 -0.2022537E+01 -0.2468977E+01
- -0.2827562E+01 -0.3473582E+01 -0.4437612E+01
- -0.6047662E+01 -0.9267761E+01 -0.1891806E+02
-0 FVECP - FVEC
-0 -0.7724666E-08 -0.3432405E-08 -0.2034843E-09
- 0.2313685E-08 0.4331078E-08 0.5984096E-08
-1
-0 Page
-0 0.7363281E-08 0.8531470E-08 0.1488591E-07
- 0.2335850E-07 0.3522012E-07 0.5301255E-07
- 0.8266660E-07 0.1419747E-06 0.3198990E-06
-0 ERR
-0 0.1141397E+00 0.9943516E-01 0.9674474E-01
- 0.9980447E-01 0.1073116E+00 0.1220445E+00
- 0.1526814E+00 0.1000000E+01 0.1000000E+01
- 0.1000000E+01 0.1000000E+01 0.1000000E+01
- 0.1000000E+01 0.1000000E+01 0.1000000E+01
diff --git a/CEP/PyBDSM/src/minpack/ex/file04 b/CEP/PyBDSM/src/minpack/ex/file04
deleted file mode 100644
index 72050313be2a601be09787e9443764f580fb188e..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/minpack/ex/file04
+++ /dev/null
@@ -1,192 +0,0 @@
- DOUBLE PRECISION FUNCTION DPMPAR(I)
- INTEGER I
-C **********
-C
-C FUNCTION DPMPAR
-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
-C THE FUNCTION STATEMENT IS
-C
-C DOUBLE PRECISION FUNCTION DPMPAR(I)
-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. MARCH 1980.
-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
- DATA MCHEPS(1),MCHEPS(2) / Z34100000, Z00000000 /
- DATA MINMAG(1),MINMAG(2) / Z00100000, Z00000000 /
- 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 FORTRAN SUPPORTING
-C 32-BIT INTEGERS (EXPRESSED IN INTEGER AND OCTAL).
-C
-C DATA MCHEPS(1),MCHEPS(2) / 620756992, 0 /
-C DATA MINMAG(1),MINMAG(2) / 8388608, 0 /
-C DATA MAXMAG(1),MAXMAG(2) / 2147483647, -1 /
-C
-C DATA MCHEPS(1),MCHEPS(2) / O04500000000, O00000000000 /
-C DATA MINMAG(1),MINMAG(2) / O00040000000, O00000000000 /
-C DATA MAXMAG(1),MAXMAG(2) / O17777777777, O37777777777 /
-C
-C MACHINE CONSTANTS FOR THE PDP-11 FORTRAN SUPPORTING
-C 16-BIT INTEGERS (EXPRESSED IN INTEGER AND OCTAL).
-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 DATA MCHEPS(1),MCHEPS(2) / O022400, O000000 /
-C DATA MCHEPS(3),MCHEPS(4) / O000000, O000000 /
-C
-C DATA MINMAG(1),MINMAG(2) / O000200, O000000 /
-C DATA MINMAG(3),MINMAG(4) / O000000, O000000 /
-C
-C DATA MAXMAG(1),MAXMAG(2) / O077777, O177777 /
-C DATA MAXMAG(3),MAXMAG(4) / O177777, O177777 /
-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
- DPMPAR = DMACH(I)
- RETURN
-C
-C LAST CARD OF FUNCTION DPMPAR.
-C
- END
diff --git a/CEP/PyBDSM/src/minpack/ex/file05 b/CEP/PyBDSM/src/minpack/ex/file05
deleted file mode 100644
index f77757797c6a83c7f1c6bd05a5885aaf58d10245..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/minpack/ex/file05
+++ /dev/null
@@ -1,4778 +0,0 @@
- SUBROUTINE CHKDER(M,N,X,FVEC,FJAC,LDFJAC,XP,FVECP,MODE,ERR)
- INTEGER M,N,LDFJAC,MODE
- DOUBLE PRECISION X(N),FVEC(M),FJAC(LDFJAC,N),XP(N),FVECP(M),
- * ERR(M)
-C **********
-C
-C SUBROUTINE CHKDER
-C
-C THIS SUBROUTINE CHECKS THE GRADIENTS OF M NONLINEAR FUNCTIONS
-C IN N VARIABLES, EVALUATED AT A POINT X, FOR CONSISTENCY WITH
-C THE FUNCTIONS THEMSELVES. THE USER MUST CALL CHKDER TWICE,
-C FIRST WITH MODE = 1 AND THEN WITH MODE = 2.
-C
-C MODE = 1. ON INPUT, X MUST CONTAIN THE POINT OF EVALUATION.
-C ON OUTPUT, XP IS SET TO A NEIGHBORING POINT.
-C
-C MODE = 2. ON INPUT, FVEC MUST CONTAIN THE FUNCTIONS AND THE
-C ROWS OF FJAC MUST CONTAIN THE GRADIENTS
-C OF THE RESPECTIVE FUNCTIONS EACH EVALUATED
-C AT X, AND FVECP MUST CONTAIN THE FUNCTIONS
-C EVALUATED AT XP.
-C ON OUTPUT, ERR CONTAINS MEASURES OF CORRECTNESS OF
-C THE RESPECTIVE GRADIENTS.
-C
-C THE SUBROUTINE DOES NOT PERFORM RELIABLY IF CANCELLATION OR
-C ROUNDING ERRORS CAUSE A SEVERE LOSS OF SIGNIFICANCE IN THE
-C EVALUATION OF A FUNCTION. THEREFORE, NONE OF THE COMPONENTS
-C OF X SHOULD BE UNUSUALLY SMALL (IN PARTICULAR, ZERO) OR ANY
-C OTHER VALUE WHICH MAY CAUSE LOSS OF SIGNIFICANCE.
-C
-C THE SUBROUTINE STATEMENT IS
-C
-C SUBROUTINE CHKDER(M,N,X,FVEC,FJAC,LDFJAC,XP,FVECP,MODE,ERR)
-C
-C WHERE
-C
-C M IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER
-C OF FUNCTIONS.
-C
-C N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER
-C OF VARIABLES.
-C
-C X IS AN INPUT ARRAY OF LENGTH N.
-C
-C FVEC IS AN ARRAY OF LENGTH M. ON INPUT WHEN MODE = 2,
-C FVEC MUST CONTAIN THE FUNCTIONS EVALUATED AT X.
-C
-C FJAC IS AN M BY N ARRAY. ON INPUT WHEN MODE = 2,
-C THE ROWS OF FJAC MUST CONTAIN THE GRADIENTS OF
-C THE RESPECTIVE FUNCTIONS EVALUATED AT X.
-C
-C LDFJAC IS A POSITIVE INTEGER INPUT PARAMETER NOT LESS THAN M
-C WHICH SPECIFIES THE LEADING DIMENSION OF THE ARRAY FJAC.
-C
-C XP IS AN ARRAY OF LENGTH N. ON OUTPUT WHEN MODE = 1,
-C XP IS SET TO A NEIGHBORING POINT OF X.
-C
-C FVECP IS AN ARRAY OF LENGTH M. ON INPUT WHEN MODE = 2,
-C FVECP MUST CONTAIN THE FUNCTIONS EVALUATED AT XP.
-C
-C MODE IS AN INTEGER INPUT VARIABLE SET TO 1 ON THE FIRST CALL
-C AND 2 ON THE SECOND. OTHER VALUES OF MODE ARE EQUIVALENT
-C TO MODE = 1.
-C
-C ERR IS AN ARRAY OF LENGTH M. ON OUTPUT WHEN MODE = 2,
-C ERR CONTAINS MEASURES OF CORRECTNESS OF THE RESPECTIVE
-C GRADIENTS. IF THERE IS NO SEVERE LOSS OF SIGNIFICANCE,
-C THEN IF ERR(I) IS 1.0 THE I-TH GRADIENT IS CORRECT,
-C WHILE IF ERR(I) IS 0.0 THE I-TH GRADIENT IS INCORRECT.
-C FOR VALUES OF ERR BETWEEN 0.0 AND 1.0, THE CATEGORIZATION
-C IS LESS CERTAIN. IN GENERAL, A VALUE OF ERR(I) GREATER
-C THAN 0.5 INDICATES THAT THE I-TH GRADIENT IS PROBABLY
-C CORRECT, WHILE A VALUE OF ERR(I) LESS THAN 0.5 INDICATES
-C THAT THE I-TH GRADIENT IS PROBABLY INCORRECT.
-C
-C SUBPROGRAMS CALLED
-C
-C MINPACK SUPPLIED ... DPMPAR
-C
-C FORTRAN SUPPLIED ... DABS,DLOG10,DSQRT
-C
-C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980.
-C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE
-C
-C **********
- INTEGER I,J
- DOUBLE PRECISION EPS,EPSF,EPSLOG,EPSMCH,FACTOR,ONE,TEMP,ZERO
- DOUBLE PRECISION DPMPAR
- DATA FACTOR,ONE,ZERO /1.0D2,1.0D0,0.0D0/
-C
-C EPSMCH IS THE MACHINE PRECISION.
-C
- EPSMCH = DPMPAR(1)
-C
- EPS = DSQRT(EPSMCH)
-C
- IF (MODE .EQ. 2) GO TO 20
-C
-C MODE = 1.
-C
- DO 10 J = 1, N
- TEMP = EPS*DABS(X(J))
- IF (TEMP .EQ. ZERO) TEMP = EPS
- XP(J) = X(J) + TEMP
- 10 CONTINUE
- GO TO 70
- 20 CONTINUE
-C
-C MODE = 2.
-C
- EPSF = FACTOR*EPSMCH
- EPSLOG = DLOG10(EPS)
- DO 30 I = 1, M
- ERR(I) = ZERO
- 30 CONTINUE
- DO 50 J = 1, N
- TEMP = DABS(X(J))
- IF (TEMP .EQ. ZERO) TEMP = ONE
- DO 40 I = 1, M
- ERR(I) = ERR(I) + TEMP*FJAC(I,J)
- 40 CONTINUE
- 50 CONTINUE
- DO 60 I = 1, M
- TEMP = ONE
- IF (FVEC(I) .NE. ZERO .AND. FVECP(I) .NE. ZERO
- * .AND. DABS(FVECP(I)-FVEC(I)) .GE. EPSF*DABS(FVEC(I)))
- * TEMP = EPS*DABS((FVECP(I)-FVEC(I))/EPS-ERR(I))
- * /(DABS(FVEC(I)) + DABS(FVECP(I)))
- ERR(I) = ONE
- IF (TEMP .GT. EPSMCH .AND. TEMP .LT. EPS)
- * ERR(I) = (DLOG10(TEMP) - EPSLOG)/EPSLOG
- IF (TEMP .GE. EPS) ERR(I) = ZERO
- 60 CONTINUE
- 70 CONTINUE
-C
- RETURN
-C
-C LAST CARD OF SUBROUTINE CHKDER.
-C
- END
- SUBROUTINE DOGLEG(N,R,LR,DIAG,QTB,DELTA,X,WA1,WA2)
- INTEGER N,LR
- DOUBLE PRECISION DELTA
- DOUBLE PRECISION R(LR),DIAG(N),QTB(N),X(N),WA1(N),WA2(N)
-C **********
-C
-C SUBROUTINE DOGLEG
-C
-C GIVEN AN M BY N MATRIX A, AN N BY N NONSINGULAR DIAGONAL
-C MATRIX D, AN M-VECTOR B, AND A POSITIVE NUMBER DELTA, THE
-C PROBLEM IS TO DETERMINE THE CONVEX COMBINATION X OF THE
-C GAUSS-NEWTON AND SCALED GRADIENT DIRECTIONS THAT MINIMIZES
-C (A*X - B) IN THE LEAST SQUARES SENSE, SUBJECT TO THE
-C RESTRICTION THAT THE EUCLIDEAN NORM OF D*X BE AT MOST DELTA.
-C
-C THIS SUBROUTINE COMPLETES THE SOLUTION OF THE PROBLEM
-C IF IT IS PROVIDED WITH THE NECESSARY INFORMATION FROM THE
-C QR FACTORIZATION OF A. THAT IS, IF A = Q*R, WHERE Q HAS
-C ORTHOGONAL COLUMNS AND R IS AN UPPER TRIANGULAR MATRIX,
-C THEN DOGLEG EXPECTS THE FULL UPPER TRIANGLE OF R AND
-C THE FIRST N COMPONENTS OF (Q TRANSPOSE)*B.
-C
-C THE SUBROUTINE STATEMENT IS
-C
-C SUBROUTINE DOGLEG(N,R,LR,DIAG,QTB,DELTA,X,WA1,WA2)
-C
-C WHERE
-C
-C N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE ORDER OF R.
-C
-C R IS AN INPUT ARRAY OF LENGTH LR WHICH MUST CONTAIN THE UPPER
-C TRIANGULAR MATRIX R STORED BY ROWS.
-C
-C LR IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN
-C (N*(N+1))/2.
-C
-C DIAG IS AN INPUT ARRAY OF LENGTH N WHICH MUST CONTAIN THE
-C DIAGONAL ELEMENTS OF THE MATRIX D.
-C
-C QTB IS AN INPUT ARRAY OF LENGTH N WHICH MUST CONTAIN THE FIRST
-C N ELEMENTS OF THE VECTOR (Q TRANSPOSE)*B.
-C
-C DELTA IS A POSITIVE INPUT VARIABLE WHICH SPECIFIES AN UPPER
-C BOUND ON THE EUCLIDEAN NORM OF D*X.
-C
-C X IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS THE DESIRED
-C CONVEX COMBINATION OF THE GAUSS-NEWTON DIRECTION AND THE
-C SCALED GRADIENT DIRECTION.
-C
-C WA1 AND WA2 ARE WORK ARRAYS OF LENGTH N.
-C
-C SUBPROGRAMS CALLED
-C
-C MINPACK-SUPPLIED ... DPMPAR,ENORM
-C
-C FORTRAN-SUPPLIED ... DABS,DMAX1,DMIN1,DSQRT
-C
-C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980.
-C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE
-C
-C **********
- INTEGER I,J,JJ,JP1,K,L
- DOUBLE PRECISION ALPHA,BNORM,EPSMCH,GNORM,ONE,QNORM,SGNORM,SUM,
- * TEMP,ZERO
- DOUBLE PRECISION DPMPAR,ENORM
- DATA ONE,ZERO /1.0D0,0.0D0/
-C
-C EPSMCH IS THE MACHINE PRECISION.
-C
- EPSMCH = DPMPAR(1)
-C
-C FIRST, CALCULATE THE GAUSS-NEWTON DIRECTION.
-C
- JJ = (N*(N + 1))/2 + 1
- DO 50 K = 1, N
- J = N - K + 1
- JP1 = J + 1
- JJ = JJ - K
- L = JJ + 1
- SUM = ZERO
- IF (N .LT. JP1) GO TO 20
- DO 10 I = JP1, N
- SUM = SUM + R(L)*X(I)
- L = L + 1
- 10 CONTINUE
- 20 CONTINUE
- TEMP = R(JJ)
- IF (TEMP .NE. ZERO) GO TO 40
- L = J
- DO 30 I = 1, J
- TEMP = DMAX1(TEMP,DABS(R(L)))
- L = L + N - I
- 30 CONTINUE
- TEMP = EPSMCH*TEMP
- IF (TEMP .EQ. ZERO) TEMP = EPSMCH
- 40 CONTINUE
- X(J) = (QTB(J) - SUM)/TEMP
- 50 CONTINUE
-C
-C TEST WHETHER THE GAUSS-NEWTON DIRECTION IS ACCEPTABLE.
-C
- DO 60 J = 1, N
- WA1(J) = ZERO
- WA2(J) = DIAG(J)*X(J)
- 60 CONTINUE
- QNORM = ENORM(N,WA2)
- IF (QNORM .LE. DELTA) GO TO 140
-C
-C THE GAUSS-NEWTON DIRECTION IS NOT ACCEPTABLE.
-C NEXT, CALCULATE THE SCALED GRADIENT DIRECTION.
-C
- L = 1
- DO 80 J = 1, N
- TEMP = QTB(J)
- DO 70 I = J, N
- WA1(I) = WA1(I) + R(L)*TEMP
- L = L + 1
- 70 CONTINUE
- WA1(J) = WA1(J)/DIAG(J)
- 80 CONTINUE
-C
-C CALCULATE THE NORM OF THE SCALED GRADIENT AND TEST FOR
-C THE SPECIAL CASE IN WHICH THE SCALED GRADIENT IS ZERO.
-C
- GNORM = ENORM(N,WA1)
- SGNORM = ZERO
- ALPHA = DELTA/QNORM
- IF (GNORM .EQ. ZERO) GO TO 120
-C
-C CALCULATE THE POINT ALONG THE SCALED GRADIENT
-C AT WHICH THE QUADRATIC IS MINIMIZED.
-C
- DO 90 J = 1, N
- WA1(J) = (WA1(J)/GNORM)/DIAG(J)
- 90 CONTINUE
- L = 1
- DO 110 J = 1, N
- SUM = ZERO
- DO 100 I = J, N
- SUM = SUM + R(L)*WA1(I)
- L = L + 1
- 100 CONTINUE
- WA2(J) = SUM
- 110 CONTINUE
- TEMP = ENORM(N,WA2)
- SGNORM = (GNORM/TEMP)/TEMP
-C
-C TEST WHETHER THE SCALED GRADIENT DIRECTION IS ACCEPTABLE.
-C
- ALPHA = ZERO
- IF (SGNORM .GE. DELTA) GO TO 120
-C
-C THE SCALED GRADIENT DIRECTION IS NOT ACCEPTABLE.
-C FINALLY, CALCULATE THE POINT ALONG THE DOGLEG
-C AT WHICH THE QUADRATIC IS MINIMIZED.
-C
- BNORM = ENORM(N,QTB)
- TEMP = (BNORM/GNORM)*(BNORM/QNORM)*(SGNORM/DELTA)
- TEMP = TEMP - (DELTA/QNORM)*(SGNORM/DELTA)**2
- * + DSQRT((TEMP-(DELTA/QNORM))**2
- * +(ONE-(DELTA/QNORM)**2)*(ONE-(SGNORM/DELTA)**2))
- ALPHA = ((DELTA/QNORM)*(ONE - (SGNORM/DELTA)**2))/TEMP
- 120 CONTINUE
-C
-C FORM APPROPRIATE CONVEX COMBINATION OF THE GAUSS-NEWTON
-C DIRECTION AND THE SCALED GRADIENT DIRECTION.
-C
- TEMP = (ONE - ALPHA)*DMIN1(SGNORM,DELTA)
- DO 130 J = 1, N
- X(J) = TEMP*WA1(J) + ALPHA*X(J)
- 130 CONTINUE
- 140 CONTINUE
- RETURN
-C
-C LAST CARD OF SUBROUTINE DOGLEG.
-C
- END
- DOUBLE PRECISION FUNCTION ENORM(N,X)
- INTEGER N
- DOUBLE PRECISION X(N)
-C **********
-C
-C FUNCTION ENORM
-C
-C GIVEN AN N-VECTOR X, THIS FUNCTION CALCULATES THE
-C EUCLIDEAN NORM OF 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
-C THE FUNCTION STATEMENT IS
-C
-C DOUBLE PRECISION FUNCTION ENORM(N,X)
-C
-C WHERE
-C
-C N IS A POSITIVE INTEGER INPUT VARIABLE.
-C
-C X IS AN INPUT ARRAY OF LENGTH N.
-C
-C SUBPROGRAMS CALLED
-C
-C FORTRAN-SUPPLIED ... DABS,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
-C
-C SUM FOR SMALL COMPONENTS.
-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
-C
-C SUM FOR INTERMEDIATE COMPONENTS.
-C
- S2 = S2 + XABS**2
- 80 CONTINUE
- 90 CONTINUE
-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
- RETURN
-C
-C LAST CARD OF FUNCTION ENORM.
-C
- END
- 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 SUBROUTINE FDJAC1
-C
-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 SUBROUTINE STATEMENT IS
-C
-C SUBROUTINE FDJAC1(FCN,N,X,FVEC,FJAC,LDFJAC,IFLAG,ML,MU,EPSFCN,
-C WA1,WA2)
-C
-C WHERE
-C
-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
-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
-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 N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER
-C OF FUNCTIONS AND VARIABLES.
-C
-C X IS AN INPUT ARRAY OF LENGTH N.
-C
-C FVEC IS AN INPUT ARRAY OF LENGTH N WHICH MUST CONTAIN THE
-C FUNCTIONS EVALUATED AT X.
-C
-C FJAC IS AN OUTPUT N BY N ARRAY WHICH CONTAINS THE
-C APPROXIMATION TO THE JACOBIAN MATRIX EVALUATED AT X.
-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 IFLAG IS AN INTEGER VARIABLE WHICH CAN BE USED TO TERMINATE
-C THE EXECUTION OF FDJAC1. SEE DESCRIPTION OF FCN.
-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 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 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 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 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,J,K,MSUM
- DOUBLE PRECISION EPS,EPSMCH,H,TEMP,ZERO
- DOUBLE PRECISION DPMPAR
- DATA ZERO /0.0D0/
-C
-C EPSMCH IS THE MACHINE PRECISION.
-C
- EPSMCH = DPMPAR(1)
-C
- 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
-C COMPUTATION OF BANDED APPROXIMATE JACOBIAN.
-C
- 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 SUBROUTINE FDJAC1.
-C
- END
- SUBROUTINE FDJAC2(FCN,M,N,X,FVEC,FJAC,LDFJAC,IFLAG,EPSFCN,WA)
- INTEGER M,N,LDFJAC,IFLAG
- DOUBLE PRECISION EPSFCN
- DOUBLE PRECISION X(N),FVEC(M),FJAC(LDFJAC,N),WA(M)
-C **********
-C
-C SUBROUTINE FDJAC2
-C
-C THIS SUBROUTINE COMPUTES A FORWARD-DIFFERENCE APPROXIMATION
-C TO THE M BY N JACOBIAN MATRIX ASSOCIATED WITH A SPECIFIED
-C PROBLEM OF M FUNCTIONS IN N VARIABLES.
-C
-C THE SUBROUTINE STATEMENT IS
-C
-C SUBROUTINE FDJAC2(FCN,M,N,X,FVEC,FJAC,LDFJAC,IFLAG,EPSFCN,WA)
-C
-C WHERE
-C
-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
-C SUBROUTINE FCN(M,N,X,FVEC,IFLAG)
-C INTEGER M,N,IFLAG
-C DOUBLE PRECISION X(N),FVEC(M)
-C ----------
-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 FDJAC2.
-C IN THIS CASE SET IFLAG TO A NEGATIVE INTEGER.
-C
-C M IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER
-C OF FUNCTIONS.
-C
-C N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER
-C OF VARIABLES. N MUST NOT EXCEED M.
-C
-C X IS AN INPUT ARRAY OF LENGTH N.
-C
-C FVEC IS AN INPUT ARRAY OF LENGTH M WHICH MUST CONTAIN THE
-C FUNCTIONS EVALUATED AT X.
-C
-C FJAC IS AN OUTPUT M BY N ARRAY WHICH CONTAINS THE
-C APPROXIMATION TO THE JACOBIAN MATRIX EVALUATED AT X.
-C
-C LDFJAC IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN M
-C WHICH SPECIFIES THE LEADING DIMENSION OF THE ARRAY FJAC.
-C
-C IFLAG IS AN INTEGER VARIABLE WHICH CAN BE USED TO TERMINATE
-C THE EXECUTION OF FDJAC2. SEE DESCRIPTION OF FCN.
-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 WA IS A WORK ARRAY OF LENGTH M.
-C
-C SUBPROGRAMS CALLED
-C
-C USER-SUPPLIED ...... FCN
-C
-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,J
- DOUBLE PRECISION EPS,EPSMCH,H,TEMP,ZERO
- DOUBLE PRECISION DPMPAR
- DATA ZERO /0.0D0/
-C
-C EPSMCH IS THE MACHINE PRECISION.
-C
- EPSMCH = DPMPAR(1)
-C
- EPS = DSQRT(DMAX1(EPSFCN,EPSMCH))
- DO 20 J = 1, N
- TEMP = X(J)
- H = EPS*DABS(TEMP)
- IF (H .EQ. ZERO) H = EPS
- X(J) = TEMP + H
- CALL FCN(M,N,X,WA,IFLAG)
- IF (IFLAG .LT. 0) GO TO 30
- X(J) = TEMP
- DO 10 I = 1, M
- FJAC(I,J) = (WA(I) - FVEC(I))/H
- 10 CONTINUE
- 20 CONTINUE
- 30 CONTINUE
- RETURN
-C
-C LAST CARD OF SUBROUTINE FDJAC2.
-C
- END
- 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 HYBRD
-C
-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. THE JACOBIAN IS
-C THEN CALCULATED BY A FORWARD-DIFFERENCE APPROXIMATION.
-C
-C THE SUBROUTINE STATEMENT IS
-C
-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. 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,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
-C THE VALUE OF IFLAG SHOULD NOT BE CHANGED BY FCN UNLESS
-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
-C OF FUNCTIONS AND VARIABLES.
-C
-C X IS AN ARRAY OF LENGTH N. ON INPUT X MUST CONTAIN
-C AN INITIAL ESTIMATE OF THE SOLUTION VECTOR. ON OUTPUT X
-C CONTAINS THE FINAL ESTIMATE OF THE SOLUTION VECTOR.
-C
-C FVEC IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS
-C THE FUNCTIONS EVALUATED AT THE OUTPUT X.
-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 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
-C MUST CONTAIN POSITIVE ENTRIES THAT SERVE AS
-C MULTIPLICATIVE SCALE FACTORS FOR THE VARIABLES.
-C
-C MODE IS AN INTEGER INPUT VARIABLE. IF MODE = 1, THE
-C VARIABLES WILL BE SCALED INTERNALLY. IF MODE = 2,
-C THE SCALING IS SPECIFIED BY THE INPUT DIAG. OTHER
-C VALUES OF MODE ARE EQUIVALENT TO MODE = 1.
-C
-C FACTOR IS A POSITIVE INPUT VARIABLE USED IN DETERMINING THE
-C INITIAL STEP BOUND. THIS BOUND IS SET TO THE PRODUCT OF
-C FACTOR AND THE EUCLIDEAN NORM OF DIAG*X IF NONZERO, OR ELSE
-C TO FACTOR ITSELF. IN MOST CASES FACTOR SHOULD LIE IN THE
-C INTERVAL (.1,100.). 100. IS A GENERALLY RECOMMENDED VALUE.
-C
-C NPRINT IS AN INTEGER INPUT VARIABLE THAT ENABLES CONTROLLED
-C PRINTING OF ITERATES IF IT IS POSITIVE. IN THIS CASE,
-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. 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)
-C VALUE OF IFLAG. SEE DESCRIPTION OF FCN. OTHERWISE,
-C INFO IS SET AS FOLLOWS.
-C
-C INFO = 0 IMPROPER INPUT PARAMETERS.
-C
-C INFO = 1 RELATIVE ERROR BETWEEN TWO CONSECUTIVE ITERATES
-C IS AT MOST XTOL.
-C
-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.
-C
-C INFO = 4 ITERATION IS NOT MAKING GOOD PROGRESS, AS
-C MEASURED BY THE IMPROVEMENT FROM THE LAST
-C FIVE JACOBIAN EVALUATIONS.
-C
-C INFO = 5 ITERATION IS NOT MAKING GOOD PROGRESS, AS
-C MEASURED BY THE IMPROVEMENT FROM THE LAST
-C TEN ITERATIONS.
-C
-C NFEV IS AN INTEGER OUTPUT VARIABLE SET TO THE NUMBER OF
-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 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
-C OF THE FINAL APPROXIMATE JACOBIAN, STORED ROWWISE.
-C
-C LR IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN
-C (N*(N+1))/2.
-C
-C QTF IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS
-C THE VECTOR (Q TRANSPOSE)*FVEC.
-C
-C WA1, WA2, WA3, AND WA4 ARE WORK ARRAYS OF LENGTH N.
-C
-C SUBPROGRAMS CALLED
-C
-C USER-SUPPLIED ...... FCN
-C
-C MINPACK-SUPPLIED ... DOGLEG,DPMPAR,ENORM,FDJAC1,
-C QFORM,QRFAC,R1MPYQ,R1UPDT
-C
-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,MSUM,NCFAIL,NCSUC,NSLOW1,NSLOW2
- INTEGER IWA(1)
- LOGICAL JEVAL,SING
- DOUBLE PRECISION ACTRED,DELTA,EPSMCH,FNORM,FNORM1,ONE,PNORM,
- * PRERED,P1,P5,P001,P0001,RATIO,SUM,TEMP,XNORM,
- * ZERO
- DOUBLE PRECISION DPMPAR,ENORM
- DATA ONE,P1,P5,P001,P0001,ZERO
- * /1.0D0,1.0D-1,5.0D-1,1.0D-3,1.0D-4,0.0D0/
-C
-C EPSMCH IS THE MACHINE PRECISION.
-C
- EPSMCH = DPMPAR(1)
-C
- INFO = 0
- IFLAG = 0
- NFEV = 0
-C
-C CHECK THE INPUT PARAMETERS FOR ERRORS.
-C
- 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
- 10 CONTINUE
- 20 CONTINUE
-C
-C EVALUATE THE FUNCTION AT THE STARTING POINT
-C AND CALCULATE ITS NORM.
-C
- IFLAG = 1
- 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
- NCSUC = 0
- NCFAIL = 0
- NSLOW1 = 0
- NSLOW2 = 0
-C
-C BEGINNING OF THE OUTER LOOP.
-C
- 30 CONTINUE
- JEVAL = .TRUE.
-C
-C CALCULATE THE JACOBIAN MATRIX.
-C
- IFLAG = 2
- 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.
-C
- CALL QRFAC(N,N,FJAC,LDFJAC,.FALSE.,IWA,1,WA1,WA2,WA3)
-C
-C ON THE FIRST ITERATION AND IF MODE IS 1, SCALE ACCORDING
-C TO THE NORMS OF THE COLUMNS OF THE INITIAL JACOBIAN.
-C
- IF (ITER .NE. 1) GO TO 70
- IF (MODE .EQ. 2) GO TO 50
- DO 40 J = 1, N
- DIAG(J) = WA2(J)
- IF (WA2(J) .EQ. ZERO) DIAG(J) = ONE
- 40 CONTINUE
- 50 CONTINUE
-C
-C ON THE FIRST ITERATION, CALCULATE THE NORM OF THE SCALED X
-C AND INITIALIZE THE STEP BOUND DELTA.
-C
- DO 60 J = 1, N
- WA3(J) = DIAG(J)*X(J)
- 60 CONTINUE
- XNORM = ENORM(N,WA3)
- DELTA = FACTOR*XNORM
- IF (DELTA .EQ. ZERO) DELTA = FACTOR
- 70 CONTINUE
-C
-C FORM (Q TRANSPOSE)*FVEC AND STORE IN QTF.
-C
- DO 80 I = 1, N
- QTF(I) = FVEC(I)
- 80 CONTINUE
- DO 120 J = 1, N
- IF (FJAC(J,J) .EQ. ZERO) GO TO 110
- SUM = ZERO
- DO 90 I = J, N
- SUM = SUM + FJAC(I,J)*QTF(I)
- 90 CONTINUE
- TEMP = -SUM/FJAC(J,J)
- DO 100 I = J, N
- QTF(I) = QTF(I) + FJAC(I,J)*TEMP
- 100 CONTINUE
- 110 CONTINUE
- 120 CONTINUE
-C
-C COPY THE TRIANGULAR FACTOR OF THE QR FACTORIZATION INTO R.
-C
- SING = .FALSE.
- DO 150 J = 1, N
- L = J
- JM1 = J - 1
- IF (JM1 .LT. 1) GO TO 140
- DO 130 I = 1, JM1
- R(L) = FJAC(I,J)
- L = L + N - I
- 130 CONTINUE
- 140 CONTINUE
- R(L) = WA1(J)
- IF (WA1(J) .EQ. ZERO) SING = .TRUE.
- 150 CONTINUE
-C
-C ACCUMULATE THE ORTHOGONAL FACTOR IN FJAC.
-C
- CALL QFORM(N,N,FJAC,LDFJAC,WA1)
-C
-C RESCALE IF NECESSARY.
-C
- IF (MODE .EQ. 2) GO TO 170
- DO 160 J = 1, N
- DIAG(J) = DMAX1(DIAG(J),WA2(J))
- 160 CONTINUE
- 170 CONTINUE
-C
-C BEGINNING OF THE INNER LOOP.
-C
- 180 CONTINUE
-C
-C IF REQUESTED, CALL FCN TO ENABLE PRINTING OF ITERATES.
-C
- IF (NPRINT .LE. 0) GO TO 190
- IFLAG = 0
- IF (MOD(ITER-1,NPRINT) .EQ. 0) CALL FCN(N,X,FVEC,IFLAG)
- IF (IFLAG .LT. 0) GO TO 300
- 190 CONTINUE
-C
-C DETERMINE THE DIRECTION P.
-C
- CALL DOGLEG(N,R,LR,DIAG,QTF,DELTA,WA1,WA2,WA3)
-C
-C STORE THE DIRECTION P AND X + P. CALCULATE THE NORM OF P.
-C
- DO 200 J = 1, N
- WA1(J) = -WA1(J)
- WA2(J) = X(J) + WA1(J)
- WA3(J) = DIAG(J)*WA1(J)
- 200 CONTINUE
- PNORM = ENORM(N,WA3)
-C
-C ON THE FIRST ITERATION, ADJUST THE INITIAL STEP BOUND.
-C
- IF (ITER .EQ. 1) DELTA = DMIN1(DELTA,PNORM)
-C
-C EVALUATE THE FUNCTION AT X + P AND CALCULATE ITS NORM.
-C
- IFLAG = 1
- CALL FCN(N,WA2,WA4,IFLAG)
- NFEV = NFEV + 1
- IF (IFLAG .LT. 0) GO TO 300
- FNORM1 = ENORM(N,WA4)
-C
-C COMPUTE THE SCALED ACTUAL REDUCTION.
-C
- ACTRED = -ONE
- IF (FNORM1 .LT. FNORM) ACTRED = ONE - (FNORM1/FNORM)**2
-C
-C COMPUTE THE SCALED PREDICTED REDUCTION.
-C
- L = 1
- DO 220 I = 1, N
- SUM = ZERO
- DO 210 J = I, N
- SUM = SUM + R(L)*WA1(J)
- L = L + 1
- 210 CONTINUE
- WA3(I) = QTF(I) + SUM
- 220 CONTINUE
- TEMP = ENORM(N,WA3)
- PRERED = ZERO
- IF (TEMP .LT. FNORM) PRERED = ONE - (TEMP/FNORM)**2
-C
-C COMPUTE THE RATIO OF THE ACTUAL TO THE PREDICTED
-C REDUCTION.
-C
- RATIO = ZERO
- IF (PRERED .GT. ZERO) RATIO = ACTRED/PRERED
-C
-C UPDATE THE STEP BOUND.
-C
- IF (RATIO .GE. P1) GO TO 230
- NCSUC = 0
- NCFAIL = NCFAIL + 1
- DELTA = P5*DELTA
- GO TO 240
- 230 CONTINUE
- NCFAIL = 0
- NCSUC = NCSUC + 1
- IF (RATIO .GE. P5 .OR. NCSUC .GT. 1)
- * DELTA = DMAX1(DELTA,PNORM/P5)
- IF (DABS(RATIO-ONE) .LE. P1) DELTA = PNORM/P5
- 240 CONTINUE
-C
-C TEST FOR SUCCESSFUL ITERATION.
-C
- IF (RATIO .LT. P0001) GO TO 260
-C
-C SUCCESSFUL ITERATION. UPDATE X, FVEC, AND THEIR NORMS.
-C
- DO 250 J = 1, N
- X(J) = WA2(J)
- WA2(J) = DIAG(J)*X(J)
- FVEC(J) = WA4(J)
- 250 CONTINUE
- XNORM = ENORM(N,WA2)
- FNORM = FNORM1
- ITER = ITER + 1
- 260 CONTINUE
-C
-C DETERMINE THE PROGRESS OF THE ITERATION.
-C
- NSLOW1 = NSLOW1 + 1
- IF (ACTRED .GE. P001) NSLOW1 = 0
- IF (JEVAL) NSLOW2 = NSLOW2 + 1
- IF (ACTRED .GE. P1) NSLOW2 = 0
-C
-C TEST FOR CONVERGENCE.
-C
- IF (DELTA .LE. XTOL*XNORM .OR. FNORM .EQ. ZERO) INFO = 1
- IF (INFO .NE. 0) GO TO 300
-C
-C TESTS FOR TERMINATION AND STRINGENT TOLERANCES.
-C
- IF (NFEV .GE. MAXFEV) INFO = 2
- IF (P1*DMAX1(P1*DELTA,PNORM) .LE. EPSMCH*XNORM) INFO = 3
- IF (NSLOW2 .EQ. 5) INFO = 4
- IF (NSLOW1 .EQ. 10) INFO = 5
- IF (INFO .NE. 0) GO TO 300
-C
-C CRITERION FOR RECALCULATING JACOBIAN APPROXIMATION
-C BY FORWARD DIFFERENCES.
-C
- IF (NCFAIL .EQ. 2) GO TO 290
-C
-C CALCULATE THE RANK ONE MODIFICATION TO THE JACOBIAN
-C AND UPDATE QTF IF NECESSARY.
-C
- DO 280 J = 1, N
- SUM = ZERO
- DO 270 I = 1, N
- SUM = SUM + FJAC(I,J)*WA4(I)
- 270 CONTINUE
- WA2(J) = (SUM - WA3(J))/PNORM
- WA1(J) = DIAG(J)*((DIAG(J)*WA1(J))/PNORM)
- IF (RATIO .GE. P0001) QTF(J) = SUM
- 280 CONTINUE
-C
-C COMPUTE THE QR FACTORIZATION OF THE UPDATED JACOBIAN.
-C
- CALL R1UPDT(N,N,R,LR,WA1,WA2,WA3,SING)
- CALL R1MPYQ(N,N,FJAC,LDFJAC,WA2,WA3)
- CALL R1MPYQ(1,N,QTF,1,WA2,WA3)
-C
-C END OF THE INNER LOOP.
-C
- JEVAL = .FALSE.
- GO TO 180
- 290 CONTINUE
-C
-C END OF THE OUTER LOOP.
-C
- GO TO 30
- 300 CONTINUE
-C
-C TERMINATION, EITHER NORMAL OR USER IMPOSED.
-C
- IF (IFLAG .LT. 0) INFO = IFLAG
- IFLAG = 0
- IF (NPRINT .GT. 0) CALL FCN(N,X,FVEC,IFLAG)
- RETURN
-C
-C LAST CARD OF SUBROUTINE HYBRD.
-C
- END
- SUBROUTINE HYBRD1(FCN,N,X,FVEC,TOL,INFO,WA,LWA)
- INTEGER N,INFO,LWA
- DOUBLE PRECISION TOL
- DOUBLE PRECISION X(N),FVEC(N),WA(LWA)
- EXTERNAL FCN
-C **********
-C
-C SUBROUTINE HYBRD1
-C
-C THE PURPOSE OF HYBRD1 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. THIS IS DONE BY USING THE
-C MORE GENERAL NONLINEAR EQUATION SOLVER HYBRD. THE USER
-C MUST PROVIDE A SUBROUTINE WHICH CALCULATES THE FUNCTIONS.
-C THE JACOBIAN IS THEN CALCULATED BY A FORWARD-DIFFERENCE
-C APPROXIMATION.
-C
-C THE SUBROUTINE STATEMENT IS
-C
-C SUBROUTINE HYBRD1(FCN,N,X,FVEC,TOL,INFO,WA,LWA)
-C
-C WHERE
-C
-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
-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
-C THE VALUE OF IFLAG SHOULD NOT BE CHANGED BY FCN UNLESS
-C THE USER WANTS TO TERMINATE EXECUTION OF HYBRD1.
-C IN THIS CASE SET IFLAG TO A NEGATIVE INTEGER.
-C
-C N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER
-C OF FUNCTIONS AND VARIABLES.
-C
-C X IS AN ARRAY OF LENGTH N. ON INPUT X MUST CONTAIN
-C AN INITIAL ESTIMATE OF THE SOLUTION VECTOR. ON OUTPUT X
-C CONTAINS THE FINAL ESTIMATE OF THE SOLUTION VECTOR.
-C
-C FVEC IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS
-C THE FUNCTIONS EVALUATED AT THE OUTPUT X.
-C
-C TOL IS A NONNEGATIVE INPUT VARIABLE. TERMINATION OCCURS
-C WHEN THE ALGORITHM ESTIMATES THAT THE RELATIVE ERROR
-C BETWEEN X AND THE SOLUTION IS AT MOST TOL.
-C
-C INFO IS AN INTEGER OUTPUT VARIABLE. IF THE USER HAS
-C TERMINATED EXECUTION, INFO IS SET TO THE (NEGATIVE)
-C VALUE OF IFLAG. SEE DESCRIPTION OF FCN. OTHERWISE,
-C INFO IS SET AS FOLLOWS.
-C
-C INFO = 0 IMPROPER INPUT PARAMETERS.
-C
-C INFO = 1 ALGORITHM ESTIMATES THAT THE RELATIVE ERROR
-C BETWEEN X AND THE SOLUTION IS AT MOST TOL.
-C
-C INFO = 2 NUMBER OF CALLS TO FCN HAS REACHED OR EXCEEDED
-C 200*(N+1).
-C
-C INFO = 3 TOL IS TOO SMALL. NO FURTHER IMPROVEMENT IN
-C THE APPROXIMATE SOLUTION X IS POSSIBLE.
-C
-C INFO = 4 ITERATION IS NOT MAKING GOOD PROGRESS.
-C
-C WA IS A WORK ARRAY OF LENGTH LWA.
-C
-C LWA IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN
-C (N*(3*N+13))/2.
-C
-C SUBPROGRAMS CALLED
-C
-C USER-SUPPLIED ...... FCN
-C
-C MINPACK-SUPPLIED ... HYBRD
-C
-C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980.
-C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE
-C
-C **********
- INTEGER INDEX,J,LR,MAXFEV,ML,MODE,MU,NFEV,NPRINT
- DOUBLE PRECISION EPSFCN,FACTOR,ONE,XTOL,ZERO
- DATA FACTOR,ONE,ZERO /1.0D2,1.0D0,0.0D0/
- INFO = 0
-C
-C CHECK THE INPUT PARAMETERS FOR ERRORS.
-C
- IF (N .LE. 0 .OR. TOL .LT. ZERO .OR. LWA .LT. (N*(3*N + 13))/2)
- * GO TO 20
-C
-C CALL HYBRD.
-C
- MAXFEV = 200*(N + 1)
- XTOL = TOL
- ML = N - 1
- MU = N - 1
- EPSFCN = ZERO
- MODE = 2
- DO 10 J = 1, N
- WA(J) = ONE
- 10 CONTINUE
- NPRINT = 0
- LR = (N*(N + 1))/2
- INDEX = 6*N + LR
- CALL HYBRD(FCN,N,X,FVEC,XTOL,MAXFEV,ML,MU,EPSFCN,WA(1),MODE,
- * FACTOR,NPRINT,INFO,NFEV,WA(INDEX+1),N,WA(6*N+1),LR,
- * WA(N+1),WA(2*N+1),WA(3*N+1),WA(4*N+1),WA(5*N+1))
- IF (INFO .EQ. 5) INFO = 4
- 20 CONTINUE
- RETURN
-C
-C LAST CARD OF SUBROUTINE HYBRD1.
-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),
- * QTF(N),WA1(N),WA2(N),WA3(N),WA4(N)
-C **********
-C
-C SUBROUTINE HYBRJ
-C
-C THE PURPOSE OF HYBRJ 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
-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
-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
-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 ----------
-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 ---------
-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 IN THIS CASE SET IFLAG TO A NEGATIVE INTEGER.
-C
-C N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER
-C OF FUNCTIONS AND VARIABLES.
-C
-C X IS AN ARRAY OF LENGTH N. ON INPUT X MUST CONTAIN
-C AN INITIAL ESTIMATE OF THE SOLUTION VECTOR. ON OUTPUT X
-C CONTAINS THE FINAL ESTIMATE OF THE SOLUTION VECTOR.
-C
-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
-C DIAG IS AN ARRAY OF LENGTH N. IF MODE = 1 (SEE
-C BELOW), DIAG IS INTERNALLY SET. IF MODE = 2, DIAG
-C MUST CONTAIN POSITIVE ENTRIES THAT SERVE AS
-C MULTIPLICATIVE SCALE FACTORS FOR THE VARIABLES.
-C
-C MODE IS AN INTEGER INPUT VARIABLE. IF MODE = 1, THE
-C VARIABLES WILL BE SCALED INTERNALLY. IF MODE = 2,
-C THE SCALING IS SPECIFIED BY THE INPUT DIAG. OTHER
-C VALUES OF MODE ARE EQUIVALENT TO MODE = 1.
-C
-C FACTOR IS A POSITIVE INPUT VARIABLE USED IN DETERMINING THE
-C INITIAL STEP BOUND. THIS BOUND IS SET TO THE PRODUCT OF
-C FACTOR AND THE EUCLIDEAN NORM OF DIAG*X IF NONZERO, OR ELSE
-C TO FACTOR ITSELF. IN MOST CASES FACTOR SHOULD LIE IN THE
-C INTERVAL (.1,100.). 100. IS A GENERALLY RECOMMENDED VALUE.
-C
-C NPRINT IS AN INTEGER INPUT VARIABLE THAT ENABLES CONTROLLED
-C PRINTING OF ITERATES IF IT IS POSITIVE. IN THIS CASE,
-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
-C INFO IS AN INTEGER OUTPUT VARIABLE. IF THE USER HAS
-C TERMINATED EXECUTION, INFO IS SET TO THE (NEGATIVE)
-C VALUE OF IFLAG. SEE DESCRIPTION OF FCN. OTHERWISE,
-C INFO IS SET AS FOLLOWS.
-C
-C INFO = 0 IMPROPER INPUT PARAMETERS.
-C
-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
-C INFO = 3 XTOL IS TOO SMALL. NO FURTHER IMPROVEMENT IN
-C THE APPROXIMATE SOLUTION X IS POSSIBLE.
-C
-C INFO = 4 ITERATION IS NOT MAKING GOOD PROGRESS, AS
-C MEASURED BY THE IMPROVEMENT FROM THE LAST
-C FIVE JACOBIAN EVALUATIONS.
-C
-C INFO = 5 ITERATION IS NOT MAKING GOOD PROGRESS, AS
-C MEASURED BY THE IMPROVEMENT FROM THE LAST
-C TEN ITERATIONS.
-C
-C NFEV IS AN INTEGER OUTPUT VARIABLE SET TO THE NUMBER OF
-C CALLS TO FCN WITH IFLAG = 1.
-C
-C NJEV IS AN INTEGER OUTPUT VARIABLE SET TO THE NUMBER OF
-C CALLS TO FCN WITH IFLAG = 2.
-C
-C R IS AN OUTPUT ARRAY OF LENGTH LR WHICH CONTAINS THE
-C UPPER TRIANGULAR MATRIX PRODUCED BY THE QR FACTORIZATION
-C OF THE FINAL APPROXIMATE JACOBIAN, STORED ROWWISE.
-C
-C LR IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN
-C (N*(N+1))/2.
-C
-C QTF IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS
-C THE VECTOR (Q TRANSPOSE)*FVEC.
-C
-C WA1, WA2, WA3, AND WA4 ARE WORK ARRAYS OF LENGTH N.
-C
-C SUBPROGRAMS CALLED
-C
-C USER-SUPPLIED ...... FCN
-C
-C MINPACK-SUPPLIED ... DOGLEG,DPMPAR,ENORM,
-C QFORM,QRFAC,R1MPYQ,R1UPDT
-C
-C FORTRAN-SUPPLIED ... DABS,DMAX1,DMIN1,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 IWA(1)
- LOGICAL JEVAL,SING
- DOUBLE PRECISION ACTRED,DELTA,EPSMCH,FNORM,FNORM1,ONE,PNORM,
- * PRERED,P1,P5,P001,P0001,RATIO,SUM,TEMP,XNORM,
- * ZERO
- DOUBLE PRECISION DPMPAR,ENORM
- DATA ONE,P1,P5,P001,P0001,ZERO
- * /1.0D0,1.0D-1,5.0D-1,1.0D-3,1.0D-4,0.0D0/
-C
-C EPSMCH IS THE MACHINE PRECISION.
-C
- EPSMCH = DPMPAR(1)
-C
- 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 (MODE .NE. 2) GO TO 20
- DO 10 J = 1, N
- IF (DIAG(J) .LE. ZERO) GO TO 300
- 10 CONTINUE
- 20 CONTINUE
-C
-C EVALUATE THE FUNCTION AT THE STARTING POINT
-C AND CALCULATE ITS NORM.
-C
- IFLAG = 1
- CALL FCN(N,X,FVEC,FJAC,LDFJAC,IFLAG)
- NFEV = 1
- IF (IFLAG .LT. 0) GO TO 300
- FNORM = ENORM(N,FVEC)
-C
-C INITIALIZE ITERATION COUNTER AND MONITORS.
-C
- ITER = 1
- NCSUC = 0
- NCFAIL = 0
- NSLOW1 = 0
- NSLOW2 = 0
-C
-C BEGINNING OF THE OUTER LOOP.
-C
- 30 CONTINUE
- JEVAL = .TRUE.
-C
-C CALCULATE THE JACOBIAN MATRIX.
-C
- IFLAG = 2
- CALL FCN(N,X,FVEC,FJAC,LDFJAC,IFLAG)
- NJEV = NJEV + 1
- IF (IFLAG .LT. 0) GO TO 300
-C
-C COMPUTE THE QR FACTORIZATION OF THE JACOBIAN.
-C
- CALL QRFAC(N,N,FJAC,LDFJAC,.FALSE.,IWA,1,WA1,WA2,WA3)
-C
-C ON THE FIRST ITERATION AND IF MODE IS 1, SCALE ACCORDING
-C TO THE NORMS OF THE COLUMNS OF THE INITIAL JACOBIAN.
-C
- IF (ITER .NE. 1) GO TO 70
- IF (MODE .EQ. 2) GO TO 50
- DO 40 J = 1, N
- DIAG(J) = WA2(J)
- IF (WA2(J) .EQ. ZERO) DIAG(J) = ONE
- 40 CONTINUE
- 50 CONTINUE
-C
-C ON THE FIRST ITERATION, CALCULATE THE NORM OF THE SCALED X
-C AND INITIALIZE THE STEP BOUND DELTA.
-C
- DO 60 J = 1, N
- WA3(J) = DIAG(J)*X(J)
- 60 CONTINUE
- XNORM = ENORM(N,WA3)
- DELTA = FACTOR*XNORM
- IF (DELTA .EQ. ZERO) DELTA = FACTOR
- 70 CONTINUE
-C
-C FORM (Q TRANSPOSE)*FVEC AND STORE IN QTF.
-C
- DO 80 I = 1, N
- QTF(I) = FVEC(I)
- 80 CONTINUE
- DO 120 J = 1, N
- IF (FJAC(J,J) .EQ. ZERO) GO TO 110
- SUM = ZERO
- DO 90 I = J, N
- SUM = SUM + FJAC(I,J)*QTF(I)
- 90 CONTINUE
- TEMP = -SUM/FJAC(J,J)
- DO 100 I = J, N
- QTF(I) = QTF(I) + FJAC(I,J)*TEMP
- 100 CONTINUE
- 110 CONTINUE
- 120 CONTINUE
-C
-C COPY THE TRIANGULAR FACTOR OF THE QR FACTORIZATION INTO R.
-C
- SING = .FALSE.
- DO 150 J = 1, N
- L = J
- JM1 = J - 1
- IF (JM1 .LT. 1) GO TO 140
- DO 130 I = 1, JM1
- R(L) = FJAC(I,J)
- L = L + N - I
- 130 CONTINUE
- 140 CONTINUE
- R(L) = WA1(J)
- IF (WA1(J) .EQ. ZERO) SING = .TRUE.
- 150 CONTINUE
-C
-C ACCUMULATE THE ORTHOGONAL FACTOR IN FJAC.
-C
- CALL QFORM(N,N,FJAC,LDFJAC,WA1)
-C
-C RESCALE IF NECESSARY.
-C
- IF (MODE .EQ. 2) GO TO 170
- DO 160 J = 1, N
- DIAG(J) = DMAX1(DIAG(J),WA2(J))
- 160 CONTINUE
- 170 CONTINUE
-C
-C BEGINNING OF THE INNER LOOP.
-C
- 180 CONTINUE
-C
-C IF REQUESTED, CALL FCN TO ENABLE PRINTING OF ITERATES.
-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 (IFLAG .LT. 0) GO TO 300
- 190 CONTINUE
-C
-C DETERMINE THE DIRECTION P.
-C
- CALL DOGLEG(N,R,LR,DIAG,QTF,DELTA,WA1,WA2,WA3)
-C
-C STORE THE DIRECTION P AND X + P. CALCULATE THE NORM OF P.
-C
- DO 200 J = 1, N
- WA1(J) = -WA1(J)
- WA2(J) = X(J) + WA1(J)
- WA3(J) = DIAG(J)*WA1(J)
- 200 CONTINUE
- PNORM = ENORM(N,WA3)
-C
-C ON THE FIRST ITERATION, ADJUST THE INITIAL STEP BOUND.
-C
- IF (ITER .EQ. 1) DELTA = DMIN1(DELTA,PNORM)
-C
-C EVALUATE THE FUNCTION AT X + P AND CALCULATE ITS NORM.
-C
- IFLAG = 1
- CALL FCN(N,WA2,WA4,FJAC,LDFJAC,IFLAG)
- NFEV = NFEV + 1
- IF (IFLAG .LT. 0) GO TO 300
- FNORM1 = ENORM(N,WA4)
-C
-C COMPUTE THE SCALED ACTUAL REDUCTION.
-C
- ACTRED = -ONE
- IF (FNORM1 .LT. FNORM) ACTRED = ONE - (FNORM1/FNORM)**2
-C
-C COMPUTE THE SCALED PREDICTED REDUCTION.
-C
- L = 1
- DO 220 I = 1, N
- SUM = ZERO
- DO 210 J = I, N
- SUM = SUM + R(L)*WA1(J)
- L = L + 1
- 210 CONTINUE
- WA3(I) = QTF(I) + SUM
- 220 CONTINUE
- TEMP = ENORM(N,WA3)
- PRERED = ZERO
- IF (TEMP .LT. FNORM) PRERED = ONE - (TEMP/FNORM)**2
-C
-C COMPUTE THE RATIO OF THE ACTUAL TO THE PREDICTED
-C REDUCTION.
-C
- RATIO = ZERO
- IF (PRERED .GT. ZERO) RATIO = ACTRED/PRERED
-C
-C UPDATE THE STEP BOUND.
-C
- IF (RATIO .GE. P1) GO TO 230
- NCSUC = 0
- NCFAIL = NCFAIL + 1
- DELTA = P5*DELTA
- GO TO 240
- 230 CONTINUE
- NCFAIL = 0
- NCSUC = NCSUC + 1
- IF (RATIO .GE. P5 .OR. NCSUC .GT. 1)
- * DELTA = DMAX1(DELTA,PNORM/P5)
- IF (DABS(RATIO-ONE) .LE. P1) DELTA = PNORM/P5
- 240 CONTINUE
-C
-C TEST FOR SUCCESSFUL ITERATION.
-C
- IF (RATIO .LT. P0001) GO TO 260
-C
-C SUCCESSFUL ITERATION. UPDATE X, FVEC, AND THEIR NORMS.
-C
- DO 250 J = 1, N
- X(J) = WA2(J)
- WA2(J) = DIAG(J)*X(J)
- FVEC(J) = WA4(J)
- 250 CONTINUE
- XNORM = ENORM(N,WA2)
- FNORM = FNORM1
- ITER = ITER + 1
- 260 CONTINUE
-C
-C DETERMINE THE PROGRESS OF THE ITERATION.
-C
- NSLOW1 = NSLOW1 + 1
- IF (ACTRED .GE. P001) NSLOW1 = 0
- IF (JEVAL) NSLOW2 = NSLOW2 + 1
- IF (ACTRED .GE. P1) NSLOW2 = 0
-C
-C TEST FOR CONVERGENCE.
-C
- IF (DELTA .LE. XTOL*XNORM .OR. FNORM .EQ. ZERO) INFO = 1
- IF (INFO .NE. 0) GO TO 300
-C
-C TESTS FOR TERMINATION AND STRINGENT TOLERANCES.
-C
- IF (NFEV .GE. MAXFEV) INFO = 2
- IF (P1*DMAX1(P1*DELTA,PNORM) .LE. EPSMCH*XNORM) INFO = 3
- IF (NSLOW2 .EQ. 5) INFO = 4
- IF (NSLOW1 .EQ. 10) INFO = 5
- IF (INFO .NE. 0) GO TO 300
-C
-C CRITERION FOR RECALCULATING JACOBIAN.
-C
- IF (NCFAIL .EQ. 2) GO TO 290
-C
-C CALCULATE THE RANK ONE MODIFICATION TO THE JACOBIAN
-C AND UPDATE QTF IF NECESSARY.
-C
- DO 280 J = 1, N
- SUM = ZERO
- DO 270 I = 1, N
- SUM = SUM + FJAC(I,J)*WA4(I)
- 270 CONTINUE
- WA2(J) = (SUM - WA3(J))/PNORM
- WA1(J) = DIAG(J)*((DIAG(J)*WA1(J))/PNORM)
- IF (RATIO .GE. P0001) QTF(J) = SUM
- 280 CONTINUE
-C
-C COMPUTE THE QR FACTORIZATION OF THE UPDATED JACOBIAN.
-C
- CALL R1UPDT(N,N,R,LR,WA1,WA2,WA3,SING)
- CALL R1MPYQ(N,N,FJAC,LDFJAC,WA2,WA3)
- CALL R1MPYQ(1,N,QTF,1,WA2,WA3)
-C
-C END OF THE INNER LOOP.
-C
- JEVAL = .FALSE.
- GO TO 180
- 290 CONTINUE
-C
-C END OF THE OUTER LOOP.
-C
- GO TO 30
- 300 CONTINUE
-C
-C TERMINATION, EITHER NORMAL OR USER IMPOSED.
-C
- IF (IFLAG .LT. 0) INFO = IFLAG
- IFLAG = 0
- IF (NPRINT .GT. 0) CALL FCN(N,X,FVEC,FJAC,LDFJAC,IFLAG)
- RETURN
-C
-C LAST CARD OF SUBROUTINE HYBRJ.
-C
- END
- SUBROUTINE HYBRJ1(FCN,N,X,FVEC,FJAC,LDFJAC,TOL,INFO,WA,LWA)
- INTEGER N,LDFJAC,INFO,LWA
- DOUBLE PRECISION TOL
- DOUBLE PRECISION X(N),FVEC(N),FJAC(LDFJAC,N),WA(LWA)
- EXTERNAL FCN
-C **********
-C
-C SUBROUTINE HYBRJ1
-C
-C THE PURPOSE OF HYBRJ1 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. THIS IS DONE BY USING THE
-C MORE GENERAL NONLINEAR EQUATION SOLVER HYBRJ. THE USER
-C MUST PROVIDE A SUBROUTINE WHICH CALCULATES THE FUNCTIONS
-C AND THE JACOBIAN.
-C
-C THE SUBROUTINE STATEMENT IS
-C
-C SUBROUTINE HYBRJ1(FCN,N,X,FVEC,FJAC,LDFJAC,TOL,INFO,WA,LWA)
-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
-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 ----------
-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 ---------
-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 HYBRJ1.
-C IN THIS CASE SET IFLAG TO A NEGATIVE INTEGER.
-C
-C N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER
-C OF FUNCTIONS AND VARIABLES.
-C
-C X IS AN ARRAY OF LENGTH N. ON INPUT X MUST CONTAIN
-C AN INITIAL ESTIMATE OF THE SOLUTION VECTOR. ON OUTPUT X
-C CONTAINS THE FINAL ESTIMATE OF THE SOLUTION VECTOR.
-C
-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 TOL IS A NONNEGATIVE INPUT VARIABLE. TERMINATION OCCURS
-C WHEN THE ALGORITHM ESTIMATES THAT THE RELATIVE ERROR
-C BETWEEN X AND THE SOLUTION IS AT MOST TOL.
-C
-C INFO IS AN INTEGER OUTPUT VARIABLE. IF THE USER HAS
-C TERMINATED EXECUTION, INFO IS SET TO THE (NEGATIVE)
-C VALUE OF IFLAG. SEE DESCRIPTION OF FCN. OTHERWISE,
-C INFO IS SET AS FOLLOWS.
-C
-C INFO = 0 IMPROPER INPUT PARAMETERS.
-C
-C INFO = 1 ALGORITHM ESTIMATES THAT THE RELATIVE ERROR
-C BETWEEN X AND THE SOLUTION IS AT MOST TOL.
-C
-C INFO = 2 NUMBER OF CALLS TO FCN WITH IFLAG = 1 HAS
-C REACHED 100*(N+1).
-C
-C INFO = 3 TOL IS TOO SMALL. NO FURTHER IMPROVEMENT IN
-C THE APPROXIMATE SOLUTION X IS POSSIBLE.
-C
-C INFO = 4 ITERATION IS NOT MAKING GOOD PROGRESS.
-C
-C WA IS A WORK ARRAY OF LENGTH LWA.
-C
-C LWA IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN
-C (N*(N+13))/2.
-C
-C SUBPROGRAMS CALLED
-C
-C USER-SUPPLIED ...... FCN
-C
-C MINPACK-SUPPLIED ... HYBRJ
-C
-C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980.
-C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE
-C
-C **********
- INTEGER J,LR,MAXFEV,MODE,NFEV,NJEV,NPRINT
- DOUBLE PRECISION FACTOR,ONE,XTOL,ZERO
- DATA FACTOR,ONE,ZERO /1.0D2,1.0D0,0.0D0/
- INFO = 0
-C
-C CHECK THE INPUT PARAMETERS FOR ERRORS.
-C
- IF (N .LE. 0 .OR. LDFJAC .LT. N .OR. TOL .LT. ZERO
- * .OR. LWA .LT. (N*(N + 13))/2) GO TO 20
-C
-C CALL HYBRJ.
-C
- MAXFEV = 100*(N + 1)
- XTOL = TOL
- MODE = 2
- DO 10 J = 1, N
- WA(J) = ONE
- 10 CONTINUE
- NPRINT = 0
- LR = (N*(N + 1))/2
- CALL HYBRJ(FCN,N,X,FVEC,FJAC,LDFJAC,XTOL,MAXFEV,WA(1),MODE,
- * FACTOR,NPRINT,INFO,NFEV,NJEV,WA(6*N+1),LR,WA(N+1),
- * WA(2*N+1),WA(3*N+1),WA(4*N+1),WA(5*N+1))
- IF (INFO .EQ. 5) INFO = 4
- 20 CONTINUE
- RETURN
-C
-C LAST CARD OF SUBROUTINE HYBRJ1.
-C
- END
- SUBROUTINE LMDER(FCN,M,N,X,FVEC,FJAC,LDFJAC,FTOL,XTOL,GTOL,
- * MAXFEV,DIAG,MODE,FACTOR,NPRINT,INFO,NFEV,NJEV,
- * IPVT,QTF,WA1,WA2,WA3,WA4)
- INTEGER M,N,LDFJAC,MAXFEV,MODE,NPRINT,INFO,NFEV,NJEV
- INTEGER IPVT(N)
- DOUBLE PRECISION FTOL,XTOL,GTOL,FACTOR
- DOUBLE PRECISION X(N),FVEC(M),FJAC(LDFJAC,N),DIAG(N),QTF(N),
- * WA1(N),WA2(N),WA3(N),WA4(M)
-C **********
-C
-C SUBROUTINE LMDER
-C
-C THE PURPOSE OF LMDER IS TO MINIMIZE THE SUM OF THE SQUARES OF
-C M NONLINEAR FUNCTIONS IN N VARIABLES BY A MODIFICATION OF
-C THE LEVENBERG-MARQUARDT ALGORITHM. THE USER MUST PROVIDE A
-C SUBROUTINE WHICH CALCULATES THE FUNCTIONS AND THE JACOBIAN.
-C
-C THE SUBROUTINE STATEMENT IS
-C
-C SUBROUTINE LMDER(FCN,M,N,X,FVEC,FJAC,LDFJAC,FTOL,XTOL,GTOL,
-C MAXFEV,DIAG,MODE,FACTOR,NPRINT,INFO,NFEV,
-C NJEV,IPVT,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
-C SUBROUTINE FCN(M,N,X,FVEC,FJAC,LDFJAC,IFLAG)
-C INTEGER M,N,LDFJAC,IFLAG
-C DOUBLE PRECISION X(N),FVEC(M),FJAC(LDFJAC,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 ----------
-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 LMDER.
-C IN THIS CASE SET IFLAG TO A NEGATIVE INTEGER.
-C
-C M IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER
-C OF FUNCTIONS.
-C
-C N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER
-C OF VARIABLES. N MUST NOT EXCEED M.
-C
-C X IS AN ARRAY OF LENGTH N. ON INPUT X MUST CONTAIN
-C AN INITIAL ESTIMATE OF THE SOLUTION VECTOR. ON OUTPUT X
-C CONTAINS THE FINAL ESTIMATE OF THE SOLUTION VECTOR.
-C
-C FVEC IS AN OUTPUT ARRAY OF LENGTH M WHICH CONTAINS
-C THE FUNCTIONS EVALUATED AT THE OUTPUT X.
-C
-C FJAC IS AN OUTPUT M BY N ARRAY. THE UPPER N BY N SUBMATRIX
-C OF FJAC CONTAINS AN UPPER TRIANGULAR MATRIX R WITH
-C DIAGONAL ELEMENTS OF NONINCREASING MAGNITUDE SUCH THAT
-C
-C T T T
-C P *(JAC *JAC)*P = R *R,
-C
-C WHERE P IS A PERMUTATION MATRIX AND JAC IS THE FINAL
-C CALCULATED JACOBIAN. COLUMN J OF P IS COLUMN IPVT(J)
-C (SEE BELOW) OF THE IDENTITY MATRIX. THE LOWER TRAPEZOIDAL
-C PART OF FJAC CONTAINS INFORMATION GENERATED DURING
-C THE COMPUTATION OF R.
-C
-C LDFJAC IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN M
-C WHICH SPECIFIES THE LEADING DIMENSION OF THE ARRAY FJAC.
-C
-C FTOL IS A NONNEGATIVE INPUT VARIABLE. TERMINATION
-C OCCURS WHEN BOTH THE ACTUAL AND PREDICTED RELATIVE
-C REDUCTIONS IN THE SUM OF SQUARES ARE AT MOST FTOL.
-C THEREFORE, FTOL MEASURES THE RELATIVE ERROR DESIRED
-C IN THE SUM OF SQUARES.
-C
-C XTOL IS A NONNEGATIVE INPUT VARIABLE. TERMINATION
-C OCCURS WHEN THE RELATIVE ERROR BETWEEN TWO CONSECUTIVE
-C ITERATES IS AT MOST XTOL. THEREFORE, XTOL MEASURES THE
-C RELATIVE ERROR DESIRED IN THE APPROXIMATE SOLUTION.
-C
-C GTOL IS A NONNEGATIVE INPUT VARIABLE. TERMINATION
-C OCCURS WHEN THE COSINE OF THE ANGLE BETWEEN FVEC AND
-C ANY COLUMN OF THE JACOBIAN IS AT MOST GTOL IN ABSOLUTE
-C VALUE. THEREFORE, GTOL MEASURES THE ORTHOGONALITY
-C DESIRED BETWEEN THE FUNCTION VECTOR AND THE COLUMNS
-C OF THE JACOBIAN.
-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
-C DIAG IS AN ARRAY OF LENGTH N. IF MODE = 1 (SEE
-C BELOW), DIAG IS INTERNALLY SET. IF MODE = 2, DIAG
-C MUST CONTAIN POSITIVE ENTRIES THAT SERVE AS
-C MULTIPLICATIVE SCALE FACTORS FOR THE VARIABLES.
-C
-C MODE IS AN INTEGER INPUT VARIABLE. IF MODE = 1, THE
-C VARIABLES WILL BE SCALED INTERNALLY. IF MODE = 2,
-C THE SCALING IS SPECIFIED BY THE INPUT DIAG. OTHER
-C VALUES OF MODE ARE EQUIVALENT TO MODE = 1.
-C
-C FACTOR IS A POSITIVE INPUT VARIABLE USED IN DETERMINING THE
-C INITIAL STEP BOUND. THIS BOUND IS SET TO THE PRODUCT OF
-C FACTOR AND THE EUCLIDEAN NORM OF DIAG*X IF NONZERO, OR ELSE
-C TO FACTOR ITSELF. IN MOST CASES FACTOR SHOULD LIE IN THE
-C INTERVAL (.1,100.).100. IS A GENERALLY RECOMMENDED VALUE.
-C
-C NPRINT IS AN INTEGER INPUT VARIABLE THAT ENABLES CONTROLLED
-C PRINTING OF ITERATES IF IT IS POSITIVE. IN THIS CASE,
-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, FVEC, AND FJAC
-C AVAILABLE FOR PRINTING. FVEC AND FJAC SHOULD NOT BE
-C ALTERED. 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)
-C VALUE OF IFLAG. SEE DESCRIPTION OF FCN. OTHERWISE,
-C INFO IS SET AS FOLLOWS.
-C
-C INFO = 0 IMPROPER INPUT PARAMETERS.
-C
-C INFO = 1 BOTH ACTUAL AND PREDICTED RELATIVE REDUCTIONS
-C IN THE SUM OF SQUARES ARE AT MOST FTOL.
-C
-C INFO = 2 RELATIVE ERROR BETWEEN TWO CONSECUTIVE ITERATES
-C IS AT MOST XTOL.
-C
-C INFO = 3 CONDITIONS FOR INFO = 1 AND INFO = 2 BOTH HOLD.
-C
-C INFO = 4 THE COSINE OF THE ANGLE BETWEEN FVEC AND ANY
-C COLUMN OF THE JACOBIAN IS AT MOST GTOL IN
-C ABSOLUTE VALUE.
-C
-C INFO = 5 NUMBER OF CALLS TO FCN WITH IFLAG = 1 HAS
-C REACHED MAXFEV.
-C
-C INFO = 6 FTOL IS TOO SMALL. NO FURTHER REDUCTION IN
-C THE SUM OF SQUARES IS POSSIBLE.
-C
-C INFO = 7 XTOL IS TOO SMALL. NO FURTHER IMPROVEMENT IN
-C THE APPROXIMATE SOLUTION X IS POSSIBLE.
-C
-C INFO = 8 GTOL IS TOO SMALL. FVEC IS ORTHOGONAL TO THE
-C COLUMNS OF THE JACOBIAN TO MACHINE PRECISION.
-C
-C NFEV IS AN INTEGER OUTPUT VARIABLE SET TO THE NUMBER OF
-C CALLS TO FCN WITH IFLAG = 1.
-C
-C NJEV IS AN INTEGER OUTPUT VARIABLE SET TO THE NUMBER OF
-C CALLS TO FCN WITH IFLAG = 2.
-C
-C IPVT IS AN INTEGER OUTPUT ARRAY OF LENGTH N. IPVT
-C DEFINES A PERMUTATION MATRIX P SUCH THAT JAC*P = Q*R,
-C WHERE JAC IS THE FINAL CALCULATED JACOBIAN, Q IS
-C ORTHOGONAL (NOT STORED), AND R IS UPPER TRIANGULAR
-C WITH DIAGONAL ELEMENTS OF NONINCREASING MAGNITUDE.
-C COLUMN J OF P IS COLUMN IPVT(J) OF THE IDENTITY MATRIX.
-C
-C QTF IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS
-C THE FIRST N ELEMENTS OF THE VECTOR (Q TRANSPOSE)*FVEC.
-C
-C WA1, WA2, AND WA3 ARE WORK ARRAYS OF LENGTH N.
-C
-C WA4 IS A WORK ARRAY OF LENGTH M.
-C
-C SUBPROGRAMS CALLED
-C
-C USER-SUPPLIED ...... FCN
-C
-C MINPACK-SUPPLIED ... DPMPAR,ENORM,LMPAR,QRFAC
-C
-C FORTRAN-SUPPLIED ... DABS,DMAX1,DMIN1,DSQRT,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,L
- DOUBLE PRECISION ACTRED,DELTA,DIRDER,EPSMCH,FNORM,FNORM1,GNORM,
- * ONE,PAR,PNORM,PRERED,P1,P5,P25,P75,P0001,RATIO,
- * SUM,TEMP,TEMP1,TEMP2,XNORM,ZERO
- DOUBLE PRECISION DPMPAR,ENORM
- DATA ONE,P1,P5,P25,P75,P0001,ZERO
- * /1.0D0,1.0D-1,5.0D-1,2.5D-1,7.5D-1,1.0D-4,0.0D0/
-C
-C EPSMCH IS THE MACHINE PRECISION.
-C
- EPSMCH = DPMPAR(1)
-C
- INFO = 0
- IFLAG = 0
- NFEV = 0
- NJEV = 0
-C
-C CHECK THE INPUT PARAMETERS FOR ERRORS.
-C
- IF (N .LE. 0 .OR. M .LT. N .OR. LDFJAC .LT. M
- * .OR. FTOL .LT. ZERO .OR. XTOL .LT. ZERO .OR. GTOL .LT. ZERO
- * .OR. MAXFEV .LE. 0 .OR. FACTOR .LE. ZERO) GO TO 300
- IF (MODE .NE. 2) GO TO 20
- DO 10 J = 1, N
- IF (DIAG(J) .LE. ZERO) GO TO 300
- 10 CONTINUE
- 20 CONTINUE
-C
-C EVALUATE THE FUNCTION AT THE STARTING POINT
-C AND CALCULATE ITS NORM.
-C
- IFLAG = 1
- CALL FCN(M,N,X,FVEC,FJAC,LDFJAC,IFLAG)
- NFEV = 1
- IF (IFLAG .LT. 0) GO TO 300
- FNORM = ENORM(M,FVEC)
-C
-C INITIALIZE LEVENBERG-MARQUARDT PARAMETER AND ITERATION COUNTER.
-C
- PAR = ZERO
- ITER = 1
-C
-C BEGINNING OF THE OUTER LOOP.
-C
- 30 CONTINUE
-C
-C CALCULATE THE JACOBIAN MATRIX.
-C
- IFLAG = 2
- CALL FCN(M,N,X,FVEC,FJAC,LDFJAC,IFLAG)
- NJEV = NJEV + 1
- IF (IFLAG .LT. 0) GO TO 300
-C
-C IF REQUESTED, CALL FCN TO ENABLE PRINTING OF ITERATES.
-C
- IF (NPRINT .LE. 0) GO TO 40
- IFLAG = 0
- IF (MOD(ITER-1,NPRINT) .EQ. 0)
- * CALL FCN(M,N,X,FVEC,FJAC,LDFJAC,IFLAG)
- IF (IFLAG .LT. 0) GO TO 300
- 40 CONTINUE
-C
-C COMPUTE THE QR FACTORIZATION OF THE JACOBIAN.
-C
- CALL QRFAC(M,N,FJAC,LDFJAC,.TRUE.,IPVT,N,WA1,WA2,WA3)
-C
-C ON THE FIRST ITERATION AND IF MODE IS 1, SCALE ACCORDING
-C TO THE NORMS OF THE COLUMNS OF THE INITIAL JACOBIAN.
-C
- IF (ITER .NE. 1) GO TO 80
- IF (MODE .EQ. 2) GO TO 60
- DO 50 J = 1, N
- DIAG(J) = WA2(J)
- IF (WA2(J) .EQ. ZERO) DIAG(J) = ONE
- 50 CONTINUE
- 60 CONTINUE
-C
-C ON THE FIRST ITERATION, CALCULATE THE NORM OF THE SCALED X
-C AND INITIALIZE THE STEP BOUND DELTA.
-C
- DO 70 J = 1, N
- WA3(J) = DIAG(J)*X(J)
- 70 CONTINUE
- XNORM = ENORM(N,WA3)
- DELTA = FACTOR*XNORM
- IF (DELTA .EQ. ZERO) DELTA = FACTOR
- 80 CONTINUE
-C
-C FORM (Q TRANSPOSE)*FVEC AND STORE THE FIRST N COMPONENTS IN
-C QTF.
-C
- DO 90 I = 1, M
- WA4(I) = FVEC(I)
- 90 CONTINUE
- DO 130 J = 1, N
- IF (FJAC(J,J) .EQ. ZERO) GO TO 120
- SUM = ZERO
- DO 100 I = J, M
- SUM = SUM + FJAC(I,J)*WA4(I)
- 100 CONTINUE
- TEMP = -SUM/FJAC(J,J)
- DO 110 I = J, M
- WA4(I) = WA4(I) + FJAC(I,J)*TEMP
- 110 CONTINUE
- 120 CONTINUE
- FJAC(J,J) = WA1(J)
- QTF(J) = WA4(J)
- 130 CONTINUE
-C
-C COMPUTE THE NORM OF THE SCALED GRADIENT.
-C
- GNORM = ZERO
- IF (FNORM .EQ. ZERO) GO TO 170
- DO 160 J = 1, N
- L = IPVT(J)
- IF (WA2(L) .EQ. ZERO) GO TO 150
- SUM = ZERO
- DO 140 I = 1, J
- SUM = SUM + FJAC(I,J)*(QTF(I)/FNORM)
- 140 CONTINUE
- GNORM = DMAX1(GNORM,DABS(SUM/WA2(L)))
- 150 CONTINUE
- 160 CONTINUE
- 170 CONTINUE
-C
-C TEST FOR CONVERGENCE OF THE GRADIENT NORM.
-C
- IF (GNORM .LE. GTOL) INFO = 4
- IF (INFO .NE. 0) GO TO 300
-C
-C RESCALE IF NECESSARY.
-C
- IF (MODE .EQ. 2) GO TO 190
- DO 180 J = 1, N
- DIAG(J) = DMAX1(DIAG(J),WA2(J))
- 180 CONTINUE
- 190 CONTINUE
-C
-C BEGINNING OF THE INNER LOOP.
-C
- 200 CONTINUE
-C
-C DETERMINE THE LEVENBERG-MARQUARDT PARAMETER.
-C
- CALL LMPAR(N,FJAC,LDFJAC,IPVT,DIAG,QTF,DELTA,PAR,WA1,WA2,
- * WA3,WA4)
-C
-C STORE THE DIRECTION P AND X + P. CALCULATE THE NORM OF P.
-C
- DO 210 J = 1, N
- WA1(J) = -WA1(J)
- WA2(J) = X(J) + WA1(J)
- WA3(J) = DIAG(J)*WA1(J)
- 210 CONTINUE
- PNORM = ENORM(N,WA3)
-C
-C ON THE FIRST ITERATION, ADJUST THE INITIAL STEP BOUND.
-C
- IF (ITER .EQ. 1) DELTA = DMIN1(DELTA,PNORM)
-C
-C EVALUATE THE FUNCTION AT X + P AND CALCULATE ITS NORM.
-C
- IFLAG = 1
- CALL FCN(M,N,WA2,WA4,FJAC,LDFJAC,IFLAG)
- NFEV = NFEV + 1
- IF (IFLAG .LT. 0) GO TO 300
- FNORM1 = ENORM(M,WA4)
-C
-C COMPUTE THE SCALED ACTUAL REDUCTION.
-C
- ACTRED = -ONE
- IF (P1*FNORM1 .LT. FNORM) ACTRED = ONE - (FNORM1/FNORM)**2
-C
-C COMPUTE THE SCALED PREDICTED REDUCTION AND
-C THE SCALED DIRECTIONAL DERIVATIVE.
-C
- DO 230 J = 1, N
- WA3(J) = ZERO
- L = IPVT(J)
- TEMP = WA1(L)
- DO 220 I = 1, J
- WA3(I) = WA3(I) + FJAC(I,J)*TEMP
- 220 CONTINUE
- 230 CONTINUE
- TEMP1 = ENORM(N,WA3)/FNORM
- TEMP2 = (DSQRT(PAR)*PNORM)/FNORM
- PRERED = TEMP1**2 + TEMP2**2/P5
- DIRDER = -(TEMP1**2 + TEMP2**2)
-C
-C COMPUTE THE RATIO OF THE ACTUAL TO THE PREDICTED
-C REDUCTION.
-C
- RATIO = ZERO
- IF (PRERED .NE. ZERO) RATIO = ACTRED/PRERED
-C
-C UPDATE THE STEP BOUND.
-C
- IF (RATIO .GT. P25) GO TO 240
- IF (ACTRED .GE. ZERO) TEMP = P5
- IF (ACTRED .LT. ZERO)
- * TEMP = P5*DIRDER/(DIRDER + P5*ACTRED)
- IF (P1*FNORM1 .GE. FNORM .OR. TEMP .LT. P1) TEMP = P1
- DELTA = TEMP*DMIN1(DELTA,PNORM/P1)
- PAR = PAR/TEMP
- GO TO 260
- 240 CONTINUE
- IF (PAR .NE. ZERO .AND. RATIO .LT. P75) GO TO 250
- DELTA = PNORM/P5
- PAR = P5*PAR
- 250 CONTINUE
- 260 CONTINUE
-C
-C TEST FOR SUCCESSFUL ITERATION.
-C
- IF (RATIO .LT. P0001) GO TO 290
-C
-C SUCCESSFUL ITERATION. UPDATE X, FVEC, AND THEIR NORMS.
-C
- DO 270 J = 1, N
- X(J) = WA2(J)
- WA2(J) = DIAG(J)*X(J)
- 270 CONTINUE
- DO 280 I = 1, M
- FVEC(I) = WA4(I)
- 280 CONTINUE
- XNORM = ENORM(N,WA2)
- FNORM = FNORM1
- ITER = ITER + 1
- 290 CONTINUE
-C
-C TESTS FOR CONVERGENCE.
-C
- IF (DABS(ACTRED) .LE. FTOL .AND. PRERED .LE. FTOL
- * .AND. P5*RATIO .LE. ONE) INFO = 1
- IF (DELTA .LE. XTOL*XNORM) INFO = 2
- IF (DABS(ACTRED) .LE. FTOL .AND. PRERED .LE. FTOL
- * .AND. P5*RATIO .LE. ONE .AND. INFO .EQ. 2) INFO = 3
- IF (INFO .NE. 0) GO TO 300
-C
-C TESTS FOR TERMINATION AND STRINGENT TOLERANCES.
-C
- IF (NFEV .GE. MAXFEV) INFO = 5
- IF (DABS(ACTRED) .LE. EPSMCH .AND. PRERED .LE. EPSMCH
- * .AND. P5*RATIO .LE. ONE) INFO = 6
- IF (DELTA .LE. EPSMCH*XNORM) INFO = 7
- IF (GNORM .LE. EPSMCH) INFO = 8
- IF (INFO .NE. 0) GO TO 300
-C
-C END OF THE INNER LOOP. REPEAT IF ITERATION UNSUCCESSFUL.
-C
- IF (RATIO .LT. P0001) GO TO 200
-C
-C END OF THE OUTER LOOP.
-C
- GO TO 30
- 300 CONTINUE
-C
-C TERMINATION, EITHER NORMAL OR USER IMPOSED.
-C
- IF (IFLAG .LT. 0) INFO = IFLAG
- IFLAG = 0
- IF (NPRINT .GT. 0) CALL FCN(M,N,X,FVEC,FJAC,LDFJAC,IFLAG)
- RETURN
-C
-C LAST CARD OF SUBROUTINE LMDER.
-C
- END
- SUBROUTINE LMDER1(FCN,M,N,X,FVEC,FJAC,LDFJAC,TOL,INFO,IPVT,WA,
- * LWA)
- INTEGER M,N,LDFJAC,INFO,LWA
- INTEGER IPVT(N)
- DOUBLE PRECISION TOL
- DOUBLE PRECISION X(N),FVEC(M),FJAC(LDFJAC,N),WA(LWA)
- EXTERNAL FCN
-C **********
-C
-C SUBROUTINE LMDER1
-C
-C THE PURPOSE OF LMDER1 IS TO MINIMIZE THE SUM OF THE SQUARES OF
-C M NONLINEAR FUNCTIONS IN N VARIABLES BY A MODIFICATION OF THE
-C LEVENBERG-MARQUARDT ALGORITHM. THIS IS DONE BY USING THE MORE
-C GENERAL LEAST-SQUARES SOLVER LMDER. THE USER MUST PROVIDE A
-C SUBROUTINE WHICH CALCULATES THE FUNCTIONS AND THE JACOBIAN.
-C
-C THE SUBROUTINE STATEMENT IS
-C
-C SUBROUTINE LMDER1(FCN,M,N,X,FVEC,FJAC,LDFJAC,TOL,INFO,
-C IPVT,WA,LWA)
-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
-C SUBROUTINE FCN(M,N,X,FVEC,FJAC,LDFJAC,IFLAG)
-C INTEGER M,N,LDFJAC,IFLAG
-C DOUBLE PRECISION X(N),FVEC(M),FJAC(LDFJAC,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 ----------
-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 LMDER1.
-C IN THIS CASE SET IFLAG TO A NEGATIVE INTEGER.
-C
-C M IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER
-C OF FUNCTIONS.
-C
-C N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER
-C OF VARIABLES. N MUST NOT EXCEED M.
-C
-C X IS AN ARRAY OF LENGTH N. ON INPUT X MUST CONTAIN
-C AN INITIAL ESTIMATE OF THE SOLUTION VECTOR. ON OUTPUT X
-C CONTAINS THE FINAL ESTIMATE OF THE SOLUTION VECTOR.
-C
-C FVEC IS AN OUTPUT ARRAY OF LENGTH M WHICH CONTAINS
-C THE FUNCTIONS EVALUATED AT THE OUTPUT X.
-C
-C FJAC IS AN OUTPUT M BY N ARRAY. THE UPPER N BY N SUBMATRIX
-C OF FJAC CONTAINS AN UPPER TRIANGULAR MATRIX R WITH
-C DIAGONAL ELEMENTS OF NONINCREASING MAGNITUDE SUCH THAT
-C
-C T T T
-C P *(JAC *JAC)*P = R *R,
-C
-C WHERE P IS A PERMUTATION MATRIX AND JAC IS THE FINAL
-C CALCULATED JACOBIAN. COLUMN J OF P IS COLUMN IPVT(J)
-C (SEE BELOW) OF THE IDENTITY MATRIX. THE LOWER TRAPEZOIDAL
-C PART OF FJAC CONTAINS INFORMATION GENERATED DURING
-C THE COMPUTATION OF R.
-C
-C LDFJAC IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN M
-C WHICH SPECIFIES THE LEADING DIMENSION OF THE ARRAY FJAC.
-C
-C TOL IS A NONNEGATIVE INPUT VARIABLE. TERMINATION OCCURS
-C WHEN THE ALGORITHM ESTIMATES EITHER THAT THE RELATIVE
-C ERROR IN THE SUM OF SQUARES IS AT MOST TOL OR THAT
-C THE RELATIVE ERROR BETWEEN X AND THE SOLUTION IS AT
-C MOST TOL.
-C
-C INFO IS AN INTEGER OUTPUT VARIABLE. IF THE USER HAS
-C TERMINATED EXECUTION, INFO IS SET TO THE (NEGATIVE)
-C VALUE OF IFLAG. SEE DESCRIPTION OF FCN. OTHERWISE,
-C INFO IS SET AS FOLLOWS.
-C
-C INFO = 0 IMPROPER INPUT PARAMETERS.
-C
-C INFO = 1 ALGORITHM ESTIMATES THAT THE RELATIVE ERROR
-C IN THE SUM OF SQUARES IS AT MOST TOL.
-C
-C INFO = 2 ALGORITHM ESTIMATES THAT THE RELATIVE ERROR
-C BETWEEN X AND THE SOLUTION IS AT MOST TOL.
-C
-C INFO = 3 CONDITIONS FOR INFO = 1 AND INFO = 2 BOTH HOLD.
-C
-C INFO = 4 FVEC IS ORTHOGONAL TO THE COLUMNS OF THE
-C JACOBIAN TO MACHINE PRECISION.
-C
-C INFO = 5 NUMBER OF CALLS TO FCN WITH IFLAG = 1 HAS
-C REACHED 100*(N+1).
-C
-C INFO = 6 TOL IS TOO SMALL. NO FURTHER REDUCTION IN
-C THE SUM OF SQUARES IS POSSIBLE.
-C
-C INFO = 7 TOL IS TOO SMALL. NO FURTHER IMPROVEMENT IN
-C THE APPROXIMATE SOLUTION X IS POSSIBLE.
-C
-C IPVT IS AN INTEGER OUTPUT ARRAY OF LENGTH N. IPVT
-C DEFINES A PERMUTATION MATRIX P SUCH THAT JAC*P = Q*R,
-C WHERE JAC IS THE FINAL CALCULATED JACOBIAN, Q IS
-C ORTHOGONAL (NOT STORED), AND R IS UPPER TRIANGULAR
-C WITH DIAGONAL ELEMENTS OF NONINCREASING MAGNITUDE.
-C COLUMN J OF P IS COLUMN IPVT(J) OF THE IDENTITY MATRIX.
-C
-C WA IS A WORK ARRAY OF LENGTH LWA.
-C
-C LWA IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN 5*N+M.
-C
-C SUBPROGRAMS CALLED
-C
-C USER-SUPPLIED ...... FCN
-C
-C MINPACK-SUPPLIED ... LMDER
-C
-C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980.
-C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE
-C
-C **********
- INTEGER MAXFEV,MODE,NFEV,NJEV,NPRINT
- DOUBLE PRECISION FACTOR,FTOL,GTOL,XTOL,ZERO
- DATA FACTOR,ZERO /1.0D2,0.0D0/
- INFO = 0
-C
-C CHECK THE INPUT PARAMETERS FOR ERRORS.
-C
- IF (N .LE. 0 .OR. M .LT. N .OR. LDFJAC .LT. M .OR. TOL .LT. ZERO
- * .OR. LWA .LT. 5*N + M) GO TO 10
-C
-C CALL LMDER.
-C
- MAXFEV = 100*(N + 1)
- FTOL = TOL
- XTOL = TOL
- GTOL = ZERO
- MODE = 1
- NPRINT = 0
- CALL LMDER(FCN,M,N,X,FVEC,FJAC,LDFJAC,FTOL,XTOL,GTOL,MAXFEV,
- * WA(1),MODE,FACTOR,NPRINT,INFO,NFEV,NJEV,IPVT,WA(N+1),
- * WA(2*N+1),WA(3*N+1),WA(4*N+1),WA(5*N+1))
- IF (INFO .EQ. 8) INFO = 4
- 10 CONTINUE
- RETURN
-C
-C LAST CARD OF SUBROUTINE LMDER1.
-C
- END
- SUBROUTINE LMDIF(FCN,M,N,X,FVEC,FTOL,XTOL,GTOL,MAXFEV,EPSFCN,
- * DIAG,MODE,FACTOR,NPRINT,INFO,NFEV,FJAC,LDFJAC,
- * IPVT,QTF,WA1,WA2,WA3,WA4)
- INTEGER M,N,MAXFEV,MODE,NPRINT,INFO,NFEV,LDFJAC
- INTEGER IPVT(N)
- DOUBLE PRECISION FTOL,XTOL,GTOL,EPSFCN,FACTOR
- DOUBLE PRECISION X(N),FVEC(M),DIAG(N),FJAC(LDFJAC,N),QTF(N),
- * WA1(N),WA2(N),WA3(N),WA4(M)
- EXTERNAL FCN
-C **********
-C
-C SUBROUTINE LMDIF
-C
-C THE PURPOSE OF LMDIF IS TO MINIMIZE THE SUM OF THE SQUARES OF
-C M NONLINEAR FUNCTIONS IN N VARIABLES BY A MODIFICATION OF
-C THE LEVENBERG-MARQUARDT ALGORITHM. THE USER MUST PROVIDE A
-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 LMDIF(FCN,M,N,X,FVEC,FTOL,XTOL,GTOL,MAXFEV,EPSFCN,
-C DIAG,MODE,FACTOR,NPRINT,INFO,NFEV,FJAC,
-C LDFJAC,IPVT,QTF,WA1,WA2,WA3,WA4)
-C
-C WHERE
-C
-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
-C SUBROUTINE FCN(M,N,X,FVEC,IFLAG)
-C INTEGER M,N,IFLAG
-C DOUBLE PRECISION X(N),FVEC(M)
-C ----------
-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 LMDIF.
-C IN THIS CASE SET IFLAG TO A NEGATIVE INTEGER.
-C
-C M IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER
-C OF FUNCTIONS.
-C
-C N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER
-C OF VARIABLES. N MUST NOT EXCEED M.
-C
-C X IS AN ARRAY OF LENGTH N. ON INPUT X MUST CONTAIN
-C AN INITIAL ESTIMATE OF THE SOLUTION VECTOR. ON OUTPUT X
-C CONTAINS THE FINAL ESTIMATE OF THE SOLUTION VECTOR.
-C
-C FVEC IS AN OUTPUT ARRAY OF LENGTH M WHICH CONTAINS
-C THE FUNCTIONS EVALUATED AT THE OUTPUT X.
-C
-C FTOL IS A NONNEGATIVE INPUT VARIABLE. TERMINATION
-C OCCURS WHEN BOTH THE ACTUAL AND PREDICTED RELATIVE
-C REDUCTIONS IN THE SUM OF SQUARES ARE AT MOST FTOL.
-C THEREFORE, FTOL MEASURES THE RELATIVE ERROR DESIRED
-C IN THE SUM OF SQUARES.
-C
-C XTOL IS A NONNEGATIVE INPUT VARIABLE. TERMINATION
-C OCCURS WHEN THE RELATIVE ERROR BETWEEN TWO CONSECUTIVE
-C ITERATES IS AT MOST XTOL. THEREFORE, XTOL MEASURES THE
-C RELATIVE ERROR DESIRED IN THE APPROXIMATE SOLUTION.
-C
-C GTOL IS A NONNEGATIVE INPUT VARIABLE. TERMINATION
-C OCCURS WHEN THE COSINE OF THE ANGLE BETWEEN FVEC AND
-C ANY COLUMN OF THE JACOBIAN IS AT MOST GTOL IN ABSOLUTE
-C VALUE. THEREFORE, GTOL MEASURES THE ORTHOGONALITY
-C DESIRED BETWEEN THE FUNCTION VECTOR AND THE COLUMNS
-C OF THE JACOBIAN.
-C
-C MAXFEV IS A POSITIVE INTEGER INPUT VARIABLE. TERMINATION
-C OCCURS WHEN THE NUMBER OF CALLS TO FCN IS AT LEAST
-C MAXFEV BY THE END OF AN ITERATION.
-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
-C MUST CONTAIN POSITIVE ENTRIES THAT SERVE AS
-C MULTIPLICATIVE SCALE FACTORS FOR THE VARIABLES.
-C
-C MODE IS AN INTEGER INPUT VARIABLE. IF MODE = 1, THE
-C VARIABLES WILL BE SCALED INTERNALLY. IF MODE = 2,
-C THE SCALING IS SPECIFIED BY THE INPUT DIAG. OTHER
-C VALUES OF MODE ARE EQUIVALENT TO MODE = 1.
-C
-C FACTOR IS A POSITIVE INPUT VARIABLE USED IN DETERMINING THE
-C INITIAL STEP BOUND. THIS BOUND IS SET TO THE PRODUCT OF
-C FACTOR AND THE EUCLIDEAN NORM OF DIAG*X IF NONZERO, OR ELSE
-C TO FACTOR ITSELF. IN MOST CASES FACTOR SHOULD LIE IN THE
-C INTERVAL (.1,100.). 100. IS A GENERALLY RECOMMENDED VALUE.
-C
-C NPRINT IS AN INTEGER INPUT VARIABLE THAT ENABLES CONTROLLED
-C PRINTING OF ITERATES IF IT IS POSITIVE. IN THIS CASE,
-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. 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)
-C VALUE OF IFLAG. SEE DESCRIPTION OF FCN. OTHERWISE,
-C INFO IS SET AS FOLLOWS.
-C
-C INFO = 0 IMPROPER INPUT PARAMETERS.
-C
-C INFO = 1 BOTH ACTUAL AND PREDICTED RELATIVE REDUCTIONS
-C IN THE SUM OF SQUARES ARE AT MOST FTOL.
-C
-C INFO = 2 RELATIVE ERROR BETWEEN TWO CONSECUTIVE ITERATES
-C IS AT MOST XTOL.
-C
-C INFO = 3 CONDITIONS FOR INFO = 1 AND INFO = 2 BOTH HOLD.
-C
-C INFO = 4 THE COSINE OF THE ANGLE BETWEEN FVEC AND ANY
-C COLUMN OF THE JACOBIAN IS AT MOST GTOL IN
-C ABSOLUTE VALUE.
-C
-C INFO = 5 NUMBER OF CALLS TO FCN HAS REACHED OR
-C EXCEEDED MAXFEV.
-C
-C INFO = 6 FTOL IS TOO SMALL. NO FURTHER REDUCTION IN
-C THE SUM OF SQUARES IS POSSIBLE.
-C
-C INFO = 7 XTOL IS TOO SMALL. NO FURTHER IMPROVEMENT IN
-C THE APPROXIMATE SOLUTION X IS POSSIBLE.
-C
-C INFO = 8 GTOL IS TOO SMALL. FVEC IS ORTHOGONAL TO THE
-C COLUMNS OF THE JACOBIAN TO MACHINE PRECISION.
-C
-C NFEV IS AN INTEGER OUTPUT VARIABLE SET TO THE NUMBER OF
-C CALLS TO FCN.
-C
-C FJAC IS AN OUTPUT M BY N ARRAY. THE UPPER N BY N SUBMATRIX
-C OF FJAC CONTAINS AN UPPER TRIANGULAR MATRIX R WITH
-C DIAGONAL ELEMENTS OF NONINCREASING MAGNITUDE SUCH THAT
-C
-C T T T
-C P *(JAC *JAC)*P = R *R,
-C
-C WHERE P IS A PERMUTATION MATRIX AND JAC IS THE FINAL
-C CALCULATED JACOBIAN. COLUMN J OF P IS COLUMN IPVT(J)
-C (SEE BELOW) OF THE IDENTITY MATRIX. THE LOWER TRAPEZOIDAL
-C PART OF FJAC CONTAINS INFORMATION GENERATED DURING
-C THE COMPUTATION OF R.
-C
-C LDFJAC IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN M
-C WHICH SPECIFIES THE LEADING DIMENSION OF THE ARRAY FJAC.
-C
-C IPVT IS AN INTEGER OUTPUT ARRAY OF LENGTH N. IPVT
-C DEFINES A PERMUTATION MATRIX P SUCH THAT JAC*P = Q*R,
-C WHERE JAC IS THE FINAL CALCULATED JACOBIAN, Q IS
-C ORTHOGONAL (NOT STORED), AND R IS UPPER TRIANGULAR
-C WITH DIAGONAL ELEMENTS OF NONINCREASING MAGNITUDE.
-C COLUMN J OF P IS COLUMN IPVT(J) OF THE IDENTITY MATRIX.
-C
-C QTF IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS
-C THE FIRST N ELEMENTS OF THE VECTOR (Q TRANSPOSE)*FVEC.
-C
-C WA1, WA2, AND WA3 ARE WORK ARRAYS OF LENGTH N.
-C
-C WA4 IS A WORK ARRAY OF LENGTH M.
-C
-C SUBPROGRAMS CALLED
-C
-C USER-SUPPLIED ...... FCN
-C
-C MINPACK-SUPPLIED ... DPMPAR,ENORM,FDJAC2,LMPAR,QRFAC
-C
-C FORTRAN-SUPPLIED ... DABS,DMAX1,DMIN1,DSQRT,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,L
- DOUBLE PRECISION ACTRED,DELTA,DIRDER,EPSMCH,FNORM,FNORM1,GNORM,
- * ONE,PAR,PNORM,PRERED,P1,P5,P25,P75,P0001,RATIO,
- * SUM,TEMP,TEMP1,TEMP2,XNORM,ZERO
- DOUBLE PRECISION DPMPAR,ENORM
- DATA ONE,P1,P5,P25,P75,P0001,ZERO
- * /1.0D0,1.0D-1,5.0D-1,2.5D-1,7.5D-1,1.0D-4,0.0D0/
-C
-C EPSMCH IS THE MACHINE PRECISION.
-C
- EPSMCH = DPMPAR(1)
-C
- INFO = 0
- IFLAG = 0
- NFEV = 0
-C
-C CHECK THE INPUT PARAMETERS FOR ERRORS.
-C
- IF (N .LE. 0 .OR. M .LT. N .OR. LDFJAC .LT. M
- * .OR. FTOL .LT. ZERO .OR. XTOL .LT. ZERO .OR. GTOL .LT. ZERO
- * .OR. MAXFEV .LE. 0 .OR. FACTOR .LE. ZERO) GO TO 300
- IF (MODE .NE. 2) GO TO 20
- DO 10 J = 1, N
- IF (DIAG(J) .LE. ZERO) GO TO 300
- 10 CONTINUE
- 20 CONTINUE
-C
-C EVALUATE THE FUNCTION AT THE STARTING POINT
-C AND CALCULATE ITS NORM.
-C
- IFLAG = 1
- CALL FCN(M,N,X,FVEC,IFLAG)
- NFEV = 1
- IF (IFLAG .LT. 0) GO TO 300
- FNORM = ENORM(M,FVEC)
-C
-C INITIALIZE LEVENBERG-MARQUARDT PARAMETER AND ITERATION COUNTER.
-C
- PAR = ZERO
- ITER = 1
-C
-C BEGINNING OF THE OUTER LOOP.
-C
- 30 CONTINUE
-C
-C CALCULATE THE JACOBIAN MATRIX.
-C
- IFLAG = 2
- CALL FDJAC2(FCN,M,N,X,FVEC,FJAC,LDFJAC,IFLAG,EPSFCN,WA4)
- NFEV = NFEV + N
- IF (IFLAG .LT. 0) GO TO 300
-C
-C IF REQUESTED, CALL FCN TO ENABLE PRINTING OF ITERATES.
-C
- IF (NPRINT .LE. 0) GO TO 40
- IFLAG = 0
- IF (MOD(ITER-1,NPRINT) .EQ. 0) CALL FCN(M,N,X,FVEC,IFLAG)
- IF (IFLAG .LT. 0) GO TO 300
- 40 CONTINUE
-C
-C COMPUTE THE QR FACTORIZATION OF THE JACOBIAN.
-C
- CALL QRFAC(M,N,FJAC,LDFJAC,.TRUE.,IPVT,N,WA1,WA2,WA3)
-C
-C ON THE FIRST ITERATION AND IF MODE IS 1, SCALE ACCORDING
-C TO THE NORMS OF THE COLUMNS OF THE INITIAL JACOBIAN.
-C
- IF (ITER .NE. 1) GO TO 80
- IF (MODE .EQ. 2) GO TO 60
- DO 50 J = 1, N
- DIAG(J) = WA2(J)
- IF (WA2(J) .EQ. ZERO) DIAG(J) = ONE
- 50 CONTINUE
- 60 CONTINUE
-C
-C ON THE FIRST ITERATION, CALCULATE THE NORM OF THE SCALED X
-C AND INITIALIZE THE STEP BOUND DELTA.
-C
- DO 70 J = 1, N
- WA3(J) = DIAG(J)*X(J)
- 70 CONTINUE
- XNORM = ENORM(N,WA3)
- DELTA = FACTOR*XNORM
- IF (DELTA .EQ. ZERO) DELTA = FACTOR
- 80 CONTINUE
-C
-C FORM (Q TRANSPOSE)*FVEC AND STORE THE FIRST N COMPONENTS IN
-C QTF.
-C
- DO 90 I = 1, M
- WA4(I) = FVEC(I)
- 90 CONTINUE
- DO 130 J = 1, N
- IF (FJAC(J,J) .EQ. ZERO) GO TO 120
- SUM = ZERO
- DO 100 I = J, M
- SUM = SUM + FJAC(I,J)*WA4(I)
- 100 CONTINUE
- TEMP = -SUM/FJAC(J,J)
- DO 110 I = J, M
- WA4(I) = WA4(I) + FJAC(I,J)*TEMP
- 110 CONTINUE
- 120 CONTINUE
- FJAC(J,J) = WA1(J)
- QTF(J) = WA4(J)
- 130 CONTINUE
-C
-C COMPUTE THE NORM OF THE SCALED GRADIENT.
-C
- GNORM = ZERO
- IF (FNORM .EQ. ZERO) GO TO 170
- DO 160 J = 1, N
- L = IPVT(J)
- IF (WA2(L) .EQ. ZERO) GO TO 150
- SUM = ZERO
- DO 140 I = 1, J
- SUM = SUM + FJAC(I,J)*(QTF(I)/FNORM)
- 140 CONTINUE
- GNORM = DMAX1(GNORM,DABS(SUM/WA2(L)))
- 150 CONTINUE
- 160 CONTINUE
- 170 CONTINUE
-C
-C TEST FOR CONVERGENCE OF THE GRADIENT NORM.
-C
- IF (GNORM .LE. GTOL) INFO = 4
- IF (INFO .NE. 0) GO TO 300
-C
-C RESCALE IF NECESSARY.
-C
- IF (MODE .EQ. 2) GO TO 190
- DO 180 J = 1, N
- DIAG(J) = DMAX1(DIAG(J),WA2(J))
- 180 CONTINUE
- 190 CONTINUE
-C
-C BEGINNING OF THE INNER LOOP.
-C
- 200 CONTINUE
-C
-C DETERMINE THE LEVENBERG-MARQUARDT PARAMETER.
-C
- CALL LMPAR(N,FJAC,LDFJAC,IPVT,DIAG,QTF,DELTA,PAR,WA1,WA2,
- * WA3,WA4)
-C
-C STORE THE DIRECTION P AND X + P. CALCULATE THE NORM OF P.
-C
- DO 210 J = 1, N
- WA1(J) = -WA1(J)
- WA2(J) = X(J) + WA1(J)
- WA3(J) = DIAG(J)*WA1(J)
- 210 CONTINUE
- PNORM = ENORM(N,WA3)
-C
-C ON THE FIRST ITERATION, ADJUST THE INITIAL STEP BOUND.
-C
- IF (ITER .EQ. 1) DELTA = DMIN1(DELTA,PNORM)
-C
-C EVALUATE THE FUNCTION AT X + P AND CALCULATE ITS NORM.
-C
- IFLAG = 1
- CALL FCN(M,N,WA2,WA4,IFLAG)
- NFEV = NFEV + 1
- IF (IFLAG .LT. 0) GO TO 300
- FNORM1 = ENORM(M,WA4)
-C
-C COMPUTE THE SCALED ACTUAL REDUCTION.
-C
- ACTRED = -ONE
- IF (P1*FNORM1 .LT. FNORM) ACTRED = ONE - (FNORM1/FNORM)**2
-C
-C COMPUTE THE SCALED PREDICTED REDUCTION AND
-C THE SCALED DIRECTIONAL DERIVATIVE.
-C
- DO 230 J = 1, N
- WA3(J) = ZERO
- L = IPVT(J)
- TEMP = WA1(L)
- DO 220 I = 1, J
- WA3(I) = WA3(I) + FJAC(I,J)*TEMP
- 220 CONTINUE
- 230 CONTINUE
- TEMP1 = ENORM(N,WA3)/FNORM
- TEMP2 = (DSQRT(PAR)*PNORM)/FNORM
- PRERED = TEMP1**2 + TEMP2**2/P5
- DIRDER = -(TEMP1**2 + TEMP2**2)
-C
-C COMPUTE THE RATIO OF THE ACTUAL TO THE PREDICTED
-C REDUCTION.
-C
- RATIO = ZERO
- IF (PRERED .NE. ZERO) RATIO = ACTRED/PRERED
-C
-C UPDATE THE STEP BOUND.
-C
- IF (RATIO .GT. P25) GO TO 240
- IF (ACTRED .GE. ZERO) TEMP = P5
- IF (ACTRED .LT. ZERO)
- * TEMP = P5*DIRDER/(DIRDER + P5*ACTRED)
- IF (P1*FNORM1 .GE. FNORM .OR. TEMP .LT. P1) TEMP = P1
- DELTA = TEMP*DMIN1(DELTA,PNORM/P1)
- PAR = PAR/TEMP
- GO TO 260
- 240 CONTINUE
- IF (PAR .NE. ZERO .AND. RATIO .LT. P75) GO TO 250
- DELTA = PNORM/P5
- PAR = P5*PAR
- 250 CONTINUE
- 260 CONTINUE
-C
-C TEST FOR SUCCESSFUL ITERATION.
-C
- IF (RATIO .LT. P0001) GO TO 290
-C
-C SUCCESSFUL ITERATION. UPDATE X, FVEC, AND THEIR NORMS.
-C
- DO 270 J = 1, N
- X(J) = WA2(J)
- WA2(J) = DIAG(J)*X(J)
- 270 CONTINUE
- DO 280 I = 1, M
- FVEC(I) = WA4(I)
- 280 CONTINUE
- XNORM = ENORM(N,WA2)
- FNORM = FNORM1
- ITER = ITER + 1
- 290 CONTINUE
-C
-C TESTS FOR CONVERGENCE.
-C
- IF (DABS(ACTRED) .LE. FTOL .AND. PRERED .LE. FTOL
- * .AND. P5*RATIO .LE. ONE) INFO = 1
- IF (DELTA .LE. XTOL*XNORM) INFO = 2
- IF (DABS(ACTRED) .LE. FTOL .AND. PRERED .LE. FTOL
- * .AND. P5*RATIO .LE. ONE .AND. INFO .EQ. 2) INFO = 3
- IF (INFO .NE. 0) GO TO 300
-C
-C TESTS FOR TERMINATION AND STRINGENT TOLERANCES.
-C
- IF (NFEV .GE. MAXFEV) INFO = 5
- IF (DABS(ACTRED) .LE. EPSMCH .AND. PRERED .LE. EPSMCH
- * .AND. P5*RATIO .LE. ONE) INFO = 6
- IF (DELTA .LE. EPSMCH*XNORM) INFO = 7
- IF (GNORM .LE. EPSMCH) INFO = 8
- IF (INFO .NE. 0) GO TO 300
-C
-C END OF THE INNER LOOP. REPEAT IF ITERATION UNSUCCESSFUL.
-C
- IF (RATIO .LT. P0001) GO TO 200
-C
-C END OF THE OUTER LOOP.
-C
- GO TO 30
- 300 CONTINUE
-C
-C TERMINATION, EITHER NORMAL OR USER IMPOSED.
-C
- IF (IFLAG .LT. 0) INFO = IFLAG
- IFLAG = 0
- IF (NPRINT .GT. 0) CALL FCN(M,N,X,FVEC,IFLAG)
- RETURN
-C
-C LAST CARD OF SUBROUTINE LMDIF.
-C
- END
- SUBROUTINE LMDIF1(FCN,M,N,X,FVEC,TOL,INFO,IWA,WA,LWA)
- INTEGER M,N,INFO,LWA
- INTEGER IWA(N)
- DOUBLE PRECISION TOL
- DOUBLE PRECISION X(N),FVEC(M),WA(LWA)
- EXTERNAL FCN
-C **********
-C
-C SUBROUTINE LMDIF1
-C
-C THE PURPOSE OF LMDIF1 IS TO MINIMIZE THE SUM OF THE SQUARES OF
-C M NONLINEAR FUNCTIONS IN N VARIABLES BY A MODIFICATION OF THE
-C LEVENBERG-MARQUARDT ALGORITHM. THIS IS DONE BY USING THE MORE
-C GENERAL LEAST-SQUARES SOLVER LMDIF. THE USER MUST PROVIDE A
-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 LMDIF1(FCN,M,N,X,FVEC,TOL,INFO,IWA,WA,LWA)
-C
-C WHERE
-C
-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
-C SUBROUTINE FCN(M,N,X,FVEC,IFLAG)
-C INTEGER M,N,IFLAG
-C DOUBLE PRECISION X(N),FVEC(M)
-C ----------
-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 LMDIF1.
-C IN THIS CASE SET IFLAG TO A NEGATIVE INTEGER.
-C
-C M IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER
-C OF FUNCTIONS.
-C
-C N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER
-C OF VARIABLES. N MUST NOT EXCEED M.
-C
-C X IS AN ARRAY OF LENGTH N. ON INPUT X MUST CONTAIN
-C AN INITIAL ESTIMATE OF THE SOLUTION VECTOR. ON OUTPUT X
-C CONTAINS THE FINAL ESTIMATE OF THE SOLUTION VECTOR.
-C
-C FVEC IS AN OUTPUT ARRAY OF LENGTH M WHICH CONTAINS
-C THE FUNCTIONS EVALUATED AT THE OUTPUT X.
-C
-C TOL IS A NONNEGATIVE INPUT VARIABLE. TERMINATION OCCURS
-C WHEN THE ALGORITHM ESTIMATES EITHER THAT THE RELATIVE
-C ERROR IN THE SUM OF SQUARES IS AT MOST TOL OR THAT
-C THE RELATIVE ERROR BETWEEN X AND THE SOLUTION IS AT
-C MOST TOL.
-C
-C INFO IS AN INTEGER OUTPUT VARIABLE. IF THE USER HAS
-C TERMINATED EXECUTION, INFO IS SET TO THE (NEGATIVE)
-C VALUE OF IFLAG. SEE DESCRIPTION OF FCN. OTHERWISE,
-C INFO IS SET AS FOLLOWS.
-C
-C INFO = 0 IMPROPER INPUT PARAMETERS.
-C
-C INFO = 1 ALGORITHM ESTIMATES THAT THE RELATIVE ERROR
-C IN THE SUM OF SQUARES IS AT MOST TOL.
-C
-C INFO = 2 ALGORITHM ESTIMATES THAT THE RELATIVE ERROR
-C BETWEEN X AND THE SOLUTION IS AT MOST TOL.
-C
-C INFO = 3 CONDITIONS FOR INFO = 1 AND INFO = 2 BOTH HOLD.
-C
-C INFO = 4 FVEC IS ORTHOGONAL TO THE COLUMNS OF THE
-C JACOBIAN TO MACHINE PRECISION.
-C
-C INFO = 5 NUMBER OF CALLS TO FCN HAS REACHED OR
-C EXCEEDED 200*(N+1).
-C
-C INFO = 6 TOL IS TOO SMALL. NO FURTHER REDUCTION IN
-C THE SUM OF SQUARES IS POSSIBLE.
-C
-C INFO = 7 TOL IS TOO SMALL. NO FURTHER IMPROVEMENT IN
-C THE APPROXIMATE SOLUTION X IS POSSIBLE.
-C
-C IWA IS AN INTEGER WORK ARRAY OF LENGTH N.
-C
-C WA IS A WORK ARRAY OF LENGTH LWA.
-C
-C LWA IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN
-C M*N+5*N+M.
-C
-C SUBPROGRAMS CALLED
-C
-C USER-SUPPLIED ...... FCN
-C
-C MINPACK-SUPPLIED ... LMDIF
-C
-C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980.
-C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE
-C
-C **********
- INTEGER MAXFEV,MODE,MP5N,NFEV,NPRINT
- DOUBLE PRECISION EPSFCN,FACTOR,FTOL,GTOL,XTOL,ZERO
- DATA FACTOR,ZERO /1.0D2,0.0D0/
- INFO = 0
-C
-C CHECK THE INPUT PARAMETERS FOR ERRORS.
-C
- IF (N .LE. 0 .OR. M .LT. N .OR. TOL .LT. ZERO
- * .OR. LWA .LT. M*N + 5*N + M) GO TO 10
-C
-C CALL LMDIF.
-C
- MAXFEV = 200*(N + 1)
- FTOL = TOL
- XTOL = TOL
- GTOL = ZERO
- EPSFCN = ZERO
- MODE = 1
- NPRINT = 0
- MP5N = M + 5*N
- CALL LMDIF(FCN,M,N,X,FVEC,FTOL,XTOL,GTOL,MAXFEV,EPSFCN,WA(1),
- * MODE,FACTOR,NPRINT,INFO,NFEV,WA(MP5N+1),M,IWA,
- * WA(N+1),WA(2*N+1),WA(3*N+1),WA(4*N+1),WA(5*N+1))
- IF (INFO .EQ. 8) INFO = 4
- 10 CONTINUE
- RETURN
-C
-C LAST CARD OF SUBROUTINE LMDIF1.
-C
- END
- SUBROUTINE LMPAR(N,R,LDR,IPVT,DIAG,QTB,DELTA,PAR,X,SDIAG,WA1,
- * WA2)
- INTEGER N,LDR
- INTEGER IPVT(N)
- DOUBLE PRECISION DELTA,PAR
- DOUBLE PRECISION R(LDR,N),DIAG(N),QTB(N),X(N),SDIAG(N),WA1(N),
- * WA2(N)
-C **********
-C
-C SUBROUTINE LMPAR
-C
-C GIVEN AN M BY N MATRIX A, AN N BY N NONSINGULAR DIAGONAL
-C MATRIX D, AN M-VECTOR B, AND A POSITIVE NUMBER DELTA,
-C THE PROBLEM IS TO DETERMINE A VALUE FOR THE PARAMETER
-C PAR SUCH THAT IF X SOLVES THE SYSTEM
-C
-C A*X = B , SQRT(PAR)*D*X = 0 ,
-C
-C IN THE LEAST SQUARES SENSE, AND DXNORM IS THE EUCLIDEAN
-C NORM OF D*X, THEN EITHER PAR IS ZERO AND
-C
-C (DXNORM-DELTA) .LE. 0.1*DELTA ,
-C
-C OR PAR IS POSITIVE AND
-C
-C ABS(DXNORM-DELTA) .LE. 0.1*DELTA .
-C
-C THIS SUBROUTINE COMPLETES THE SOLUTION OF THE PROBLEM
-C IF IT IS PROVIDED WITH THE NECESSARY INFORMATION FROM THE
-C QR FACTORIZATION, WITH COLUMN PIVOTING, OF A. THAT IS, IF
-C A*P = Q*R, WHERE P IS A PERMUTATION MATRIX, Q HAS ORTHOGONAL
-C COLUMNS, AND R IS AN UPPER TRIANGULAR MATRIX WITH DIAGONAL
-C ELEMENTS OF NONINCREASING MAGNITUDE, THEN LMPAR EXPECTS
-C THE FULL UPPER TRIANGLE OF R, THE PERMUTATION MATRIX P,
-C AND THE FIRST N COMPONENTS OF (Q TRANSPOSE)*B. ON OUTPUT
-C LMPAR ALSO PROVIDES AN UPPER TRIANGULAR MATRIX S SUCH THAT
-C
-C T T T
-C P *(A *A + PAR*D*D)*P = S *S .
-C
-C S IS EMPLOYED WITHIN LMPAR AND MAY BE OF SEPARATE INTEREST.
-C
-C ONLY A FEW ITERATIONS ARE GENERALLY NEEDED FOR CONVERGENCE
-C OF THE ALGORITHM. IF, HOWEVER, THE LIMIT OF 10 ITERATIONS
-C IS REACHED, THEN THE OUTPUT PAR WILL CONTAIN THE BEST
-C VALUE OBTAINED SO FAR.
-C
-C THE SUBROUTINE STATEMENT IS
-C
-C SUBROUTINE LMPAR(N,R,LDR,IPVT,DIAG,QTB,DELTA,PAR,X,SDIAG,
-C WA1,WA2)
-C
-C WHERE
-C
-C N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE ORDER OF R.
-C
-C R IS AN N BY N ARRAY. ON INPUT THE FULL UPPER TRIANGLE
-C MUST CONTAIN THE FULL UPPER TRIANGLE OF THE MATRIX R.
-C ON OUTPUT THE FULL UPPER TRIANGLE IS UNALTERED, AND THE
-C STRICT LOWER TRIANGLE CONTAINS THE STRICT UPPER TRIANGLE
-C (TRANSPOSED) OF THE UPPER TRIANGULAR MATRIX S.
-C
-C LDR IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN N
-C WHICH SPECIFIES THE LEADING DIMENSION OF THE ARRAY R.
-C
-C IPVT IS AN INTEGER INPUT ARRAY OF LENGTH N WHICH DEFINES THE
-C PERMUTATION MATRIX P SUCH THAT A*P = Q*R. COLUMN J OF P
-C IS COLUMN IPVT(J) OF THE IDENTITY MATRIX.
-C
-C DIAG IS AN INPUT ARRAY OF LENGTH N WHICH MUST CONTAIN THE
-C DIAGONAL ELEMENTS OF THE MATRIX D.
-C
-C QTB IS AN INPUT ARRAY OF LENGTH N WHICH MUST CONTAIN THE FIRST
-C N ELEMENTS OF THE VECTOR (Q TRANSPOSE)*B.
-C
-C DELTA IS A POSITIVE INPUT VARIABLE WHICH SPECIFIES AN UPPER
-C BOUND ON THE EUCLIDEAN NORM OF D*X.
-C
-C PAR IS A NONNEGATIVE VARIABLE. ON INPUT PAR CONTAINS AN
-C INITIAL ESTIMATE OF THE LEVENBERG-MARQUARDT PARAMETER.
-C ON OUTPUT PAR CONTAINS THE FINAL ESTIMATE.
-C
-C X IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS THE LEAST
-C SQUARES SOLUTION OF THE SYSTEM A*X = B, SQRT(PAR)*D*X = 0,
-C FOR THE OUTPUT PAR.
-C
-C SDIAG IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS THE
-C DIAGONAL ELEMENTS OF THE UPPER TRIANGULAR MATRIX S.
-C
-C WA1 AND WA2 ARE WORK ARRAYS OF LENGTH N.
-C
-C SUBPROGRAMS CALLED
-C
-C MINPACK-SUPPLIED ... DPMPAR,ENORM,QRSOLV
-C
-C FORTRAN-SUPPLIED ... DABS,DMAX1,DMIN1,DSQRT
-C
-C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980.
-C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE
-C
-C **********
- INTEGER I,ITER,J,JM1,JP1,K,L,NSING
- DOUBLE PRECISION DXNORM,DWARF,FP,GNORM,PARC,PARL,PARU,P1,P001,
- * SUM,TEMP,ZERO
- DOUBLE PRECISION DPMPAR,ENORM
- DATA P1,P001,ZERO /1.0D-1,1.0D-3,0.0D0/
-C
-C DWARF IS THE SMALLEST POSITIVE MAGNITUDE.
-C
- DWARF = DPMPAR(2)
-C
-C COMPUTE AND STORE IN X THE GAUSS-NEWTON DIRECTION. IF THE
-C JACOBIAN IS RANK-DEFICIENT, OBTAIN A LEAST SQUARES SOLUTION.
-C
- NSING = N
- DO 10 J = 1, N
- WA1(J) = QTB(J)
- IF (R(J,J) .EQ. ZERO .AND. NSING .EQ. N) NSING = J - 1
- IF (NSING .LT. N) WA1(J) = ZERO
- 10 CONTINUE
- IF (NSING .LT. 1) GO TO 50
- DO 40 K = 1, NSING
- J = NSING - K + 1
- WA1(J) = WA1(J)/R(J,J)
- TEMP = WA1(J)
- JM1 = J - 1
- IF (JM1 .LT. 1) GO TO 30
- DO 20 I = 1, JM1
- WA1(I) = WA1(I) - R(I,J)*TEMP
- 20 CONTINUE
- 30 CONTINUE
- 40 CONTINUE
- 50 CONTINUE
- DO 60 J = 1, N
- L = IPVT(J)
- X(L) = WA1(J)
- 60 CONTINUE
-C
-C INITIALIZE THE ITERATION COUNTER.
-C EVALUATE THE FUNCTION AT THE ORIGIN, AND TEST
-C FOR ACCEPTANCE OF THE GAUSS-NEWTON DIRECTION.
-C
- ITER = 0
- DO 70 J = 1, N
- WA2(J) = DIAG(J)*X(J)
- 70 CONTINUE
- DXNORM = ENORM(N,WA2)
- FP = DXNORM - DELTA
- IF (FP .LE. P1*DELTA) GO TO 220
-C
-C IF THE JACOBIAN IS NOT RANK DEFICIENT, THE NEWTON
-C STEP PROVIDES A LOWER BOUND, PARL, FOR THE ZERO OF
-C THE FUNCTION. OTHERWISE SET THIS BOUND TO ZERO.
-C
- PARL = ZERO
- IF (NSING .LT. N) GO TO 120
- DO 80 J = 1, N
- L = IPVT(J)
- WA1(J) = DIAG(L)*(WA2(L)/DXNORM)
- 80 CONTINUE
- DO 110 J = 1, N
- SUM = ZERO
- JM1 = J - 1
- IF (JM1 .LT. 1) GO TO 100
- DO 90 I = 1, JM1
- SUM = SUM + R(I,J)*WA1(I)
- 90 CONTINUE
- 100 CONTINUE
- WA1(J) = (WA1(J) - SUM)/R(J,J)
- 110 CONTINUE
- TEMP = ENORM(N,WA1)
- PARL = ((FP/DELTA)/TEMP)/TEMP
- 120 CONTINUE
-C
-C CALCULATE AN UPPER BOUND, PARU, FOR THE ZERO OF THE FUNCTION.
-C
- DO 140 J = 1, N
- SUM = ZERO
- DO 130 I = 1, J
- SUM = SUM + R(I,J)*QTB(I)
- 130 CONTINUE
- L = IPVT(J)
- WA1(J) = SUM/DIAG(L)
- 140 CONTINUE
- GNORM = ENORM(N,WA1)
- PARU = GNORM/DELTA
- IF (PARU .EQ. ZERO) PARU = DWARF/DMIN1(DELTA,P1)
-C
-C IF THE INPUT PAR LIES OUTSIDE OF THE INTERVAL (PARL,PARU),
-C SET PAR TO THE CLOSER ENDPOINT.
-C
- PAR = DMAX1(PAR,PARL)
- PAR = DMIN1(PAR,PARU)
- IF (PAR .EQ. ZERO) PAR = GNORM/DXNORM
-C
-C BEGINNING OF AN ITERATION.
-C
- 150 CONTINUE
- ITER = ITER + 1
-C
-C EVALUATE THE FUNCTION AT THE CURRENT VALUE OF PAR.
-C
- IF (PAR .EQ. ZERO) PAR = DMAX1(DWARF,P001*PARU)
- TEMP = DSQRT(PAR)
- DO 160 J = 1, N
- WA1(J) = TEMP*DIAG(J)
- 160 CONTINUE
- CALL QRSOLV(N,R,LDR,IPVT,WA1,QTB,X,SDIAG,WA2)
- DO 170 J = 1, N
- WA2(J) = DIAG(J)*X(J)
- 170 CONTINUE
- DXNORM = ENORM(N,WA2)
- TEMP = FP
- FP = DXNORM - DELTA
-C
-C IF THE FUNCTION IS SMALL ENOUGH, ACCEPT THE CURRENT VALUE
-C OF PAR. ALSO TEST FOR THE EXCEPTIONAL CASES WHERE PARL
-C IS ZERO OR THE NUMBER OF ITERATIONS HAS REACHED 10.
-C
- IF (DABS(FP) .LE. P1*DELTA
- * .OR. PARL .EQ. ZERO .AND. FP .LE. TEMP
- * .AND. TEMP .LT. ZERO .OR. ITER .EQ. 10) GO TO 220
-C
-C COMPUTE THE NEWTON CORRECTION.
-C
- DO 180 J = 1, N
- L = IPVT(J)
- WA1(J) = DIAG(L)*(WA2(L)/DXNORM)
- 180 CONTINUE
- DO 210 J = 1, N
- WA1(J) = WA1(J)/SDIAG(J)
- TEMP = WA1(J)
- JP1 = J + 1
- IF (N .LT. JP1) GO TO 200
- DO 190 I = JP1, N
- WA1(I) = WA1(I) - R(I,J)*TEMP
- 190 CONTINUE
- 200 CONTINUE
- 210 CONTINUE
- TEMP = ENORM(N,WA1)
- PARC = ((FP/DELTA)/TEMP)/TEMP
-C
-C DEPENDING ON THE SIGN OF THE FUNCTION, UPDATE PARL OR PARU.
-C
- IF (FP .GT. ZERO) PARL = DMAX1(PARL,PAR)
- IF (FP .LT. ZERO) PARU = DMIN1(PARU,PAR)
-C
-C COMPUTE AN IMPROVED ESTIMATE FOR PAR.
-C
- PAR = DMAX1(PARL,PAR+PARC)
-C
-C END OF AN ITERATION.
-C
- GO TO 150
- 220 CONTINUE
-C
-C TERMINATION.
-C
- IF (ITER .EQ. 0) PAR = ZERO
- RETURN
-C
-C LAST CARD OF SUBROUTINE LMPAR.
-C
- END
- SUBROUTINE LMSTR(FCN,M,N,X,FVEC,FJAC,LDFJAC,FTOL,XTOL,GTOL,
- * MAXFEV,DIAG,MODE,FACTOR,NPRINT,INFO,NFEV,NJEV,
- * IPVT,QTF,WA1,WA2,WA3,WA4)
- INTEGER M,N,LDFJAC,MAXFEV,MODE,NPRINT,INFO,NFEV,NJEV
- INTEGER IPVT(N)
- LOGICAL SING
- DOUBLE PRECISION FTOL,XTOL,GTOL,FACTOR
- DOUBLE PRECISION X(N),FVEC(M),FJAC(LDFJAC,N),DIAG(N),QTF(N),
- * WA1(N),WA2(N),WA3(N),WA4(M)
-C **********
-C
-C SUBROUTINE LMSTR
-C
-C THE PURPOSE OF LMSTR IS TO MINIMIZE THE SUM OF THE SQUARES OF
-C M NONLINEAR FUNCTIONS IN N VARIABLES BY A MODIFICATION OF
-C THE LEVENBERG-MARQUARDT ALGORITHM WHICH USES MINIMAL STORAGE.
-C THE USER MUST PROVIDE A SUBROUTINE WHICH CALCULATES THE
-C FUNCTIONS AND THE ROWS OF THE JACOBIAN.
-C
-C THE SUBROUTINE STATEMENT IS
-C
-C SUBROUTINE LMSTR(FCN,M,N,X,FVEC,FJAC,LDFJAC,FTOL,XTOL,GTOL,
-C MAXFEV,DIAG,MODE,FACTOR,NPRINT,INFO,NFEV,
-C NJEV,IPVT,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 ROWS OF THE JACOBIAN.
-C FCN MUST BE DECLARED IN AN EXTERNAL STATEMENT IN THE
-C USER CALLING PROGRAM, AND SHOULD BE WRITTEN AS FOLLOWS.
-C
-C SUBROUTINE FCN(M,N,X,FVEC,FJROW,IFLAG)
-C INTEGER M,N,IFLAG
-C DOUBLE PRECISION X(N),FVEC(M),FJROW(N)
-C ----------
-C IF IFLAG = 1 CALCULATE THE FUNCTIONS AT X AND
-C RETURN THIS VECTOR IN FVEC.
-C IF IFLAG = I CALCULATE THE (I-1)-ST ROW OF THE
-C JACOBIAN AT X AND RETURN THIS VECTOR IN FJROW.
-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 LMSTR.
-C IN THIS CASE SET IFLAG TO A NEGATIVE INTEGER.
-C
-C M IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER
-C OF FUNCTIONS.
-C
-C N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER
-C OF VARIABLES. N MUST NOT EXCEED M.
-C
-C X IS AN ARRAY OF LENGTH N. ON INPUT X MUST CONTAIN
-C AN INITIAL ESTIMATE OF THE SOLUTION VECTOR. ON OUTPUT X
-C CONTAINS THE FINAL ESTIMATE OF THE SOLUTION VECTOR.
-C
-C FVEC IS AN OUTPUT ARRAY OF LENGTH M WHICH CONTAINS
-C THE FUNCTIONS EVALUATED AT THE OUTPUT X.
-C
-C FJAC IS AN OUTPUT N BY N ARRAY. THE UPPER TRIANGLE OF FJAC
-C CONTAINS AN UPPER TRIANGULAR MATRIX R SUCH THAT
-C
-C T T T
-C P *(JAC *JAC)*P = R *R,
-C
-C WHERE P IS A PERMUTATION MATRIX AND JAC IS THE FINAL
-C CALCULATED JACOBIAN. COLUMN J OF P IS COLUMN IPVT(J)
-C (SEE BELOW) OF THE IDENTITY MATRIX. THE LOWER TRIANGULAR
-C PART OF FJAC CONTAINS INFORMATION GENERATED DURING
-C THE COMPUTATION OF R.
-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 FTOL IS A NONNEGATIVE INPUT VARIABLE. TERMINATION
-C OCCURS WHEN BOTH THE ACTUAL AND PREDICTED RELATIVE
-C REDUCTIONS IN THE SUM OF SQUARES ARE AT MOST FTOL.
-C THEREFORE, FTOL MEASURES THE RELATIVE ERROR DESIRED
-C IN THE SUM OF SQUARES.
-C
-C XTOL IS A NONNEGATIVE INPUT VARIABLE. TERMINATION
-C OCCURS WHEN THE RELATIVE ERROR BETWEEN TWO CONSECUTIVE
-C ITERATES IS AT MOST XTOL. THEREFORE, XTOL MEASURES THE
-C RELATIVE ERROR DESIRED IN THE APPROXIMATE SOLUTION.
-C
-C GTOL IS A NONNEGATIVE INPUT VARIABLE. TERMINATION
-C OCCURS WHEN THE COSINE OF THE ANGLE BETWEEN FVEC AND
-C ANY COLUMN OF THE JACOBIAN IS AT MOST GTOL IN ABSOLUTE
-C VALUE. THEREFORE, GTOL MEASURES THE ORTHOGONALITY
-C DESIRED BETWEEN THE FUNCTION VECTOR AND THE COLUMNS
-C OF THE JACOBIAN.
-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
-C DIAG IS AN ARRAY OF LENGTH N. IF MODE = 1 (SEE
-C BELOW), DIAG IS INTERNALLY SET. IF MODE = 2, DIAG
-C MUST CONTAIN POSITIVE ENTRIES THAT SERVE AS
-C MULTIPLICATIVE SCALE FACTORS FOR THE VARIABLES.
-C
-C MODE IS AN INTEGER INPUT VARIABLE. IF MODE = 1, THE
-C VARIABLES WILL BE SCALED INTERNALLY. IF MODE = 2,
-C THE SCALING IS SPECIFIED BY THE INPUT DIAG. OTHER
-C VALUES OF MODE ARE EQUIVALENT TO MODE = 1.
-C
-C FACTOR IS A POSITIVE INPUT VARIABLE USED IN DETERMINING THE
-C INITIAL STEP BOUND. THIS BOUND IS SET TO THE PRODUCT OF
-C FACTOR AND THE EUCLIDEAN NORM OF DIAG*X IF NONZERO, OR ELSE
-C TO FACTOR ITSELF. IN MOST CASES FACTOR SHOULD LIE IN THE
-C INTERVAL (.1,100.). 100. IS A GENERALLY RECOMMENDED VALUE.
-C
-C NPRINT IS AN INTEGER INPUT VARIABLE THAT ENABLES CONTROLLED
-C PRINTING OF ITERATES IF IT IS POSITIVE. IN THIS CASE,
-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. 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)
-C VALUE OF IFLAG. SEE DESCRIPTION OF FCN. OTHERWISE,
-C INFO IS SET AS FOLLOWS.
-C
-C INFO = 0 IMPROPER INPUT PARAMETERS.
-C
-C INFO = 1 BOTH ACTUAL AND PREDICTED RELATIVE REDUCTIONS
-C IN THE SUM OF SQUARES ARE AT MOST FTOL.
-C
-C INFO = 2 RELATIVE ERROR BETWEEN TWO CONSECUTIVE ITERATES
-C IS AT MOST XTOL.
-C
-C INFO = 3 CONDITIONS FOR INFO = 1 AND INFO = 2 BOTH HOLD.
-C
-C INFO = 4 THE COSINE OF THE ANGLE BETWEEN FVEC AND ANY
-C COLUMN OF THE JACOBIAN IS AT MOST GTOL IN
-C ABSOLUTE VALUE.
-C
-C INFO = 5 NUMBER OF CALLS TO FCN WITH IFLAG = 1 HAS
-C REACHED MAXFEV.
-C
-C INFO = 6 FTOL IS TOO SMALL. NO FURTHER REDUCTION IN
-C THE SUM OF SQUARES IS POSSIBLE.
-C
-C INFO = 7 XTOL IS TOO SMALL. NO FURTHER IMPROVEMENT IN
-C THE APPROXIMATE SOLUTION X IS POSSIBLE.
-C
-C INFO = 8 GTOL IS TOO SMALL. FVEC IS ORTHOGONAL TO THE
-C COLUMNS OF THE JACOBIAN TO MACHINE PRECISION.
-C
-C NFEV IS AN INTEGER OUTPUT VARIABLE SET TO THE NUMBER OF
-C CALLS TO FCN WITH IFLAG = 1.
-C
-C NJEV IS AN INTEGER OUTPUT VARIABLE SET TO THE NUMBER OF
-C CALLS TO FCN WITH IFLAG = 2.
-C
-C IPVT IS AN INTEGER OUTPUT ARRAY OF LENGTH N. IPVT
-C DEFINES A PERMUTATION MATRIX P SUCH THAT JAC*P = Q*R,
-C WHERE JAC IS THE FINAL CALCULATED JACOBIAN, Q IS
-C ORTHOGONAL (NOT STORED), AND R IS UPPER TRIANGULAR.
-C COLUMN J OF P IS COLUMN IPVT(J) OF THE IDENTITY MATRIX.
-C
-C QTF IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS
-C THE FIRST N ELEMENTS OF THE VECTOR (Q TRANSPOSE)*FVEC.
-C
-C WA1, WA2, AND WA3 ARE WORK ARRAYS OF LENGTH N.
-C
-C WA4 IS A WORK ARRAY OF LENGTH M.
-C
-C SUBPROGRAMS CALLED
-C
-C USER-SUPPLIED ...... FCN
-C
-C MINPACK-SUPPLIED ... DPMPAR,ENORM,LMPAR,QRFAC,RWUPDT
-C
-C FORTRAN-SUPPLIED ... DABS,DMAX1,DMIN1,DSQRT,MOD
-C
-C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980.
-C BURTON S. GARBOW, DUDLEY V. GOETSCHEL, KENNETH E. HILLSTROM,
-C JORGE J. MORE
-C
-C **********
- INTEGER I,IFLAG,ITER,J,L
- DOUBLE PRECISION ACTRED,DELTA,DIRDER,EPSMCH,FNORM,FNORM1,GNORM,
- * ONE,PAR,PNORM,PRERED,P1,P5,P25,P75,P0001,RATIO,
- * SUM,TEMP,TEMP1,TEMP2,XNORM,ZERO
- DOUBLE PRECISION DPMPAR,ENORM
- DATA ONE,P1,P5,P25,P75,P0001,ZERO
- * /1.0D0,1.0D-1,5.0D-1,2.5D-1,7.5D-1,1.0D-4,0.0D0/
-C
-C EPSMCH IS THE MACHINE PRECISION.
-C
- EPSMCH = DPMPAR(1)
-C
- INFO = 0
- IFLAG = 0
- NFEV = 0
- NJEV = 0
-C
-C CHECK THE INPUT PARAMETERS FOR ERRORS.
-C
- IF (N .LE. 0 .OR. M .LT. N .OR. LDFJAC .LT. N
- * .OR. FTOL .LT. ZERO .OR. XTOL .LT. ZERO .OR. GTOL .LT. ZERO
- * .OR. MAXFEV .LE. 0 .OR. FACTOR .LE. ZERO) GO TO 340
- IF (MODE .NE. 2) GO TO 20
- DO 10 J = 1, N
- IF (DIAG(J) .LE. ZERO) GO TO 340
- 10 CONTINUE
- 20 CONTINUE
-C
-C EVALUATE THE FUNCTION AT THE STARTING POINT
-C AND CALCULATE ITS NORM.
-C
- IFLAG = 1
- CALL FCN(M,N,X,FVEC,WA3,IFLAG)
- NFEV = 1
- IF (IFLAG .LT. 0) GO TO 340
- FNORM = ENORM(M,FVEC)
-C
-C INITIALIZE LEVENBERG-MARQUARDT PARAMETER AND ITERATION COUNTER.
-C
- PAR = ZERO
- ITER = 1
-C
-C BEGINNING OF THE OUTER LOOP.
-C
- 30 CONTINUE
-C
-C IF REQUESTED, CALL FCN TO ENABLE PRINTING OF ITERATES.
-C
- IF (NPRINT .LE. 0) GO TO 40
- IFLAG = 0
- IF (MOD(ITER-1,NPRINT) .EQ. 0) CALL FCN(M,N,X,FVEC,WA3,IFLAG)
- IF (IFLAG .LT. 0) GO TO 340
- 40 CONTINUE
-C
-C COMPUTE THE QR FACTORIZATION OF THE JACOBIAN MATRIX
-C CALCULATED ONE ROW AT A TIME, WHILE SIMULTANEOUSLY
-C FORMING (Q TRANSPOSE)*FVEC AND STORING THE FIRST
-C N COMPONENTS IN QTF.
-C
- DO 60 J = 1, N
- QTF(J) = ZERO
- DO 50 I = 1, N
- FJAC(I,J) = ZERO
- 50 CONTINUE
- 60 CONTINUE
- IFLAG = 2
- DO 70 I = 1, M
- CALL FCN(M,N,X,FVEC,WA3,IFLAG)
- IF (IFLAG .LT. 0) GO TO 340
- TEMP = FVEC(I)
- CALL RWUPDT(N,FJAC,LDFJAC,WA3,QTF,TEMP,WA1,WA2)
- IFLAG = IFLAG + 1
- 70 CONTINUE
- NJEV = NJEV + 1
-C
-C IF THE JACOBIAN IS RANK DEFICIENT, CALL QRFAC TO
-C REORDER ITS COLUMNS AND UPDATE THE COMPONENTS OF QTF.
-C
- SING = .FALSE.
- DO 80 J = 1, N
- IF (FJAC(J,J) .EQ. ZERO) SING = .TRUE.
- IPVT(J) = J
- WA2(J) = ENORM(J,FJAC(1,J))
- 80 CONTINUE
- IF (.NOT.SING) GO TO 130
- CALL QRFAC(N,N,FJAC,LDFJAC,.TRUE.,IPVT,N,WA1,WA2,WA3)
- DO 120 J = 1, N
- IF (FJAC(J,J) .EQ. ZERO) GO TO 110
- SUM = ZERO
- DO 90 I = J, N
- SUM = SUM + FJAC(I,J)*QTF(I)
- 90 CONTINUE
- TEMP = -SUM/FJAC(J,J)
- DO 100 I = J, N
- QTF(I) = QTF(I) + FJAC(I,J)*TEMP
- 100 CONTINUE
- 110 CONTINUE
- FJAC(J,J) = WA1(J)
- 120 CONTINUE
- 130 CONTINUE
-C
-C ON THE FIRST ITERATION AND IF MODE IS 1, SCALE ACCORDING
-C TO THE NORMS OF THE COLUMNS OF THE INITIAL JACOBIAN.
-C
- IF (ITER .NE. 1) GO TO 170
- IF (MODE .EQ. 2) GO TO 150
- DO 140 J = 1, N
- DIAG(J) = WA2(J)
- IF (WA2(J) .EQ. ZERO) DIAG(J) = ONE
- 140 CONTINUE
- 150 CONTINUE
-C
-C ON THE FIRST ITERATION, CALCULATE THE NORM OF THE SCALED X
-C AND INITIALIZE THE STEP BOUND DELTA.
-C
- DO 160 J = 1, N
- WA3(J) = DIAG(J)*X(J)
- 160 CONTINUE
- XNORM = ENORM(N,WA3)
- DELTA = FACTOR*XNORM
- IF (DELTA .EQ. ZERO) DELTA = FACTOR
- 170 CONTINUE
-C
-C COMPUTE THE NORM OF THE SCALED GRADIENT.
-C
- GNORM = ZERO
- IF (FNORM .EQ. ZERO) GO TO 210
- DO 200 J = 1, N
- L = IPVT(J)
- IF (WA2(L) .EQ. ZERO) GO TO 190
- SUM = ZERO
- DO 180 I = 1, J
- SUM = SUM + FJAC(I,J)*(QTF(I)/FNORM)
- 180 CONTINUE
- GNORM = DMAX1(GNORM,DABS(SUM/WA2(L)))
- 190 CONTINUE
- 200 CONTINUE
- 210 CONTINUE
-C
-C TEST FOR CONVERGENCE OF THE GRADIENT NORM.
-C
- IF (GNORM .LE. GTOL) INFO = 4
- IF (INFO .NE. 0) GO TO 340
-C
-C RESCALE IF NECESSARY.
-C
- IF (MODE .EQ. 2) GO TO 230
- DO 220 J = 1, N
- DIAG(J) = DMAX1(DIAG(J),WA2(J))
- 220 CONTINUE
- 230 CONTINUE
-C
-C BEGINNING OF THE INNER LOOP.
-C
- 240 CONTINUE
-C
-C DETERMINE THE LEVENBERG-MARQUARDT PARAMETER.
-C
- CALL LMPAR(N,FJAC,LDFJAC,IPVT,DIAG,QTF,DELTA,PAR,WA1,WA2,
- * WA3,WA4)
-C
-C STORE THE DIRECTION P AND X + P. CALCULATE THE NORM OF P.
-C
- DO 250 J = 1, N
- WA1(J) = -WA1(J)
- WA2(J) = X(J) + WA1(J)
- WA3(J) = DIAG(J)*WA1(J)
- 250 CONTINUE
- PNORM = ENORM(N,WA3)
-C
-C ON THE FIRST ITERATION, ADJUST THE INITIAL STEP BOUND.
-C
- IF (ITER .EQ. 1) DELTA = DMIN1(DELTA,PNORM)
-C
-C EVALUATE THE FUNCTION AT X + P AND CALCULATE ITS NORM.
-C
- IFLAG = 1
- CALL FCN(M,N,WA2,WA4,WA3,IFLAG)
- NFEV = NFEV + 1
- IF (IFLAG .LT. 0) GO TO 340
- FNORM1 = ENORM(M,WA4)
-C
-C COMPUTE THE SCALED ACTUAL REDUCTION.
-C
- ACTRED = -ONE
- IF (P1*FNORM1 .LT. FNORM) ACTRED = ONE - (FNORM1/FNORM)**2
-C
-C COMPUTE THE SCALED PREDICTED REDUCTION AND
-C THE SCALED DIRECTIONAL DERIVATIVE.
-C
- DO 270 J = 1, N
- WA3(J) = ZERO
- L = IPVT(J)
- TEMP = WA1(L)
- DO 260 I = 1, J
- WA3(I) = WA3(I) + FJAC(I,J)*TEMP
- 260 CONTINUE
- 270 CONTINUE
- TEMP1 = ENORM(N,WA3)/FNORM
- TEMP2 = (DSQRT(PAR)*PNORM)/FNORM
- PRERED = TEMP1**2 + TEMP2**2/P5
- DIRDER = -(TEMP1**2 + TEMP2**2)
-C
-C COMPUTE THE RATIO OF THE ACTUAL TO THE PREDICTED
-C REDUCTION.
-C
- RATIO = ZERO
- IF (PRERED .NE. ZERO) RATIO = ACTRED/PRERED
-C
-C UPDATE THE STEP BOUND.
-C
- IF (RATIO .GT. P25) GO TO 280
- IF (ACTRED .GE. ZERO) TEMP = P5
- IF (ACTRED .LT. ZERO)
- * TEMP = P5*DIRDER/(DIRDER + P5*ACTRED)
- IF (P1*FNORM1 .GE. FNORM .OR. TEMP .LT. P1) TEMP = P1
- DELTA = TEMP*DMIN1(DELTA,PNORM/P1)
- PAR = PAR/TEMP
- GO TO 300
- 280 CONTINUE
- IF (PAR .NE. ZERO .AND. RATIO .LT. P75) GO TO 290
- DELTA = PNORM/P5
- PAR = P5*PAR
- 290 CONTINUE
- 300 CONTINUE
-C
-C TEST FOR SUCCESSFUL ITERATION.
-C
- IF (RATIO .LT. P0001) GO TO 330
-C
-C SUCCESSFUL ITERATION. UPDATE X, FVEC, AND THEIR NORMS.
-C
- DO 310 J = 1, N
- X(J) = WA2(J)
- WA2(J) = DIAG(J)*X(J)
- 310 CONTINUE
- DO 320 I = 1, M
- FVEC(I) = WA4(I)
- 320 CONTINUE
- XNORM = ENORM(N,WA2)
- FNORM = FNORM1
- ITER = ITER + 1
- 330 CONTINUE
-C
-C TESTS FOR CONVERGENCE.
-C
- IF (DABS(ACTRED) .LE. FTOL .AND. PRERED .LE. FTOL
- * .AND. P5*RATIO .LE. ONE) INFO = 1
- IF (DELTA .LE. XTOL*XNORM) INFO = 2
- IF (DABS(ACTRED) .LE. FTOL .AND. PRERED .LE. FTOL
- * .AND. P5*RATIO .LE. ONE .AND. INFO .EQ. 2) INFO = 3
- IF (INFO .NE. 0) GO TO 340
-C
-C TESTS FOR TERMINATION AND STRINGENT TOLERANCES.
-C
- IF (NFEV .GE. MAXFEV) INFO = 5
- IF (DABS(ACTRED) .LE. EPSMCH .AND. PRERED .LE. EPSMCH
- * .AND. P5*RATIO .LE. ONE) INFO = 6
- IF (DELTA .LE. EPSMCH*XNORM) INFO = 7
- IF (GNORM .LE. EPSMCH) INFO = 8
- IF (INFO .NE. 0) GO TO 340
-C
-C END OF THE INNER LOOP. REPEAT IF ITERATION UNSUCCESSFUL.
-C
- IF (RATIO .LT. P0001) GO TO 240
-C
-C END OF THE OUTER LOOP.
-C
- GO TO 30
- 340 CONTINUE
-C
-C TERMINATION, EITHER NORMAL OR USER IMPOSED.
-C
- IF (IFLAG .LT. 0) INFO = IFLAG
- IFLAG = 0
- IF (NPRINT .GT. 0) CALL FCN(M,N,X,FVEC,WA3,IFLAG)
- RETURN
-C
-C LAST CARD OF SUBROUTINE LMSTR.
-C
- END
- SUBROUTINE LMSTR1(FCN,M,N,X,FVEC,FJAC,LDFJAC,TOL,INFO,IPVT,WA,
- * LWA)
- INTEGER M,N,LDFJAC,INFO,LWA
- INTEGER IPVT(N)
- DOUBLE PRECISION TOL
- DOUBLE PRECISION X(N),FVEC(M),FJAC(LDFJAC,N),WA(LWA)
- EXTERNAL FCN
-C **********
-C
-C SUBROUTINE LMSTR1
-C
-C THE PURPOSE OF LMSTR1 IS TO MINIMIZE THE SUM OF THE SQUARES OF
-C M NONLINEAR FUNCTIONS IN N VARIABLES BY A MODIFICATION OF
-C THE LEVENBERG-MARQUARDT ALGORITHM WHICH USES MINIMAL STORAGE.
-C THIS IS DONE BY USING THE MORE GENERAL LEAST-SQUARES SOLVER
-C LMSTR. THE USER MUST PROVIDE A SUBROUTINE WHICH CALCULATES
-C THE FUNCTIONS AND THE ROWS OF THE JACOBIAN.
-C
-C THE SUBROUTINE STATEMENT IS
-C
-C SUBROUTINE LMSTR1(FCN,M,N,X,FVEC,FJAC,LDFJAC,TOL,INFO,
-C IPVT,WA,LWA)
-C
-C WHERE
-C
-C FCN IS THE NAME OF THE USER-SUPPLIED SUBROUTINE WHICH
-C CALCULATES THE FUNCTIONS AND THE ROWS OF THE JACOBIAN.
-C FCN MUST BE DECLARED IN AN EXTERNAL STATEMENT IN THE
-C USER CALLING PROGRAM, AND SHOULD BE WRITTEN AS FOLLOWS.
-C
-C SUBROUTINE FCN(M,N,X,FVEC,FJROW,IFLAG)
-C INTEGER M,N,IFLAG
-C DOUBLE PRECISION X(N),FVEC(M),FJROW(N)
-C ----------
-C IF IFLAG = 1 CALCULATE THE FUNCTIONS AT X AND
-C RETURN THIS VECTOR IN FVEC.
-C IF IFLAG = I CALCULATE THE (I-1)-ST ROW OF THE
-C JACOBIAN AT X AND RETURN THIS VECTOR IN FJROW.
-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 LMSTR1.
-C IN THIS CASE SET IFLAG TO A NEGATIVE INTEGER.
-C
-C M IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER
-C OF FUNCTIONS.
-C
-C N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER
-C OF VARIABLES. N MUST NOT EXCEED M.
-C
-C X IS AN ARRAY OF LENGTH N. ON INPUT X MUST CONTAIN
-C AN INITIAL ESTIMATE OF THE SOLUTION VECTOR. ON OUTPUT X
-C CONTAINS THE FINAL ESTIMATE OF THE SOLUTION VECTOR.
-C
-C FVEC IS AN OUTPUT ARRAY OF LENGTH M WHICH CONTAINS
-C THE FUNCTIONS EVALUATED AT THE OUTPUT X.
-C
-C FJAC IS AN OUTPUT N BY N ARRAY. THE UPPER TRIANGLE OF FJAC
-C CONTAINS AN UPPER TRIANGULAR MATRIX R SUCH THAT
-C
-C T T T
-C P *(JAC *JAC)*P = R *R,
-C
-C WHERE P IS A PERMUTATION MATRIX AND JAC IS THE FINAL
-C CALCULATED JACOBIAN. COLUMN J OF P IS COLUMN IPVT(J)
-C (SEE BELOW) OF THE IDENTITY MATRIX. THE LOWER TRIANGULAR
-C PART OF FJAC CONTAINS INFORMATION GENERATED DURING
-C THE COMPUTATION OF R.
-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 TOL IS A NONNEGATIVE INPUT VARIABLE. TERMINATION OCCURS
-C WHEN THE ALGORITHM ESTIMATES EITHER THAT THE RELATIVE
-C ERROR IN THE SUM OF SQUARES IS AT MOST TOL OR THAT
-C THE RELATIVE ERROR BETWEEN X AND THE SOLUTION IS AT
-C MOST TOL.
-C
-C INFO IS AN INTEGER OUTPUT VARIABLE. IF THE USER HAS
-C TERMINATED EXECUTION, INFO IS SET TO THE (NEGATIVE)
-C VALUE OF IFLAG. SEE DESCRIPTION OF FCN. OTHERWISE,
-C INFO IS SET AS FOLLOWS.
-C
-C INFO = 0 IMPROPER INPUT PARAMETERS.
-C
-C INFO = 1 ALGORITHM ESTIMATES THAT THE RELATIVE ERROR
-C IN THE SUM OF SQUARES IS AT MOST TOL.
-C
-C INFO = 2 ALGORITHM ESTIMATES THAT THE RELATIVE ERROR
-C BETWEEN X AND THE SOLUTION IS AT MOST TOL.
-C
-C INFO = 3 CONDITIONS FOR INFO = 1 AND INFO = 2 BOTH HOLD.
-C
-C INFO = 4 FVEC IS ORTHOGONAL TO THE COLUMNS OF THE
-C JACOBIAN TO MACHINE PRECISION.
-C
-C INFO = 5 NUMBER OF CALLS TO FCN WITH IFLAG = 1 HAS
-C REACHED 100*(N+1).
-C
-C INFO = 6 TOL IS TOO SMALL. NO FURTHER REDUCTION IN
-C THE SUM OF SQUARES IS POSSIBLE.
-C
-C INFO = 7 TOL IS TOO SMALL. NO FURTHER IMPROVEMENT IN
-C THE APPROXIMATE SOLUTION X IS POSSIBLE.
-C
-C IPVT IS AN INTEGER OUTPUT ARRAY OF LENGTH N. IPVT
-C DEFINES A PERMUTATION MATRIX P SUCH THAT JAC*P = Q*R,
-C WHERE JAC IS THE FINAL CALCULATED JACOBIAN, Q IS
-C ORTHOGONAL (NOT STORED), AND R IS UPPER TRIANGULAR.
-C COLUMN J OF P IS COLUMN IPVT(J) OF THE IDENTITY MATRIX.
-C
-C WA IS A WORK ARRAY OF LENGTH LWA.
-C
-C LWA IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN 5*N+M.
-C
-C SUBPROGRAMS CALLED
-C
-C USER-SUPPLIED ...... FCN
-C
-C MINPACK-SUPPLIED ... LMSTR
-C
-C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980.
-C BURTON S. GARBOW, DUDLEY V. GOETSCHEL, KENNETH E. HILLSTROM,
-C JORGE J. MORE
-C
-C **********
- INTEGER MAXFEV,MODE,NFEV,NJEV,NPRINT
- DOUBLE PRECISION FACTOR,FTOL,GTOL,XTOL,ZERO
- DATA FACTOR,ZERO /1.0D2,0.0D0/
- INFO = 0
-C
-C CHECK THE INPUT PARAMETERS FOR ERRORS.
-C
- IF (N .LE. 0 .OR. M .LT. N .OR. LDFJAC .LT. N .OR. TOL .LT. ZERO
- * .OR. LWA .LT. 5*N + M) GO TO 10
-C
-C CALL LMSTR.
-C
- MAXFEV = 100*(N + 1)
- FTOL = TOL
- XTOL = TOL
- GTOL = ZERO
- MODE = 1
- NPRINT = 0
- CALL LMSTR(FCN,M,N,X,FVEC,FJAC,LDFJAC,FTOL,XTOL,GTOL,MAXFEV,
- * WA(1),MODE,FACTOR,NPRINT,INFO,NFEV,NJEV,IPVT,WA(N+1),
- * WA(2*N+1),WA(3*N+1),WA(4*N+1),WA(5*N+1))
- IF (INFO .EQ. 8) INFO = 4
- 10 CONTINUE
- RETURN
-C
-C LAST CARD OF SUBROUTINE LMSTR1.
-C
- END
- SUBROUTINE QFORM(M,N,Q,LDQ,WA)
- INTEGER M,N,LDQ
- DOUBLE PRECISION Q(LDQ,M),WA(M)
-C **********
-C
-C SUBROUTINE QFORM
-C
-C THIS SUBROUTINE PROCEEDS FROM THE COMPUTED QR FACTORIZATION OF
-C AN M BY N MATRIX A TO ACCUMULATE THE M BY M ORTHOGONAL MATRIX
-C Q FROM ITS FACTORED FORM.
-C
-C THE SUBROUTINE STATEMENT IS
-C
-C SUBROUTINE QFORM(M,N,Q,LDQ,WA)
-C
-C WHERE
-C
-C M IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER
-C OF ROWS OF A AND THE ORDER OF Q.
-C
-C N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER
-C OF COLUMNS OF A.
-C
-C Q IS AN M BY M ARRAY. ON INPUT THE FULL LOWER TRAPEZOID IN
-C THE FIRST MIN(M,N) COLUMNS OF Q CONTAINS THE FACTORED FORM.
-C ON OUTPUT Q HAS BEEN ACCUMULATED INTO A SQUARE MATRIX.
-C
-C LDQ IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN M
-C WHICH SPECIFIES THE LEADING DIMENSION OF THE ARRAY Q.
-C
-C WA IS A WORK ARRAY OF LENGTH M.
-C
-C SUBPROGRAMS CALLED
-C
-C FORTRAN-SUPPLIED ... 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,JM1,K,L,MINMN,NP1
- DOUBLE PRECISION ONE,SUM,TEMP,ZERO
- DATA ONE,ZERO /1.0D0,0.0D0/
-C
-C ZERO OUT UPPER TRIANGLE OF Q IN THE FIRST MIN(M,N) COLUMNS.
-C
- MINMN = MIN0(M,N)
- IF (MINMN .LT. 2) GO TO 30
- DO 20 J = 2, MINMN
- JM1 = J - 1
- DO 10 I = 1, JM1
- Q(I,J) = ZERO
- 10 CONTINUE
- 20 CONTINUE
- 30 CONTINUE
-C
-C INITIALIZE REMAINING COLUMNS TO THOSE OF THE IDENTITY MATRIX.
-C
- NP1 = N + 1
- IF (M .LT. NP1) GO TO 60
- DO 50 J = NP1, M
- DO 40 I = 1, M
- Q(I,J) = ZERO
- 40 CONTINUE
- Q(J,J) = ONE
- 50 CONTINUE
- 60 CONTINUE
-C
-C ACCUMULATE Q FROM ITS FACTORED FORM.
-C
- DO 120 L = 1, MINMN
- K = MINMN - L + 1
- DO 70 I = K, M
- WA(I) = Q(I,K)
- Q(I,K) = ZERO
- 70 CONTINUE
- Q(K,K) = ONE
- IF (WA(K) .EQ. ZERO) GO TO 110
- DO 100 J = K, M
- SUM = ZERO
- DO 80 I = K, M
- SUM = SUM + Q(I,J)*WA(I)
- 80 CONTINUE
- TEMP = SUM/WA(K)
- DO 90 I = K, M
- Q(I,J) = Q(I,J) - TEMP*WA(I)
- 90 CONTINUE
- 100 CONTINUE
- 110 CONTINUE
- 120 CONTINUE
- 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 QRSOLV(N,R,LDR,IPVT,DIAG,QTB,X,SDIAG,WA)
- INTEGER N,LDR
- INTEGER IPVT(N)
- DOUBLE PRECISION R(LDR,N),DIAG(N),QTB(N),X(N),SDIAG(N),WA(N)
-C **********
-C
-C SUBROUTINE QRSOLV
-C
-C GIVEN AN M BY N MATRIX A, AN N BY N DIAGONAL MATRIX D,
-C AND AN M-VECTOR B, THE PROBLEM IS TO DETERMINE AN X WHICH
-C SOLVES THE SYSTEM
-C
-C A*X = B , D*X = 0 ,
-C
-C IN THE LEAST SQUARES SENSE.
-C
-C THIS SUBROUTINE COMPLETES THE SOLUTION OF THE PROBLEM
-C IF IT IS PROVIDED WITH THE NECESSARY INFORMATION FROM THE
-C QR FACTORIZATION, WITH COLUMN PIVOTING, OF A. THAT IS, IF
-C A*P = Q*R, WHERE P IS A PERMUTATION MATRIX, Q HAS ORTHOGONAL
-C COLUMNS, AND R IS AN UPPER TRIANGULAR MATRIX WITH DIAGONAL
-C ELEMENTS OF NONINCREASING MAGNITUDE, THEN QRSOLV EXPECTS
-C THE FULL UPPER TRIANGLE OF R, THE PERMUTATION MATRIX P,
-C AND THE FIRST N COMPONENTS OF (Q TRANSPOSE)*B. THE SYSTEM
-C A*X = B, D*X = 0, IS THEN EQUIVALENT TO
-C
-C T T
-C R*Z = Q *B , P *D*P*Z = 0 ,
-C
-C WHERE X = P*Z. IF THIS SYSTEM DOES NOT HAVE FULL RANK,
-C THEN A LEAST SQUARES SOLUTION IS OBTAINED. ON OUTPUT QRSOLV
-C ALSO PROVIDES AN UPPER TRIANGULAR MATRIX S SUCH THAT
-C
-C T T T
-C P *(A *A + D*D)*P = S *S .
-C
-C S IS COMPUTED WITHIN QRSOLV AND MAY BE OF SEPARATE INTEREST.
-C
-C THE SUBROUTINE STATEMENT IS
-C
-C SUBROUTINE QRSOLV(N,R,LDR,IPVT,DIAG,QTB,X,SDIAG,WA)
-C
-C WHERE
-C
-C N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE ORDER OF R.
-C
-C R IS AN N BY N ARRAY. ON INPUT THE FULL UPPER TRIANGLE
-C MUST CONTAIN THE FULL UPPER TRIANGLE OF THE MATRIX R.
-C ON OUTPUT THE FULL UPPER TRIANGLE IS UNALTERED, AND THE
-C STRICT LOWER TRIANGLE CONTAINS THE STRICT UPPER TRIANGLE
-C (TRANSPOSED) OF THE UPPER TRIANGULAR MATRIX S.
-C
-C LDR IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN N
-C WHICH SPECIFIES THE LEADING DIMENSION OF THE ARRAY R.
-C
-C IPVT IS AN INTEGER INPUT ARRAY OF LENGTH N WHICH DEFINES THE
-C PERMUTATION MATRIX P SUCH THAT A*P = Q*R. COLUMN J OF P
-C IS COLUMN IPVT(J) OF THE IDENTITY MATRIX.
-C
-C DIAG IS AN INPUT ARRAY OF LENGTH N WHICH MUST CONTAIN THE
-C DIAGONAL ELEMENTS OF THE MATRIX D.
-C
-C QTB IS AN INPUT ARRAY OF LENGTH N WHICH MUST CONTAIN THE FIRST
-C N ELEMENTS OF THE VECTOR (Q TRANSPOSE)*B.
-C
-C X IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS THE LEAST
-C SQUARES SOLUTION OF THE SYSTEM A*X = B, D*X = 0.
-C
-C SDIAG IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS THE
-C DIAGONAL ELEMENTS OF THE UPPER TRIANGULAR MATRIX S.
-C
-C WA IS A WORK ARRAY OF LENGTH N.
-C
-C SUBPROGRAMS CALLED
-C
-C FORTRAN-SUPPLIED ... DABS,DSQRT
-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,KP1,L,NSING
- DOUBLE PRECISION COS,COTAN,P5,P25,QTBPJ,SIN,SUM,TAN,TEMP,ZERO
- DATA P5,P25,ZERO /5.0D-1,2.5D-1,0.0D0/
-C
-C COPY R AND (Q TRANSPOSE)*B TO PRESERVE INPUT AND INITIALIZE S.
-C IN PARTICULAR, SAVE THE DIAGONAL ELEMENTS OF R IN X.
-C
- DO 20 J = 1, N
- DO 10 I = J, N
- R(I,J) = R(J,I)
- 10 CONTINUE
- X(J) = R(J,J)
- WA(J) = QTB(J)
- 20 CONTINUE
-C
-C ELIMINATE THE DIAGONAL MATRIX D USING A GIVENS ROTATION.
-C
- DO 100 J = 1, N
-C
-C PREPARE THE ROW OF D TO BE ELIMINATED, LOCATING THE
-C DIAGONAL ELEMENT USING P FROM THE QR FACTORIZATION.
-C
- L = IPVT(J)
- IF (DIAG(L) .EQ. ZERO) GO TO 90
- DO 30 K = J, N
- SDIAG(K) = ZERO
- 30 CONTINUE
- SDIAG(J) = DIAG(L)
-C
-C THE TRANSFORMATIONS TO ELIMINATE THE ROW OF D
-C MODIFY ONLY A SINGLE ELEMENT OF (Q TRANSPOSE)*B
-C BEYOND THE FIRST N, WHICH IS INITIALLY ZERO.
-C
- QTBPJ = ZERO
- DO 80 K = J, N
-C
-C DETERMINE A GIVENS ROTATION WHICH ELIMINATES THE
-C APPROPRIATE ELEMENT IN THE CURRENT ROW OF D.
-C
- IF (SDIAG(K) .EQ. ZERO) GO TO 70
- IF (DABS(R(K,K)) .GE. DABS(SDIAG(K))) GO TO 40
- COTAN = R(K,K)/SDIAG(K)
- SIN = P5/DSQRT(P25+P25*COTAN**2)
- COS = SIN*COTAN
- GO TO 50
- 40 CONTINUE
- TAN = SDIAG(K)/R(K,K)
- COS = P5/DSQRT(P25+P25*TAN**2)
- SIN = COS*TAN
- 50 CONTINUE
-C
-C COMPUTE THE MODIFIED DIAGONAL ELEMENT OF R AND
-C THE MODIFIED ELEMENT OF ((Q TRANSPOSE)*B,0).
-C
- R(K,K) = COS*R(K,K) + SIN*SDIAG(K)
- TEMP = COS*WA(K) + SIN*QTBPJ
- QTBPJ = -SIN*WA(K) + COS*QTBPJ
- WA(K) = TEMP
-C
-C ACCUMULATE THE TRANFORMATION IN THE ROW OF S.
-C
- KP1 = K + 1
- IF (N .LT. KP1) GO TO 70
- DO 60 I = KP1, N
- TEMP = COS*R(I,K) + SIN*SDIAG(I)
- SDIAG(I) = -SIN*R(I,K) + COS*SDIAG(I)
- R(I,K) = TEMP
- 60 CONTINUE
- 70 CONTINUE
- 80 CONTINUE
- 90 CONTINUE
-C
-C STORE THE DIAGONAL ELEMENT OF S AND RESTORE
-C THE CORRESPONDING DIAGONAL ELEMENT OF R.
-C
- SDIAG(J) = R(J,J)
- R(J,J) = X(J)
- 100 CONTINUE
-C
-C SOLVE THE TRIANGULAR SYSTEM FOR Z. IF THE SYSTEM IS
-C SINGULAR, THEN OBTAIN A LEAST SQUARES SOLUTION.
-C
- NSING = N
- DO 110 J = 1, N
- IF (SDIAG(J) .EQ. ZERO .AND. NSING .EQ. N) NSING = J - 1
- IF (NSING .LT. N) WA(J) = ZERO
- 110 CONTINUE
- IF (NSING .LT. 1) GO TO 150
- DO 140 K = 1, NSING
- J = NSING - K + 1
- SUM = ZERO
- JP1 = J + 1
- IF (NSING .LT. JP1) GO TO 130
- DO 120 I = JP1, NSING
- SUM = SUM + R(I,J)*WA(I)
- 120 CONTINUE
- 130 CONTINUE
- WA(J) = (WA(J) - SUM)/SDIAG(J)
- 140 CONTINUE
- 150 CONTINUE
-C
-C PERMUTE THE COMPONENTS OF Z BACK TO COMPONENTS OF X.
-C
- DO 160 J = 1, N
- L = IPVT(J)
- X(L) = WA(J)
- 160 CONTINUE
- RETURN
-C
-C LAST CARD OF SUBROUTINE QRSOLV.
-C
- END
- SUBROUTINE RWUPDT(N,R,LDR,W,B,ALPHA,COS,SIN)
- INTEGER N,LDR
- DOUBLE PRECISION ALPHA
- DOUBLE PRECISION R(LDR,N),W(N),B(N),COS(N),SIN(N)
-C **********
-C
-C SUBROUTINE RWUPDT
-C
-C GIVEN AN N BY N UPPER TRIANGULAR MATRIX R, THIS SUBROUTINE
-C COMPUTES THE QR DECOMPOSITION OF THE MATRIX FORMED WHEN A ROW
-C IS ADDED TO R. IF THE ROW IS SPECIFIED BY THE VECTOR W, THEN
-C RWUPDT DETERMINES AN ORTHOGONAL MATRIX Q SUCH THAT WHEN THE
-C N+1 BY N MATRIX COMPOSED OF R AUGMENTED BY W IS PREMULTIPLIED
-C BY (Q TRANSPOSE), THE RESULTING MATRIX IS UPPER TRAPEZOIDAL.
-C THE MATRIX (Q TRANSPOSE) IS THE PRODUCT OF N TRANSFORMATIONS
-C
-C G(N)*G(N-1)* ... *G(1)
-C
-C WHERE G(I) IS A GIVENS ROTATION IN THE (I,N+1) PLANE WHICH
-C ELIMINATES ELEMENTS IN THE (N+1)-ST PLANE. RWUPDT ALSO
-C COMPUTES THE PRODUCT (Q TRANSPOSE)*C WHERE C IS THE
-C (N+1)-VECTOR (B,ALPHA). Q ITSELF IS NOT ACCUMULATED, RATHER
-C THE INFORMATION TO RECOVER THE G ROTATIONS IS SUPPLIED.
-C
-C THE SUBROUTINE STATEMENT IS
-C
-C SUBROUTINE RWUPDT(N,R,LDR,W,B,ALPHA,COS,SIN)
-C
-C WHERE
-C
-C N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE ORDER OF R.
-C
-C R IS AN N BY N ARRAY. ON INPUT THE UPPER TRIANGULAR PART OF
-C R MUST CONTAIN THE MATRIX TO BE UPDATED. ON OUTPUT R
-C CONTAINS THE UPDATED TRIANGULAR MATRIX.
-C
-C LDR IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN N
-C WHICH SPECIFIES THE LEADING DIMENSION OF THE ARRAY R.
-C
-C W IS AN INPUT ARRAY OF LENGTH N WHICH MUST CONTAIN THE ROW
-C VECTOR TO BE ADDED TO R.
-C
-C B IS AN ARRAY OF LENGTH N. ON INPUT B MUST CONTAIN THE
-C FIRST N ELEMENTS OF THE VECTOR C. ON OUTPUT B CONTAINS
-C THE FIRST N ELEMENTS OF THE VECTOR (Q TRANSPOSE)*C.
-C
-C ALPHA IS A VARIABLE. ON INPUT ALPHA MUST CONTAIN THE
-C (N+1)-ST ELEMENT OF THE VECTOR C. ON OUTPUT ALPHA CONTAINS
-C THE (N+1)-ST ELEMENT OF THE VECTOR (Q TRANSPOSE)*C.
-C
-C COS IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS THE
-C COSINES OF THE TRANSFORMING GIVENS ROTATIONS.
-C
-C SIN IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS THE
-C SINES OF THE TRANSFORMING GIVENS ROTATIONS.
-C
-C SUBPROGRAMS CALLED
-C
-C FORTRAN-SUPPLIED ... DABS,DSQRT
-C
-C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980.
-C BURTON S. GARBOW, DUDLEY V. GOETSCHEL, KENNETH E. HILLSTROM,
-C JORGE J. MORE
-C
-C **********
- INTEGER I,J,JM1
- DOUBLE PRECISION COTAN,ONE,P5,P25,ROWJ,TAN,TEMP,ZERO
- DATA ONE,P5,P25,ZERO /1.0D0,5.0D-1,2.5D-1,0.0D0/
-C
- DO 60 J = 1, N
- ROWJ = W(J)
- JM1 = J - 1
-C
-C APPLY THE PREVIOUS TRANSFORMATIONS TO
-C R(I,J), I=1,2,...,J-1, AND TO W(J).
-C
- IF (JM1 .LT. 1) GO TO 20
- DO 10 I = 1, JM1
- TEMP = COS(I)*R(I,J) + SIN(I)*ROWJ
- ROWJ = -SIN(I)*R(I,J) + COS(I)*ROWJ
- R(I,J) = TEMP
- 10 CONTINUE
- 20 CONTINUE
-C
-C DETERMINE A GIVENS ROTATION WHICH ELIMINATES W(J).
-C
- COS(J) = ONE
- SIN(J) = ZERO
- IF (ROWJ .EQ. ZERO) GO TO 50
- IF (DABS(R(J,J)) .GE. DABS(ROWJ)) GO TO 30
- COTAN = R(J,J)/ROWJ
- SIN(J) = P5/DSQRT(P25+P25*COTAN**2)
- COS(J) = SIN(J)*COTAN
- GO TO 40
- 30 CONTINUE
- TAN = ROWJ/R(J,J)
- COS(J) = P5/DSQRT(P25+P25*TAN**2)
- SIN(J) = COS(J)*TAN
- 40 CONTINUE
-C
-C APPLY THE CURRENT TRANSFORMATION TO R(J,J), B(J), AND ALPHA.
-C
- R(J,J) = COS(J)*R(J,J) + SIN(J)*ROWJ
- TEMP = COS(J)*B(J) + SIN(J)*ALPHA
- ALPHA = -SIN(J)*B(J) + COS(J)*ALPHA
- B(J) = TEMP
- 50 CONTINUE
- 60 CONTINUE
- RETURN
-C
-C LAST CARD OF SUBROUTINE RWUPDT.
-C
- END
- SUBROUTINE R1MPYQ(M,N,A,LDA,V,W)
- INTEGER M,N,LDA
- DOUBLE PRECISION A(LDA,N),V(N),W(N)
-C **********
-C
-C SUBROUTINE R1MPYQ
-C
-C GIVEN AN M BY N MATRIX A, THIS SUBROUTINE COMPUTES A*Q WHERE
-C Q IS THE PRODUCT OF 2*(N - 1) TRANSFORMATIONS
-C
-C GV(N-1)*...*GV(1)*GW(1)*...*GW(N-1)
-C
-C AND GV(I), GW(I) ARE GIVENS ROTATIONS IN THE (I,N) PLANE WHICH
-C ELIMINATE ELEMENTS IN THE I-TH AND N-TH PLANES, RESPECTIVELY.
-C Q ITSELF IS NOT GIVEN, RATHER THE INFORMATION TO RECOVER THE
-C GV, GW ROTATIONS IS SUPPLIED.
-C
-C THE SUBROUTINE STATEMENT IS
-C
-C SUBROUTINE R1MPYQ(M,N,A,LDA,V,W)
-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 MUST CONTAIN THE MATRIX
-C TO BE POSTMULTIPLIED BY THE ORTHOGONAL MATRIX Q
-C DESCRIBED ABOVE. ON OUTPUT A*Q HAS REPLACED A.
-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 V IS AN INPUT ARRAY OF LENGTH N. V(I) MUST CONTAIN THE
-C INFORMATION NECESSARY TO RECOVER THE GIVENS ROTATION GV(I)
-C DESCRIBED ABOVE.
-C
-C W IS AN INPUT ARRAY OF LENGTH N. W(I) MUST CONTAIN THE
-C INFORMATION NECESSARY TO RECOVER THE GIVENS ROTATION GW(I)
-C DESCRIBED ABOVE.
-C
-C SUBROUTINES CALLED
-C
-C FORTRAN-SUPPLIED ... DABS,DSQRT
-C
-C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980.
-C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE
-C
-C **********
- INTEGER I,J,NMJ,NM1
- DOUBLE PRECISION COS,ONE,SIN,TEMP
- DATA ONE /1.0D0/
-C
-C APPLY THE FIRST SET OF GIVENS ROTATIONS TO A.
-C
- NM1 = N - 1
- IF (NM1 .LT. 1) GO TO 50
- DO 20 NMJ = 1, NM1
- J = N - NMJ
- IF (DABS(V(J)) .GT. ONE) COS = ONE/V(J)
- IF (DABS(V(J)) .GT. ONE) SIN = DSQRT(ONE-COS**2)
- IF (DABS(V(J)) .LE. ONE) SIN = V(J)
- IF (DABS(V(J)) .LE. ONE) COS = DSQRT(ONE-SIN**2)
- DO 10 I = 1, M
- TEMP = COS*A(I,J) - SIN*A(I,N)
- A(I,N) = SIN*A(I,J) + COS*A(I,N)
- A(I,J) = TEMP
- 10 CONTINUE
- 20 CONTINUE
-C
-C APPLY THE SECOND SET OF GIVENS ROTATIONS TO A.
-C
- DO 40 J = 1, NM1
- IF (DABS(W(J)) .GT. ONE) COS = ONE/W(J)
- IF (DABS(W(J)) .GT. ONE) SIN = DSQRT(ONE-COS**2)
- IF (DABS(W(J)) .LE. ONE) SIN = W(J)
- IF (DABS(W(J)) .LE. ONE) COS = DSQRT(ONE-SIN**2)
- DO 30 I = 1, M
- TEMP = COS*A(I,J) + SIN*A(I,N)
- A(I,N) = -SIN*A(I,J) + COS*A(I,N)
- A(I,J) = TEMP
- 30 CONTINUE
- 40 CONTINUE
- 50 CONTINUE
- RETURN
-C
-C LAST CARD OF SUBROUTINE R1MPYQ.
-C
- END
- SUBROUTINE R1UPDT(M,N,S,LS,U,V,W,SING)
- INTEGER M,N,LS
- LOGICAL SING
- DOUBLE PRECISION S(LS),U(M),V(N),W(M)
-C **********
-C
-C SUBROUTINE R1UPDT
-C
-C GIVEN AN M BY N LOWER TRAPEZOIDAL MATRIX S, AN M-VECTOR U,
-C AND AN N-VECTOR V, THE PROBLEM IS TO DETERMINE AN
-C ORTHOGONAL MATRIX Q SUCH THAT
-C
-C T
-C (S + U*V )*Q
-C
-C IS AGAIN LOWER TRAPEZOIDAL.
-C
-C THIS SUBROUTINE DETERMINES Q AS THE PRODUCT OF 2*(N - 1)
-C TRANSFORMATIONS
-C
-C GV(N-1)*...*GV(1)*GW(1)*...*GW(N-1)
-C
-C WHERE GV(I), GW(I) ARE GIVENS ROTATIONS IN THE (I,N) PLANE
-C WHICH ELIMINATE ELEMENTS IN THE I-TH AND N-TH PLANES,
-C RESPECTIVELY. Q ITSELF IS NOT ACCUMULATED, RATHER THE
-C INFORMATION TO RECOVER THE GV, GW ROTATIONS IS RETURNED.
-C
-C THE SUBROUTINE STATEMENT IS
-C
-C SUBROUTINE R1UPDT(M,N,S,LS,U,V,W,SING)
-C
-C WHERE
-C
-C M IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER
-C OF ROWS OF S.
-C
-C N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER
-C OF COLUMNS OF S. N MUST NOT EXCEED M.
-C
-C S IS AN ARRAY OF LENGTH LS. ON INPUT S MUST CONTAIN THE LOWER
-C TRAPEZOIDAL MATRIX S STORED BY COLUMNS. ON OUTPUT S CONTAINS
-C THE LOWER TRAPEZOIDAL MATRIX PRODUCED AS DESCRIBED ABOVE.
-C
-C LS IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN
-C (N*(2*M-N+1))/2.
-C
-C U IS AN INPUT ARRAY OF LENGTH M WHICH MUST CONTAIN THE
-C VECTOR U.
-C
-C V IS AN ARRAY OF LENGTH N. ON INPUT V MUST CONTAIN THE VECTOR
-C V. ON OUTPUT V(I) CONTAINS THE INFORMATION NECESSARY TO
-C RECOVER THE GIVENS ROTATION GV(I) DESCRIBED ABOVE.
-C
-C W IS AN OUTPUT ARRAY OF LENGTH M. W(I) CONTAINS INFORMATION
-C NECESSARY TO RECOVER THE GIVENS ROTATION GW(I) DESCRIBED
-C ABOVE.
-C
-C SING IS A LOGICAL OUTPUT VARIABLE. SING IS SET TRUE IF ANY
-C OF THE DIAGONAL ELEMENTS OF THE OUTPUT S ARE ZERO. OTHERWISE
-C SING IS SET FALSE.
-C
-C SUBPROGRAMS CALLED
-C
-C MINPACK-SUPPLIED ... DPMPAR
-C
-C FORTRAN-SUPPLIED ... DABS,DSQRT
-C
-C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980.
-C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE,
-C JOHN L. NAZARETH
-C
-C **********
- INTEGER I,J,JJ,L,NMJ,NM1
- DOUBLE PRECISION COS,COTAN,GIANT,ONE,P5,P25,SIN,TAN,TAU,TEMP,
- * ZERO
- DOUBLE PRECISION DPMPAR
- DATA ONE,P5,P25,ZERO /1.0D0,5.0D-1,2.5D-1,0.0D0/
-C
-C GIANT IS THE LARGEST MAGNITUDE.
-C
- GIANT = DPMPAR(3)
-C
-C INITIALIZE THE DIAGONAL ELEMENT POINTER.
-C
- JJ = (N*(2*M - N + 1))/2 - (M - N)
-C
-C MOVE THE NONTRIVIAL PART OF THE LAST COLUMN OF S INTO W.
-C
- L = JJ
- DO 10 I = N, M
- W(I) = S(L)
- L = L + 1
- 10 CONTINUE
-C
-C ROTATE THE VECTOR V INTO A MULTIPLE OF THE N-TH UNIT VECTOR
-C IN SUCH A WAY THAT A SPIKE IS INTRODUCED INTO W.
-C
- NM1 = N - 1
- IF (NM1 .LT. 1) GO TO 70
- DO 60 NMJ = 1, NM1
- J = N - NMJ
- JJ = JJ - (M - J + 1)
- W(J) = ZERO
- IF (V(J) .EQ. ZERO) GO TO 50
-C
-C DETERMINE A GIVENS ROTATION WHICH ELIMINATES THE
-C J-TH ELEMENT OF V.
-C
- IF (DABS(V(N)) .GE. DABS(V(J))) GO TO 20
- COTAN = V(N)/V(J)
- SIN = P5/DSQRT(P25+P25*COTAN**2)
- COS = SIN*COTAN
- TAU = ONE
- IF (DABS(COS)*GIANT .GT. ONE) TAU = ONE/COS
- GO TO 30
- 20 CONTINUE
- TAN = V(J)/V(N)
- COS = P5/DSQRT(P25+P25*TAN**2)
- SIN = COS*TAN
- TAU = SIN
- 30 CONTINUE
-C
-C APPLY THE TRANSFORMATION TO V AND STORE THE INFORMATION
-C NECESSARY TO RECOVER THE GIVENS ROTATION.
-C
- V(N) = SIN*V(J) + COS*V(N)
- V(J) = TAU
-C
-C APPLY THE TRANSFORMATION TO S AND EXTEND THE SPIKE IN W.
-C
- L = JJ
- DO 40 I = J, M
- TEMP = COS*S(L) - SIN*W(I)
- W(I) = SIN*S(L) + COS*W(I)
- S(L) = TEMP
- L = L + 1
- 40 CONTINUE
- 50 CONTINUE
- 60 CONTINUE
- 70 CONTINUE
-C
-C ADD THE SPIKE FROM THE RANK 1 UPDATE TO W.
-C
- DO 80 I = 1, M
- W(I) = W(I) + V(N)*U(I)
- 80 CONTINUE
-C
-C ELIMINATE THE SPIKE.
-C
- SING = .FALSE.
- IF (NM1 .LT. 1) GO TO 140
- DO 130 J = 1, NM1
- IF (W(J) .EQ. ZERO) GO TO 120
-C
-C DETERMINE A GIVENS ROTATION WHICH ELIMINATES THE
-C J-TH ELEMENT OF THE SPIKE.
-C
- IF (DABS(S(JJ)) .GE. DABS(W(J))) GO TO 90
- COTAN = S(JJ)/W(J)
- SIN = P5/DSQRT(P25+P25*COTAN**2)
- COS = SIN*COTAN
- TAU = ONE
- IF (DABS(COS)*GIANT .GT. ONE) TAU = ONE/COS
- GO TO 100
- 90 CONTINUE
- TAN = W(J)/S(JJ)
- COS = P5/DSQRT(P25+P25*TAN**2)
- SIN = COS*TAN
- TAU = SIN
- 100 CONTINUE
-C
-C APPLY THE TRANSFORMATION TO S AND REDUCE THE SPIKE IN W.
-C
- L = JJ
- DO 110 I = J, M
- TEMP = COS*S(L) + SIN*W(I)
- W(I) = -SIN*S(L) + COS*W(I)
- S(L) = TEMP
- L = L + 1
- 110 CONTINUE
-C
-C STORE THE INFORMATION NECESSARY TO RECOVER THE
-C GIVENS ROTATION.
-C
- W(J) = TAU
- 120 CONTINUE
-C
-C TEST FOR ZERO DIAGONAL ELEMENTS IN THE OUTPUT S.
-C
- IF (S(JJ) .EQ. ZERO) SING = .TRUE.
- JJ = JJ + (M - J + 1)
- 130 CONTINUE
- 140 CONTINUE
-C
-C MOVE W BACK INTO THE LAST COLUMN OF THE OUTPUT S.
-C
- L = JJ
- DO 150 I = N, M
- S(L) = W(I)
- L = L + 1
- 150 CONTINUE
- IF (S(JJ) .EQ. ZERO) SING = .TRUE.
- RETURN
-C
-C LAST CARD OF SUBROUTINE R1UPDT.
-C
- END
diff --git a/CEP/PyBDSM/src/minpack/ex/file06 b/CEP/PyBDSM/src/minpack/ex/file06
deleted file mode 100644
index b9da052be2742f119b7167e783e0afdfc0c5fd04..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/minpack/ex/file06
+++ /dev/null
@@ -1,3528 +0,0 @@
-1
-0 Page
-0 Documentation for MINPACK subroutine HYBRD1
-0 Double precision version
-0 Argonne National Laboratory
-0 Burton S. Garbow, Kenneth E. Hillstrom, Jorge J. More
-0 March 1980
-0
- 1. Purpose.
-0 The purpose of HYBRD1 is to find a zero of a system of N non-
- linear functions in N variables by a modification of the Powell
- hybrid method. This is done by using the more general nonlinea
- equation solver HYBRD. The user must provide a subroutine whic
- calculates the functions. The Jacobian is then calculated by a
- forward-difference approximation.
-0
- 2. Subroutine and type statements.
-0 SUBROUTINE HYBRD1(FCN,N,X,FVEC,TOL,INFO,WA,LWA)
- INTEGER N,INFO,LWA
- DOUBLE PRECISION TOL
- DOUBLE PRECISION X(N),FVEC(N),WA(LWA)
- EXTERNAL FCN
-0
- 3. Parameters.
-0 Parameters designated as input parameters must be specified on
- entry to HYBRD1 and are not changed on exit, while parameters
- designated as output parameters need not be specified on entry
- and are set to appropriate values on exit from HYBRD1.
-0 FCN is the name of the user-supplied subroutine which calculate
- the functions. FCN must be declared in an EXTERNAL statement
- in the user calling program, and should be written as follows
-0 SUBROUTINE FCN(N,X,FVEC,IFLAG)
- INTEGER N,IFLAG
- DOUBLE PRECISION X(N),FVEC(N)
- ----------
- CALCULATE THE FUNCTIONS AT X AND
- RETURN THIS VECTOR IN FVEC.
- ----------
- RETURN
- END
-0 The value of IFLAG should not be changed by FCN unless the
- user wants to terminate execution of HYBRD1. In this case se
- IFLAG to a negative integer.
-1
-0 Page
-0 N is a positive integer input variable set to the number of
- functions and variables.
-0 X is an array of length N. On input X must contain an initial
- estimate of the solution vector. On output X contains the
- final estimate of the solution vector.
-0 FVEC is an output array of length N which contains the function
- evaluated at the output X.
-0 TOL is a nonnegative input variable. Termination occurs when
- the algorithm estimates that the relative error between X and
- the solution is at most TOL. Section 4 contains more details
- about TOL.
-0 INFO is an integer output variable. If the user has terminated
- execution, INFO is set to the (negative) value of IFLAG. See
- description of FCN. Otherwise, INFO is set as follows.
-0 INFO = 0 Improper input parameters.
-0 INFO = 1 Algorithm estimates that the relative error between
- X and the solution is at most TOL.
-0 INFO = 2 Number of calls to FCN has reached or exceeded
- 200*(N+1).
-0 INFO = 3 TOL is too small. No further improvement in the
- approximate solution X is possible.
-0 INFO = 4 Iteration is not making good progress.
-0 Sections 4 and 5 contain more details about INFO.
-0 WA is a work array of length LWA.
-0 LWA is a positive integer input variable not less than
- (N*(3*N+13))/2.
-0
- 4. Successful completion.
-0 The accuracy of HYBRD1 is controlled by the convergence parame-
- ter TOL. This parameter is used in a test which makes a compar
- ison between the approximation X and a solution XSOL. HYBRD1
- terminates when the test is satisfied. If TOL is less than the
- machine precision (as defined by the MINPACK function
- DPMPAR(1)), then HYBRD1 only attempts to satisfy the test
- defined by the machine precision. Further progress is not usu-
- ally possible. Unless high precision solutions are required,
- the recommended value for TOL is the square root of the machine
- precision.
-0 The test assumes that the functions are reasonably well behaved
-1
-0 Page
-0 If this condition is not satisfied, then HYBRD1 may incorrectly
- indicate convergence. The validity of the answer can be
- checked, for example, by rerunning HYBRD1 with a tighter toler-
- ance.
-0 Convergence test. If ENORM(Z) denotes the Euclidean norm of a
- vector Z, then this test attempts to guarantee that
-0 ENORM(X-XSOL) .LE. TOL*ENORM(XSOL).
-0 If this condition is satisfied with TOL = 10**(-K), then the
- larger components of X have K significant decimal digits and
- INFO is set to 1. There is a danger that the smaller compo-
- nents of X may have large relative errors, but the fast rate
- of convergence of HYBRD1 usually avoids this possibility.
-0
- 5. Unsuccessful completion.
-0 Unsuccessful termination of HYBRD1 can be due to improper input
- parameters, arithmetic interrupts, an excessive number of func-
- tion evaluations, errors in the functions, or lack of good prog
- ress.
-0 Improper input parameters. INFO is set to 0 if N .LE. 0, or
- TOL .LT. 0.D0, or LWA .LT. (N*(3*N+13))/2.
-0 Arithmetic interrupts. If these interrupts occur in the FCN
- subroutine during an early stage of the computation, they may
- be caused by an unacceptable choice of X by HYBRD1. In this
- case, it may be possible to remedy the situation by not evalu
- ating the functions here, but instead setting the components
- of FVEC to numbers that exceed those in the initial FVEC,
- thereby indirectly reducing the step length. The step length
- can be more directly controlled by using instead HYBRD, which
- includes in its calling sequence the step-length- governing
- parameter FACTOR.
-0 Excessive number of function evaluations. If the number of
- calls to FCN reaches 200*(N+1), then this indicates that the
- routine is converging very slowly as measured by the progress
- of FVEC, and INFO is set to 2. This situation should be unu-
- sual because, as indicated below, lack of good progress is
- usually diagnosed earlier by HYBRD1, causing termination with
- INFO = 4.
-0 Errors in the functions. The choice of step length in the for-
- ward-difference approximation to the Jacobian assumes that th
- relative errors in the functions are of the order of the
- machine precision. If this is not the case, HYBRD1 may fail
- (usually with INFO = 4). The user should then use HYBRD
- instead, or one of the programs which require the analytic
- Jacobian (HYBRJ1 and HYBRJ).
-1
-0 Page
-0 Lack of good progress. HYBRD1 searches for a zero of the syste
- by minimizing the sum of the squares of the functions. In so
- doing, it can become trapped in a region where the minimum
- does not correspond to a zero of the system and, in this situ
- ation, the iteration eventually fails to make good progress.
- In particular, this will happen if the system does not have a
- zero. If the system has a zero, rerunning HYBRD1 from a dif-
- ferent starting point may be helpful.
-0
- 6. Characteristics of the algorithm.
-0 HYBRD1 is a modification of the Powell hybrid method. Two of
- its main characteristics involve the choice of the correction a
- a convex combination of the Newton and scaled gradient direc-
- tions, and the updating of the Jacobian by the rank-1 method of
- Broyden. The choice of the correction guarantees (under reason
- able conditions) global convergence for starting points far fro
- the solution and a fast rate of convergence. The Jacobian is
- approximated by forward differences at the starting point, but
- forward differences are not used again until the rank-1 method
- fails to produce satisfactory progress.
-0 Timing. The time required by HYBRD1 to solve a given problem
- depends on N, the behavior of the functions, the accuracy
- requested, and the starting point. The number of arithmetic
- operations needed by HYBRD1 is about 11.5*(N**2) to process
- each call to FCN. Unless FCN can be evaluated quickly, the
- timing of HYBRD1 will be strongly influenced by the time spen
- in FCN.
-0 Storage. HYBRD1 requires (3*N**2 + 17*N)/2 double precision
- storage locations, in addition to the storage required by the
- program. There are no internally declared storage arrays.
-0
- 7. Subprograms required.
-0 USER-supplied ...... FCN
-0 MINPACK-supplied ... DOGLEG,DPMPAR,ENORM,FDJAC1,HYBRD,
- QFORM,QRFAC,R1MPYQ,R1UPDT
-0 FORTRAN-supplied ... DABS,DMAX1,DMIN1,DSQRT,MIN0,MOD
-0
- 8. References.
-0 M. J. D. Powell, A Hybrid Method for Nonlinear Equations.
- Numerical Methods for Nonlinear Algebraic Equations,
- P. Rabinowitz, editor. Gordon and Breach, 1970.
-0
- 9. Example.
-1
-0 Page
-0 The problem is to determine the values of x(1), x(2), ..., x(9)
- which solve the system of tridiagonal equations
-0 (3-2*x(1))*x(1) -2*x(2) = -1
- -x(i-1) + (3-2*x(i))*x(i) -2*x(i+1) = -1, i=2-8
- -x(8) + (3-2*x(9))*x(9) = -1
-0 C **********
- C
- C DRIVER FOR HYBRD1 EXAMPLE.
- C DOUBLE PRECISION VERSION
- C
- C **********
- INTEGER J,N,INFO,LWA,NWRITE
- DOUBLE PRECISION TOL,FNORM
- DOUBLE PRECISION X(9),FVEC(9),WA(180)
- DOUBLE PRECISION ENORM,DPMPAR
- EXTERNAL FCN
- C
- C LOGICAL OUTPUT UNIT IS ASSUMED TO BE NUMBER 6.
- C
- DATA NWRITE /6/
- C
- N = 9
- C
- C THE FOLLOWING STARTING VALUES PROVIDE A ROUGH SOLUTION.
- C
- DO 10 J = 1, 9
- X(J) = -1.D0
- 10 CONTINUE
- C
- LWA = 180
- C
- C SET TOL TO THE SQUARE ROOT OF THE MACHINE PRECISION.
- C UNLESS HIGH PRECISION SOLUTIONS ARE REQUIRED,
- C THIS IS THE RECOMMENDED SETTING.
- C
- TOL = DSQRT(DPMPAR(1))
- C
- CALL HYBRD1(FCN,N,X,FVEC,TOL,INFO,WA,LWA)
- FNORM = ENORM(N,FVEC)
- WRITE (NWRITE,1000) FNORM,INFO,(X(J),J=1,N)
- STOP
- 1000 FORMAT (5X,31H FINAL L2 NORM OF THE RESIDUALS,D15.7 //
- * 5X,15H EXIT PARAMETER,16X,I10 //
- * 5X,27H FINAL APPROXIMATE SOLUTION // (5X,3D15.7))
- C
- C LAST CARD OF DRIVER FOR HYBRD1 EXAMPLE.
- C
- END
- SUBROUTINE FCN(N,X,FVEC,IFLAG)
- INTEGER N,IFLAG
- DOUBLE PRECISION X(N),FVEC(N)
- C
-1
-0 Page
-0 C SUBROUTINE FCN FOR HYBRD1 EXAMPLE.
- C
- INTEGER K
- DOUBLE PRECISION ONE,TEMP,TEMP1,TEMP2,THREE,TWO,ZERO
- DATA ZERO,ONE,TWO,THREE /0.D0,1.D0,2.D0,3.D0/
- C
- DO 10 K = 1, N
- TEMP = (THREE - TWO*X(K))*X(K)
- TEMP1 = ZERO
- IF (K .NE. 1) TEMP1 = X(K-1)
- TEMP2 = ZERO
- IF (K .NE. N) TEMP2 = X(K+1)
- FVEC(K) = TEMP - TEMP1 - TWO*TEMP2 + ONE
- 10 CONTINUE
- RETURN
- C
- C LAST CARD OF SUBROUTINE FCN.
- C
- END
-0 Results obtained with different compilers or machines
- may be slightly different.
-0 FINAL L2 NORM OF THE RESIDUALS 0.1192636D-07
-0 EXIT PARAMETER 1
-0 FINAL APPROXIMATE SOLUTION
-0 -0.5706545D+00 -0.6816283D+00 -0.7017325D+00
- -0.7042129D+00 -0.7013690D+00 -0.6918656D+00
- -0.6657920D+00 -0.5960342D+00 -0.4164121D+00
-1
-0
-1
-0 Page
-0 Documentation for MINPACK subroutine HYBRD
-0 Double precision version
-0 Argonne National Laboratory
-0 Burton S. Garbow, Kenneth E. Hillstrom, Jorge J. More
-0 March 1980
-0
- 1. Purpose.
-0 The purpose of HYBRD is to find a zero of a system of N non-
- linear functions in N variables by a modification of the Powell
- hybrid method. The user must provide a subroutine which calcu-
- lates the functions. The Jacobian is then calculated by a for-
- ward-difference approximation.
-0
- 2. Subroutine and type statements.
-0 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(
- * WA1(N),WA2(N),WA3(N),WA4(N)
- EXTERNAL FCN
-0
- 3. Parameters.
-0 Parameters designated as input parameters must be specified on
- entry to HYBRD and are not changed on exit, while parameters
- designated as output parameters need not be specified on entry
- and are set to appropriate values on exit from HYBRD.
-0 FCN is the name of the user-supplied subroutine which calculate
- the functions. FCN must be declared in an EXTERNAL statement
- in the user calling program, and should be written as follows
-0 SUBROUTINE FCN(N,X,FVEC,IFLAG)
- INTEGER N,IFLAG
- DOUBLE PRECISION X(N),FVEC(N)
- ----------
- CALCULATE THE FUNCTIONS AT X AND
- RETURN THIS VECTOR IN FVEC.
- ----------
- RETURN
- END
-0 The value of IFLAG should not be changed by FCN unless the
-1
-0 Page
-0 user wants to terminate execution of HYBRD. In this case set
- IFLAG to a negative integer.
-0 N is a positive integer input variable set to the number of
- functions and variables.
-0 X is an array of length N. On input X must contain an initial
- estimate of the solution vector. On output X contains the
- final estimate of the solution vector.
-0 FVEC is an output array of length N which contains the function
- evaluated at the output X.
-0 XTOL is a nonnegative input variable. Termination occurs when
- the relative error between two consecutive iterates is at mos
- XTOL. Therefore, XTOL measures the relative error desired in
- the approximate solution. Section 4 contains more details
- about XTOL.
-0 MAXFEV is a positive integer input variable. Termination occur
- when the number of calls to FCN is at least MAXFEV by the end
- of an iteration.
-0 ML is a nonnegative integer input variable which specifies the
- number of subdiagonals within the band of the Jacobian matrix
- If the Jacobian is not banded, set ML to at least N - 1.
-0 MU is a nonnegative integer input variable which specifies the
- number of superdiagonals within the band of the Jacobian
- matrix. If the Jacobian is not banded, set MU to at least
- N - 1.
-0 EPSFCN is an input variable used in determining a suitable step
- for the forward-difference approximation. This approximation
- assumes that the relative errors in the functions are of the
- order of EPSFCN. If EPSFCN is less than the machine preci-
- sion, it is assumed that the relative errors in the functions
- are of the order of the machine precision.
-0 DIAG is an array of length N. If MODE = 1 (see below), DIAG is
- internally set. If MODE = 2, DIAG must contain positive
- entries that serve as multiplicative scale factors for the
- variables.
-0 MODE is an integer input variable. If MODE = 1, the variables
- will be scaled internally. If MODE = 2, the scaling is speci
- fied by the input DIAG. Other values of MODE are equivalent
- to MODE = 1.
-0 FACTOR is a positive input variable used in determining the ini
- tial step bound. This bound is set to the product of FACTOR
- and the Euclidean norm of DIAG*X if nonzero, or else to FACTO
- itself. In most cases FACTOR should lie in the interval
- (.1,100.). 100. is a generally recommended value.
-1
-0 Page
-0 NPRINT is an integer input variable that enables controlled
- printing of iterates if it is positive. In this case, FCN is
- called with IFLAG = 0 at the beginning of the first iteration
- and every NPRINT iterations thereafter and immediately prior
- to return, with X and FVEC available for printing. If NPRINT
- is not positive, no special calls of FCN with IFLAG = 0 are
- made.
-0 INFO is an integer output variable. If the user has terminated
- execution, INFO is set to the (negative) value of IFLAG. See
- description of FCN. Otherwise, INFO is set as follows.
-0 INFO = 0 Improper input parameters.
-0 INFO = 1 Relative error between two consecutive iterates is
- at most XTOL.
-0 INFO = 2 Number of calls to FCN has reached or exceeded
- MAXFEV.
-0 INFO = 3 XTOL is too small. No further improvement in the
- approximate solution X is possible.
-0 INFO = 4 Iteration is not making good progress, as measured
- by the improvement from the last five Jacobian eval
- uations.
-0 INFO = 5 Iteration is not making good progress, as measured
- by the improvement from the last ten iterations.
-0 Sections 4 and 5 contain more details about INFO.
-0 NFEV is an integer output variable set to the number of calls t
- FCN.
-0 FJAC is an output N by N array which contains the orthogonal
- matrix Q produced by the QR factorization of the final approx
- imate Jacobian.
-0 LDFJAC is a positive integer input variable not less than N
- which specifies the leading dimension of the array FJAC.
-0 R is an output array of length LR which contains the upper
- triangular matrix produced by the QR factorization of the
- final approximate Jacobian, stored rowwise.
-0 LR is a positive integer input variable not less than
- (N*(N+1))/2.
-0 QTF is an output array of length N which contains the vector
- (Q transpose)*FVEC.
-0 WA1, WA2, WA3, and WA4 are work arrays of length N.
-1
-0 Page
-0
- 4. Successful completion.
-0 The accuracy of HYBRD is controlled by the convergence paramete
- XTOL. This parameter is used in a test which makes a compariso
- between the approximation X and a solution XSOL. HYBRD termi-
- nates when the test is satisfied. If the convergence parameter
- is less than the machine precision (as defined by the MINPACK
- function DPMPAR(1)), then HYBRD only attempts to satisfy the
- test defined by the machine precision. Further progress is not
- usually possible.
-0 The test assumes that the functions are reasonably well behaved
- If this condition is not satisfied, then HYBRD may incorrectly
- indicate convergence. The validity of the answer can be
- checked, for example, by rerunning HYBRD with a tighter toler-
- ance.
-0 Convergence test. If ENORM(Z) denotes the Euclidean norm of a
- vector Z and D is the diagonal matrix whose entries are
- defined by the array DIAG, then this test attempts to guaran-
- tee that
-0 ENORM(D*(X-XSOL)) .LE. XTOL*ENORM(D*XSOL).
-0 If this condition is satisfied with XTOL = 10**(-K), then the
- larger components of D*X have K significant decimal digits an
- INFO is set to 1. There is a danger that the smaller compo-
- nents of D*X may have large relative errors, but the fast rat
- of convergence of HYBRD usually avoids this possibility.
- Unless high precision solutions are required, the recommended
- value for XTOL is the square root of the machine precision.
-0
- 5. Unsuccessful completion.
-0 Unsuccessful termination of HYBRD can be due to improper input
- parameters, arithmetic interrupts, an excessive number of func-
- tion evaluations, or lack of good progress.
-0 Improper input parameters. INFO is set to 0 if N .LE. 0, or
- XTOL .LT. 0.D0, or MAXFEV .LE. 0, or ML .LT. 0, or MU .LT. 0,
- or FACTOR .LE. 0.D0, or LDFJAC .LT. N, or LR .LT. (N*(N+1))/2
-0 Arithmetic interrupts. If these interrupts occur in the FCN
- subroutine during an early stage of the computation, they may
- be caused by an unacceptable choice of X by HYBRD. In this
- case, it may be possible to remedy the situation by rerunning
- HYBRD with a smaller value of FACTOR.
-0 Excessive number of function evaluations. A reasonable value
- for MAXFEV is 200*(N+1). If the number of calls to FCN
- reaches MAXFEV, then this indicates that the routine is con-
- verging very slowly as measured by the progress of FVEC, and
-1
-0 Page
-0 INFO is set to 2. This situation should be unusual because,
- as indicated below, lack of good progress is usually diagnose
- earlier by HYBRD, causing termination with INFO = 4 or
- INFO = 5.
-0 Lack of good progress. HYBRD searches for a zero of the system
- by minimizing the sum of the squares of the functions. In so
- doing, it can become trapped in a region where the minimum
- does not correspond to a zero of the system and, in this situ
- ation, the iteration eventually fails to make good progress.
- In particular, this will happen if the system does not have a
- zero. If the system has a zero, rerunning HYBRD from a dif-
- ferent starting point may be helpful.
-0
- 6. Characteristics of the algorithm.
-0 HYBRD is a modification of the Powell hybrid method. Two of it
- main characteristics involve the choice of the correction as a
- convex combination of the Newton and scaled gradient directions
- and the updating of the Jacobian by the rank-1 method of Broy-
- den. The choice of the correction guarantees (under reasonable
- conditions) global convergence for starting points far from the
- solution and a fast rate of convergence. The Jacobian is
- approximated by forward differences at the starting point, but
- forward differences are not used again until the rank-1 method
- fails to produce satisfactory progress.
-0 Timing. The time required by HYBRD to solve a given problem
- depends on N, the behavior of the functions, the accuracy
- requested, and the starting point. The number of arithmetic
- operations needed by HYBRD is about 11.5*(N**2) to process
- each call to FCN. Unless FCN can be evaluated quickly, the
- timing of HYBRD will be strongly influenced by the time spent
- in FCN.
-0 Storage. HYBRD requires (3*N**2 + 17*N)/2 double precision
- storage locations, in addition to the storage required by the
- program. There are no internally declared storage arrays.
-0
- 7. Subprograms required.
-0 USER-supplied ...... FCN
-0 MINPACK-supplied ... DOGLEG,DPMPAR,ENORM,FDJAC1,
- QFORM,QRFAC,R1MPYQ,R1UPDT
-0 FORTRAN-supplied ... DABS,DMAX1,DMIN1,DSQRT,MIN0,MOD
-0
- 8. References.
-0 M. J. D. Powell, A Hybrid Method for Nonlinear Equations.
-1
-0 Page
-0 Numerical Methods for Nonlinear Algebraic Equations,
- P. Rabinowitz, editor. Gordon and Breach, 1970.
-0
- 9. Example.
-0 The problem is to determine the values of x(1), x(2), ..., x(9)
- which solve the system of tridiagonal equations
-0 (3-2*x(1))*x(1) -2*x(2) = -1
- -x(i-1) + (3-2*x(i))*x(i) -2*x(i+1) = -1, i=2-8
- -x(8) + (3-2*x(9))*x(9) = -1
-0 C **********
- C
- C DRIVER FOR HYBRD EXAMPLE.
- C DOUBLE PRECISION VERSION
- C
- C **********
- INTEGER J,N,MAXFEV,ML,MU,MODE,NPRINT,INFO,NFEV,LDFJAC,LR,NWRITE
- DOUBLE PRECISION XTOL,EPSFCN,FACTOR,FNORM
- DOUBLE PRECISION X(9),FVEC(9),DIAG(9),FJAC(9,9),R(45),QTF(9),
- * WA1(9),WA2(9),WA3(9),WA4(9)
- DOUBLE PRECISION ENORM,DPMPAR
- EXTERNAL FCN
- C
- C LOGICAL OUTPUT UNIT IS ASSUMED TO BE NUMBER 6.
- C
- DATA NWRITE /6/
- C
- N = 9
- C
- C THE FOLLOWING STARTING VALUES PROVIDE A ROUGH SOLUTION.
- C
- DO 10 J = 1, 9
- X(J) = -1.D0
- 10 CONTINUE
- C
- LDFJAC = 9
- LR = 45
- C
- C SET XTOL TO THE SQUARE ROOT OF THE MACHINE PRECISION.
- C UNLESS HIGH PRECISION SOLUTIONS ARE REQUIRED,
- C THIS IS THE RECOMMENDED SETTING.
- C
- XTOL = DSQRT(DPMPAR(1))
- C
- MAXFEV = 2000
- ML = 1
- MU = 1
- EPSFCN = 0.D0
- MODE = 2
- DO 20 J = 1, 9
- DIAG(J) = 1.D0
-1
-0 Page
-0 20 CONTINUE
- FACTOR = 1.D2
- NPRINT = 0
- C
- CALL 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)
- FNORM = ENORM(N,FVEC)
- WRITE (NWRITE,1000) FNORM,NFEV,INFO,(X(J),J=1,N)
- STOP
- 1000 FORMAT (5X,31H FINAL L2 NORM OF THE RESIDUALS,D15.7 //
- * 5X,31H NUMBER OF FUNCTION EVALUATIONS,I10 //
- * 5X,15H EXIT PARAMETER,16X,I10 //
- * 5X,27H FINAL APPROXIMATE SOLUTION // (5X,3D15.7))
- C
- C LAST CARD OF DRIVER FOR HYBRD EXAMPLE.
- C
- END
- SUBROUTINE FCN(N,X,FVEC,IFLAG)
- INTEGER N,IFLAG
- DOUBLE PRECISION X(N),FVEC(N)
- C
- C SUBROUTINE FCN FOR HYBRD EXAMPLE.
- C
- INTEGER K
- DOUBLE PRECISION ONE,TEMP,TEMP1,TEMP2,THREE,TWO,ZERO
- DATA ZERO,ONE,TWO,THREE /0.D0,1.D0,2.D0,3.D0/
- C
- IF (IFLAG .NE. 0) GO TO 5
- C
- C INSERT PRINT STATEMENTS HERE WHEN NPRINT IS POSITIVE.
- C
- RETURN
- 5 CONTINUE
- DO 10 K = 1, N
- TEMP = (THREE - TWO*X(K))*X(K)
- TEMP1 = ZERO
- IF (K .NE. 1) TEMP1 = X(K-1)
- TEMP2 = ZERO
- IF (K .NE. N) TEMP2 = X(K+1)
- FVEC(K) = TEMP - TEMP1 - TWO*TEMP2 + ONE
- 10 CONTINUE
- RETURN
- C
- C LAST CARD OF SUBROUTINE FCN.
- C
- END
-0 Results obtained with different compilers or machines
- may be slightly different.
-0 FINAL L2 NORM OF THE RESIDUALS 0.1192636D-07
-0 NUMBER OF FUNCTION EVALUATIONS 14
-1
-0 Page
-0 EXIT PARAMETER 1
-0 FINAL APPROXIMATE SOLUTION
-0 -0.5706545D+00 -0.6816283D+00 -0.7017325D+00
- -0.7042129D+00 -0.7013690D+00 -0.6918656D+00
- -0.6657920D+00 -0.5960342D+00 -0.4164121D+00
-1
-0
-1
-0 Page
-0 Documentation for MINPACK subroutine HYBRJ1
-0 Double precision version
-0 Argonne National Laboratory
-0 Burton S. Garbow, Kenneth E. Hillstrom, Jorge J. More
-0 March 1980
-0
- 1. Purpose.
-0 The purpose of HYBRJ1 is to find a zero of a system of N non-
- linear functions in N variables by a modification of the Powell
- hybrid method. This is done by using the more general nonlinea
- equation solver HYBRJ. The user must provide a subroutine whic
- calculates the functions and the Jacobian.
-0
- 2. Subroutine and type statements.
-0 SUBROUTINE HYBRJ1(FCN,N,X,FVEC,FJAC,LDFJAC,TOL,INFO,WA,LWA)
- INTEGER N,LDFJAC,INFO,LWA
- DOUBLE PRECISION TOL
- DOUBLE PRECISION X(N),FVEC(N),FJAC(LDFJAC,N),WA(LWA)
- EXTERNAL FCN
-0
- 3. Parameters.
-0 Parameters designated as input parameters must be specified on
- entry to HYBRJ1 and are not changed on exit, while parameters
- designated as output parameters need not be specified on entry
- and are set to appropriate values on exit from HYBRJ1.
-0 FCN is the name of the user-supplied subroutine which calculate
- the functions and the Jacobian. FCN must be declared in an
- EXTERNAL statement in the user calling program, and should be
- written as follows.
-0 SUBROUTINE FCN(N,X,FVEC,FJAC,LDFJAC,IFLAG)
- INTEGER N,LDFJAC,IFLAG
- DOUBLE PRECISION X(N),FVEC(N),FJAC(LDFJAC,N)
- ----------
- IF IFLAG = 1 CALCULATE THE FUNCTIONS AT X AND
- RETURN THIS VECTOR IN FVEC. DO NOT ALTER FJAC.
- IF IFLAG = 2 CALCULATE THE JACOBIAN AT X AND
- RETURN THIS MATRIX IN FJAC. DO NOT ALTER FVEC.
- ----------
- RETURN
- END
-0 The value of IFLAG should not be changed by FCN unless the
-1
-0 Page
-0 user wants to terminate execution of HYBRJ1. In this case se
- IFLAG to a negative integer.
-0 N is a positive integer input variable set to the number of
- functions and variables.
-0 X is an array of length N. On input X must contain an initial
- estimate of the solution vector. On output X contains the
- final estimate of the solution vector.
-0 FVEC is an output array of length N which contains the function
- evaluated at the output X.
-0 FJAC is an output N by N array which contains the orthogonal
- matrix Q produced by the QR factorization of the final approx
- imate Jacobian. Section 6 contains more details about the
- approximation to the Jacobian.
-0 LDFJAC is a positive integer input variable not less than N
- which specifies the leading dimension of the array FJAC.
-0 TOL is a nonnegative input variable. Termination occurs when
- the algorithm estimates that the relative error between X and
- the solution is at most TOL. Section 4 contains more details
- about TOL.
-0 INFO is an integer output variable. If the user has terminated
- execution, INFO is set to the (negative) value of IFLAG. See
- description of FCN. Otherwise, INFO is set as follows.
-0 INFO = 0 Improper input parameters.
-0 INFO = 1 Algorithm estimates that the relative error between
- X and the solution is at most TOL.
-0 INFO = 2 Number of calls to FCN with IFLAG = 1 has reached
- 100*(N+1).
-0 INFO = 3 TOL is too small. No further improvement in the
- approximate solution X is possible.
-0 INFO = 4 Iteration is not making good progress.
-0 Sections 4 and 5 contain more details about INFO.
-0 WA is a work array of length LWA.
-0 LWA is a positive integer input variable not less than
- (N*(N+13))/2.
-0
- 4. Successful completion.
-0 The accuracy of HYBRJ1 is controlled by the convergence
-1
-0 Page
-0 parameter TOL. This parameter is used in a test which makes a
- comparison between the approximation X and a solution XSOL.
- HYBRJ1 terminates when the test is satisfied. If TOL is less
- than the machine precision (as defined by the MINPACK function
- DPMPAR(1)), then HYBRJ1 only attempts to satisfy the test
- defined by the machine precision. Further progress is not usu-
- ally possible. Unless high precision solutions are required,
- the recommended value for TOL is the square root of the machine
- precision.
-0 The test assumes that the functions and the Jacobian are coded
- consistently, and that the functions are reasonably well
- behaved. If these conditions are not satisfied, then HYBRJ1 ma
- incorrectly indicate convergence. The coding of the Jacobian
- can be checked by the MINPACK subroutine CHKDER. If the Jaco-
- bian is coded correctly, then the validity of the answer can be
- checked, for example, by rerunning HYBRJ1 with a tighter toler-
- ance.
-0 Convergence test. If ENORM(Z) denotes the Euclidean norm of a
- vector Z, then this test attempts to guarantee that
-0 ENORM(X-XSOL) .LE. TOL*ENORM(XSOL).
-0 If this condition is satisfied with TOL = 10**(-K), then the
- larger components of X have K significant decimal digits and
- INFO is set to 1. There is a danger that the smaller compo-
- nents of X may have large relative errors, but the fast rate
- of convergence of HYBRJ1 usually avoids this possibility.
-0
- 5. Unsuccessful completion.
-0 Unsuccessful termination of HYBRJ1 can be due to improper input
- parameters, arithmetic interrupts, an excessive number of func-
- tion evaluations, or lack of good progress.
-0 Improper input parameters. INFO is set to 0 if N .LE. 0, or
- LDFJAC .LT. N, or TOL .LT. 0.D0, or LWA .LT. (N*(N+13))/2.
-0 Arithmetic interrupts. If these interrupts occur in the FCN
- subroutine during an early stage of the computation, they may
- be caused by an unacceptable choice of X by HYBRJ1. In this
- case, it may be possible to remedy the situation by not evalu
- ating the functions here, but instead setting the components
- of FVEC to numbers that exceed those in the initial FVEC,
- thereby indirectly reducing the step length. The step length
- can be more directly controlled by using instead HYBRJ, which
- includes in its calling sequence the step-length- governing
- parameter FACTOR.
-0 Excessive number of function evaluations. If the number of
- calls to FCN with IFLAG = 1 reaches 100*(N+1), then this indi
- cates that the routine is converging very slowly as measured
-1
-0 Page
-0 by the progress of FVEC, and INFO is set to 2. This situatio
- should be unusual because, as indicated below, lack of good
- progress is usually diagnosed earlier by HYBRJ1, causing ter-
- mination with INFO = 4.
-0 Lack of good progress. HYBRJ1 searches for a zero of the syste
- by minimizing the sum of the squares of the functions. In so
- doing, it can become trapped in a region where the minimum
- does not correspond to a zero of the system and, in this situ
- ation, the iteration eventually fails to make good progress.
- In particular, this will happen if the system does not have a
- zero. If the system has a zero, rerunning HYBRJ1 from a dif-
- ferent starting point may be helpful.
-0
- 6. Characteristics of the algorithm.
-0 HYBRJ1 is a modification of the Powell hybrid method. Two of
- its main characteristics involve the choice of the correction a
- a convex combination of the Newton and scaled gradient direc-
- tions, and the updating of the Jacobian by the rank-1 method of
- Broyden. The choice of the correction guarantees (under reason
- able conditions) global convergence for starting points far fro
- the solution and a fast rate of convergence. The Jacobian is
- calculated at the starting point, but it is not recalculated
- until the rank-1 method fails to produce satisfactory progress.
-0 Timing. The time required by HYBRJ1 to solve a given problem
- depends on N, the behavior of the functions, the accuracy
- requested, and the starting point. The number of arithmetic
- operations needed by HYBRJ1 is about 11.5*(N**2) to process
- each evaluation of the functions (call to FCN with IFLAG = 1)
- and 1.3*(N**3) to process each evaluation of the Jacobian
- (call to FCN with IFLAG = 2). Unless FCN can be evaluated
- quickly, the timing of HYBRJ1 will be strongly influenced by
- the time spent in FCN.
-0 Storage. HYBRJ1 requires (3*N**2 + 17*N)/2 double precision
- storage locations, in addition to the storage required by the
- program. There are no internally declared storage arrays.
-0
- 7. Subprograms required.
-0 USER-supplied ...... FCN
-0 MINPACK-supplied ... DOGLEG,DPMPAR,ENORM,HYBRJ,
- QFORM,QRFAC,R1MPYQ,R1UPDT
-0 FORTRAN-supplied ... DABS,DMAX1,DMIN1,DSQRT,MIN0,MOD
-0
- 8. References.
-1
-0 Page
-0 M. J. D. Powell, A Hybrid Method for Nonlinear Equations.
- Numerical Methods for Nonlinear Algebraic Equations,
- P. Rabinowitz, editor. Gordon and Breach, 1970.
-0
- 9. Example.
-0 The problem is to determine the values of x(1), x(2), ..., x(9)
- which solve the system of tridiagonal equations
-0 (3-2*x(1))*x(1) -2*x(2) = -1
- -x(i-1) + (3-2*x(i))*x(i) -2*x(i+1) = -1, i=2-8
- -x(8) + (3-2*x(9))*x(9) = -1
-0 C **********
- C
- C DRIVER FOR HYBRJ1 EXAMPLE.
- C DOUBLE PRECISION VERSION
- C
- C **********
- INTEGER J,N,LDFJAC,INFO,LWA,NWRITE
- DOUBLE PRECISION TOL,FNORM
- DOUBLE PRECISION X(9),FVEC(9),FJAC(9,9),WA(99)
- DOUBLE PRECISION ENORM,DPMPAR
- EXTERNAL FCN
- C
- C LOGICAL OUTPUT UNIT IS ASSUMED TO BE NUMBER 6.
- C
- DATA NWRITE /6/
- C
- N = 9
- C
- C THE FOLLOWING STARTING VALUES PROVIDE A ROUGH SOLUTION.
- C
- DO 10 J = 1, 9
- X(J) = -1.D0
- 10 CONTINUE
- C
- LDFJAC = 9
- LWA = 99
- C
- C SET TOL TO THE SQUARE ROOT OF THE MACHINE PRECISION.
- C UNLESS HIGH PRECISION SOLUTIONS ARE REQUIRED,
- C THIS IS THE RECOMMENDED SETTING.
- C
- TOL = DSQRT(DPMPAR(1))
- C
- CALL HYBRJ1(FCN,N,X,FVEC,FJAC,LDFJAC,TOL,INFO,WA,LWA)
- FNORM = ENORM(N,FVEC)
- WRITE (NWRITE,1000) FNORM,INFO,(X(J),J=1,N)
- STOP
- 1000 FORMAT (5X,31H FINAL L2 NORM OF THE RESIDUALS,D15.7 //
- * 5X,15H EXIT PARAMETER,16X,I10 //
- * 5X,27H FINAL APPROXIMATE SOLUTION // (5X,3D15.7))
-1
-0 Page
-0 C
- C LAST CARD OF DRIVER FOR HYBRJ1 EXAMPLE.
- C
- END
- SUBROUTINE FCN(N,X,FVEC,FJAC,LDFJAC,IFLAG)
- INTEGER N,LDFJAC,IFLAG
- DOUBLE PRECISION X(N),FVEC(N),FJAC(LDFJAC,N)
- C
- C SUBROUTINE FCN FOR HYBRJ1 EXAMPLE.
- C
- INTEGER J,K
- DOUBLE PRECISION ONE,TEMP,TEMP1,TEMP2,THREE,TWO,ZERO
- DATA ZERO,ONE,TWO,THREE,FOUR /0.D0,1.D0,2.D0,3.D0,4.D0/
- C
- IF (IFLAG .EQ. 2) GO TO 20
- DO 10 K = 1, N
- TEMP = (THREE - TWO*X(K))*X(K)
- TEMP1 = ZERO
- IF (K .NE. 1) TEMP1 = X(K-1)
- TEMP2 = ZERO
- IF (K .NE. N) TEMP2 = X(K+1)
- FVEC(K) = TEMP - TEMP1 - TWO*TEMP2 + ONE
- 10 CONTINUE
- GO TO 50
- 20 CONTINUE
- DO 40 K = 1, N
- DO 30 J = 1, N
- FJAC(K,J) = ZERO
- 30 CONTINUE
- FJAC(K,K) = THREE - FOUR*X(K)
- IF (K .NE. 1) FJAC(K,K-1) = -ONE
- IF (K .NE. N) FJAC(K,K+1) = -TWO
- 40 CONTINUE
- 50 CONTINUE
- RETURN
- C
- C LAST CARD OF SUBROUTINE FCN.
- C
- END
-0 Results obtained with different compilers or machines
- may be slightly different.
-0 FINAL L2 NORM OF THE RESIDUALS 0.1192636D-07
-0 EXIT PARAMETER 1
-0 FINAL APPROXIMATE SOLUTION
-0 -0.5706545D+00 -0.6816283D+00 -0.7017325D+00
- -0.7042129D+00 -0.7013690D+00 -0.6918656D+00
- -0.6657920D+00 -0.5960342D+00 -0.4164121D+00
-1
-0
-1
-0 Page
-0 Documentation for MINPACK subroutine HYBRJ
-0 Double precision version
-0 Argonne National Laboratory
-0 Burton S. Garbow, Kenneth E. Hillstrom, Jorge J. More
-0 March 1980
-0
- 1. Purpose.
-0 The purpose of HYBRJ is to find a zero of a system of N non-
- linear functions in N variables by a modification of the Powell
- hybrid method. The user must provide a subroutine which calcu-
- lates the functions and the Jacobian.
-0
- 2. Subroutine and type statements.
-0 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),QTF(
- * WA1(N),WA2(N),WA3(N),WA4(N)
-0
- 3. Parameters.
-0 Parameters designated as input parameters must be specified on
- entry to HYBRJ and are not changed on exit, while parameters
- designated as output parameters need not be specified on entry
- and are set to appropriate values on exit from HYBRJ.
-0 FCN is the name of the user-supplied subroutine which calculate
- the functions and the Jacobian. FCN must be declared in an
- EXTERNAL statement in the user calling program, and should be
- written as follows.
-0 SUBROUTINE FCN(N,X,FVEC,FJAC,LDFJAC,IFLAG)
- INTEGER N,LDFJAC,IFLAG
- DOUBLE PRECISION X(N),FVEC(N),FJAC(LDFJAC,N)
- ----------
- IF IFLAG = 1 CALCULATE THE FUNCTIONS AT X AND
- RETURN THIS VECTOR IN FVEC. DO NOT ALTER FJAC.
- IF IFLAG = 2 CALCULATE THE JACOBIAN AT X AND
- RETURN THIS MATRIX IN FJAC. DO NOT ALTER FVEC.
- ----------
- RETURN
- END
-1
-0 Page
-0 The value of IFLAG should not be changed by FCN unless the
- user wants to terminate execution of HYBRJ. In this case set
- IFLAG to a negative integer.
-0 N is a positive integer input variable set to the number of
- functions and variables.
-0 X is an array of length N. On input X must contain an initial
- estimate of the solution vector. On output X contains the
- final estimate of the solution vector.
-0 FVEC is an output array of length N which contains the function
- evaluated at the output X.
-0 FJAC is an output N by N array which contains the orthogonal
- matrix Q produced by the QR factorization of the final approx
- imate Jacobian. Section 6 contains more details about the
- approximation to the Jacobian.
-0 LDFJAC is a positive integer input variable not less than N
- which specifies the leading dimension of the array FJAC.
-0 XTOL is a nonnegative input variable. Termination occurs when
- the relative error between two consecutive iterates is at mos
- XTOL. Therefore, XTOL measures the relative error desired in
- the approximate solution. Section 4 contains more details
- about XTOL.
-0 MAXFEV is a positive integer input variable. Termination occur
- when the number of calls to FCN with IFLAG = 1 has reached
- MAXFEV.
-0 DIAG is an array of length N. If MODE = 1 (see below), DIAG is
- internally set. If MODE = 2, DIAG must contain positive
- entries that serve as multiplicative scale factors for the
- variables.
-0 MODE is an integer input variable. If MODE = 1, the variables
- will be scaled internally. If MODE = 2, the scaling is speci
- fied by the input DIAG. Other values of MODE are equivalent
- to MODE = 1.
-0 FACTOR is a positive input variable used in determining the ini
- tial step bound. This bound is set to the product of FACTOR
- and the Euclidean norm of DIAG*X if nonzero, or else to FACTO
- itself. In most cases FACTOR should lie in the interval
- (.1,100.). 100. is a generally recommended value.
-0 NPRINT is an integer input variable that enables controlled
- printing of iterates if it is positive. In this case, FCN is
- called with IFLAG = 0 at the beginning of the first iteration
- and every NPRINT iterations thereafter and immediately prior
- to return, with X and FVEC available for printing. FVEC and
- FJAC should not be altered. If NPRINT is not positive, no
-1
-0 Page
-0 special calls of FCN with IFLAG = 0 are made.
-0 INFO is an integer output variable. If the user has terminated
- execution, INFO is set to the (negative) value of IFLAG. See
- description of FCN. Otherwise, INFO is set as follows.
-0 INFO = 0 Improper input parameters.
-0 INFO = 1 Relative error between two consecutive iterates is
- at most XTOL.
-0 INFO = 2 Number of calls to FCN with IFLAG = 1 has reached
- MAXFEV.
-0 INFO = 3 XTOL is too small. No further improvement in the
- approximate solution X is possible.
-0 INFO = 4 Iteration is not making good progress, as measured
- by the improvement from the last five Jacobian eval
- uations.
-0 INFO = 5 Iteration is not making good progress, as measured
- by the improvement from the last ten iterations.
-0 Sections 4 and 5 contain more details about INFO.
-0 NFEV is an integer output variable set to the number of calls t
- FCN with IFLAG = 1.
-0 NJEV is an integer output variable set to the number of calls t
- FCN with IFLAG = 2.
-0 R is an output array of length LR which contains the upper
- triangular matrix produced by the QR factorization of the
- final approximate Jacobian, stored rowwise.
-0 LR is a positive integer input variable not less than
- (N*(N+1))/2.
-0 QTF is an output array of length N which contains the vector
- (Q transpose)*FVEC.
-0 WA1, WA2, WA3, and WA4 are work arrays of length N.
-0
- 4. Successful completion.
-0 The accuracy of HYBRJ is controlled by the convergence paramete
- XTOL. This parameter is used in a test which makes a compariso
- between the approximation X and a solution XSOL. HYBRJ termi-
- nates when the test is satisfied. If the convergence parameter
- is less than the machine precision (as defined by the MINPACK
- function DPMPAR(1)), then HYBRJ only attempts to satisfy the
- test defined by the machine precision. Further progress is not
-1
-0 Page
-0 usually possible.
-0 The test assumes that the functions and the Jacobian are coded
- consistently, and that the functions are reasonably well
- behaved. If these conditions are not satisfied, then HYBRJ may
- incorrectly indicate convergence. The coding of the Jacobian
- can be checked by the MINPACK subroutine CHKDER. If the Jaco-
- bian is coded correctly, then the validity of the answer can be
- checked, for example, by rerunning HYBRJ with a tighter toler-
- ance.
-0 Convergence test. If ENORM(Z) denotes the Euclidean norm of a
- vector Z and D is the diagonal matrix whose entries are
- defined by the array DIAG, then this test attempts to guaran-
- tee that
-0 ENORM(D*(X-XSOL)) .LE. XTOL*ENORM(D*XSOL).
-0 If this condition is satisfied with XTOL = 10**(-K), then the
- larger components of D*X have K significant decimal digits an
- INFO is set to 1. There is a danger that the smaller compo-
- nents of D*X may have large relative errors, but the fast rat
- of convergence of HYBRJ usually avoids this possibility.
- Unless high precision solutions are required, the recommended
- value for XTOL is the square root of the machine precision.
-0
- 5. Unsuccessful completion.
-0 Unsuccessful termination of HYBRJ can be due to improper input
- parameters, arithmetic interrupts, an excessive number of func-
- tion evaluations, or lack of good progress.
-0 Improper input parameters. INFO is set to 0 if N .LE. 0, or
- LDFJAC .LT. N, or XTOL .LT. 0.D0, or MAXFEV .LE. 0, or
- FACTOR .LE. 0.D0, or LR .LT. (N*(N+1))/2.
-0 Arithmetic interrupts. If these interrupts occur in the FCN
- subroutine during an early stage of the computation, they may
- be caused by an unacceptable choice of X by HYBRJ. In this
- case, it may be possible to remedy the situation by rerunning
- HYBRJ with a smaller value of FACTOR.
-0 Excessive number of function evaluations. A reasonable value
- for MAXFEV is 100*(N+1). If the number of calls to FCN with
- IFLAG = 1 reaches MAXFEV, then this indicates that the routin
- is converging very slowly as measured by the progress of FVEC
- and INFO is set to 2. This situation should be unusual
- because, as indicated below, lack of good progress is usually
- diagnosed earlier by HYBRJ, causing termination with INFO = 4
- or INFO = 5.
-0 Lack of good progress. HYBRJ searches for a zero of the system
- by minimizing the sum of the squares of the functions. In so
-1
-0 Page
-0 doing, it can become trapped in a region where the minimum
- does not correspond to a zero of the system and, in this situ
- ation, the iteration eventually fails to make good progress.
- In particular, this will happen if the system does not have a
- zero. If the system has a zero, rerunning HYBRJ from a dif-
- ferent starting point may be helpful.
-0
- 6. Characteristics of the algorithm.
-0 HYBRJ is a modification of the Powell hybrid method. Two of it
- main characteristics involve the choice of the correction as a
- convex combination of the Newton and scaled gradient directions
- and the updating of the Jacobian by the rank-1 method of Broy-
- den. The choice of the correction guarantees (under reasonable
- conditions) global convergence for starting points far from the
- solution and a fast rate of convergence. The Jacobian is calcu
- lated at the starting point, but it is not recalculated until
- the rank-1 method fails to produce satisfactory progress.
-0 Timing. The time required by HYBRJ to solve a given problem
- depends on N, the behavior of the functions, the accuracy
- requested, and the starting point. The number of arithmetic
- operations needed by HYBRJ is about 11.5*(N**2) to process
- each evaluation of the functions (call to FCN with IFLAG = 1)
- and 1.3*(N**3) to process each evaluation of the Jacobian
- (call to FCN with IFLAG = 2). Unless FCN can be evaluated
- quickly, the timing of HYBRJ will be strongly influenced by
- the time spent in FCN.
-0 Storage. HYBRJ requires (3*N**2 + 17*N)/2 double precision
- storage locations, in addition to the storage required by the
- program. There are no internally declared storage arrays.
-0
- 7. Subprograms required.
-0 USER-supplied ...... FCN
-0 MINPACK-supplied ... DOGLEG,DPMPAR,ENORM,
- QFORM,QRFAC,R1MPYQ,R1UPDT
-0 FORTRAN-supplied ... DABS,DMAX1,DMIN1,DSQRT,MIN0,MOD
-0
- 8. References.
-0 M. J. D. Powell, A Hybrid Method for Nonlinear Equations.
- Numerical Methods for Nonlinear Algebraic Equations,
- P. Rabinowitz, editor. Gordon and Breach, 1970.
-0
- 9. Example.
-1
-0 Page
-0 The problem is to determine the values of x(1), x(2), ..., x(9)
- which solve the system of tridiagonal equations
-0 (3-2*x(1))*x(1) -2*x(2) = -1
- -x(i-1) + (3-2*x(i))*x(i) -2*x(i+1) = -1, i=2-8
- -x(8) + (3-2*x(9))*x(9) = -1
-0 C **********
- C
- C DRIVER FOR HYBRJ EXAMPLE.
- C DOUBLE PRECISION VERSION
- C
- C **********
- INTEGER J,N,LDFJAC,MAXFEV,MODE,NPRINT,INFO,NFEV,NJEV,LR,NWRITE
- DOUBLE PRECISION XTOL,FACTOR,FNORM
- DOUBLE PRECISION X(9),FVEC(9),FJAC(9,9),DIAG(9),R(45),QTF(9),
- * WA1(9),WA2(9),WA3(9),WA4(9)
- DOUBLE PRECISION ENORM,DPMPAR
- EXTERNAL FCN
- C
- C LOGICAL OUTPUT UNIT IS ASSUMED TO BE NUMBER 6.
- C
- DATA NWRITE /6/
- C
- N = 9
- C
- C THE FOLLOWING STARTING VALUES PROVIDE A ROUGH SOLUTION.
- C
- DO 10 J = 1, 9
- X(J) = -1.D0
- 10 CONTINUE
- C
- LDFJAC = 9
- LR = 45
- C
- C SET XTOL TO THE SQUARE ROOT OF THE MACHINE PRECISION.
- C UNLESS HIGH PRECISION SOLUTIONS ARE REQUIRED,
- C THIS IS THE RECOMMENDED SETTING.
- C
- XTOL = DSQRT(DPMPAR(1))
- C
- MAXFEV = 1000
- MODE = 2
- DO 20 J = 1, 9
- DIAG(J) = 1.D0
- 20 CONTINUE
- FACTOR = 1.D2
- NPRINT = 0
- C
- CALL HYBRJ(FCN,N,X,FVEC,FJAC,LDFJAC,XTOL,MAXFEV,DIAG,
- * MODE,FACTOR,NPRINT,INFO,NFEV,NJEV,R,LR,QTF,
- * WA1,WA2,WA3,WA4)
- FNORM = ENORM(N,FVEC)
- WRITE (NWRITE,1000) FNORM,NFEV,NJEV,INFO,(X(J),J=1,N)
-1
-0 Page
-0 STOP
- 1000 FORMAT (5X,31H FINAL L2 NORM OF THE RESIDUALS,D15.7 //
- * 5X,31H NUMBER OF FUNCTION EVALUATIONS,I10 //
- * 5X,31H NUMBER OF JACOBIAN EVALUATIONS,I10 //
- * 5X,15H EXIT PARAMETER,16X,I10 //
- * 5X,27H FINAL APPROXIMATE SOLUTION // (5X,3D15.7))
- C
- C LAST CARD OF DRIVER FOR HYBRJ EXAMPLE.
- C
- END
- SUBROUTINE FCN(N,X,FVEC,FJAC,LDFJAC,IFLAG)
- INTEGER N,LDFJAC,IFLAG
- DOUBLE PRECISION X(N),FVEC(N),FJAC(LDFJAC,N)
- C
- C SUBROUTINE FCN FOR HYBRJ EXAMPLE.
- C
- INTEGER J,K
- DOUBLE PRECISION ONE,TEMP,TEMP1,TEMP2,THREE,TWO,ZERO
- DATA ZERO,ONE,TWO,THREE,FOUR /0.D0,1.D0,2.D0,3.D0,4.D0/
- C
- IF (IFLAG .NE. 0) GO TO 5
- C
- C INSERT PRINT STATEMENTS HERE WHEN NPRINT IS POSITIVE.
- C
- RETURN
- 5 CONTINUE
- IF (IFLAG .EQ. 2) GO TO 20
- DO 10 K = 1, N
- TEMP = (THREE - TWO*X(K))*X(K)
- TEMP1 = ZERO
- IF (K .NE. 1) TEMP1 = X(K-1)
- TEMP2 = ZERO
- IF (K .NE. N) TEMP2 = X(K+1)
- FVEC(K) = TEMP - TEMP1 - TWO*TEMP2 + ONE
- 10 CONTINUE
- GO TO 50
- 20 CONTINUE
- DO 40 K = 1, N
- DO 30 J = 1, N
- FJAC(K,J) = ZERO
- 30 CONTINUE
- FJAC(K,K) = THREE - FOUR*X(K)
- IF (K .NE. 1) FJAC(K,K-1) = -ONE
- IF (K .NE. N) FJAC(K,K+1) = -TWO
- 40 CONTINUE
- 50 CONTINUE
- RETURN
- C
- C LAST CARD OF SUBROUTINE FCN.
- C
- END
-0 Results obtained with different compilers or machines
- may be slightly different.
-1
-0 Page
-0 FINAL L2 NORM OF THE RESIDUALS 0.1192636D-07
-0 NUMBER OF FUNCTION EVALUATIONS 11
-0 NUMBER OF JACOBIAN EVALUATIONS 1
-0 EXIT PARAMETER 1
-0 FINAL APPROXIMATE SOLUTION
-0 -0.5706545D+00 -0.6816283D+00 -0.7017325D+00
- -0.7042129D+00 -0.7013690D+00 -0.6918656D+00
- -0.6657920D+00 -0.5960342D+00 -0.4164121D+00
-1
-0
-1
-0 Page
-0 Documentation for MINPACK subroutine LMDER1
-0 Double precision version
-0 Argonne National Laboratory
-0 Burton S. Garbow, Kenneth E. Hillstrom, Jorge J. More
-0 March 1980
-0
- 1. Purpose.
-0 The purpose of LMDER1 is to minimize the sum of the squares of
- nonlinear functions in N variables by a modification of the
- Levenberg-Marquardt algorithm. This is done by using the more
- general least-squares solver LMDER. The user must provide a
- subroutine which calculates the functions and the Jacobian.
-0
- 2. Subroutine and type statements.
-0 SUBROUTINE LMDER1(FCN,M,N,X,FVEC,FJAC,LDFJAC,TOL,
- * INFO,IPVT,WA,LWA)
- INTEGER M,N,LDFJAC,INFO,LWA
- INTEGER IPVT(N)
- DOUBLE PRECISION TOL
- DOUBLE PRECISION X(N),FVEC(M),FJAC(LDFJAC,N),WA(LWA)
- EXTERNAL FCN
-0
- 3. Parameters.
-0 Parameters designated as input parameters must be specified on
- entry to LMDER1 and are not changed on exit, while parameters
- designated as output parameters need not be specified on entry
- and are set to appropriate values on exit from LMDER1.
-0 FCN is the name of the user-supplied subroutine which calculate
- the functions and the Jacobian. FCN must be declared in an
- EXTERNAL statement in the user calling program, and should be
- written as follows.
-0 SUBROUTINE FCN(M,N,X,FVEC,FJAC,LDFJAC,IFLAG)
- INTEGER M,N,LDFJAC,IFLAG
- DOUBLE PRECISION X(N),FVEC(M),FJAC(LDFJAC,N)
- ----------
- IF IFLAG = 1 CALCULATE THE FUNCTIONS AT X AND
- RETURN THIS VECTOR IN FVEC. DO NOT ALTER FJAC.
- IF IFLAG = 2 CALCULATE THE JACOBIAN AT X AND
- RETURN THIS MATRIX IN FJAC. DO NOT ALTER FVEC.
- ----------
- RETURN
- END
-1
-0 Page
-0 The value of IFLAG should not be changed by FCN unless the
- user wants to terminate execution of LMDER1. In this case se
- IFLAG to a negative integer.
-0 M is a positive integer input variable set to the number of
- functions.
-0 N is a positive integer input variable set to the number of
- variables. N must not exceed M.
-0 X is an array of length N. On input X must contain an initial
- estimate of the solution vector. On output X contains the
- final estimate of the solution vector.
-0 FVEC is an output array of length M which contains the function
- evaluated at the output X.
-0 FJAC is an output M by N array. The upper N by N submatrix of
- FJAC contains an upper triangular matrix R with diagonal ele-
- ments of nonincreasing magnitude such that
-0 T T T
- P *(JAC *JAC)*P = R *R,
-0 where P is a permutation matrix and JAC is the final calcu-
- lated Jacobian. Column j of P is column IPVT(j) (see below)
- of the identity matrix. The lower trapezoidal part of FJAC
- contains information generated during the computation of R.
-0 LDFJAC is a positive integer input variable not less than M
- which specifies the leading dimension of the array FJAC.
-0 TOL is a nonnegative input variable. Termination occurs when
- the algorithm estimates either that the relative error in the
- sum of squares is at most TOL or that the relative error
- between X and the solution is at most TOL. Section 4 contain
- more details about TOL.
-0 INFO is an integer output variable. If the user has terminated
- execution, INFO is set to the (negative) value of IFLAG. See
- description of FCN. Otherwise, INFO is set as follows.
-0 INFO = 0 Improper input parameters.
-0 INFO = 1 Algorithm estimates that the relative error in the
- sum of squares is at most TOL.
-0 INFO = 2 Algorithm estimates that the relative error between
- X and the solution is at most TOL.
-0 INFO = 3 Conditions for INFO = 1 and INFO = 2 both hold.
-0 INFO = 4 FVEC is orthogonal to the columns of the Jacobian t
- machine precision.
-1
-0 Page
-0 INFO = 5 Number of calls to FCN with IFLAG = 1 has reached
- 100*(N+1).
-0 INFO = 6 TOL is too small. No further reduction in the sum
- of squares is possible.
-0 INFO = 7 TOL is too small. No further improvement in the
- approximate solution X is possible.
-0 Sections 4 and 5 contain more details about INFO.
-0 IPVT is an integer output array of length N. IPVT defines a
- permutation matrix P such that JAC*P = Q*R, where JAC is the
- final calculated Jacobian, Q is orthogonal (not stored), and
- is upper triangular with diagonal elements of nonincreasing
- magnitude. Column j of P is column IPVT(j) of the identity
- matrix.
-0 WA is a work array of length LWA.
-0 LWA is a positive integer input variable not less than 5*N+M.
-0
- 4. Successful completion.
-0 The accuracy of LMDER1 is controlled by the convergence parame-
- ter TOL. This parameter is used in tests which make three type
- of comparisons between the approximation X and a solution XSOL.
- LMDER1 terminates when any of the tests is satisfied. If TOL i
- less than the machine precision (as defined by the MINPACK func
- tion DPMPAR(1)), then LMDER1 only attempts to satisfy the test
- defined by the machine precision. Further progress is not usu-
- ally possible. Unless high precision solutions are required,
- the recommended value for TOL is the square root of the machine
- precision.
-0 The tests assume that the functions and the Jacobian are coded
- consistently, and that the functions are reasonably well
- behaved. If these conditions are not satisfied, then LMDER1 ma
- incorrectly indicate convergence. The coding of the Jacobian
- can be checked by the MINPACK subroutine CHKDER. If the Jaco-
- bian is coded correctly, then the validity of the answer can be
- checked, for example, by rerunning LMDER1 with a tighter toler-
- ance.
-0 First convergence test. If ENORM(Z) denotes the Euclidean norm
- of a vector Z, then this test attempts to guarantee that
-0 ENORM(FVEC) .LE. (1+TOL)*ENORM(FVECS),
-0 where FVECS denotes the functions evaluated at XSOL. If this
- condition is satisfied with TOL = 10**(-K), then the final
- residual norm ENORM(FVEC) has K significant decimal digits an
- INFO is set to 1 (or to 3 if the second test is also
-1
-0 Page
-0 satisfied).
-0 Second convergence test. If D is a diagonal matrix (implicitly
- generated by LMDER1) whose entries contain scale factors for
- the variables, then this test attempts to guarantee that
-0 ENORM(D*(X-XSOL)) .LE. TOL*ENORM(D*XSOL).
-0 If this condition is satisfied with TOL = 10**(-K), then the
- larger components of D*X have K significant decimal digits an
- INFO is set to 2 (or to 3 if the first test is also satis-
- fied). There is a danger that the smaller components of D*X
- may have large relative errors, but the choice of D is such
- that the accuracy of the components of X is usually related t
- their sensitivity.
-0 Third convergence test. This test is satisfied when FVEC is
- orthogonal to the columns of the Jacobian to machine preci-
- sion. There is no clear relationship between this test and
- the accuracy of LMDER1, and furthermore, the test is equally
- well satisfied at other critical points, namely maximizers an
- saddle points. Therefore, termination caused by this test
- (INFO = 4) should be examined carefully.
-0
- 5. Unsuccessful completion.
-0 Unsuccessful termination of LMDER1 can be due to improper input
- parameters, arithmetic interrupts, or an excessive number of
- function evaluations.
-0 Improper input parameters. INFO is set to 0 if N .LE. 0, or
- M .LT. N, or LDFJAC .LT. M, or TOL .LT. 0.D0, or
- LWA .LT. 5*N+M.
-0 Arithmetic interrupts. If these interrupts occur in the FCN
- subroutine during an early stage of the computation, they may
- be caused by an unacceptable choice of X by LMDER1. In this
- case, it may be possible to remedy the situation by not evalu
- ating the functions here, but instead setting the components
- of FVEC to numbers that exceed those in the initial FVEC,
- thereby indirectly reducing the step length. The step length
- can be more directly controlled by using instead LMDER, which
- includes in its calling sequence the step-length- governing
- parameter FACTOR.
-0 Excessive number of function evaluations. If the number of
- calls to FCN with IFLAG = 1 reaches 100*(N+1), then this indi
- cates that the routine is converging very slowly as measured
- by the progress of FVEC, and INFO is set to 5. In this case,
- it may be helpful to restart LMDER1, thereby forcing it to
- disregard old (and possibly harmful) information.
-0
-1
-0 Page
-0 6. Characteristics of the algorithm.
-0 LMDER1 is a modification of the Levenberg-Marquardt algorithm.
- Two of its main characteristics involve the proper use of
- implicitly scaled variables and an optimal choice for the cor-
- rection. The use of implicitly scaled variables achieves scale
- invariance of LMDER1 and limits the size of the correction in
- any direction where the functions are changing rapidly. The
- optimal choice of the correction guarantees (under reasonable
- conditions) global convergence from starting points far from th
- solution and a fast rate of convergence for problems with small
- residuals.
-0 Timing. The time required by LMDER1 to solve a given problem
- depends on M and N, the behavior of the functions, the accu-
- racy requested, and the starting point. The number of arith-
- metic operations needed by LMDER1 is about N**3 to process
- each evaluation of the functions (call to FCN with IFLAG = 1)
- and M*(N**2) to process each evaluation of the Jacobian (call
- to FCN with IFLAG = 2). Unless FCN can be evaluated quickly,
- the timing of LMDER1 will be strongly influenced by the time
- spent in FCN.
-0 Storage. LMDER1 requires M*N + 2*M + 6*N double precision sto-
- rage locations and N integer storage locations, in addition t
- the storage required by the program. There are no internally
- declared storage arrays.
-0
- 7. Subprograms required.
-0 USER-supplied ...... FCN
-0 MINPACK-supplied ... DPMPAR,ENORM,LMDER,LMPAR,QRFAC,QRSOLV
-0 FORTRAN-supplied ... DABS,DMAX1,DMIN1,DSQRT,MOD
-0
- 8. References.
-0 Jorge J. More, The Levenberg-Marquardt Algorithm, Implementatio
- and Theory. Numerical Analysis, G. A. Watson, editor.
- Lecture Notes in Mathematics 630, Springer-Verlag, 1977.
-0
- 9. Example.
-0 The problem is to determine the values of x(1), x(2), and x(3)
- which provide the best fit (in the least squares sense) of
-0 x(1) + u(i)/(v(i)*x(2) + w(i)*x(3)), i = 1, 15
-0 to the data
-1
-0 Page
-0 y = (0.14,0.18,0.22,0.25,0.29,0.32,0.35,0.39,
- 0.37,0.58,0.73,0.96,1.34,2.10,4.39),
-0 where u(i) = i, v(i) = 16 - i, and w(i) = min(u(i),v(i)). The
- i-th component of FVEC is thus defined by
-0 y(i) - (x(1) + u(i)/(v(i)*x(2) + w(i)*x(3))).
-0 C **********
- C
- C DRIVER FOR LMDER1 EXAMPLE.
- C DOUBLE PRECISION VERSION
- C
- C **********
- INTEGER J,M,N,LDFJAC,INFO,LWA,NWRITE
- INTEGER IPVT(3)
- DOUBLE PRECISION TOL,FNORM
- DOUBLE PRECISION X(3),FVEC(15),FJAC(15,3),WA(30)
- DOUBLE PRECISION ENORM,DPMPAR
- EXTERNAL FCN
- C
- C LOGICAL OUTPUT UNIT IS ASSUMED TO BE NUMBER 6.
- C
- DATA NWRITE /6/
- C
- M = 15
- N = 3
- C
- C THE FOLLOWING STARTING VALUES PROVIDE A ROUGH FIT.
- C
- X(1) = 1.D0
- X(2) = 1.D0
- X(3) = 1.D0
- C
- LDFJAC = 15
- LWA = 30
- C
- C SET TOL TO THE SQUARE ROOT OF THE MACHINE PRECISION.
- C UNLESS HIGH PRECISION SOLUTIONS ARE REQUIRED,
- C THIS IS THE RECOMMENDED SETTING.
- C
- TOL = DSQRT(DPMPAR(1))
- C
- CALL LMDER1(FCN,M,N,X,FVEC,FJAC,LDFJAC,TOL,
- * INFO,IPVT,WA,LWA)
- FNORM = ENORM(M,FVEC)
- WRITE (NWRITE,1000) FNORM,INFO,(X(J),J=1,N)
- STOP
- 1000 FORMAT (5X,31H FINAL L2 NORM OF THE RESIDUALS,D15.7 //
- * 5X,15H EXIT PARAMETER,16X,I10 //
- * 5X,27H FINAL APPROXIMATE SOLUTION // 5X,3D15.7)
- C
- C LAST CARD OF DRIVER FOR LMDER1 EXAMPLE.
- C
-1
-0 Page
-0 END
- SUBROUTINE FCN(M,N,X,FVEC,FJAC,LDFJAC,IFLAG)
- INTEGER M,N,LDFJAC,IFLAG
- DOUBLE PRECISION X(N),FVEC(M),FJAC(LDFJAC,N)
- C
- C SUBROUTINE FCN FOR LMDER1 EXAMPLE.
- C
- INTEGER I
- DOUBLE PRECISION TMP1,TMP2,TMP3,TMP4
- DOUBLE PRECISION Y(15)
- DATA Y(1),Y(2),Y(3),Y(4),Y(5),Y(6),Y(7),Y(8),
- * Y(9),Y(10),Y(11),Y(12),Y(13),Y(14),Y(15)
- * /1.4D-1,1.8D-1,2.2D-1,2.5D-1,2.9D-1,3.2D-1,3.5D-1,3.9D-1,
- * 3.7D-1,5.8D-1,7.3D-1,9.6D-1,1.34D0,2.1D0,4.39D0/
- C
- IF (IFLAG .EQ. 2) GO TO 20
- DO 10 I = 1, 15
- TMP1 = I
- TMP2 = 16 - I
- TMP3 = TMP1
- IF (I .GT. 8) TMP3 = TMP2
- FVEC(I) = Y(I) - (X(1) + TMP1/(X(2)*TMP2 + X(3)*TMP3))
- 10 CONTINUE
- GO TO 40
- 20 CONTINUE
- DO 30 I = 1, 15
- TMP1 = I
- TMP2 = 16 - I
- TMP3 = TMP1
- IF (I .GT. 8) TMP3 = TMP2
- TMP4 = (X(2)*TMP2 + X(3)*TMP3)**2
- FJAC(I,1) = -1.D0
- FJAC(I,2) = TMP1*TMP2/TMP4
- FJAC(I,3) = TMP1*TMP3/TMP4
- 30 CONTINUE
- 40 CONTINUE
- RETURN
- C
- C LAST CARD OF SUBROUTINE FCN.
- C
- END
-0 Results obtained with different compilers or machines
- may be slightly different.
-0 FINAL L2 NORM OF THE RESIDUALS 0.9063596D-01
-0 EXIT PARAMETER 1
-0 FINAL APPROXIMATE SOLUTION
-0 0.8241058D-01 0.1133037D+01 0.2343695D+01
-1
-0
-1
-0 Page
-0 Documentation for MINPACK subroutine LMDER
-0 Double precision version
-0 Argonne National Laboratory
-0 Burton S. Garbow, Kenneth E. Hillstrom, Jorge J. More
-0 March 1980
-0
- 1. Purpose.
-0 The purpose of LMDER is to minimize the sum of the squares of M
- nonlinear functions in N variables by a modification of the
- Levenberg-Marquardt algorithm. The user must provide a subrou-
- tine which calculates the functions and the Jacobian.
-0
- 2. Subroutine and type statements.
-0 SUBROUTINE LMDER(FCN,M,N,X,FVEC,FJAC,LDFJAC,FTOL,XTOL,GTOL,
- * MAXFEV,DIAG,MODE,FACTOR,NPRINT,INFO,NFEV,NJEV,
- * IPVT,QTF,WA1,WA2,WA3,WA4)
- INTEGER M,N,LDFJAC,MAXFEV,MODE,NPRINT,INFO,NFEV,NJEV
- INTEGER IPVT(N)
- DOUBLE PRECISION FTOL,XTOL,GTOL,FACTOR
- DOUBLE PRECISION X(N),FVEC(M),FJAC(LDFJAC,N),DIAG(N),QTF(N),
- * WA1(N),WA2(N),WA3(N),WA4(M)
-0
- 3. Parameters.
-0 Parameters designated as input parameters must be specified on
- entry to LMDER and are not changed on exit, while parameters
- designated as output parameters need not be specified on entry
- and are set to appropriate values on exit from LMDER.
-0 FCN is the name of the user-supplied subroutine which calculate
- the functions and the Jacobian. FCN must be declared in an
- EXTERNAL statement in the user calling program, and should be
- written as follows.
-0 SUBROUTINE FCN(M,N,X,FVEC,FJAC,LDFJAC,IFLAG)
- INTEGER M,N,LDFJAC,IFLAG
- DOUBLE PRECISION X(N),FVEC(M),FJAC(LDFJAC,N)
- ----------
- IF IFLAG = 1 CALCULATE THE FUNCTIONS AT X AND
- RETURN THIS VECTOR IN FVEC. DO NOT ALTER FJAC.
- IF IFLAG = 2 CALCULATE THE JACOBIAN AT X AND
- RETURN THIS MATRIX IN FJAC. DO NOT ALTER FVEC.
- ----------
- RETURN
- END
-1
-0 Page
-0 The value of IFLAG should not be changed by FCN unless the
- user wants to terminate execution of LMDER. In this case set
- IFLAG to a negative integer.
-0 M is a positive integer input variable set to the number of
- functions.
-0 N is a positive integer input variable set to the number of
- variables. N must not exceed M.
-0 X is an array of length N. On input X must contain an initial
- estimate of the solution vector. On output X contains the
- final estimate of the solution vector.
-0 FVEC is an output array of length M which contains the function
- evaluated at the output X.
-0 FJAC is an output M by N array. The upper N by N submatrix of
- FJAC contains an upper triangular matrix R with diagonal ele-
- ments of nonincreasing magnitude such that
-0 T T T
- P *(JAC *JAC)*P = R *R,
-0 where P is a permutation matrix and JAC is the final calcu-
- lated Jacobian. Column j of P is column IPVT(j) (see below)
- of the identity matrix. The lower trapezoidal part of FJAC
- contains information generated during the computation of R.
-0 LDFJAC is a positive integer input variable not less than M
- which specifies the leading dimension of the array FJAC.
-0 FTOL is a nonnegative input variable. Termination occurs when
- both the actual and predicted relative reductions in the sum
- of squares are at most FTOL. Therefore, FTOL measures the
- relative error desired in the sum of squares. Section 4 con-
- tains more details about FTOL.
-0 XTOL is a nonnegative input variable. Termination occurs when
- the relative error between two consecutive iterates is at mos
- XTOL. Therefore, XTOL measures the relative error desired in
- the approximate solution. Section 4 contains more details
- about XTOL.
-0 GTOL is a nonnegative input variable. Termination occurs when
- the cosine of the angle between FVEC and any column of the
- Jacobian is at most GTOL in absolute value. Therefore, GTOL
- measures the orthogonality desired between the function vecto
- and the columns of the Jacobian. Section 4 contains more
- details about GTOL.
-0 MAXFEV is a positive integer input variable. Termination occur
- when the number of calls to FCN with IFLAG = 1 has reached
- MAXFEV.
-1
-0 Page
-0 DIAG is an array of length N. If MODE = 1 (see below), DIAG is
- internally set. If MODE = 2, DIAG must contain positive
- entries that serve as multiplicative scale factors for the
- variables.
-0 MODE is an integer input variable. If MODE = 1, the variables
- will be scaled internally. If MODE = 2, the scaling is speci
- fied by the input DIAG. Other values of MODE are equivalent
- to MODE = 1.
-0 FACTOR is a positive input variable used in determining the ini
- tial step bound. This bound is set to the product of FACTOR
- and the Euclidean norm of DIAG*X if nonzero, or else to FACTO
- itself. In most cases FACTOR should lie in the interval
- (.1,100.). 100. is a generally recommended value.
-0 NPRINT is an integer input variable that enables controlled
- printing of iterates if it is positive. In this case, FCN is
- called with IFLAG = 0 at the beginning of the first iteration
- and every NPRINT iterations thereafter and immediately prior
- to return, with X, FVEC, and FJAC available for printing.
- FVEC and FJAC should not be altered. If NPRINT is not posi-
- tive, no special calls of FCN with IFLAG = 0 are made.
-0 INFO is an integer output variable. If the user has terminated
- execution, INFO is set to the (negative) value of IFLAG. See
- description of FCN. Otherwise, INFO is set as follows.
-0 INFO = 0 Improper input parameters.
-0 INFO = 1 Both actual and predicted relative reductions in th
- sum of squares are at most FTOL.
-0 INFO = 2 Relative error between two consecutive iterates is
- at most XTOL.
-0 INFO = 3 Conditions for INFO = 1 and INFO = 2 both hold.
-0 INFO = 4 The cosine of the angle between FVEC and any column
- of the Jacobian is at most GTOL in absolute value.
-0 INFO = 5 Number of calls to FCN with IFLAG = 1 has reached
- MAXFEV.
-0 INFO = 6 FTOL is too small. No further reduction in the sum
- of squares is possible.
-0 INFO = 7 XTOL is too small. No further improvement in the
- approximate solution X is possible.
-0 INFO = 8 GTOL is too small. FVEC is orthogonal to the
- columns of the Jacobian to machine precision.
-0 Sections 4 and 5 contain more details about INFO.
-1
-0 Page
-0 NFEV is an integer output variable set to the number of calls t
- FCN with IFLAG = 1.
-0 NJEV is an integer output variable set to the number of calls t
- FCN with IFLAG = 2.
-0 IPVT is an integer output array of length N. IPVT defines a
- permutation matrix P such that JAC*P = Q*R, where JAC is the
- final calculated Jacobian, Q is orthogonal (not stored), and
- is upper triangular with diagonal elements of nonincreasing
- magnitude. Column j of P is column IPVT(j) of the identity
- matrix.
-0 QTF is an output array of length N which contains the first N
- elements of the vector (Q transpose)*FVEC.
-0 WA1, WA2, and WA3 are work arrays of length N.
-0 WA4 is a work array of length M.
-0
- 4. Successful completion.
-0 The accuracy of LMDER is controlled by the convergence parame-
- ters FTOL, XTOL, and GTOL. These parameters are used in tests
- which make three types of comparisons between the approximation
- X and a solution XSOL. LMDER terminates when any of the tests
- is satisfied. If any of the convergence parameters is less tha
- the machine precision (as defined by the MINPACK function
- DPMPAR(1)), then LMDER only attempts to satisfy the test define
- by the machine precision. Further progress is not usually pos-
- sible.
-0 The tests assume that the functions and the Jacobian are coded
- consistently, and that the functions are reasonably well
- behaved. If these conditions are not satisfied, then LMDER may
- incorrectly indicate convergence. The coding of the Jacobian
- can be checked by the MINPACK subroutine CHKDER. If the Jaco-
- bian is coded correctly, then the validity of the answer can be
- checked, for example, by rerunning LMDER with tighter toler-
- ances.
-0 First convergence test. If ENORM(Z) denotes the Euclidean norm
- of a vector Z, then this test attempts to guarantee that
-0 ENORM(FVEC) .LE. (1+FTOL)*ENORM(FVECS),
-0 where FVECS denotes the functions evaluated at XSOL. If this
- condition is satisfied with FTOL = 10**(-K), then the final
- residual norm ENORM(FVEC) has K significant decimal digits an
- INFO is set to 1 (or to 3 if the second test is also satis-
- fied). Unless high precision solutions are required, the
- recommended value for FTOL is the square root of the machine
- precision.
-1
-0 Page
-0 Second convergence test. If D is the diagonal matrix whose
- entries are defined by the array DIAG, then this test attempt
- to guarantee that
-0 ENORM(D*(X-XSOL)) .LE. XTOL*ENORM(D*XSOL).
-0 If this condition is satisfied with XTOL = 10**(-K), then the
- larger components of D*X have K significant decimal digits an
- INFO is set to 2 (or to 3 if the first test is also satis-
- fied). There is a danger that the smaller components of D*X
- may have large relative errors, but if MODE = 1, then the
- accuracy of the components of X is usually related to their
- sensitivity. Unless high precision solutions are required,
- the recommended value for XTOL is the square root of the
- machine precision.
-0 Third convergence test. This test is satisfied when the cosine
- of the angle between FVEC and any column of the Jacobian at X
- is at most GTOL in absolute value. There is no clear rela-
- tionship between this test and the accuracy of LMDER, and
- furthermore, the test is equally well satisfied at other crit
- ical points, namely maximizers and saddle points. Therefore,
- termination caused by this test (INFO = 4) should be examined
- carefully. The recommended value for GTOL is zero.
-0
- 5. Unsuccessful completion.
-0 Unsuccessful termination of LMDER can be due to improper input
- parameters, arithmetic interrupts, or an excessive number of
- function evaluations.
-0 Improper input parameters. INFO is set to 0 if N .LE. 0, or
- M .LT. N, or LDFJAC .LT. M, or FTOL .LT. 0.D0, or
- XTOL .LT. 0.D0, or GTOL .LT. 0.D0, or MAXFEV .LE. 0, or
- FACTOR .LE. 0.D0.
-0 Arithmetic interrupts. If these interrupts occur in the FCN
- subroutine during an early stage of the computation, they may
- be caused by an unacceptable choice of X by LMDER. In this
- case, it may be possible to remedy the situation by rerunning
- LMDER with a smaller value of FACTOR.
-0 Excessive number of function evaluations. A reasonable value
- for MAXFEV is 100*(N+1). If the number of calls to FCN with
- IFLAG = 1 reaches MAXFEV, then this indicates that the routin
- is converging very slowly as measured by the progress of FVEC
- and INFO is set to 5. In this case, it may be helpful to
- restart LMDER with MODE set to 1.
-0
- 6. Characteristics of the algorithm.
-0 LMDER is a modification of the Levenberg-Marquardt algorithm.
-1
-0 Page
-0 Two of its main characteristics involve the proper use of
- implicitly scaled variables (if MODE = 1) and an optimal choice
- for the correction. The use of implicitly scaled variables
- achieves scale invariance of LMDER and limits the size of the
- correction in any direction where the functions are changing
- rapidly. The optimal choice of the correction guarantees (unde
- reasonable conditions) global convergence from starting points
- far from the solution and a fast rate of convergence for prob-
- lems with small residuals.
-0 Timing. The time required by LMDER to solve a given problem
- depends on M and N, the behavior of the functions, the accu-
- racy requested, and the starting point. The number of arith-
- metic operations needed by LMDER is about N**3 to process eac
- evaluation of the functions (call to FCN with IFLAG = 1) and
- M*(N**2) to process each evaluation of the Jacobian (call to
- FCN with IFLAG = 2). Unless FCN can be evaluated quickly, th
- timing of LMDER will be strongly influenced by the time spent
- in FCN.
-0 Storage. LMDER requires M*N + 2*M + 6*N double precision sto-
- rage locations and N integer storage locations, in addition t
- the storage required by the program. There are no internally
- declared storage arrays.
-0
- 7. Subprograms required.
-0 USER-supplied ...... FCN
-0 MINPACK-supplied ... DPMPAR,ENORM,LMPAR,QRFAC,QRSOLV
-0 FORTRAN-supplied ... DABS,DMAX1,DMIN1,DSQRT,MOD
-0
- 8. References.
-0 Jorge J. More, The Levenberg-Marquardt Algorithm, Implementatio
- and Theory. Numerical Analysis, G. A. Watson, editor.
- Lecture Notes in Mathematics 630, Springer-Verlag, 1977.
-0
- 9. Example.
-0 The problem is to determine the values of x(1), x(2), and x(3)
- which provide the best fit (in the least squares sense) of
-0 x(1) + u(i)/(v(i)*x(2) + w(i)*x(3)), i = 1, 15
-0 to the data
-0 y = (0.14,0.18,0.22,0.25,0.29,0.32,0.35,0.39,
- 0.37,0.58,0.73,0.96,1.34,2.10,4.39),
-1
-0 Page
-0 where u(i) = i, v(i) = 16 - i, and w(i) = min(u(i),v(i)). The
- i-th component of FVEC is thus defined by
-0 y(i) - (x(1) + u(i)/(v(i)*x(2) + w(i)*x(3))).
-0 C **********
- C
- C DRIVER FOR LMDER EXAMPLE.
- C DOUBLE PRECISION VERSION
- C
- C **********
- INTEGER J,M,N,LDFJAC,MAXFEV,MODE,NPRINT,INFO,NFEV,NJEV,NWRITE
- INTEGER IPVT(3)
- DOUBLE PRECISION FTOL,XTOL,GTOL,FACTOR,FNORM
- DOUBLE PRECISION X(3),FVEC(15),FJAC(15,3),DIAG(3),QTF(3),
- * WA1(3),WA2(3),WA3(3),WA4(15)
- DOUBLE PRECISION ENORM,DPMPAR
- EXTERNAL FCN
- C
- C LOGICAL OUTPUT UNIT IS ASSUMED TO BE NUMBER 6.
- C
- DATA NWRITE /6/
- C
- M = 15
- N = 3
- C
- C THE FOLLOWING STARTING VALUES PROVIDE A ROUGH FIT.
- C
- X(1) = 1.D0
- X(2) = 1.D0
- X(3) = 1.D0
- C
- LDFJAC = 15
- C
- C SET FTOL AND XTOL TO THE SQUARE ROOT OF THE MACHINE PRECISION
- C AND GTOL TO ZERO. UNLESS HIGH PRECISION SOLUTIONS ARE
- C REQUIRED, THESE ARE THE RECOMMENDED SETTINGS.
- C
- FTOL = DSQRT(DPMPAR(1))
- XTOL = DSQRT(DPMPAR(1))
- GTOL = 0.D0
- C
- MAXFEV = 400
- MODE = 1
- FACTOR = 1.D2
- NPRINT = 0
- C
- CALL LMDER(FCN,M,N,X,FVEC,FJAC,LDFJAC,FTOL,XTOL,GTOL,
- * MAXFEV,DIAG,MODE,FACTOR,NPRINT,INFO,NFEV,NJEV,
- * IPVT,QTF,WA1,WA2,WA3,WA4)
- FNORM = ENORM(M,FVEC)
- WRITE (NWRITE,1000) FNORM,NFEV,NJEV,INFO,(X(J),J=1,N)
- STOP
- 1000 FORMAT (5X,31H FINAL L2 NORM OF THE RESIDUALS,D15.7 //
-1
-0 Page
-0 * 5X,31H NUMBER OF FUNCTION EVALUATIONS,I10 //
- * 5X,31H NUMBER OF JACOBIAN EVALUATIONS,I10 //
- * 5X,15H EXIT PARAMETER,16X,I10 //
- * 5X,27H FINAL APPROXIMATE SOLUTION // 5X,3D15.7)
- C
- C LAST CARD OF DRIVER FOR LMDER EXAMPLE.
- C
- END
- SUBROUTINE FCN(M,N,X,FVEC,FJAC,LDFJAC,IFLAG)
- INTEGER M,N,LDFJAC,IFLAG
- DOUBLE PRECISION X(N),FVEC(M),FJAC(LDFJAC,N)
- C
- C SUBROUTINE FCN FOR LMDER EXAMPLE.
- C
- INTEGER I
- DOUBLE PRECISION TMP1,TMP2,TMP3,TMP4
- DOUBLE PRECISION Y(15)
- DATA Y(1),Y(2),Y(3),Y(4),Y(5),Y(6),Y(7),Y(8),
- * Y(9),Y(10),Y(11),Y(12),Y(13),Y(14),Y(15)
- * /1.4D-1,1.8D-1,2.2D-1,2.5D-1,2.9D-1,3.2D-1,3.5D-1,3.9D-1,
- * 3.7D-1,5.8D-1,7.3D-1,9.6D-1,1.34D0,2.1D0,4.39D0/
- C
- IF (IFLAG .NE. 0) GO TO 5
- C
- C INSERT PRINT STATEMENTS HERE WHEN NPRINT IS POSITIVE.
- C
- RETURN
- 5 CONTINUE
- IF (IFLAG .EQ. 2) GO TO 20
- DO 10 I = 1, 15
- TMP1 = I
- TMP2 = 16 - I
- TMP3 = TMP1
- IF (I .GT. 8) TMP3 = TMP2
- FVEC(I) = Y(I) - (X(1) + TMP1/(X(2)*TMP2 + X(3)*TMP3))
- 10 CONTINUE
- GO TO 40
- 20 CONTINUE
- DO 30 I = 1, 15
- TMP1 = I
- TMP2 = 16 - I
- TMP3 = TMP1
- IF (I .GT. 8) TMP3 = TMP2
- TMP4 = (X(2)*TMP2 + X(3)*TMP3)**2
- FJAC(I,1) = -1.D0
- FJAC(I,2) = TMP1*TMP2/TMP4
- FJAC(I,3) = TMP1*TMP3/TMP4
- 30 CONTINUE
- 40 CONTINUE
- RETURN
- C
- C LAST CARD OF SUBROUTINE FCN.
- C
- END
-1
-0 Page
-0 Results obtained with different compilers or machines
- may be slightly different.
-0 FINAL L2 NORM OF THE RESIDUALS 0.9063596D-01
-0 NUMBER OF FUNCTION EVALUATIONS 6
-0 NUMBER OF JACOBIAN EVALUATIONS 5
-0 EXIT PARAMETER 1
-0 FINAL APPROXIMATE SOLUTION
-0 0.8241058D-01 0.1133037D+01 0.2343695D+01
-1
-0
-1
-0 Page
-0 Documentation for MINPACK subroutine LMSTR1
-0 Double precision version
-0 Argonne National Laboratory
-0 Burton S. Garbow, Kenneth E. Hillstrom, Jorge J. More
-0 March 1980
-0
- 1. Purpose.
-0 The purpose of LMSTR1 is to minimize the sum of the squares of
- nonlinear functions in N variables by a modification of the
- Levenberg-Marquardt algorithm which uses minimal storage. This
- is done by using the more general least-squares solver LMSTR.
- The user must provide a subroutine which calculates the func-
- tions and the rows of the Jacobian.
-0
- 2. Subroutine and type statements.
-0 SUBROUTINE LMSTR1(FCN,M,N,X,FVEC,FJAC,LDFJAC,TOL,
- * INFO,IPVT,WA,LWA)
- INTEGER M,N,LDFJAC,INFO,LWA
- INTEGER IPVT(N)
- DOUBLE PRECISION TOL
- DOUBLE PRECISION X(N),FVEC(M),FJAC(LDFJAC,N),WA(LWA)
- EXTERNAL FCN
-0
- 3. Parameters.
-0 Parameters designated as input parameters must be specified on
- entry to LMSTR1 and are not changed on exit, while parameters
- designated as output parameters need not be specified on entry
- and are set to appropriate values on exit from LMSTR1.
-0 FCN is the name of the user-supplied subroutine which calculate
- the functions and the rows of the Jacobian. FCN must be
- declared in an EXTERNAL statement in the user calling program
- and should be written as follows.
-0 SUBROUTINE FCN(M,N,X,FVEC,FJROW,IFLAG)
- INTEGER M,N,IFLAG
- DOUBLE PRECISION X(N),FVEC(M),FJROW(N)
- ----------
- IF IFLAG = 1 CALCULATE THE FUNCTIONS AT X AND
- RETURN THIS VECTOR IN FVEC.
- IF IFLAG = I CALCULATE THE (I-1)-ST ROW OF THE
- JACOBIAN AT X AND RETURN THIS VECTOR IN FJROW.
- ----------
- RETURN
-1
-0 Page
-0 END
-0 The value of IFLAG should not be changed by FCN unless the
- user wants to terminate execution of LMSTR1. In this case se
- IFLAG to a negative integer.
-0 M is a positive integer input variable set to the number of
- functions.
-0 N is a positive integer input variable set to the number of
- variables. N must not exceed M.
-0 X is an array of length N. On input X must contain an initial
- estimate of the solution vector. On output X contains the
- final estimate of the solution vector.
-0 FVEC is an output array of length M which contains the function
- evaluated at the output X.
-0 FJAC is an output N by N array. The upper triangle of FJAC con
- tains an upper triangular matrix R such that
-0 T T T
- P *(JAC *JAC)*P = R *R,
-0 where P is a permutation matrix and JAC is the final calcu-
- lated Jacobian. Column j of P is column IPVT(j) (see below)
- of the identity matrix. The lower triangular part of FJAC
- contains information generated during the computation of R.
-0 LDFJAC is a positive integer input variable not less than N
- which specifies the leading dimension of the array FJAC.
-0 TOL is a nonnegative input variable. Termination occurs when
- the algorithm estimates either that the relative error in the
- sum of squares is at most TOL or that the relative error
- between X and the solution is at most TOL. Section 4 contain
- more details about TOL.
-0 INFO is an integer output variable. If the user has terminated
- execution, INFO is set to the (negative) value of IFLAG. See
- description of FCN. Otherwise, INFO is set as follows.
-0 INFO = 0 Improper input parameters.
-0 INFO = 1 Algorithm estimates that the relative error in the
- sum of squares is at most TOL.
-0 INFO = 2 Algorithm estimates that the relative error between
- X and the solution is at most TOL.
-0 INFO = 3 Conditions for INFO = 1 and INFO = 2 both hold.
-0 INFO = 4 FVEC is orthogonal to the columns of the Jacobian t
-1
-0 Page
-0 machine precision.
-0 INFO = 5 Number of calls to FCN with IFLAG = 1 has reached
- 100*(N+1).
-0 INFO = 6 TOL is too small. No further reduction in the sum
- of squares is possible.
-0 INFO = 7 TOL is too small. No further improvement in the
- approximate solution X is possible.
-0 Sections 4 and 5 contain more details about INFO.
-0 IPVT is an integer output array of length N. IPVT defines a
- permutation matrix P such that JAC*P = Q*R, where JAC is the
- final calculated Jacobian, Q is orthogonal (not stored), and
- is upper triangular. Column j of P is column IPVT(j) of the
- identity matrix.
-0 WA is a work array of length LWA.
-0 LWA is a positive integer input variable not less than 5*N+M.
-0
- 4. Successful completion.
-0 The accuracy of LMSTR1 is controlled by the convergence parame-
- ter TOL. This parameter is used in tests which make three type
- of comparisons between the approximation X and a solution XSOL.
- LMSTR1 terminates when any of the tests is satisfied. If TOL i
- less than the machine precision (as defined by the MINPACK func
- tion DPMPAR(1)), then LMSTR1 only attempts to satisfy the test
- defined by the machine precision. Further progress is not usu-
- ally possible. Unless high precision solutions are required,
- the recommended value for TOL is the square root of the machine
- precision.
-0 The tests assume that the functions and the Jacobian are coded
- consistently, and that the functions are reasonably well
- behaved. If these conditions are not satisfied, then LMSTR1 ma
- incorrectly indicate convergence. The coding of the Jacobian
- can be checked by the MINPACK subroutine CHKDER. If the Jaco-
- bian is coded correctly, then the validity of the answer can be
- checked, for example, by rerunning LMSTR1 with a tighter toler-
- ance.
-0 First convergence test. If ENORM(Z) denotes the Euclidean norm
- of a vector Z, then this test attempts to guarantee that
-0 ENORM(FVEC) .LE. (1+TOL)*ENORM(FVECS),
-0 where FVECS denotes the functions evaluated at XSOL. If this
- condition is satisfied with TOL = 10**(-K), then the final
- residual norm ENORM(FVEC) has K significant decimal digits an
-1
-0 Page
-0 INFO is set to 1 (or to 3 if the second test is also satis-
- fied).
-0 Second convergence test. If D is a diagonal matrix (implicitly
- generated by LMSTR1) whose entries contain scale factors for
- the variables, then this test attempts to guarantee that
-0 ENORM(D*(X-XSOL)) .LE. TOL*ENORM(D*XSOL).
-0 If this condition is satisfied with TOL = 10**(-K), then the
- larger components of D*X have K significant decimal digits an
- INFO is set to 2 (or to 3 if the first test is also satis-
- fied). There is a danger that the smaller components of D*X
- may have large relative errors, but the choice of D is such
- that the accuracy of the components of X is usually related t
- their sensitivity.
-0 Third convergence test. This test is satisfied when FVEC is
- orthogonal to the columns of the Jacobian to machine preci-
- sion. There is no clear relationship between this test and
- the accuracy of LMSTR1, and furthermore, the test is equally
- well satisfied at other critical points, namely maximizers an
- saddle points. Therefore, termination caused by this test
- (INFO = 4) should be examined carefully.
-0
- 5. Unsuccessful completion.
-0 Unsuccessful termination of LMSTR1 can be due to improper input
- parameters, arithmetic interrupts, or an excessive number of
- function evaluations.
-0 Improper input parameters. INFO is set to 0 if N .LE. 0, or
- M .LT. N, or LDFJAC .LT. N, or TOL .LT. 0.D0, or
- LWA .LT. 5*N+M.
-0 Arithmetic interrupts. If these interrupts occur in the FCN
- subroutine during an early stage of the computation, they may
- be caused by an unacceptable choice of X by LMSTR1. In this
- case, it may be possible to remedy the situation by not evalu
- ating the functions here, but instead setting the components
- of FVEC to numbers that exceed those in the initial FVEC,
- thereby indirectly reducing the step length. The step length
- can be more directly controlled by using instead LMSTR, which
- includes in its calling sequence the step-length- governing
- parameter FACTOR.
-0 Excessive number of function evaluations. If the number of
- calls to FCN with IFLAG = 1 reaches 100*(N+1), then this indi
- cates that the routine is converging very slowly as measured
- by the progress of FVEC, and INFO is set to 5. In this case,
- it may be helpful to restart LMSTR1, thereby forcing it to
- disregard old (and possibly harmful) information.
-1
-0 Page
-0
- 6. Characteristics of the algorithm.
-0 LMSTR1 is a modification of the Levenberg-Marquardt algorithm.
- Two of its main characteristics involve the proper use of
- implicitly scaled variables and an optimal choice for the cor-
- rection. The use of implicitly scaled variables achieves scale
- invariance of LMSTR1 and limits the size of the correction in
- any direction where the functions are changing rapidly. The
- optimal choice of the correction guarantees (under reasonable
- conditions) global convergence from starting points far from th
- solution and a fast rate of convergence for problems with small
- residuals.
-0 Timing. The time required by LMSTR1 to solve a given problem
- depends on M and N, the behavior of the functions, the accu-
- racy requested, and the starting point. The number of arith-
- metic operations needed by LMSTR1 is about N**3 to process
- each evaluation of the functions (call to FCN with IFLAG = 1)
- and 1.5*(N**2) to process each row of the Jacobian (call to
- FCN with IFLAG .GE. 2). Unless FCN can be evaluated quickly,
- the timing of LMSTR1 will be strongly influenced by the time
- spent in FCN.
-0 Storage. LMSTR1 requires N**2 + 2*M + 6*N double precision sto
- rage locations and N integer storage locations, in addition t
- the storage required by the program. There are no internally
- declared storage arrays.
-0
- 7. Subprograms required.
-0 USER-supplied ...... FCN
-0 MINPACK-supplied ... DPMPAR,ENORM,LMSTR,LMPAR,QRFAC,QRSOLV,
- RWUPDT
-0 FORTRAN-supplied ... DABS,DMAX1,DMIN1,DSQRT,MOD
-0
- 8. References.
-0 Jorge J. More, The Levenberg-Marquardt Algorithm, Implementatio
- and Theory. Numerical Analysis, G. A. Watson, editor.
- Lecture Notes in Mathematics 630, Springer-Verlag, 1977.
-0
- 9. Example.
-0 The problem is to determine the values of x(1), x(2), and x(3)
- which provide the best fit (in the least squares sense) of
-0 x(1) + u(i)/(v(i)*x(2) + w(i)*x(3)), i = 1, 15
-1
-0 Page
-0 to the data
-0 y = (0.14,0.18,0.22,0.25,0.29,0.32,0.35,0.39,
- 0.37,0.58,0.73,0.96,1.34,2.10,4.39),
-0 where u(i) = i, v(i) = 16 - i, and w(i) = min(u(i),v(i)). The
- i-th component of FVEC is thus defined by
-0 y(i) - (x(1) + u(i)/(v(i)*x(2) + w(i)*x(3))).
-0 C **********
- C
- C DRIVER FOR LMSTR1 EXAMPLE.
- C DOUBLE PRECISION VERSION
- C
- C **********
- INTEGER J,M,N,LDFJAC,INFO,LWA,NWRITE
- INTEGER IPVT(3)
- DOUBLE PRECISION TOL,FNORM
- DOUBLE PRECISION X(3),FVEC(15),FJAC(3,3),WA(30)
- DOUBLE PRECISION ENORM,DPMPAR
- EXTERNAL FCN
- C
- C LOGICAL OUTPUT UNIT IS ASSUMED TO BE NUMBER 6.
- C
- DATA NWRITE /6/
- C
- M = 15
- N = 3
- C
- C THE FOLLOWING STARTING VALUES PROVIDE A ROUGH FIT.
- C
- X(1) = 1.D0
- X(2) = 1.D0
- X(3) = 1.D0
- C
- LDFJAC = 3
- LWA = 30
- C
- C SET TOL TO THE SQUARE ROOT OF THE MACHINE PRECISION.
- C UNLESS HIGH PRECISION SOLUTIONS ARE REQUIRED,
- C THIS IS THE RECOMMENDED SETTING.
- C
- TOL = DSQRT(DPMPAR(1))
- C
- CALL LMSTR1(FCN,M,N,X,FVEC,FJAC,LDFJAC,TOL,
- * INFO,IPVT,WA,LWA)
- FNORM = ENORM(M,FVEC)
- WRITE (NWRITE,1000) FNORM,INFO,(X(J),J=1,N)
- STOP
- 1000 FORMAT (5X,31H FINAL L2 NORM OF THE RESIDUALS,D15.7 //
- * 5X,15H EXIT PARAMETER,16X,I10 //
- * 5X,27H FINAL APPROXIMATE SOLUTION // 5X,3D15.7)
- C
-1
-0 Page
-0 C LAST CARD OF DRIVER FOR LMSTR1 EXAMPLE.
- C
- END
- SUBROUTINE FCN(M,N,X,FVEC,FJROW,IFLAG)
- INTEGER M,N,IFLAG
- DOUBLE PRECISION X(N),FVEC(M),FJROW(N)
- C
- C SUBROUTINE FCN FOR LMSTR1 EXAMPLE.
- C
- INTEGER I
- DOUBLE PRECISION TMP1,TMP2,TMP3,TMP4
- DOUBLE PRECISION Y(15)
- DATA Y(1),Y(2),Y(3),Y(4),Y(5),Y(6),Y(7),Y(8),
- * Y(9),Y(10),Y(11),Y(12),Y(13),Y(14),Y(15)
- * /1.4D-1,1.8D-1,2.2D-1,2.5D-1,2.9D-1,3.2D-1,3.5D-1,3.9D-1,
- * 3.7D-1,5.8D-1,7.3D-1,9.6D-1,1.34D0,2.1D0,4.39D0/
- C
- IF (IFLAG .GE. 2) GO TO 20
- DO 10 I = 1, 15
- TMP1 = I
- TMP2 = 16 - I
- TMP3 = TMP1
- IF (I .GT. 8) TMP3 = TMP2
- FVEC(I) = Y(I) - (X(1) + TMP1/(X(2)*TMP2 + X(3)*TMP3))
- 10 CONTINUE
- GO TO 40
- 20 CONTINUE
- I = IFLAG - 1
- TMP1 = I
- TMP2 = 16 - I
- TMP3 = TMP1
- IF (I .GT. 8) TMP3 = TMP2
- TMP4 = (X(2)*TMP2 + X(3)*TMP3)**2
- FJROW(1) = -1.D0
- FJROW(2) = TMP1*TMP2/TMP4
- FJROW(3) = TMP1*TMP3/TMP4
- 30 CONTINUE
- 40 CONTINUE
- RETURN
- C
- C LAST CARD OF SUBROUTINE FCN.
- C
- END
-0 Results obtained with different compilers or machines
- may be slightly different.
-0 FINAL L2 NORM OF THE RESIDUALS 0.9063596D-01
-0 EXIT PARAMETER 1
-0 FINAL APPROXIMATE SOLUTION
-0 0.8241058D-01 0.1133037D+01 0.2343695D+01
-1
-0
-1
-0 Page
-0 Documentation for MINPACK subroutine LMSTR
-0 Double precision version
-0 Argonne National Laboratory
-0 Burton S. Garbow, Kenneth E. Hillstrom, Jorge J. More
-0 March 1980
-0
- 1. Purpose.
-0 The purpose of LMSTR is to minimize the sum of the squares of M
- nonlinear functions in N variables by a modification of the
- Levenberg-Marquardt algorithm which uses minimal storage. The
- user must provide a subroutine which calculates the functions
- and the rows of the Jacobian.
-0
- 2. Subroutine and type statements.
-0 SUBROUTINE LMSTR(FCN,M,N,X,FVEC,FJAC,LDFJAC,FTOL,XTOL,GTOL,
- * MAXFEV,DIAG,MODE,FACTOR,NPRINT,INFO,NFEV,NJEV,
- * IPVT,QTF,WA1,WA2,WA3,WA4)
- INTEGER M,N,LDFJAC,MAXFEV,MODE,NPRINT,INFO,NFEV,NJEV
- INTEGER IPVT(N)
- DOUBLE PRECISION FTOL,XTOL,GTOL,FACTOR
- DOUBLE PRECISION X(N),FVEC(M),FJAC(LDFJAC,N),DIAG(N),QTF(N),
- * WA1(N),WA2(N),WA3(N),WA4(M)
-0
- 3. Parameters.
-0 Parameters designated as input parameters must be specified on
- entry to LMSTR and are not changed on exit, while parameters
- designated as output parameters need not be specified on entry
- and are set to appropriate values on exit from LMSTR.
-0 FCN is the name of the user-supplied subroutine which calculate
- the functions and the rows of the Jacobian. FCN must be
- declared in an EXTERNAL statement in the user calling program
- and should be written as follows.
-0 SUBROUTINE FCN(M,N,X,FVEC,FJROW,IFLAG)
- INTEGER M,N,IFLAG
- DOUBLE PRECISION X(N),FVEC(M),FJROW(N)
- ----------
- IF IFLAG = 1 CALCULATE THE FUNCTIONS AT X AND
- RETURN THIS VECTOR IN FVEC.
- IF IFLAG = I CALCULATE THE (I-1)-ST ROW OF THE
- JACOBIAN AT X AND RETURN THIS VECTOR IN FJROW.
- ----------
- RETURN
-1
-0 Page
-0 END
-0 The value of IFLAG should not be changed by FCN unless the
- user wants to terminate execution of LMSTR. In this case set
- IFLAG to a negative integer.
-0 M is a positive integer input variable set to the number of
- functions.
-0 N is a positive integer input variable set to the number of
- variables. N must not exceed M.
-0 X is an array of length N. On input X must contain an initial
- estimate of the solution vector. On output X contains the
- final estimate of the solution vector.
-0 FVEC is an output array of length M which contains the function
- evaluated at the output X.
-0 FJAC is an output N by N array. The upper triangle of FJAC con
- tains an upper triangular matrix R such that
-0 T T T
- P *(JAC *JAC)*P = R *R,
-0 where P is a permutation matrix and JAC is the final calcu-
- lated Jacobian. Column j of P is column IPVT(j) (see below)
- of the identity matrix. The lower triangular part of FJAC
- contains information generated during the computation of R.
-0 LDFJAC is a positive integer input variable not less than N
- which specifies the leading dimension of the array FJAC.
-0 FTOL is a nonnegative input variable. Termination occurs when
- both the actual and predicted relative reductions in the sum
- of squares are at most FTOL. Therefore, FTOL measures the
- relative error desired in the sum of squares. Section 4 con-
- tains more details about FTOL.
-0 XTOL is a nonnegative input variable. Termination occurs when
- the relative error between two consecutive iterates is at mos
- XTOL. Therefore, XTOL measures the relative error desired in
- the approximate solution. Section 4 contains more details
- about XTOL.
-0 GTOL is a nonnegative input variable. Termination occurs when
- the cosine of the angle between FVEC and any column of the
- Jacobian is at most GTOL in absolute value. Therefore, GTOL
- measures the orthogonality desired between the function vecto
- and the columns of the Jacobian. Section 4 contains more
- details about GTOL.
-0 MAXFEV is a positive integer input variable. Termination occur
- when the number of calls to FCN with IFLAG = 1 has reached
-1
-0 Page
-0 MAXFEV.
-0 DIAG is an array of length N. If MODE = 1 (see below), DIAG is
- internally set. If MODE = 2, DIAG must contain positive
- entries that serve as multiplicative scale factors for the
- variables.
-0 MODE is an integer input variable. If MODE = 1, the variables
- will be scaled internally. If MODE = 2, the scaling is speci
- fied by the input DIAG. Other values of MODE are equivalent
- to MODE = 1.
-0 FACTOR is a positive input variable used in determining the ini
- tial step bound. This bound is set to the product of FACTOR
- and the Euclidean norm of DIAG*X if nonzero, or else to FACTO
- itself. In most cases FACTOR should lie in the interval
- (.1,100.). 100. is a generally recommended value.
-0 NPRINT is an integer input variable that enables controlled
- printing of iterates if it is positive. In this case, FCN is
- called with IFLAG = 0 at the beginning of the first iteration
- and every NPRINT iterations thereafter and immediately prior
- to return, with X and FVEC available for printing. If NPRINT
- is not positive, no special calls of FCN with IFLAG = 0 are
- made.
-0 INFO is an integer output variable. If the user has terminated
- execution, INFO is set to the (negative) value of IFLAG. See
- description of FCN. Otherwise, INFO is set as follows.
-0 INFO = 0 Improper input parameters.
-0 INFO = 1 Both actual and predicted relative reductions in th
- sum of squares are at most FTOL.
-0 INFO = 2 Relative error between two consecutive iterates is
- at most XTOL.
-0 INFO = 3 Conditions for INFO = 1 and INFO = 2 both hold.
-0 INFO = 4 The cosine of the angle between FVEC and any column
- of the Jacobian is at most GTOL in absolute value.
-0 INFO = 5 Number of calls to FCN with IFLAG = 1 has reached
- MAXFEV.
-0 INFO = 6 FTOL is too small. No further reduction in the sum
- of squares is possible.
-0 INFO = 7 XTOL is too small. No further improvement in the
- approximate solution X is possible.
-0 INFO = 8 GTOL is too small. FVEC is orthogonal to the
- columns of the Jacobian to machine precision.
-1
-0 Page
-0 Sections 4 and 5 contain more details about INFO.
-0 NFEV is an integer output variable set to the number of calls t
- FCN with IFLAG = 1.
-0 NJEV is an integer output variable set to the number of calls t
- FCN with IFLAG = 2.
-0 IPVT is an integer output array of length N. IPVT defines a
- permutation matrix P such that JAC*P = Q*R, where JAC is the
- final calculated Jacobian, Q is orthogonal (not stored), and
- is upper triangular. Column j of P is column IPVT(j) of the
- identity matrix.
-0 QTF is an output array of length N which contains the first N
- elements of the vector (Q transpose)*FVEC.
-0 WA1, WA2, and WA3 are work arrays of length N.
-0 WA4 is a work array of length M.
-0
- 4. Successful completion.
-0 The accuracy of LMSTR is controlled by the convergence parame-
- ters FTOL, XTOL, and GTOL. These parameters are used in tests
- which make three types of comparisons between the approximation
- X and a solution XSOL. LMSTR terminates when any of the tests
- is satisfied. If any of the convergence parameters is less tha
- the machine precision (as defined by the MINPACK function
- DPMPAR(1)), then LMSTR only attempts to satisfy the test define
- by the machine precision. Further progress is not usually pos-
- sible.
-0 The tests assume that the functions and the Jacobian are coded
- consistently, and that the functions are reasonably well
- behaved. If these conditions are not satisfied, then LMSTR may
- incorrectly indicate convergence. The coding of the Jacobian
- can be checked by the MINPACK subroutine CHKDER. If the Jaco-
- bian is coded correctly, then the validity of the answer can be
- checked, for example, by rerunning LMSTR with tighter toler-
- ances.
-0 First convergence test. If ENORM(Z) denotes the Euclidean norm
- of a vector Z, then this test attempts to guarantee that
-0 ENORM(FVEC) .LE. (1+FTOL)*ENORM(FVECS),
-0 where FVECS denotes the functions evaluated at XSOL. If this
- condition is satisfied with FTOL = 10**(-K), then the final
- residual norm ENORM(FVEC) has K significant decimal digits an
- INFO is set to 1 (or to 3 if the second test is also satis-
- fied). Unless high precision solutions are required, the
- recommended value for FTOL is the square root of the machine
-1
-0 Page
-0 precision.
-0 Second convergence test. If D is the diagonal matrix whose
- entries are defined by the array DIAG, then this test attempt
- to guarantee that
-0 ENORM(D*(X-XSOL)) .LE. XTOL*ENORM(D*XSOL).
-0 If this condition is satisfied with XTOL = 10**(-K), then the
- larger components of D*X have K significant decimal digits an
- INFO is set to 2 (or to 3 if the first test is also satis-
- fied). There is a danger that the smaller components of D*X
- may have large relative errors, but if MODE = 1, then the
- accuracy of the components of X is usually related to their
- sensitivity. Unless high precision solutions are required,
- the recommended value for XTOL is the square root of the
- machine precision.
-0 Third convergence test. This test is satisfied when the cosine
- of the angle between FVEC and any column of the Jacobian at X
- is at most GTOL in absolute value. There is no clear rela-
- tionship between this test and the accuracy of LMSTR, and
- furthermore, the test is equally well satisfied at other crit
- ical points, namely maximizers and saddle points. Therefore,
- termination caused by this test (INFO = 4) should be examined
- carefully. The recommended value for GTOL is zero.
-0
- 5. Unsuccessful completion.
-0 Unsuccessful termination of LMSTR can be due to improper input
- parameters, arithmetic interrupts, or an excessive number of
- function evaluations.
-0 Improper input parameters. INFO is set to 0 if N .LE. 0, or
- M .LT. N, or LDFJAC .LT. N, or FTOL .LT. 0.D0, or
- XTOL .LT. 0.D0, or GTOL .LT. 0.D0, or MAXFEV .LE. 0, or
- FACTOR .LE. 0.D0.
-0 Arithmetic interrupts. If these interrupts occur in the FCN
- subroutine during an early stage of the computation, they may
- be caused by an unacceptable choice of X by LMSTR. In this
- case, it may be possible to remedy the situation by rerunning
- LMSTR with a smaller value of FACTOR.
-0 Excessive number of function evaluations. A reasonable value
- for MAXFEV is 100*(N+1). If the number of calls to FCN with
- IFLAG = 1 reaches MAXFEV, then this indicates that the routin
- is converging very slowly as measured by the progress of FVEC
- and INFO is set to 5. In this case, it may be helpful to
- restart LMSTR with MODE set to 1.
-0
- 6. Characteristics of the algorithm.
-1
-0 Page
-0 LMSTR is a modification of the Levenberg-Marquardt algorithm.
- Two of its main characteristics involve the proper use of
- implicitly scaled variables (if MODE = 1) and an optimal choice
- for the correction. The use of implicitly scaled variables
- achieves scale invariance of LMSTR and limits the size of the
- correction in any direction where the functions are changing
- rapidly. The optimal choice of the correction guarantees (unde
- reasonable conditions) global convergence from starting points
- far from the solution and a fast rate of convergence for prob-
- lems with small residuals.
-0 Timing. The time required by LMSTR to solve a given problem
- depends on M and N, the behavior of the functions, the accu-
- racy requested, and the starting point. The number of arith-
- metic operations needed by LMSTR is about N**3 to process eac
- evaluation of the functions (call to FCN with IFLAG = 1) and
- 1.5*(N**2) to process each row of the Jacobian (call to FCN
- with IFLAG .GE. 2). Unless FCN can be evaluated quickly, the
- timing of LMSTR will be strongly influenced by the time spent
- in FCN.
-0 Storage. LMSTR requires N**2 + 2*M + 6*N double precision sto-
- rage locations and N integer storage locations, in addition t
- the storage required by the program. There are no internally
- declared storage arrays.
-0
- 7. Subprograms required.
-0 USER-supplied ...... FCN
-0 MINPACK-supplied ... DPMPAR,ENORM,LMPAR,QRFAC,QRSOLV,RWUPDT
-0 FORTRAN-supplied ... DABS,DMAX1,DMIN1,DSQRT,MOD
-0
- 8. References.
-0 Jorge J. More, The Levenberg-Marquardt Algorithm, Implementatio
- and Theory. Numerical Analysis, G. A. Watson, editor.
- Lecture Notes in Mathematics 630, Springer-Verlag, 1977.
-0
- 9. Example.
-0 The problem is to determine the values of x(1), x(2), and x(3)
- which provide the best fit (in the least squares sense) of
-0 x(1) + u(i)/(v(i)*x(2) + w(i)*x(3)), i = 1, 15
-0 to the data
-0 y = (0.14,0.18,0.22,0.25,0.29,0.32,0.35,0.39,
- 0.37,0.58,0.73,0.96,1.34,2.10,4.39),
-1
-0 Page
-0 where u(i) = i, v(i) = 16 - i, and w(i) = min(u(i),v(i)). The
- i-th component of FVEC is thus defined by
-0 y(i) - (x(1) + u(i)/(v(i)*x(2) + w(i)*x(3))).
-0 C **********
- C
- C DRIVER FOR LMSTR EXAMPLE.
- C DOUBLE PRECISION VERSION
- C
- C **********
- INTEGER J,M,N,LDFJAC,MAXFEV,MODE,NPRINT,INFO,NFEV,NJEV,NWRITE
- INTEGER IPVT(3)
- DOUBLE PRECISION FTOL,XTOL,GTOL,FACTOR,FNORM
- DOUBLE PRECISION X(3),FVEC(15),FJAC(3,3),DIAG(3),QTF(3),
- * WA1(3),WA2(3),WA3(3),WA4(15)
- DOUBLE PRECISION ENORM,DPMPAR
- EXTERNAL FCN
- C
- C LOGICAL OUTPUT UNIT IS ASSUMED TO BE NUMBER 6.
- C
- DATA NWRITE /6/
- C
- M = 15
- N = 3
- C
- C THE FOLLOWING STARTING VALUES PROVIDE A ROUGH FIT.
- C
- X(1) = 1.D0
- X(2) = 1.D0
- X(3) = 1.D0
- C
- LDFJAC = 3
- C
- C SET FTOL AND XTOL TO THE SQUARE ROOT OF THE MACHINE PRECISION
- C AND GTOL TO ZERO. UNLESS HIGH PRECISION SOLUTIONS ARE
- C REQUIRED, THESE ARE THE RECOMMENDED SETTINGS.
- C
- FTOL = DSQRT(DPMPAR(1))
- XTOL = DSQRT(DPMPAR(1))
- GTOL = 0.D0
- C
- MAXFEV = 400
- MODE = 1
- FACTOR = 1.D2
- NPRINT = 0
- C
- CALL LMSTR(FCN,M,N,X,FVEC,FJAC,LDFJAC,FTOL,XTOL,GTOL,
- * MAXFEV,DIAG,MODE,FACTOR,NPRINT,INFO,NFEV,NJEV,
- * IPVT,QTF,WA1,WA2,WA3,WA4)
- FNORM = ENORM(M,FVEC)
- WRITE (NWRITE,1000) FNORM,NFEV,NJEV,INFO,(X(J),J=1,N)
- STOP
- 1000 FORMAT (5X,31H FINAL L2 NORM OF THE RESIDUALS,D15.7 //
-1
-0 Page
-0 * 5X,31H NUMBER OF FUNCTION EVALUATIONS,I10 //
- * 5X,31H NUMBER OF JACOBIAN EVALUATIONS,I10 //
- * 5X,15H EXIT PARAMETER,16X,I10 //
- * 5X,27H FINAL APPROXIMATE SOLUTION // 5X,3D15.7)
- C
- C LAST CARD OF DRIVER FOR LMSTR EXAMPLE.
- C
- END
- SUBROUTINE FCN(M,N,X,FVEC,FJROW,IFLAG)
- INTEGER M,N,IFLAG
- DOUBLE PRECISION X(N),FVEC(M),FJROW(N)
- C
- C SUBROUTINE FCN FOR LMSTR EXAMPLE.
- C
- INTEGER I
- DOUBLE PRECISION TMP1,TMP2,TMP3,TMP4
- DOUBLE PRECISION Y(15)
- DATA Y(1),Y(2),Y(3),Y(4),Y(5),Y(6),Y(7),Y(8),
- * Y(9),Y(10),Y(11),Y(12),Y(13),Y(14),Y(15)
- * /1.4D-1,1.8D-1,2.2D-1,2.5D-1,2.9D-1,3.2D-1,3.5D-1,3.9D-1,
- * 3.7D-1,5.8D-1,7.3D-1,9.6D-1,1.34D0,2.1D0,4.39D0/
- C
- IF (IFLAG .NE. 0) GO TO 5
- C
- C INSERT PRINT STATEMENTS HERE WHEN NPRINT IS POSITIVE.
- C
- RETURN
- 5 CONTINUE
- IF (IFLAG .GE. 2) GO TO 20
- DO 10 I = 1, 15
- TMP1 = I
- TMP2 = 16 - I
- TMP3 = TMP1
- IF (I .GT. 8) TMP3 = TMP2
- FVEC(I) = Y(I) - (X(1) + TMP1/(X(2)*TMP2 + X(3)*TMP3))
- 10 CONTINUE
- GO TO 40
- 20 CONTINUE
- I = IFLAG - 1
- TMP1 = I
- TMP2 = 16 - I
- TMP3 = TMP1
- IF (I .GT. 8) TMP3 = TMP2
- TMP4 = (X(2)*TMP2 + X(3)*TMP3)**2
- FJROW(1) = -1.D0
- FJROW(2) = TMP1*TMP2/TMP4
- FJROW(3) = TMP1*TMP3/TMP4
- 30 CONTINUE
- 40 CONTINUE
- RETURN
- C
- C LAST CARD OF SUBROUTINE FCN.
- C
- END
-1
-0 Page
-0 Results obtained with different compilers or machines
- may be slightly different.
-0 FINAL L2 NORM OF THE RESIDUALS 0.9063596D-01
-0 NUMBER OF FUNCTION EVALUATIONS 6
-0 NUMBER OF JACOBIAN EVALUATIONS 5
-0 EXIT PARAMETER 1
-0 FINAL APPROXIMATE SOLUTION
-0 0.8241058D-01 0.1133037D+01 0.2343695D+01
-1
-0
-1
-0 Page
-0 Documentation for MINPACK subroutine LMDIF1
-0 Double precision version
-0 Argonne National Laboratory
-0 Burton S. Garbow, Kenneth E. Hillstrom, Jorge J. More
-0 March 1980
-0
- 1. Purpose.
-0 The purpose of LMDIF1 is to minimize the sum of the squares of
- nonlinear functions in N variables by a modification of the
- Levenberg-Marquardt algorithm. This is done by using the more
- general least-squares solver LMDIF. The user must provide a
- subroutine which calculates the functions. The Jacobian is the
- calculated by a forward-difference approximation.
-0
- 2. Subroutine and type statements.
-0 SUBROUTINE LMDIF1(FCN,M,N,X,FVEC,TOL,INFO,IWA,WA,LWA)
- INTEGER M,N,INFO,LWA
- INTEGER IWA(N)
- DOUBLE PRECISION TOL
- DOUBLE PRECISION X(N),FVEC(M),WA(LWA)
- EXTERNAL FCN
-0
- 3. Parameters.
-0 Parameters designated as input parameters must be specified on
- entry to LMDIF1 and are not changed on exit, while parameters
- designated as output parameters need not be specified on entry
- and are set to appropriate values on exit from LMDIF1.
-0 FCN is the name of the user-supplied subroutine which calculate
- the functions. FCN must be declared in an EXTERNAL statement
- in the user calling program, and should be written as follows
-0 SUBROUTINE FCN(M,N,X,FVEC,IFLAG)
- INTEGER M,N,IFLAG
- DOUBLE PRECISION X(N),FVEC(M)
- ----------
- CALCULATE THE FUNCTIONS AT X AND
- RETURN THIS VECTOR IN FVEC.
- ----------
- RETURN
- END
-0 The value of IFLAG should not be changed by FCN unless the
- user wants to terminate execution of LMDIF1. In this case se
-1
-0 Page
-0 IFLAG to a negative integer.
-0 M is a positive integer input variable set to the number of
- functions.
-0 N is a positive integer input variable set to the number of
- variables. N must not exceed M.
-0 X is an array of length N. On input X must contain an initial
- estimate of the solution vector. On output X contains the
- final estimate of the solution vector.
-0 FVEC is an output array of length M which contains the function
- evaluated at the output X.
-0 TOL is a nonnegative input variable. Termination occurs when
- the algorithm estimates either that the relative error in the
- sum of squares is at most TOL or that the relative error
- between X and the solution is at most TOL. Section 4 contain
- more details about TOL.
-0 INFO is an integer output variable. If the user has terminated
- execution, INFO is set to the (negative) value of IFLAG. See
- description of FCN. Otherwise, INFO is set as follows.
-0 INFO = 0 Improper input parameters.
-0 INFO = 1 Algorithm estimates that the relative error in the
- sum of squares is at most TOL.
-0 INFO = 2 Algorithm estimates that the relative error between
- X and the solution is at most TOL.
-0 INFO = 3 Conditions for INFO = 1 and INFO = 2 both hold.
-0 INFO = 4 FVEC is orthogonal to the columns of the Jacobian t
- machine precision.
-0 INFO = 5 Number of calls to FCN has reached or exceeded
- 200*(N+1).
-0 INFO = 6 TOL is too small. No further reduction in the sum
- of squares is possible.
-0 INFO = 7 TOL is too small. No further improvement in the
- approximate solution X is possible.
-0 Sections 4 and 5 contain more details about INFO.
-0 IWA is an integer work array of length N.
-0 WA is a work array of length LWA.
-0 LWA is a positive integer input variable not less than
-1
-0 Page
-0 M*N+5*N+M.
-0
- 4. Successful completion.
-0 The accuracy of LMDIF1 is controlled by the convergence parame-
- ter TOL. This parameter is used in tests which make three type
- of comparisons between the approximation X and a solution XSOL.
- LMDIF1 terminates when any of the tests is satisfied. If TOL i
- less than the machine precision (as defined by the MINPACK func
- tion DPMPAR(1)), then LMDIF1 only attempts to satisfy the test
- defined by the machine precision. Further progress is not usu-
- ally possible. Unless high precision solutions are required,
- the recommended value for TOL is the square root of the machine
- precision.
-0 The tests assume that the functions are reasonably well behaved
- If this condition is not satisfied, then LMDIF1 may incorrectly
- indicate convergence. The validity of the answer can be
- checked, for example, by rerunning LMDIF1 with a tighter toler-
- ance.
-0 First convergence test. If ENORM(Z) denotes the Euclidean norm
- of a vector Z, then this test attempts to guarantee that
-0 ENORM(FVEC) .LE. (1+TOL)*ENORM(FVECS),
-0 where FVECS denotes the functions evaluated at XSOL. If this
- condition is satisfied with TOL = 10**(-K), then the final
- residual norm ENORM(FVEC) has K significant decimal digits an
- INFO is set to 1 (or to 3 if the second test is also satis-
- fied).
-0 Second convergence test. If D is a diagonal matrix (implicitly
- generated by LMDIF1) whose entries contain scale factors for
- the variables, then this test attempts to guarantee that
-0 ENORM(D*(X-XSOL)) .LE. TOL*ENORM(D*XSOL).
-0 If this condition is satisfied with TOL = 10**(-K), then the
- larger components of D*X have K significant decimal digits an
- INFO is set to 2 (or to 3 if the first test is also satis-
- fied). There is a danger that the smaller components of D*X
- may have large relative errors, but the choice of D is such
- that the accuracy of the components of X is usually related t
- their sensitivity.
-0 Third convergence test. This test is satisfied when FVEC is
- orthogonal to the columns of the Jacobian to machine preci-
- sion. There is no clear relationship between this test and
- the accuracy of LMDIF1, and furthermore, the test is equally
- well satisfied at other critical points, namely maximizers an
- saddle points. Also, errors in the functions (see below) may
- result in the test being satisfied at a point not close to th
-1
-0 Page
-0 minimum. Therefore, termination caused by this test
- (INFO = 4) should be examined carefully.
-0
- 5. Unsuccessful completion.
-0 Unsuccessful termination of LMDIF1 can be due to improper input
- parameters, arithmetic interrupts, an excessive number of func-
- tion evaluations, or errors in the functions.
-0 Improper input parameters. INFO is set to 0 if N .LE. 0, or
- M .LT. N, or TOL .LT. 0.D0, or LWA .LT. M*N+5*N+M.
-0 Arithmetic interrupts. If these interrupts occur in the FCN
- subroutine during an early stage of the computation, they may
- be caused by an unacceptable choice of X by LMDIF1. In this
- case, it may be possible to remedy the situation by not evalu
- ating the functions here, but instead setting the components
- of FVEC to numbers that exceed those in the initial FVEC,
- thereby indirectly reducing the step length. The step length
- can be more directly controlled by using instead LMDIF, which
- includes in its calling sequence the step-length-governing
- parameter FACTOR.
-0 Excessive number of function evaluations. If the number of
- calls to FCN reaches 200*(N+1), then this indicates that the
- routine is converging very slowly as measured by the progress
- of FVEC, and INFO is set to 5. In this case, it may be help-
- ful to restart LMDIF1, thereby forcing it to disregard old
- (and possibly harmful) information.
-0 Errors in the functions. The choice of step length in the for-
- ward-difference approximation to the Jacobian assumes that th
- relative errors in the functions are of the order of the
- machine precision. If this is not the case, LMDIF1 may fail
- (usually with INFO = 4). The user should then use LMDIF
- instead, or one of the programs which require the analytic
- Jacobian (LMDER1 and LMDER).
-0
- 6. Characteristics of the algorithm.
-0 LMDIF1 is a modification of the Levenberg-Marquardt algorithm.
- Two of its main characteristics involve the proper use of
- implicitly scaled variables and an optimal choice for the cor-
- rection. The use of implicitly scaled variables achieves scale
- invariance of LMDIF1 and limits the size of the correction in
- any direction where the functions are changing rapidly. The
- optimal choice of the correction guarantees (under reasonable
- conditions) global convergence from starting points far from th
- solution and a fast rate of convergence for problems with small
- residuals.
-0 Timing. The time required by LMDIF1 to solve a given problem
-1
-0 Page
-0 depends on M and N, the behavior of the functions, the accu-
- racy requested, and the starting point. The number of arith-
- metic operations needed by LMDIF1 is about N**3 to process
- each evaluation of the functions (one call to FCN) and
- M*(N**2) to process each approximation to the Jacobian (N
- calls to FCN). Unless FCN can be evaluated quickly, the tim-
- ing of LMDIF1 will be strongly influenced by the time spent i
- FCN.
-0 Storage. LMDIF1 requires M*N + 2*M + 6*N double precision sto-
- rage locations and N integer storage locations, in addition t
- the storage required by the program. There are no internally
- declared storage arrays.
-0
- 7. Subprograms required.
-0 USER-supplied ...... FCN
-0 MINPACK-supplied ... DPMPAR,ENORM,FDJAC2,LMDIF,LMPAR,
- QRFAC,QRSOLV
-0 FORTRAN-supplied ... DABS,DMAX1,DMIN1,DSQRT,MOD
-0
- 8. References.
-0 Jorge J. More, The Levenberg-Marquardt Algorithm, Implementatio
- and Theory. Numerical Analysis, G. A. Watson, editor.
- Lecture Notes in Mathematics 630, Springer-Verlag, 1977.
-0
- 9. Example.
-0 The problem is to determine the values of x(1), x(2), and x(3)
- which provide the best fit (in the least squares sense) of
-0 x(1) + u(i)/(v(i)*x(2) + w(i)*x(3)), i = 1, 15
-0 to the data
-0 y = (0.14,0.18,0.22,0.25,0.29,0.32,0.35,0.39,
- 0.37,0.58,0.73,0.96,1.34,2.10,4.39),
-0 where u(i) = i, v(i) = 16 - i, and w(i) = min(u(i),v(i)). The
- i-th component of FVEC is thus defined by
-0 y(i) - (x(1) + u(i)/(v(i)*x(2) + w(i)*x(3))).
-0 C **********
- C
- C DRIVER FOR LMDIF1 EXAMPLE.
- C DOUBLE PRECISION VERSION
- C
-1
-0 Page
-0 C **********
- INTEGER J,M,N,INFO,LWA,NWRITE
- INTEGER IWA(3)
- DOUBLE PRECISION TOL,FNORM
- DOUBLE PRECISION X(3),FVEC(15),WA(75)
- DOUBLE PRECISION ENORM,DPMPAR
- EXTERNAL FCN
- C
- C LOGICAL OUTPUT UNIT IS ASSUMED TO BE NUMBER 6.
- C
- DATA NWRITE /6/
- C
- M = 15
- N = 3
- C
- C THE FOLLOWING STARTING VALUES PROVIDE A ROUGH FIT.
- C
- X(1) = 1.D0
- X(2) = 1.D0
- X(3) = 1.D0
- C
- LWA = 75
- C
- C SET TOL TO THE SQUARE ROOT OF THE MACHINE PRECISION.
- C UNLESS HIGH PRECISION SOLUTIONS ARE REQUIRED,
- C THIS IS THE RECOMMENDED SETTING.
- C
- TOL = DSQRT(DPMPAR(1))
- C
- CALL LMDIF1(FCN,M,N,X,FVEC,TOL,INFO,IWA,WA,LWA)
- FNORM = ENORM(M,FVEC)
- WRITE (NWRITE,1000) FNORM,INFO,(X(J),J=1,N)
- STOP
- 1000 FORMAT (5X,31H FINAL L2 NORM OF THE RESIDUALS,D15.7 //
- * 5X,15H EXIT PARAMETER,16X,I10 //
- * 5X,27H FINAL APPROXIMATE SOLUTION // 5X,3D15.7)
- C
- C LAST CARD OF DRIVER FOR LMDIF1 EXAMPLE.
- C
- END
- SUBROUTINE FCN(M,N,X,FVEC,IFLAG)
- INTEGER M,N,IFLAG
- DOUBLE PRECISION X(N),FVEC(M)
- C
- C SUBROUTINE FCN FOR LMDIF1 EXAMPLE.
- C
- INTEGER I
- DOUBLE PRECISION TMP1,TMP2,TMP3
- DOUBLE PRECISION Y(15)
- DATA Y(1),Y(2),Y(3),Y(4),Y(5),Y(6),Y(7),Y(8),
- * Y(9),Y(10),Y(11),Y(12),Y(13),Y(14),Y(15)
- * /1.4D-1,1.8D-1,2.2D-1,2.5D-1,2.9D-1,3.2D-1,3.5D-1,3.9D-1,
- * 3.7D-1,5.8D-1,7.3D-1,9.6D-1,1.34D0,2.1D0,4.39D0/
- C
-1
-0 Page
-0 DO 10 I = 1, 15
- TMP1 = I
- TMP2 = 16 - I
- TMP3 = TMP1
- IF (I .GT. 8) TMP3 = TMP2
- FVEC(I) = Y(I) - (X(1) + TMP1/(X(2)*TMP2 + X(3)*TMP3))
- 10 CONTINUE
- RETURN
- C
- C LAST CARD OF SUBROUTINE FCN.
- C
- END
-0 Results obtained with different compilers or machines
- may be slightly different.
-0 FINAL L2 NORM OF THE RESIDUALS 0.9063596D-01
-0 EXIT PARAMETER 1
-0 FINAL APPROXIMATE SOLUTION
-0 0.8241057D-01 0.1133037D+01 0.2343695D+01
-1
-0
-1
-0 Page
-0 Documentation for MINPACK subroutine LMDIF
-0 Double precision version
-0 Argonne National Laboratory
-0 Burton S. Garbow, Kenneth E. Hillstrom, Jorge J. More
-0 March 1980
-0
- 1. Purpose.
-0 The purpose of LMDIF is to minimize the sum of the squares of M
- nonlinear functions in N variables by a modification of the
- Levenberg-Marquardt algorithm. The user must provide a subrou-
- tine which calculates the functions. The Jacobian is then cal-
- culated by a forward-difference approximation.
-0
- 2. Subroutine and type statements.
-0 SUBROUTINE LMDIF(FCN,M,N,X,FVEC,FTOL,XTOL,GTOL,MAXFEV,EPSFCN,
- * DIAG,MODE,FACTOR,NPRINT,INFO,NFEV,FJAC,LDFJAC,
- * IPVT,QTF,WA1,WA2,WA3,WA4)
- INTEGER M,N,MAXFEV,MODE,NPRINT,INFO,NFEV,LDFJAC
- INTEGER IPVT(N)
- DOUBLE PRECISION FTOL,XTOL,GTOL,EPSFCN,FACTOR
- DOUBLE PRECISION X(N),FVEC(M),DIAG(N),FJAC(LDFJAC,N),QTF(N),
- * WA1(N),WA2(N),WA3(N),WA4(M)
- EXTERNAL FCN
-0
- 3. Parameters.
-0 Parameters designated as input parameters must be specified on
- entry to LMDIF and are not changed on exit, while parameters
- designated as output parameters need not be specified on entry
- and are set to appropriate values on exit from LMDIF.
-0 FCN is the name of the user-supplied subroutine which calculate
- the functions. FCN must be declared in an EXTERNAL statement
- in the user calling program, and should be written as follows
-0 SUBROUTINE FCN(M,N,X,FVEC,IFLAG)
- INTEGER M,N,IFLAG
- DOUBLE PRECISION X(N),FVEC(M)
- ----------
- CALCULATE THE FUNCTIONS AT X AND
- RETURN THIS VECTOR IN FVEC.
- ----------
- RETURN
- END
-1
-0 Page
-0 The value of IFLAG should not be changed by FCN unless the
- user wants to terminate execution of LMDIF. In this case set
- IFLAG to a negative integer.
-0 M is a positive integer input variable set to the number of
- functions.
-0 N is a positive integer input variable set to the number of
- variables. N must not exceed M.
-0 X is an array of length N. On input X must contain an initial
- estimate of the solution vector. On output X contains the
- final estimate of the solution vector.
-0 FVEC is an output array of length M which contains the function
- evaluated at the output X.
-0 FTOL is a nonnegative input variable. Termination occurs when
- both the actual and predicted relative reductions in the sum
- of squares are at most FTOL. Therefore, FTOL measures the
- relative error desired in the sum of squares. Section 4 con-
- tains more details about FTOL.
-0 XTOL is a nonnegative input variable. Termination occurs when
- the relative error between two consecutive iterates is at mos
- XTOL. Therefore, XTOL measures the relative error desired in
- the approximate solution. Section 4 contains more details
- about XTOL.
-0 GTOL is a nonnegative input variable. Termination occurs when
- the cosine of the angle between FVEC and any column of the
- Jacobian is at most GTOL in absolute value. Therefore, GTOL
- measures the orthogonality desired between the function vecto
- and the columns of the Jacobian. Section 4 contains more
- details about GTOL.
-0 MAXFEV is a positive integer input variable. Termination occur
- when the number of calls to FCN is at least MAXFEV by the end
- of an iteration.
-0 EPSFCN is an input variable used in determining a suitable step
- for the forward-difference approximation. This approximation
- assumes that the relative errors in the functions are of the
- order of EPSFCN. If EPSFCN is less than the machine preci-
- sion, it is assumed that the relative errors in the functions
- are of the order of the machine precision.
-0 DIAG is an array of length N. If MODE = 1 (see below), DIAG is
- internally set. If MODE = 2, DIAG must contain positive
- entries that serve as multiplicative scale factors for the
- variables.
-0 MODE is an integer input variable. If MODE = 1, the variables
- will be scaled internally. If MODE = 2, the scaling is
-1
-0 Page
-0 specified by the input DIAG. Other values of MODE are equiva
- lent to MODE = 1.
-0 FACTOR is a positive input variable used in determining the ini
- tial step bound. This bound is set to the product of FACTOR
- and the Euclidean norm of DIAG*X if nonzero, or else to FACTO
- itself. In most cases FACTOR should lie in the interval
- (.1,100.). 100. is a generally recommended value.
-0 NPRINT is an integer input variable that enables controlled
- printing of iterates if it is positive. In this case, FCN is
- called with IFLAG = 0 at the beginning of the first iteration
- and every NPRINT iterations thereafter and immediately prior
- to return, with X and FVEC available for printing. If NPRINT
- is not positive, no special calls of FCN with IFLAG = 0 are
- made.
-0 INFO is an integer output variable. If the user has terminated
- execution, INFO is set to the (negative) value of IFLAG. See
- description of FCN. Otherwise, INFO is set as follows.
-0 INFO = 0 Improper input parameters.
-0 INFO = 1 Both actual and predicted relative reductions in th
- sum of squares are at most FTOL.
-0 INFO = 2 Relative error between two consecutive iterates is
- at most XTOL.
-0 INFO = 3 Conditions for INFO = 1 and INFO = 2 both hold.
-0 INFO = 4 The cosine of the angle between FVEC and any column
- of the Jacobian is at most GTOL in absolute value.
-0 INFO = 5 Number of calls to FCN has reached or exceeded
- MAXFEV.
-0 INFO = 6 FTOL is too small. No further reduction in the sum
- of squares is possible.
-0 INFO = 7 XTOL is too small. No further improvement in the
- approximate solution X is possible.
-0 INFO = 8 GTOL is too small. FVEC is orthogonal to the
- columns of the Jacobian to machine precision.
-0 Sections 4 and 5 contain more details about INFO.
-0 NFEV is an integer output variable set to the number of calls t
- FCN.
-0 FJAC is an output M by N array. The upper N by N submatrix of
- FJAC contains an upper triangular matrix R with diagonal ele-
- ments of nonincreasing magnitude such that
-1
-0 Page
-0 T T T
- P *(JAC *JAC)*P = R *R,
-0 where P is a permutation matrix and JAC is the final calcu-
- lated Jacobian. Column j of P is column IPVT(j) (see below)
- of the identity matrix. The lower trapezoidal part of FJAC
- contains information generated during the computation of R.
-0 LDFJAC is a positive integer input variable not less than M
- which specifies the leading dimension of the array FJAC.
-0 IPVT is an integer output array of length N. IPVT defines a
- permutation matrix P such that JAC*P = Q*R, where JAC is the
- final calculated Jacobian, Q is orthogonal (not stored), and
- is upper triangular with diagonal elements of nonincreasing
- magnitude. Column j of P is column IPVT(j) of the identity
- matrix.
-0 QTF is an output array of length N which contains the first N
- elements of the vector (Q transpose)*FVEC.
-0 WA1, WA2, and WA3 are work arrays of length N.
-0 WA4 is a work array of length M.
-0
- 4. Successful completion.
-0 The accuracy of LMDIF is controlled by the convergence parame-
- ters FTOL, XTOL, and GTOL. These parameters are used in tests
- which make three types of comparisons between the approximation
- X and a solution XSOL. LMDIF terminates when any of the tests
- is satisfied. If any of the convergence parameters is less tha
- the machine precision (as defined by the MINPACK function
- DPMPAR(1)), then LMDIF only attempts to satisfy the test define
- by the machine precision. Further progress is not usually pos-
- sible.
-0 The tests assume that the functions are reasonably well behaved
- If this condition is not satisfied, then LMDIF may incorrectly
- indicate convergence. The validity of the answer can be
- checked, for example, by rerunning LMDIF with tighter toler-
- ances.
-0 First convergence test. If ENORM(Z) denotes the Euclidean norm
- of a vector Z, then this test attempts to guarantee that
-0 ENORM(FVEC) .LE. (1+FTOL)*ENORM(FVECS),
-0 where FVECS denotes the functions evaluated at XSOL. If this
- condition is satisfied with FTOL = 10**(-K), then the final
- residual norm ENORM(FVEC) has K significant decimal digits an
- INFO is set to 1 (or to 3 if the second test is also satis-
- fied). Unless high precision solutions are required, the
-1
-0 Page
-0 recommended value for FTOL is the square root of the machine
- precision.
-0 Second convergence test. If D is the diagonal matrix whose
- entries are defined by the array DIAG, then this test attempt
- to guarantee that
-0 ENORM(D*(X-XSOL)) .LE. XTOL*ENORM(D*XSOL).
-0 If this condition is satisfied with XTOL = 10**(-K), then the
- larger components of D*X have K significant decimal digits an
- INFO is set to 2 (or to 3 if the first test is also satis-
- fied). There is a danger that the smaller components of D*X
- may have large relative errors, but if MODE = 1, then the
- accuracy of the components of X is usually related to their
- sensitivity. Unless high precision solutions are required,
- the recommended value for XTOL is the square root of the
- machine precision.
-0 Third convergence test. This test is satisfied when the cosine
- of the angle between FVEC and any column of the Jacobian at X
- is at most GTOL in absolute value. There is no clear rela-
- tionship between this test and the accuracy of LMDIF, and
- furthermore, the test is equally well satisfied at other crit
- ical points, namely maximizers and saddle points. Therefore,
- termination caused by this test (INFO = 4) should be examined
- carefully. The recommended value for GTOL is zero.
-0
- 5. Unsuccessful completion.
-0 Unsuccessful termination of LMDIF can be due to improper input
- parameters, arithmetic interrupts, or an excessive number of
- function evaluations.
-0 Improper input parameters. INFO is set to 0 if N .LE. 0, or
- M .LT. N, or LDFJAC .LT. M, or FTOL .LT. 0.D0, or
- XTOL .LT. 0.D0, or GTOL .LT. 0.D0, or MAXFEV .LE. 0, or
- FACTOR .LE. 0.D0.
-0 Arithmetic interrupts. If these interrupts occur in the FCN
- subroutine during an early stage of the computation, they may
- be caused by an unacceptable choice of X by LMDIF. In this
- case, it may be possible to remedy the situation by rerunning
- LMDIF with a smaller value of FACTOR.
-0 Excessive number of function evaluations. A reasonable value
- for MAXFEV is 200*(N+1). If the number of calls to FCN
- reaches MAXFEV, then this indicates that the routine is con-
- verging very slowly as measured by the progress of FVEC, and
- INFO is set to 5. In this case, it may be helpful to restart
- LMDIF with MODE set to 1.
-0
-1
-0 Page
-0 6. Characteristics of the algorithm.
-0 LMDIF is a modification of the Levenberg-Marquardt algorithm.
- Two of its main characteristics involve the proper use of
- implicitly scaled variables (if MODE = 1) and an optimal choice
- for the correction. The use of implicitly scaled variables
- achieves scale invariance of LMDIF and limits the size of the
- correction in any direction where the functions are changing
- rapidly. The optimal choice of the correction guarantees (unde
- reasonable conditions) global convergence from starting points
- far from the solution and a fast rate of convergence for prob-
- lems with small residuals.
-0 Timing. The time required by LMDIF to solve a given problem
- depends on M and N, the behavior of the functions, the accu-
- racy requested, and the starting point. The number of arith-
- metic operations needed by LMDIF is about N**3 to process eac
- evaluation of the functions (one call to FCN) and M*(N**2) to
- process each approximation to the Jacobian (N calls to FCN).
- Unless FCN can be evaluated quickly, the timing of LMDIF will
- be strongly influenced by the time spent in FCN.
-0 Storage. LMDIF requires M*N + 2*M + 6*N double precision sto-
- rage locations and N integer storage locations, in addition t
- the storage required by the program. There are no internally
- declared storage arrays.
-0
- 7. Subprograms required.
-0 USER-supplied ...... FCN
-0 MINPACK-supplied ... DPMPAR,ENORM,FDJAC2,LMPAR,QRFAC,QRSOLV
-0 FORTRAN-supplied ... DABS,DMAX1,DMIN1,DSQRT,MOD
-0
- 8. References.
-0 Jorge J. More, The Levenberg-Marquardt Algorithm, Implementatio
- and Theory. Numerical Analysis, G. A. Watson, editor.
- Lecture Notes in Mathematics 630, Springer-Verlag, 1977.
-0
- 9. Example.
-0 The problem is to determine the values of x(1), x(2), and x(3)
- which provide the best fit (in the least squares sense) of
-0 x(1) + u(i)/(v(i)*x(2) + w(i)*x(3)), i = 1, 15
-0 to the data
-1
-0 Page
-0 y = (0.14,0.18,0.22,0.25,0.29,0.32,0.35,0.39,
- 0.37,0.58,0.73,0.96,1.34,2.10,4.39),
-0 where u(i) = i, v(i) = 16 - i, and w(i) = min(u(i),v(i)). The
- i-th component of FVEC is thus defined by
-0 y(i) - (x(1) + u(i)/(v(i)*x(2) + w(i)*x(3))).
-0 C **********
- C
- C DRIVER FOR LMDIF EXAMPLE.
- C DOUBLE PRECISION VERSION
- C
- C **********
- INTEGER J,M,N,MAXFEV,MODE,NPRINT,INFO,NFEV,LDFJAC,NWRITE
- INTEGER IPVT(3)
- DOUBLE PRECISION FTOL,XTOL,GTOL,EPSFCN,FACTOR,FNORM
- DOUBLE PRECISION X(3),FVEC(15),DIAG(3),FJAC(15,3),QTF(3),
- * WA1(3),WA2(3),WA3(3),WA4(15)
- DOUBLE PRECISION ENORM,DPMPAR
- EXTERNAL FCN
- C
- C LOGICAL OUTPUT UNIT IS ASSUMED TO BE NUMBER 6.
- C
- DATA NWRITE /6/
- C
- M = 15
- N = 3
- C
- C THE FOLLOWING STARTING VALUES PROVIDE A ROUGH FIT.
- C
- X(1) = 1.D0
- X(2) = 1.D0
- X(3) = 1.D0
- C
- LDFJAC = 15
- C
- C SET FTOL AND XTOL TO THE SQUARE ROOT OF THE MACHINE PRECISION
- C AND GTOL TO ZERO. UNLESS HIGH PRECISION SOLUTIONS ARE
- C REQUIRED, THESE ARE THE RECOMMENDED SETTINGS.
- C
- FTOL = DSQRT(DPMPAR(1))
- XTOL = DSQRT(DPMPAR(1))
- GTOL = 0.D0
- C
- MAXFEV = 800
- EPSFCN = 0.D0
- MODE = 1
- FACTOR = 1.D2
- NPRINT = 0
- C
- CALL LMDIF(FCN,M,N,X,FVEC,FTOL,XTOL,GTOL,MAXFEV,EPSFCN,
- * DIAG,MODE,FACTOR,NPRINT,INFO,NFEV,FJAC,LDFJAC,
- * IPVT,QTF,WA1,WA2,WA3,WA4)
-1
-0 Page
-0 FNORM = ENORM(M,FVEC)
- WRITE (NWRITE,1000) FNORM,NFEV,INFO,(X(J),J=1,N)
- STOP
- 1000 FORMAT (5X,31H FINAL L2 NORM OF THE RESIDUALS,D15.7 //
- * 5X,31H NUMBER OF FUNCTION EVALUATIONS,I10 //
- * 5X,15H EXIT PARAMETER,16X,I10 //
- * 5X,27H FINAL APPROXIMATE SOLUTION // 5X,3D15.7)
- C
- C LAST CARD OF DRIVER FOR LMDIF EXAMPLE.
- C
- END
- SUBROUTINE FCN(M,N,X,FVEC,IFLAG)
- INTEGER M,N,IFLAG
- DOUBLE PRECISION X(N),FVEC(M)
- C
- C SUBROUTINE FCN FOR LMDIF EXAMPLE.
- C
- INTEGER I
- DOUBLE PRECISION TMP1,TMP2,TMP3
- DOUBLE PRECISION Y(15)
- DATA Y(1),Y(2),Y(3),Y(4),Y(5),Y(6),Y(7),Y(8),
- * Y(9),Y(10),Y(11),Y(12),Y(13),Y(14),Y(15)
- * /1.4D-1,1.8D-1,2.2D-1,2.5D-1,2.9D-1,3.2D-1,3.5D-1,3.9D-1,
- * 3.7D-1,5.8D-1,7.3D-1,9.6D-1,1.34D0,2.1D0,4.39D0/
- C
- IF (IFLAG .NE. 0) GO TO 5
- C
- C INSERT PRINT STATEMENTS HERE WHEN NPRINT IS POSITIVE.
- C
- RETURN
- 5 CONTINUE
- DO 10 I = 1, 15
- TMP1 = I
- TMP2 = 16 - I
- TMP3 = TMP1
- IF (I .GT. 8) TMP3 = TMP2
- FVEC(I) = Y(I) - (X(1) + TMP1/(X(2)*TMP2 + X(3)*TMP3))
- 10 CONTINUE
- RETURN
- C
- C LAST CARD OF SUBROUTINE FCN.
- C
- END
-0 Results obtained with different compilers or machines
- may be slightly different.
-0 FINAL L2 NORM OF THE RESIDUALS 0.9063596D-01
-0 NUMBER OF FUNCTION EVALUATIONS 21
-0 EXIT PARAMETER 1
-0 FINAL APPROXIMATE SOLUTION
-1
-0 Page
-0 0.8241057D-01 0.1133037D+01 0.2343695D+01
-1
-0
-1
-0 Page
-0 Documentation for MINPACK subroutine CHKDER
-0 Double precision version
-0 Argonne National Laboratory
-0 Burton S. Garbow, Kenneth E. Hillstrom, Jorge J. More
-0 March 1980
-0
- 1. Purpose.
-0 The purpose of CHKDER is to check the gradients of M nonlinear
- functions in N variables, evaluated at a point X, for consis-
- tency with the functions themselves. The user must call CHKDER
- twice, first with MODE = 1 and then with MODE = 2.
-0
- 2. Subroutine and type statements.
-0 SUBROUTINE CHKDER(M,N,X,FVEC,FJAC,LDFJAC,XP,FVECP,MODE,ERR)
- INTEGER M,N,LDFJAC,MODE
- DOUBLE PRECISION X(N),FVEC(M),FJAC(LDFJAC,N),XP(N),FVECP(M),
- * ERR(M)
-0
- 3. Parameters.
-0 Parameters designated as input parameters must be specified on
- entry to CHKDER and are not changed on exit, while parameters
- designated as output parameters need not be specified on entry
- and are set to appropriate values on exit from CHKDER.
-0 M is a positive integer input variable set to the number of
- functions.
-0 N is a positive integer input variable set to the number of
- variables.
-0 X is an input array of length N.
-0 FVEC is an array of length M. On input when MODE = 2, FVEC mus
- contain the functions evaluated at X.
-0 FJAC is an M by N array. On input when MODE = 2, the rows of
- FJAC must contain the gradients of the respective functions
- evaluated at X.
-0 LDFJAC is a positive integer input variable not less than M
- which specifies the leading dimension of the array FJAC.
-0 XP is an array of length N. On output when MODE = 1, XP is set
- to a neighboring point of X.
-1
-0 Page
-0 FVECP is an array of length M. On input when MODE = 2, FVECP
- must contain the functions evaluated at XP.
-0 MODE is an integer input variable set to 1 on the first call an
- 2 on the second. Other values of MODE are equivalent to
- MODE = 1.
-0 ERR is an array of length M. On output when MODE = 2, ERR con-
- tains measures of correctness of the respective gradients. I
- there is no severe loss of significance, then if ERR(I) is 1.
- the I-th gradient is correct, while if ERR(I) is 0.0 the I-th
- gradient is incorrect. For values of ERR between 0.0 and 1.0
- the categorization is less certain. In general, a value of
- ERR(I) greater than 0.5 indicates that the I-th gradient is
- probably correct, while a value of ERR(I) less than 0.5 indi-
- cates that the I-th gradient is probably incorrect.
-0
- 4. Successful completion.
-0 CHKDER usually guarantees that if ERR(I) is 1.0, then the I-th
- gradient at X is consistent with the I-th function. This sug-
- gests that the input X be such that consistency of the gradient
- at X implies consistency of the gradient at all points of inter
- est. If all the components of X are distinct and the fractiona
- part of each one has two nonzero digits, then X is likely to be
- a satisfactory choice.
-0 If ERR(I) is not 1.0 but is greater than 0.5, then the I-th gra
- dient is probably consistent with the I-th function (the more s
- the larger ERR(I) is), but the conditions for ERR(I) to be 1.0
- have not been completely satisfied. In this case, it is recom-
- mended that CHKDER be rerun with other input values of X. If
- ERR(I) is always greater than 0.5, then the I-th gradient is
- consistent with the I-th function.
-0
- 5. Unsuccessful completion.
-0 CHKDER does not perform reliably if cancellation or rounding
- errors cause a severe loss of significance in the evaluation of
- a function. Therefore, none of the components of X should be
- unusually small (in particular, zero) or any other value which
- may cause loss of significance. The relative differences
- between corresponding elements of FVECP and FVEC should be at
- least two orders of magnitude greater than the machine precisio
- (as defined by the MINPACK function DPMPAR(1)). If there is a
- severe loss of significance in the evaluation of the I-th func-
- tion, then ERR(I) may be 0.0 and yet the I-th gradient could be
- correct.
-0 If ERR(I) is not 0.0 but is less than 0.5, then the I-th gra-
- dient is probably not consistent with the I-th function (the
- more so the smaller ERR(I) is), but the conditions for ERR(I) t
-1
-0 Page
-0 be 0.0 have not been completely satisfied. In this case, it is
- recommended that CHKDER be rerun with other input values of X.
- If ERR(I) is always less than 0.5 and if there is no severe los
- of significance, then the I-th gradient is not consistent with
- the I-th function.
-0
- 6. Characteristics of the algorithm.
-0 CHKDER checks the I-th gradient for consistency with the I-th
- function by computing a forward-difference approximation along
- suitably chosen direction and comparing this approximation with
- the user-supplied gradient along the same direction. The prin-
- cipal characteristic of CHKDER is its invariance to changes in
- scale of the variables or functions.
-0 Timing. The time required by CHKDER depends only on M and N.
- The number of arithmetic operations needed by CHKDER is about
- N when MODE = 1 and M*N when MODE = 2.
-0 Storage. CHKDER requires M*N + 3*M + 2*N double precision stor
- age locations, in addition to the storage required by the pro
- gram. There are no internally declared storage arrays.
-0
- 7. Subprograms required.
-0 MINPACK-supplied ... DPMPAR
-0 FORTRAN-supplied ... DABS,DLOG10,DSQRT
-0
- 8. References.
-0 None.
-0
- 9. Example.
-0 This example checks the Jacobian matrix for the problem that
- determines the values of x(1), x(2), and x(3) which provide the
- best fit (in the least squares sense) of
-0 x(1) + u(i)/(v(i)*x(2) + w(i)*x(3)), i = 1, 15
-0 to the data
-0 y = (0.14,0.18,0.22,0.25,0.29,0.32,0.35,0.39,
- 0.37,0.58,0.73,0.96,1.34,2.10,4.39),
-0 where u(i) = i, v(i) = 16 - i, and w(i) = min(u(i),v(i)). The
- i-th component of FVEC is thus defined by
-0 y(i) - (x(1) + u(i)/(v(i)*x(2) + w(i)*x(3))).
-1
-0 Page
-0 C **********
- C
- C DRIVER FOR CHKDER EXAMPLE.
- C DOUBLE PRECISION VERSION
- C
- C **********
- INTEGER I,M,N,LDFJAC,MODE,NWRITE
- DOUBLE PRECISION X(3),FVEC(15),FJAC(15,3),XP(3),FVECP(15),
- * ERR(15)
- C
- C LOGICAL OUTPUT UNIT IS ASSUMED TO BE NUMBER 6.
- C
- DATA NWRITE /6/
- C
- M = 15
- N = 3
- C
- C THE FOLLOWING VALUES SHOULD BE SUITABLE FOR
- C CHECKING THE JACOBIAN MATRIX.
- C
- X(1) = 9.2D-1
- X(2) = 1.3D-1
- X(3) = 5.4D-1
- C
- LDFJAC = 15
- C
- MODE = 1
- CALL CHKDER(M,N,X,FVEC,FJAC,LDFJAC,XP,FVECP,MODE,ERR)
- MODE = 2
- CALL FCN(M,N,X,FVEC,FJAC,LDFJAC,1)
- CALL FCN(M,N,X,FVEC,FJAC,LDFJAC,2)
- CALL FCN(M,N,XP,FVECP,FJAC,LDFJAC,1)
- CALL CHKDER(M,N,X,FVEC,FJAC,LDFJAC,XP,FVECP,MODE,ERR)
- C
- DO 10 I = 1, M
- FVECP(I) = FVECP(I) - FVEC(I)
- 10 CONTINUE
- WRITE (NWRITE,1000) (FVEC(I),I=1,M)
- WRITE (NWRITE,2000) (FVECP(I),I=1,M)
- WRITE (NWRITE,3000) (ERR(I),I=1,M)
- STOP
- 1000 FORMAT (/5X,5H FVEC // (5X,3D15.7))
- 2000 FORMAT (/5X,13H FVECP - FVEC // (5X,3D15.7))
- 3000 FORMAT (/5X,4H ERR // (5X,3D15.7))
- C
- C LAST CARD OF DRIVER FOR CHKDER EXAMPLE.
- C
- END
- SUBROUTINE FCN(M,N,X,FVEC,FJAC,LDFJAC,IFLAG)
- INTEGER M,N,LDFJAC,IFLAG
- DOUBLE PRECISION X(N),FVEC(M),FJAC(LDFJAC,N)
- C
- C SUBROUTINE FCN FOR CHKDER EXAMPLE.
- C
-1
-0 Page
-0 INTEGER I
- DOUBLE PRECISION TMP1,TMP2,TMP3,TMP4
- DOUBLE PRECISION Y(15)
- DATA Y(1),Y(2),Y(3),Y(4),Y(5),Y(6),Y(7),Y(8),
- * Y(9),Y(10),Y(11),Y(12),Y(13),Y(14),Y(15)
- * /1.4D-1,1.8D-1,2.2D-1,2.5D-1,2.9D-1,3.2D-1,3.5D-1,3.9D-1,
- * 3.7D-1,5.8D-1,7.3D-1,9.6D-1,1.34D0,2.1D0,4.39D0/
- C
- IF (IFLAG .EQ. 2) GO TO 20
- DO 10 I = 1, 15
- TMP1 = I
- TMP2 = 16 - I
- TMP3 = TMP1
- IF (I .GT. 8) TMP3 = TMP2
- FVEC(I) = Y(I) - (X(1) + TMP1/(X(2)*TMP2 + X(3)*TMP3))
- 10 CONTINUE
- GO TO 40
- 20 CONTINUE
- DO 30 I = 1, 15
- TMP1 = I
- TMP2 = 16 - I
- C
- C ERROR INTRODUCED INTO NEXT STATEMENT FOR ILLUSTRATION.
- C CORRECTED STATEMENT SHOULD READ TMP3 = TMP1 .
- C
- TMP3 = TMP2
- IF (I .GT. 8) TMP3 = TMP2
- TMP4 = (X(2)*TMP2 + X(3)*TMP3)**2
- FJAC(I,1) = -1.D0
- FJAC(I,2) = TMP1*TMP2/TMP4
- FJAC(I,3) = TMP1*TMP3/TMP4
- 30 CONTINUE
- 40 CONTINUE
- RETURN
- C
- C LAST CARD OF SUBROUTINE FCN.
- C
- END
-0 Results obtained with different compilers or machines
- may be different. In particular, the differences
- FVECP - FVEC are machine dependent.
-0 FVEC
-0 -0.1181606D+01 -0.1429655D+01 -0.1606344D+01
- -0.1745269D+01 -0.1840654D+01 -0.1921586D+01
- -0.1984141D+01 -0.2022537D+01 -0.2468977D+01
- -0.2827562D+01 -0.3473582D+01 -0.4437612D+01
- -0.6047662D+01 -0.9267761D+01 -0.1891806D+02
-0 FVECP - FVEC
-0 -0.7724666D-08 -0.3432405D-08 -0.2034843D-09
-1
-0 Page
-0 0.2313685D-08 0.4331078D-08 0.5984096D-08
- 0.7363281D-08 0.8531470D-08 0.1488591D-07
- 0.2335850D-07 0.3522012D-07 0.5301255D-07
- 0.8266660D-07 0.1419747D-06 0.3198990D-06
-0 ERR
-0 0.1141397D+00 0.9943516D-01 0.9674474D-01
- 0.9980447D-01 0.1073116D+00 0.1220445D+00
- 0.1526814D+00 0.1000000D+01 0.1000000D+01
- 0.1000000D+01 0.1000000D+01 0.1000000D+01
- 0.1000000D+01 0.1000000D+01 0.1000000D+01
diff --git a/CEP/PyBDSM/src/minpack/ex/file07 b/CEP/PyBDSM/src/minpack/ex/file07
deleted file mode 100644
index c9403b1151093e79c791a36e1a29f7cfd6dbccf7..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/minpack/ex/file07
+++ /dev/null
@@ -1,283 +0,0 @@
-C **********
-C
-C THIS PROGRAM CHECKS THE CONSTANTS OF MACHINE PRECISION AND
-C SMALLEST AND LARGEST MACHINE REPRESENTABLE NUMBERS SPECIFIED IN
-C FUNCTION SPMPAR, AGAINST THE CORRESPONDING HARDWARE-DETERMINED
-C MACHINE CONSTANTS OBTAINED BY SMCHAR, A SUBROUTINE DUE TO
-C W. J. CODY.
-C
-C DATA STATEMENTS IN SPMPAR CORRESPONDING TO THE MACHINE USED MUST
-C BE ACTIVATED BY REMOVING C IN COLUMN 1.
-C
-C THE PRINTED OUTPUT CONSISTS OF THE MACHINE CONSTANTS OBTAINED BY
-C SMCHAR AND COMPARISONS OF THE SPMPAR CONSTANTS WITH THEIR
-C SMCHAR COUNTERPARTS. DESCRIPTIONS OF THE MACHINE CONSTANTS ARE
-C GIVEN IN THE PROLOGUE COMMENTS OF SMCHAR.
-C
-C SUBPROGRAMS CALLED
-C
-C MINPACK-SUPPLIED ... SMCHAR,SPMPAR
-C
-C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980.
-C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE
-C
-C **********
- INTEGER IBETA,IEXP,IRND,IT,MACHEP,MAXEXP,MINEXP,NEGEP,NGRD,
- * NWRITE
- REAL DWARF,EPS,EPSMCH,EPSNEG,GIANT,XMAX,XMIN
- REAL RERR(3)
- REAL SPMPAR
-C
-C LOGICAL OUTPUT UNIT IS ASSUMED TO BE NUMBER 6.
-C
- DATA NWRITE /6/
-C
-C DETERMINE THE MACHINE CONSTANTS DYNAMICALLY FROM SMCHAR.
-C
- CALL SMCHAR(IBETA,IT,IRND,NGRD,MACHEP,NEGEP,IEXP,MINEXP,MAXEXP,
- * EPS,EPSNEG,XMIN,XMAX)
-C
-C COMPARE THE SPMPAR CONSTANTS WITH THEIR SMCHAR COUNTERPARTS AND
-C STORE THE RELATIVE DIFFERENCES IN RERR.
-C
- EPSMCH = SPMPAR(1)
- DWARF = SPMPAR(2)
- GIANT = SPMPAR(3)
- RERR(1) = (EPSMCH - EPS)/EPSMCH
- RERR(2) = (DWARF - XMIN)/DWARF
- RERR(3) = (XMAX - GIANT)/GIANT
-C
-C WRITE THE SMCHAR CONSTANTS.
-C
- WRITE (NWRITE,10)
- * IBETA,IT,IRND,NGRD,MACHEP,NEGEP,IEXP,MINEXP,MAXEXP,EPS,
- * EPSNEG,XMIN,XMAX
-C
-C WRITE THE SPMPAR CONSTANTS AND THE RELATIVE DIFFERENCES.
-C
- WRITE (NWRITE,20) EPSMCH,RERR(1),DWARF,RERR(2),GIANT,RERR(3)
- STOP
- 10 FORMAT (17H1SMCHAR CONSTANTS /// 8H IBETA =, I6 // 8H IT =,
- * I6 // 8H IRND =, I6 // 8H NGRD =, I6 // 9H MACHEP =,
- * I6 // 8H NEGEP =, I6 // 7H IEXP =, I6 // 9H MINEXP =,
- * I6 // 9H MAXEXP =, I6 // 6H EPS =, E15.7 // 9H EPSNEG =,
- * E15.7 // 7H XMIN =, E15.7 // 7H XMAX =, E15.7)
- 20 FORMAT ( /// 42H SPMPAR CONSTANTS AND RELATIVE DIFFERENCES ///
- * 9H EPSMCH =, E15.7 / 10H RERR(1) =, E15.7 //
- * 8H DWARF =, E15.7 / 10H RERR(2) =, E15.7 // 8H GIANT =,
- * E15.7 / 10H RERR(3) =, E15.7)
-C
-C LAST CARD OF DRIVER.
-C
- END
- SUBROUTINE SMCHAR(IBETA,IT,IRND,NGRD,MACHEP,NEGEP,IEXP,MINEXP,
- 1 MAXEXP,EPS,EPSNEG,XMIN,XMAX)
-C
- INTEGER I,IBETA,IEXP,IRND,IT,IZ,J,K,MACHEP,MAXEXP,MINEXP,
- 1 MX,NEGEP,NGRD
- REAL A,B,BETA,BETAIN,BETAM1,EPS,EPSNEG,ONE,XMAX,XMIN,Y,Z,ZERO
-C
-C THIS SUBROUTINE IS INTENDED TO DETERMINE THE CHARACTERISTICS
-C OF THE FLOATING-POINT ARITHMETIC SYSTEM THAT ARE SPECIFIED
-C BELOW. THE FIRST THREE ARE DETERMINED ACCORDING TO AN
-C ALGORITHM DUE TO M. MALCOLM, CACM 15 (1972), PP. 949-951,
-C INCORPORATING SOME, BUT NOT ALL, OF THE IMPROVEMENTS
-C SUGGESTED BY M. GENTLEMAN AND S. MAROVICH, CACM 17 (1974),
-C PP. 276-277.
-C
-C
-C IBETA - THE RADIX OF THE FLOATING-POINT REPRESENTATION
-C IT - THE NUMBER OF BASE IBETA DIGITS IN THE FLOATING-POINT
-C SIGNIFICAND
-C IRND - 0 IF FLOATING-POINT ADDITION CHOPS,
-C 1 IF FLOATING-POINT ADDITION ROUNDS
-C NGRD - THE NUMBER OF GUARD DIGITS FOR MULTIPLICATION. IT IS
-C 0 IF IRND=1, OR IF IRND=0 AND ONLY IT BASE IBET
-C DIGITS PARTICIPATE IN THE POST NORMALIZATION SHIFT
-C OF THE FLOATING-POINT SIGNIFICAND IN MULTIPLICATION
-C 1 IF IRND=0 AND MORE THAN IT BASE IBETA DIGITS
-C PARTICIPATE IN THE POST NORMALIZATION SHIFT OF THE
-C FLOATING-POINT SIGNIFICAND IN MULTIPLICATION
-C MACHEP - THE LARGEST NEGATIVE INTEGER SUCH THAT
-C 1.0+FLOAT(IBETA)**MACHEP .NE. 1.0, EXCEPT THAT
-C MACHEP IS BOUNDED BELOW BY -(IT+3)
-C NEGEPS - THE LARGEST NEGATIVE INTEGER SUCH THAT
-C 1.0-FLOAT(IBETA)**NEGEPS .NE. 1.0, EXCEPT THAT
-C NEGEPS IS BOUNDED BELOW BY -(IT+3)
-C IEXP - THE NUMBER OF BITS (DECIMAL PLACES IF IBETA = 10)
-C RESERVED FOR THE REPRESENTATION OF THE EXPONENT
-C (INCLUDING THE BIAS OR SIGN) OF A FLOATING-POINT
-C NUMBER
-C MINEXP - THE LARGEST IN MAGNITUDE NEGATIVE INTEGER SUCH THAT
-C FLOAT(IBETA)**MINEXP IS A POSITIVE FLOATING-POINT
-C NUMBER
-C MAXEXP - THE LARGEST POSITIVE INTEGER EXPONENT FOR A FINITE
-C FLOATING-POINT NUMBER
-C EPS - THE SMALLEST POSITIVE FLOATING-POINT NUMBER SUCH
-C THAT 1.0+EPS .NE. 1.0. IN PARTICULAR, IF EITHER
-C IBETA = 2 OR IRND = 0, EPS = FLOAT(IBETA)**MACHEP.
-C OTHERWISE, EPS = (FLOAT(IBETA)**MACHEP)/2
-C EPSNEG - A SMALL POSITIVE FLOATING-POINT NUMBER SUCH THAT
-C 1.0-EPSNEG .NE. 1.0. IN PARTICULAR, IF IBETA = 2
-C OR IRND = 0, EPSNEG = FLOAT(IBETA)**NEGEPS.
-C OTHERWISE, EPSNEG = (IBETA**NEGEPS)/2. BECAUSE
-C NEGEPS IS BOUNDED BELOW BY -(IT+3), EPSNEG MAY NOT
-C BE THE SMALLEST NUMBER WHICH CAN ALTER 1.0 BY
-C SUBTRACTION.
-C XMIN - THE SMALLEST NON-VANISHING FLOATING-POINT POWER OF TH
-C RADIX. IN PARTICULAR, XMIN = FLOAT(IBETA)**MINEXP
-C XMAX - THE LARGEST FINITE FLOATING-POINT NUMBER. IN
-C PARTICULAR XMAX = (1.0-EPSNEG)*FLOAT(IBETA)**MAXEXP
-C NOTE - ON SOME MACHINES XMAX WILL BE ONLY THE
-C SECOND, OR PERHAPS THIRD, LARGEST NUMBER, BEING
-C TOO SMALL BY 1 OR 2 UNITS IN THE LAST DIGIT OF
-C THE SIGNIFICAND.
-C
-C LATEST REVISION - OCTOBER 22, 1979
-C
-C AUTHOR - W. J. CODY
-C ARGONNE NATIONAL LABORATORY
-C
-C-----------------------------------------------------------------
- ONE = FLOAT(1)
- ZERO = 0.0E0
-C-----------------------------------------------------------------
-C DETERMINE IBETA,BETA ALA MALCOLM
-C-----------------------------------------------------------------
- A = ONE
- 10 A = A + A
- IF (((A+ONE)-A)-ONE .EQ. ZERO) GO TO 10
- B = ONE
- 20 B = B + B
- IF ((A+B)-A .EQ. ZERO) GO TO 20
- IBETA = INT((A+B)-A)
- BETA = FLOAT(IBETA)
-C-----------------------------------------------------------------
-C DETERMINE IT, IRND
-C-----------------------------------------------------------------
- IT = 0
- B = ONE
- 100 IT = IT + 1
- B = B * BETA
- IF (((B+ONE)-B)-ONE .EQ. ZERO) GO TO 100
- IRND = 0
- BETAM1 = BETA - ONE
- IF ((A+BETAM1)-A .NE. ZERO) IRND = 1
-C-----------------------------------------------------------------
-C DETERMINE NEGEP, EPSNEG
-C-----------------------------------------------------------------
- NEGEP = IT + 3
- BETAIN = ONE / BETA
- A = ONE
-C
- DO 200 I = 1, NEGEP
- A = A * BETAIN
- 200 CONTINUE
-C
- B = A
- 210 IF ((ONE-A)-ONE .NE. ZERO) GO TO 220
- A = A * BETA
- NEGEP = NEGEP - 1
- GO TO 210
- 220 NEGEP = -NEGEP
- EPSNEG = A
- IF ((IBETA .EQ. 2) .OR. (IRND .EQ. 0)) GO TO 300
- A = (A*(ONE+A)) / (ONE+ONE)
- IF ((ONE-A)-ONE .NE. ZERO) EPSNEG = A
-C-----------------------------------------------------------------
-C DETERMINE MACHEP, EPS
-C-----------------------------------------------------------------
- 300 MACHEP = -IT - 3
- A = B
- 310 IF((ONE+A)-ONE .NE. ZERO) GO TO 320
- A = A * BETA
- MACHEP = MACHEP + 1
- GO TO 310
- 320 EPS = A
- IF ((IBETA .EQ. 2) .OR. (IRND .EQ. 0)) GO TO 350
- A = (A*(ONE+A)) / (ONE+ONE)
- IF ((ONE+A)-ONE .NE. ZERO) EPS = A
-C-----------------------------------------------------------------
-C DETERMINE NGRD
-C-----------------------------------------------------------------
- 350 NGRD = 0
- IF ((IRND .EQ. 0) .AND. ((ONE+EPS)*ONE-ONE) .NE. ZERO) NGRD = 1
-C-----------------------------------------------------------------
-C DETERMINE IEXP, MINEXP, XMIN
-C
-C LOOP TO DETERMINE LARGEST I AND K = 2**I SUCH THAT
-C (1/BETA) ** (2**(I))
-C DOES NOT UNDERFLOW
-C EXIT FROM LOOP IS SIGNALED BY AN UNDERFLOW.
-C-----------------------------------------------------------------
- I = 0
- K = 1
- Z = BETAIN
- 400 Y = Z
- Z = Y * Y
-C-----------------------------------------------------------------
-C CHECK FOR UNDERFLOW HERE
-C-----------------------------------------------------------------
- A = Z * ONE
- IF ((A+A .EQ. ZERO) .OR. (ABS(Z) .GE. Y)) GO TO 410
- I = I + 1
- K = K + K
- GO TO 400
- 410 IF (IBETA .EQ. 10) GO TO 420
- IEXP = I + 1
- MX = K + K
- GO TO 450
-C-----------------------------------------------------------------
-C FOR DECIMAL MACHINES ONLY
-C-----------------------------------------------------------------
- 420 IEXP = 2
- IZ = IBETA
- 430 IF (K .LT. IZ) GO TO 440
- IZ = IZ * IBETA
- IEXP = IEXP + 1
- GO TO 430
- 440 MX = IZ + IZ - 1
-C-----------------------------------------------------------------
-C LOOP TO DETERMINE MINEXP, XMIN
-C EXIT FROM LOOP IS SIGNALED BY AN UNDERFLOW.
-C-----------------------------------------------------------------
- 450 XMIN = Y
- Y = Y * BETAIN
-C-----------------------------------------------------------------
-C CHECK FOR UNDERFLOW HERE
-C-----------------------------------------------------------------
- A = Y * ONE
- IF (((A+A) .EQ. ZERO) .OR. (ABS(Y) .GE. XMIN)) GO TO 460
- K = K + 1
- GO TO 450
- 460 MINEXP = -K
-C-----------------------------------------------------------------
-C DETERMINE MAXEXP, XMAX
-C-----------------------------------------------------------------
- IF ((MX .GT. K+K-3) .OR. (IBETA .EQ. 10)) GO TO 500
- MX = MX + MX
- IEXP = IEXP + 1
- 500 MAXEXP = MX + MINEXP
-C-----------------------------------------------------------------
-C ADJUST FOR MACHINES WITH IMPLICIT LEADING
-C BIT IN BINARY SIGNIFICAND AND MACHINES WITH
-C RADIX POINT AT EXTREME RIGHT OF SIGNIFICAND
-C-----------------------------------------------------------------
- I = MAXEXP + MINEXP
- IF ((IBETA .EQ. 2) .AND. (I .EQ. 0)) MAXEXP = MAXEXP - 1
- IF (I .GT. 20) MAXEXP = MAXEXP - 1
- IF (A .NE. Y) MAXEXP = MAXEXP - 2
- XMAX = ONE - EPSNEG
- IF (XMAX*ONE .NE. XMAX) XMAX = ONE - BETA * EPSNEG
- XMAX = XMAX / (BETA * BETA * BETA * XMIN)
- I = MAXEXP + MINEXP + 3
- IF (I .LE. 0) GO TO 520
-C
- DO 510 J = 1, I
- IF (IBETA .EQ. 2) XMAX = XMAX + XMAX
- IF (IBETA .NE. 2) XMAX = XMAX * BETA
- 510 CONTINUE
-C
- 520 RETURN
-C ---------- LAST CARD OF SMCHAR ----------
- END
diff --git a/CEP/PyBDSM/src/minpack/ex/file08 b/CEP/PyBDSM/src/minpack/ex/file08
deleted file mode 100644
index 47fdb710840994e9ab83359e6dbe5b1ecbf42502..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/minpack/ex/file08
+++ /dev/null
@@ -1,551 +0,0 @@
-C **********
-C
-C THIS PROGRAM TESTS CODES FOR THE SOLUTION OF N NONLINEAR
-C EQUATIONS IN N VARIABLES. IT CONSISTS OF A DRIVER AND AN
-C INTERFACE SUBROUTINE FCN. THE DRIVER READS IN DATA, CALLS THE
-C NONLINEAR EQUATION SOLVER, AND FINALLY PRINTS OUT INFORMATION
-C ON THE PERFORMANCE OF THE SOLVER. THIS IS ONLY A SAMPLE DRIVER,
-C MANY OTHER DRIVERS ARE POSSIBLE. THE INTERFACE SUBROUTINE FCN
-C IS NECESSARY TO TAKE INTO ACCOUNT THE FORMS OF CALLING
-C SEQUENCES USED BY THE FUNCTION SUBROUTINES IN THE VARIOUS
-C NONLINEAR EQUATION SOLVERS.
-C
-C SUBPROGRAMS CALLED
-C
-C USER-SUPPLIED ...... FCN
-C
-C MINPACK-SUPPLIED ... SPMPAR,ENORM,HYBRD1,INITPT,VECFCN
-C
-C FORTRAN-SUPPLIED ... SQRT
-C
-C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980.
-C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE
-C
-C **********
- INTEGER I,IC,INFO,K,LWA,N,NFEV,NPROB,NREAD,NTRIES,NWRITE
- INTEGER NA(60),NF(60),NP(60),NX(60)
- REAL FACTOR,FNORM1,FNORM2,ONE,TEN,TOL
- REAL FNM(60),FVEC(40),WA(2660),X(40)
- REAL SPMPAR,ENORM
- EXTERNAL FCN
- COMMON /REFNUM/ NPROB,NFEV
-C
-C LOGICAL INPUT UNIT IS ASSUMED TO BE NUMBER 5.
-C LOGICAL OUTPUT UNIT IS ASSUMED TO BE NUMBER 6.
-C
- DATA NREAD,NWRITE /5,6/
-C
- DATA ONE,TEN /1.0E0,1.0E1/
- TOL = SQRT(SPMPAR(1))
- LWA = 2660
- IC = 0
- 10 CONTINUE
- READ (NREAD,50) NPROB,N,NTRIES
- IF (NPROB .LE. 0) GO TO 30
- FACTOR = ONE
- DO 20 K = 1, NTRIES
- IC = IC + 1
- CALL INITPT(N,X,NPROB,FACTOR)
- CALL VECFCN(N,X,FVEC,NPROB)
- FNORM1 = ENORM(N,FVEC)
- WRITE (NWRITE,60) NPROB,N
- NFEV = 0
- CALL HYBRD1(FCN,N,X,FVEC,TOL,INFO,WA,LWA)
- FNORM2 = ENORM(N,FVEC)
- NP(IC) = NPROB
- NA(IC) = N
- NF(IC) = NFEV
- NX(IC) = INFO
- FNM(IC) = FNORM2
- WRITE (NWRITE,70) FNORM1,FNORM2,NFEV,INFO,(X(I), I = 1, N)
- FACTOR = TEN*FACTOR
- 20 CONTINUE
- GO TO 10
- 30 CONTINUE
- WRITE (NWRITE,80) IC
- WRITE (NWRITE,90)
- DO 40 I = 1, IC
- WRITE (NWRITE,100) NP(I),NA(I),NF(I),NX(I),FNM(I)
- 40 CONTINUE
- STOP
- 50 FORMAT (3I5)
- 60 FORMAT ( //// 5X, 8H PROBLEM, I5, 5X, 10H DIMENSION, I5, 5X //)
- 70 FORMAT (5X, 33H INITIAL L2 NORM OF THE RESIDUALS, E15.7 // 5X,
- * 33H FINAL L2 NORM OF THE RESIDUALS , E15.7 // 5X,
- * 33H NUMBER OF FUNCTION EVALUATIONS , I10 // 5X,
- * 15H EXIT PARAMETER, 18X, I10 // 5X,
- * 27H FINAL APPROXIMATE SOLUTION // (5X, 5E15.7))
- 80 FORMAT (12H1SUMMARY OF , I3, 16H CALLS TO HYBRD1 /)
- 90 FORMAT (39H NPROB N NFEV INFO FINAL L2 NORM /)
- 100 FORMAT (I4, I6, I7, I6, 1X, E15.7)
-C
-C LAST CARD OF DRIVER.
-C
- END
- SUBROUTINE FCN(N,X,FVEC,IFLAG)
- INTEGER N,IFLAG
- REAL X(N),FVEC(N)
-C **********
-C
-C THE CALLING SEQUENCE OF FCN SHOULD BE IDENTICAL TO THE
-C CALLING SEQUENCE OF THE FUNCTION SUBROUTINE IN THE NONLINEAR
-C EQUATION SOLVER. FCN SHOULD ONLY CALL THE TESTING FUNCTION
-C SUBROUTINE VECFCN WITH THE APPROPRIATE VALUE OF PROBLEM
-C NUMBER (NPROB).
-C
-C SUBPROGRAMS CALLED
-C
-C MINPACK-SUPPLIED ... VECFCN
-C
-C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980.
-C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE
-C
-C **********
- INTEGER NPROB,NFEV
- COMMON /REFNUM/ NPROB,NFEV
- CALL VECFCN(N,X,FVEC,NPROB)
- NFEV = NFEV + 1
- RETURN
-C
-C LAST CARD OF INTERFACE SUBROUTINE FCN.
-C
- END
- SUBROUTINE VECFCN(N,X,FVEC,NPROB)
- INTEGER N,NPROB
- REAL X(N),FVEC(N)
-C **********
-C
-C SUBROUTINE VECFCN
-C
-C THIS SUBROUTINE DEFINES FOURTEEN TEST FUNCTIONS. THE FIRST
-C FIVE TEST FUNCTIONS ARE OF DIMENSIONS 2,4,2,4,3, RESPECTIVELY,
-C WHILE THE REMAINING TEST FUNCTIONS ARE OF VARIABLE DIMENSION
-C N FOR ANY N GREATER THAN OR EQUAL TO 1 (PROBLEM 6 IS AN
-C EXCEPTION TO THIS, SINCE IT DOES NOT ALLOW N = 1).
-C
-C THE SUBROUTINE STATEMENT IS
-C
-C SUBROUTINE VECFCN(N,X,FVEC,NPROB)
-C
-C WHERE
-C
-C N IS A POSITIVE INTEGER INPUT VARIABLE.
-C
-C X IS AN INPUT ARRAY OF LENGTH N.
-C
-C FVEC IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS THE NPROB
-C FUNCTION VECTOR EVALUATED AT X.
-C
-C NPROB IS A POSITIVE INTEGER INPUT VARIABLE WHICH DEFINES THE
-C NUMBER OF THE PROBLEM. NPROB MUST NOT EXCEED 14.
-C
-C SUBPROGRAMS CALLED
-C
-C FORTRAN-SUPPLIED ... ATAN,COS,EXP,SIGN,SIN,SQRT,
-C MAX0,MIN0
-C
-C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980.
-C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE
-C
-C **********
- INTEGER I,IEV,IVAR,J,K,K1,K2,KP1,ML,MU
- REAL C1,C2,C3,C4,C5,C6,C7,C8,C9,EIGHT,FIVE,H,ONE,PROD,SUM,SUM1,
- * SUM2,TEMP,TEMP1,TEMP2,TEN,THREE,TI,TJ,TK,TPI,TWO,ZERO
- REAL FLOAT
- DATA ZERO,ONE,TWO,THREE,FIVE,EIGHT,TEN
- * /0.0E0,1.0E0,2.0E0,3.0E0,5.0E0,8.0E0,1.0E1/
- DATA C1,C2,C3,C4,C5,C6,C7,C8,C9
- * /1.0E4,1.0001E0,2.0E2,2.02E1,1.98E1,1.8E2,2.5E-1,5.0E-1,
- * 2.9E1/
- FLOAT(IVAR) = IVAR
-C
-C PROBLEM SELECTOR.
-C
- GO TO (10,20,30,40,50,60,120,170,200,220,270,300,330,350), NPROB
-C
-C ROSENBROCK FUNCTION.
-C
- 10 CONTINUE
- FVEC(1) = ONE - X(1)
- FVEC(2) = TEN*(X(2) - X(1)**2)
- GO TO 380
-C
-C POWELL SINGULAR FUNCTION.
-C
- 20 CONTINUE
- FVEC(1) = X(1) + TEN*X(2)
- FVEC(2) = SQRT(FIVE)*(X(3) - X(4))
- FVEC(3) = (X(2) - TWO*X(3))**2
- FVEC(4) = SQRT(TEN)*(X(1) - X(4))**2
- GO TO 380
-C
-C POWELL BADLY SCALED FUNCTION.
-C
- 30 CONTINUE
- FVEC(1) = C1*X(1)*X(2) - ONE
- FVEC(2) = EXP(-X(1)) + EXP(-X(2)) - C2
- GO TO 380
-C
-C WOOD FUNCTION.
-C
- 40 CONTINUE
- TEMP1 = X(2) - X(1)**2
- TEMP2 = X(4) - X(3)**2
- FVEC(1) = -C3*X(1)*TEMP1 - (ONE - X(1))
- FVEC(2) = C3*TEMP1 + C4*(X(2) - ONE) + C5*(X(4) - ONE)
- FVEC(3) = -C6*X(3)*TEMP2 - (ONE - X(3))
- FVEC(4) = C6*TEMP2 + C4*(X(4) - ONE) + C5*(X(2) - ONE)
- GO TO 380
-C
-C HELICAL VALLEY FUNCTION.
-C
- 50 CONTINUE
- TPI = EIGHT*ATAN(ONE)
- TEMP1 = SIGN(C7,X(2))
- IF (X(1) .GT. ZERO) TEMP1 = ATAN(X(2)/X(1))/TPI
- IF (X(1) .LT. ZERO) TEMP1 = ATAN(X(2)/X(1))/TPI + C8
- TEMP2 = SQRT(X(1)**2+X(2)**2)
- FVEC(1) = TEN*(X(3) - TEN*TEMP1)
- FVEC(2) = TEN*(TEMP2 - ONE)
- FVEC(3) = X(3)
- GO TO 380
-C
-C WATSON FUNCTION.
-C
- 60 CONTINUE
- DO 70 K = 1, N
- FVEC(K) = ZERO
- 70 CONTINUE
- DO 110 I = 1, 29
- TI = FLOAT(I)/C9
- SUM1 = ZERO
- TEMP = ONE
- DO 80 J = 2, N
- SUM1 = SUM1 + FLOAT(J-1)*TEMP*X(J)
- TEMP = TI*TEMP
- 80 CONTINUE
- SUM2 = ZERO
- TEMP = ONE
- DO 90 J = 1, N
- SUM2 = SUM2 + TEMP*X(J)
- TEMP = TI*TEMP
- 90 CONTINUE
- TEMP1 = SUM1 - SUM2**2 - ONE
- TEMP2 = TWO*TI*SUM2
- TEMP = ONE/TI
- DO 100 K = 1, N
- FVEC(K) = FVEC(K) + TEMP*(FLOAT(K-1) - TEMP2)*TEMP1
- TEMP = TI*TEMP
- 100 CONTINUE
- 110 CONTINUE
- TEMP = X(2) - X(1)**2 - ONE
- FVEC(1) = FVEC(1) + X(1)*(ONE - TWO*TEMP)
- FVEC(2) = FVEC(2) + TEMP
- GO TO 380
-C
-C CHEBYQUAD FUNCTION.
-C
- 120 CONTINUE
- DO 130 K = 1, N
- FVEC(K) = ZERO
- 130 CONTINUE
- DO 150 J = 1, N
- TEMP1 = ONE
- TEMP2 = TWO*X(J) - ONE
- TEMP = TWO*TEMP2
- DO 140 I = 1, N
- FVEC(I) = FVEC(I) + TEMP2
- TI = TEMP*TEMP2 - TEMP1
- TEMP1 = TEMP2
- TEMP2 = TI
- 140 CONTINUE
- 150 CONTINUE
- TK = ONE/FLOAT(N)
- IEV = -1
- DO 160 K = 1, N
- FVEC(K) = TK*FVEC(K)
- IF (IEV .GT. 0) FVEC(K) = FVEC(K) + ONE/(FLOAT(K)**2 - ONE)
- IEV = -IEV
- 160 CONTINUE
- GO TO 380
-C
-C BROWN ALMOST-LINEAR FUNCTION.
-C
- 170 CONTINUE
- SUM = -FLOAT(N+1)
- PROD = ONE
- DO 180 J = 1, N
- SUM = SUM + X(J)
- PROD = X(J)*PROD
- 180 CONTINUE
- DO 190 K = 1, N
- FVEC(K) = X(K) + SUM
- 190 CONTINUE
- FVEC(N) = PROD - ONE
- GO TO 380
-C
-C DISCRETE BOUNDARY VALUE FUNCTION.
-C
- 200 CONTINUE
- H = ONE/FLOAT(N+1)
- DO 210 K = 1, N
- TEMP = (X(K) + FLOAT(K)*H + ONE)**3
- TEMP1 = ZERO
- IF (K .NE. 1) TEMP1 = X(K-1)
- TEMP2 = ZERO
- IF (K .NE. N) TEMP2 = X(K+1)
- FVEC(K) = TWO*X(K) - TEMP1 - TEMP2 + TEMP*H**2/TWO
- 210 CONTINUE
- GO TO 380
-C
-C DISCRETE INTEGRAL EQUATION FUNCTION.
-C
- 220 CONTINUE
- H = ONE/FLOAT(N+1)
- DO 260 K = 1, N
- TK = FLOAT(K)*H
- SUM1 = ZERO
- DO 230 J = 1, K
- TJ = FLOAT(J)*H
- TEMP = (X(J) + TJ + ONE)**3
- SUM1 = SUM1 + TJ*TEMP
- 230 CONTINUE
- SUM2 = ZERO
- KP1 = K + 1
- IF (N .LT. KP1) GO TO 250
- DO 240 J = KP1, N
- TJ = FLOAT(J)*H
- TEMP = (X(J) + TJ + ONE)**3
- SUM2 = SUM2 + (ONE - TJ)*TEMP
- 240 CONTINUE
- 250 CONTINUE
- FVEC(K) = X(K) + H*((ONE - TK)*SUM1 + TK*SUM2)/TWO
- 260 CONTINUE
- GO TO 380
-C
-C TRIGONOMETRIC FUNCTION.
-C
- 270 CONTINUE
- SUM = ZERO
- DO 280 J = 1, N
- FVEC(J) = COS(X(J))
- SUM = SUM + FVEC(J)
- 280 CONTINUE
- DO 290 K = 1, N
- FVEC(K) = FLOAT(N+K) - SIN(X(K)) - SUM - FLOAT(K)*FVEC(K)
- 290 CONTINUE
- GO TO 380
-C
-C VARIABLY DIMENSIONED FUNCTION.
-C
- 300 CONTINUE
- SUM = ZERO
- DO 310 J = 1, N
- SUM = SUM + FLOAT(J)*(X(J) - ONE)
- 310 CONTINUE
- TEMP = SUM*(ONE + TWO*SUM**2)
- DO 320 K = 1, N
- FVEC(K) = X(K) - ONE + FLOAT(K)*TEMP
- 320 CONTINUE
- GO TO 380
-C
-C BROYDEN TRIDIAGONAL FUNCTION.
-C
- 330 CONTINUE
- DO 340 K = 1, N
- TEMP = (THREE - TWO*X(K))*X(K)
- TEMP1 = ZERO
- IF (K .NE. 1) TEMP1 = X(K-1)
- TEMP2 = ZERO
- IF (K .NE. N) TEMP2 = X(K+1)
- FVEC(K) = TEMP - TEMP1 - TWO*TEMP2 + ONE
- 340 CONTINUE
- GO TO 380
-C
-C BROYDEN BANDED FUNCTION.
-C
- 350 CONTINUE
- ML = 5
- MU = 1
- DO 370 K = 1, N
- K1 = MAX0(1,K-ML)
- K2 = MIN0(K+MU,N)
- TEMP = ZERO
- DO 360 J = K1, K2
- IF (J .NE. K) TEMP = TEMP + X(J)*(ONE + X(J))
- 360 CONTINUE
- FVEC(K) = X(K)*(TWO + FIVE*X(K)**2) + ONE - TEMP
- 370 CONTINUE
- 380 CONTINUE
- RETURN
-C
-C LAST CARD OF SUBROUTINE VECFCN.
-C
- END
- SUBROUTINE INITPT(N,X,NPROB,FACTOR)
- INTEGER N,NPROB
- REAL FACTOR
- REAL X(N)
-C **********
-C
-C SUBROUTINE INITPT
-C
-C THIS SUBROUTINE SPECIFIES THE STANDARD STARTING POINTS FOR
-C THE FUNCTIONS DEFINED BY SUBROUTINE VECFCN. THE SUBROUTINE
-C RETURNS IN X A MULTIPLE (FACTOR) OF THE STANDARD STARTING
-C POINT. FOR THE SIXTH FUNCTION THE STANDARD STARTING POINT IS
-C ZERO, SO IN THIS CASE, IF FACTOR IS NOT UNITY, THEN THE
-C SUBROUTINE RETURNS THE VECTOR X(J) = FACTOR, J=1,...,N.
-C
-C THE SUBROUTINE STATEMENT IS
-C
-C SUBROUTINE INITPT(N,X,NPROB,FACTOR)
-C
-C WHERE
-C
-C N IS A POSITIVE INTEGER INPUT VARIABLE.
-C
-C X IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS THE STANDARD
-C STARTING POINT FOR PROBLEM NPROB MULTIPLIED BY FACTOR.
-C
-C NPROB IS A POSITIVE INTEGER INPUT VARIABLE WHICH DEFINES THE
-C NUMBER OF THE PROBLEM. NPROB MUST NOT EXCEED 14.
-C
-C FACTOR IS AN INPUT VARIABLE WHICH SPECIFIES THE MULTIPLE OF
-C THE STANDARD STARTING POINT. IF FACTOR IS UNITY, NO
-C MULTIPLICATION IS PERFORMED.
-C
-C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980.
-C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE
-C
-C **********
- INTEGER IVAR,J
- REAL C1,H,HALF,ONE,THREE,TJ,ZERO
- REAL FLOAT
- DATA ZERO,HALF,ONE,THREE,C1 /0.0E0,5.0E-1,1.0E0,3.0E0,1.2E0/
- FLOAT(IVAR) = IVAR
-C
-C SELECTION OF INITIAL POINT.
-C
- GO TO (10,20,30,40,50,60,80,100,120,120,140,160,180,180), NPROB
-C
-C ROSENBROCK FUNCTION.
-C
- 10 CONTINUE
- X(1) = -C1
- X(2) = ONE
- GO TO 200
-C
-C POWELL SINGULAR FUNCTION.
-C
- 20 CONTINUE
- X(1) = THREE
- X(2) = -ONE
- X(3) = ZERO
- X(4) = ONE
- GO TO 200
-C
-C POWELL BADLY SCALED FUNCTION.
-C
- 30 CONTINUE
- X(1) = ZERO
- X(2) = ONE
- GO TO 200
-C
-C WOOD FUNCTION.
-C
- 40 CONTINUE
- X(1) = -THREE
- X(2) = -ONE
- X(3) = -THREE
- X(4) = -ONE
- GO TO 200
-C
-C HELICAL VALLEY FUNCTION.
-C
- 50 CONTINUE
- X(1) = -ONE
- X(2) = ZERO
- X(3) = ZERO
- GO TO 200
-C
-C WATSON FUNCTION.
-C
- 60 CONTINUE
- DO 70 J = 1, N
- X(J) = ZERO
- 70 CONTINUE
- GO TO 200
-C
-C CHEBYQUAD FUNCTION.
-C
- 80 CONTINUE
- H = ONE/FLOAT(N+1)
- DO 90 J = 1, N
- X(J) = FLOAT(J)*H
- 90 CONTINUE
- GO TO 200
-C
-C BROWN ALMOST-LINEAR FUNCTION.
-C
- 100 CONTINUE
- DO 110 J = 1, N
- X(J) = HALF
- 110 CONTINUE
- GO TO 200
-C
-C DISCRETE BOUNDARY VALUE AND INTEGRAL EQUATION FUNCTIONS.
-C
- 120 CONTINUE
- H = ONE/FLOAT(N+1)
- DO 130 J = 1, N
- TJ = FLOAT(J)*H
- X(J) = TJ*(TJ - ONE)
- 130 CONTINUE
- GO TO 200
-C
-C TRIGONOMETRIC FUNCTION.
-C
- 140 CONTINUE
- H = ONE/FLOAT(N)
- DO 150 J = 1, N
- X(J) = H
- 150 CONTINUE
- GO TO 200
-C
-C VARIABLY DIMENSIONED FUNCTION.
-C
- 160 CONTINUE
- H = ONE/FLOAT(N)
- DO 170 J = 1, N
- X(J) = ONE - FLOAT(J)*H
- 170 CONTINUE
- GO TO 200
-C
-C BROYDEN TRIDIAGONAL AND BANDED FUNCTIONS.
-C
- 180 CONTINUE
- DO 190 J = 1, N
- X(J) = -ONE
- 190 CONTINUE
- 200 CONTINUE
-C
-C COMPUTE MULTIPLE OF INITIAL POINT.
-C
- IF (FACTOR .EQ. ONE) GO TO 250
- IF (NPROB .EQ. 6) GO TO 220
- DO 210 J = 1, N
- X(J) = FACTOR*X(J)
- 210 CONTINUE
- GO TO 240
- 220 CONTINUE
- DO 230 J = 1, N
- X(J) = FACTOR
- 230 CONTINUE
- 240 CONTINUE
- 250 CONTINUE
- RETURN
-C
-C LAST CARD OF SUBROUTINE INITPT.
-C
- END
diff --git a/CEP/PyBDSM/src/minpack/ex/file09 b/CEP/PyBDSM/src/minpack/ex/file09
deleted file mode 100644
index 672ec011e3682230e33ae9f55b1dea384a35d75a..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/minpack/ex/file09
+++ /dev/null
@@ -1,879 +0,0 @@
-C **********
-C
-C THIS PROGRAM TESTS CODES FOR THE SOLUTION OF N NONLINEAR
-C EQUATIONS IN N VARIABLES. IT CONSISTS OF A DRIVER AND AN
-C INTERFACE SUBROUTINE FCN. THE DRIVER READS IN DATA, CALLS THE
-C NONLINEAR EQUATION SOLVER, AND FINALLY PRINTS OUT INFORMATION
-C ON THE PERFORMANCE OF THE SOLVER. THIS IS ONLY A SAMPLE DRIVER,
-C MANY OTHER DRIVERS ARE POSSIBLE. THE INTERFACE SUBROUTINE FCN
-C IS NECESSARY TO TAKE INTO ACCOUNT THE FORMS OF CALLING
-C SEQUENCES USED BY THE FUNCTION AND JACOBIAN SUBROUTINES IN
-C THE VARIOUS NONLINEAR EQUATION SOLVERS.
-C
-C SUBPROGRAMS CALLED
-C
-C USER-SUPPLIED ...... FCN
-C
-C MINPACK-SUPPLIED ... SPMPAR,ENORM,HYBRJ1,INITPT,VECFCN
-C
-C FORTRAN-SUPPLIED ... SQRT
-C
-C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980.
-C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE
-C
-C **********
- INTEGER I,IC,INFO,K,LDFJAC,LWA,N,NFEV,NJEV,NPROB,NREAD,NTRIES,
- * NWRITE
- INTEGER NA(60),NF(60),NJ(60),NP(60),NX(60)
- REAL FACTOR,FNORM1,FNORM2,ONE,TEN,TOL
- REAL FNM(60),FJAC(40,40),FVEC(40),WA(1060),X(40)
- REAL SPMPAR,ENORM
- EXTERNAL FCN
- COMMON /REFNUM/ NPROB,NFEV,NJEV
-C
-C LOGICAL INPUT UNIT IS ASSUMED TO BE NUMBER 5.
-C LOGICAL OUTPUT UNIT IS ASSUMED TO BE NUMBER 6.
-C
- DATA NREAD,NWRITE /5,6/
-C
- DATA ONE,TEN /1.0E0,1.0E1/
- TOL = SQRT(SPMPAR(1))
- LDFJAC = 40
- LWA = 1060
- IC = 0
- 10 CONTINUE
- READ (NREAD,50) NPROB,N,NTRIES
- IF (NPROB .LE. 0) GO TO 30
- FACTOR = ONE
- DO 20 K = 1, NTRIES
- IC = IC + 1
- CALL INITPT(N,X,NPROB,FACTOR)
- CALL VECFCN(N,X,FVEC,NPROB)
- FNORM1 = ENORM(N,FVEC)
- WRITE (NWRITE,60) NPROB,N
- NFEV = 0
- NJEV = 0
- CALL HYBRJ1(FCN,N,X,FVEC,FJAC,LDFJAC,TOL,INFO,WA,LWA)
- FNORM2 = ENORM(N,FVEC)
- NP(IC) = NPROB
- NA(IC) = N
- NF(IC) = NFEV
- NJ(IC) = NJEV
- NX(IC) = INFO
- FNM(IC) = FNORM2
- WRITE (NWRITE,70)
- * FNORM1,FNORM2,NFEV,NJEV,INFO,(X(I), I = 1, N)
- FACTOR = TEN*FACTOR
- 20 CONTINUE
- GO TO 10
- 30 CONTINUE
- WRITE (NWRITE,80) IC
- WRITE (NWRITE,90)
- DO 40 I = 1, IC
- WRITE (NWRITE,100) NP(I),NA(I),NF(I),NJ(I),NX(I),FNM(I)
- 40 CONTINUE
- STOP
- 50 FORMAT (3I5)
- 60 FORMAT ( //// 5X, 8H PROBLEM, I5, 5X, 10H DIMENSION, I5, 5X //)
- 70 FORMAT (5X, 33H INITIAL L2 NORM OF THE RESIDUALS, E15.7 // 5X,
- * 33H FINAL L2 NORM OF THE RESIDUALS , E15.7 // 5X,
- * 33H NUMBER OF FUNCTION EVALUATIONS , I10 // 5X,
- * 33H NUMBER OF JACOBIAN EVALUATIONS , I10 // 5X,
- * 15H EXIT PARAMETER, 18X, I10 // 5X,
- * 27H FINAL APPROXIMATE SOLUTION // (5X, 5E15.7))
- 80 FORMAT (12H1SUMMARY OF , I3, 16H CALLS TO HYBRJ1 /)
- 90 FORMAT (46H NPROB N NFEV NJEV INFO FINAL L2 NORM /)
- 100 FORMAT (I4, I6, 2I7, I6, 1X, E15.7)
-C
-C LAST CARD OF DRIVER.
-C
- END
- SUBROUTINE FCN(N,X,FVEC,FJAC,LDFJAC,IFLAG)
- INTEGER N,LDFJAC,IFLAG
- REAL X(N),FVEC(N),FJAC(LDFJAC,N)
-C **********
-C
-C THE CALLING SEQUENCE OF FCN SHOULD BE IDENTICAL TO THE
-C CALLING SEQUENCE OF THE FUNCTION SUBROUTINE IN THE NONLINEAR
-C EQUATION SOLVER. FCN SHOULD ONLY CALL THE TESTING FUNCTION
-C AND JACOBIAN SUBROUTINES VECFCN AND VECJAC WITH THE
-C APPROPRIATE VALUE OF PROBLEM NUMBER (NPROB).
-C
-C SUBPROGRAMS CALLED
-C
-C MINPACK-SUPPLIED ... VECFCN,VECJAC
-C
-C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980.
-C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE
-C
-C **********
- INTEGER NPROB,NFEV,NJEV
- COMMON /REFNUM/ NPROB,NFEV,NJEV
- IF (IFLAG .EQ. 1) CALL VECFCN(N,X,FVEC,NPROB)
- IF (IFLAG .EQ. 2) CALL VECJAC(N,X,FJAC,LDFJAC,NPROB)
- IF (IFLAG .EQ. 1) NFEV = NFEV + 1
- IF (IFLAG .EQ. 2) NJEV = NJEV + 1
- RETURN
-C
-C LAST CARD OF INTERFACE SUBROUTINE FCN.
-C
- END
- SUBROUTINE VECJAC(N,X,FJAC,LDFJAC,NPROB)
- INTEGER N,LDFJAC,NPROB
- REAL X(N),FJAC(LDFJAC,N)
-C **********
-C
-C SUBROUTINE VECJAC
-C
-C THIS SUBROUTINE DEFINES THE JACOBIAN MATRICES OF FOURTEEN
-C TEST FUNCTIONS. THE PROBLEM DIMENSIONS ARE AS DESCRIBED
-C IN THE PROLOGUE COMMENTS OF VECFCN.
-C
-C THE SUBROUTINE STATEMENT IS
-C
-C SUBROUTINE VECJAC(N,X,FJAC,LDFJAC,NPROB)
-C
-C WHERE
-C
-C N IS A POSITIVE INTEGER VARIABLE.
-C
-C X IS AN ARRAY OF LENGTH N.
-C
-C FJAC IS AN N BY N ARRAY. ON OUTPUT FJAC CONTAINS THE
-C JACOBIAN MATRIX OF THE NPROB FUNCTION EVALUATED AT X.
-C
-C LDFJAC IS A POSITIVE INTEGER VARIABLE NOT LESS THAN N
-C WHICH SPECIFIES THE LEADING DIMENSION OF THE ARRAY FJAC.
-C
-C NPROB IS A POSITIVE INTEGER VARIABLE WHICH DEFINES THE
-C NUMBER OF THE PROBLEM. NPROB MUST NOT EXCEED 14.
-C
-C SUBPROGRAMS CALLED
-C
-C FORTRAN-SUPPLIED ... ATAN,COS,EXP,AMIN1,SIN,SQRT,
-C MAX0,MIN0
-C
-C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980.
-C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE
-C
-C **********
- INTEGER I,IVAR,J,K,K1,K2,ML,MU
- REAL C1,C3,C4,C5,C6,C9,EIGHT,FIFTN,FIVE,FOUR,H,HUNDRD,ONE,PROD,
- * SIX,SUM,SUM1,SUM2,TEMP,TEMP1,TEMP2,TEMP3,TEMP4,TEN,THREE,
- * TI,TJ,TK,TPI,TWENTY,TWO,ZERO
- REAL FLOAT
- DATA ZERO,ONE,TWO,THREE,FOUR,FIVE,SIX,EIGHT,TEN,FIFTN,TWENTY,
- * HUNDRD
- * /0.0E0,1.0E0,2.0E0,3.0E0,4.0E0,5.0E0,6.0E0,8.0E0,1.0E1,
- * 1.5E1,2.0E1,1.0E2/
- DATA C1,C3,C4,C5,C6,C9 /1.0E4,2.0E2,2.02E1,1.98E1,1.8E2,2.9E1/
- FLOAT(IVAR) = IVAR
-C
-C JACOBIAN ROUTINE SELECTOR.
-C
- GO TO (10,20,50,60,90,100,200,230,290,320,350,380,420,450),
- * NPROB
-C
-C ROSENBROCK FUNCTION.
-C
- 10 CONTINUE
- FJAC(1,1) = -ONE
- FJAC(1,2) = ZERO
- FJAC(2,1) = -TWENTY*X(1)
- FJAC(2,2) = TEN
- GO TO 490
-C
-C POWELL SINGULAR FUNCTION.
-C
- 20 CONTINUE
- DO 40 K = 1, 4
- DO 30 J = 1, 4
- FJAC(K,J) = ZERO
- 30 CONTINUE
- 40 CONTINUE
- FJAC(1,1) = ONE
- FJAC(1,2) = TEN
- FJAC(2,3) = SQRT(FIVE)
- FJAC(2,4) = -FJAC(2,3)
- FJAC(3,2) = TWO*(X(2) - TWO*X(3))
- FJAC(3,3) = -TWO*FJAC(3,2)
- FJAC(4,1) = TWO*SQRT(TEN)*(X(1) - X(4))
- FJAC(4,4) = -FJAC(4,1)
- GO TO 490
-C
-C POWELL BADLY SCALED FUNCTION.
-C
- 50 CONTINUE
- FJAC(1,1) = C1*X(2)
- FJAC(1,2) = C1*X(1)
- FJAC(2,1) = -EXP(-X(1))
- FJAC(2,2) = -EXP(-X(2))
- GO TO 490
-C
-C WOOD FUNCTION.
-C
- 60 CONTINUE
- DO 80 K = 1, 4
- DO 70 J = 1, 4
- FJAC(K,J) = ZERO
- 70 CONTINUE
- 80 CONTINUE
- TEMP1 = X(2) - THREE*X(1)**2
- TEMP2 = X(4) - THREE*X(3)**2
- FJAC(1,1) = -C3*TEMP1 + ONE
- FJAC(1,2) = -C3*X(1)
- FJAC(2,1) = -TWO*C3*X(1)
- FJAC(2,2) = C3 + C4
- FJAC(2,4) = C5
- FJAC(3,3) = -C6*TEMP2 + ONE
- FJAC(3,4) = -C6*X(3)
- FJAC(4,2) = C5
- FJAC(4,3) = -TWO*C6*X(3)
- FJAC(4,4) = C6 + C4
- GO TO 490
-C
-C HELICAL VALLEY FUNCTION.
-C
- 90 CONTINUE
- TPI = EIGHT*ATAN(ONE)
- TEMP = X(1)**2 + X(2)**2
- TEMP1 = TPI*TEMP
- TEMP2 = SQRT(TEMP)
- FJAC(1,1) = HUNDRD*X(2)/TEMP1
- FJAC(1,2) = -HUNDRD*X(1)/TEMP1
- FJAC(1,3) = TEN
- FJAC(2,1) = TEN*X(1)/TEMP2
- FJAC(2,2) = TEN*X(2)/TEMP2
- FJAC(2,3) = ZERO
- FJAC(3,1) = ZERO
- FJAC(3,2) = ZERO
- FJAC(3,3) = ONE
- GO TO 490
-C
-C WATSON FUNCTION.
-C
- 100 CONTINUE
- DO 120 K = 1, N
- DO 110 J = K, N
- FJAC(K,J) = ZERO
- 110 CONTINUE
- 120 CONTINUE
- DO 170 I = 1, 29
- TI = FLOAT(I)/C9
- SUM1 = ZERO
- TEMP = ONE
- DO 130 J = 2, N
- SUM1 = SUM1 + FLOAT(J-1)*TEMP*X(J)
- TEMP = TI*TEMP
- 130 CONTINUE
- SUM2 = ZERO
- TEMP = ONE
- DO 140 J = 1, N
- SUM2 = SUM2 + TEMP*X(J)
- TEMP = TI*TEMP
- 140 CONTINUE
- TEMP1 = TWO*(SUM1 - SUM2**2 - ONE)
- TEMP2 = TWO*SUM2
- TEMP = TI**2
- TK = ONE
- DO 160 K = 1, N
- TJ = TK
- DO 150 J = K, N
- FJAC(K,J) = FJAC(K,J)
- * + TJ
- * *((FLOAT(K-1)/TI - TEMP2)
- * *(FLOAT(J-1)/TI - TEMP2) - TEMP1)
- TJ = TI*TJ
- 150 CONTINUE
- TK = TEMP*TK
- 160 CONTINUE
- 170 CONTINUE
- FJAC(1,1) = FJAC(1,1) + SIX*X(1)**2 - TWO*X(2) + THREE
- FJAC(1,2) = FJAC(1,2) - TWO*X(1)
- FJAC(2,2) = FJAC(2,2) + ONE
- DO 190 K = 1, N
- DO 180 J = K, N
- FJAC(J,K) = FJAC(K,J)
- 180 CONTINUE
- 190 CONTINUE
- GO TO 490
-C
-C CHEBYQUAD FUNCTION.
-C
- 200 CONTINUE
- TK = ONE/FLOAT(N)
- DO 220 J = 1, N
- TEMP1 = ONE
- TEMP2 = TWO*X(J) - ONE
- TEMP = TWO*TEMP2
- TEMP3 = ZERO
- TEMP4 = TWO
- DO 210 K = 1, N
- FJAC(K,J) = TK*TEMP4
- TI = FOUR*TEMP2 + TEMP*TEMP4 - TEMP3
- TEMP3 = TEMP4
- TEMP4 = TI
- TI = TEMP*TEMP2 - TEMP1
- TEMP1 = TEMP2
- TEMP2 = TI
- 210 CONTINUE
- 220 CONTINUE
- GO TO 490
-C
-C BROWN ALMOST-LINEAR FUNCTION.
-C
- 230 CONTINUE
- PROD = ONE
- DO 250 J = 1, N
- PROD = X(J)*PROD
- DO 240 K = 1, N
- FJAC(K,J) = ONE
- 240 CONTINUE
- FJAC(J,J) = TWO
- 250 CONTINUE
- DO 280 J = 1, N
- TEMP = X(J)
- IF (TEMP .NE. ZERO) GO TO 270
- TEMP = ONE
- PROD = ONE
- DO 260 K = 1, N
- IF (K .NE. J) PROD = X(K)*PROD
- 260 CONTINUE
- 270 CONTINUE
- FJAC(N,J) = PROD/TEMP
- 280 CONTINUE
- GO TO 490
-C
-C DISCRETE BOUNDARY VALUE FUNCTION.
-C
- 290 CONTINUE
- H = ONE/FLOAT(N+1)
- DO 310 K = 1, N
- TEMP = THREE*(X(K) + FLOAT(K)*H + ONE)**2
- DO 300 J = 1, N
- FJAC(K,J) = ZERO
- 300 CONTINUE
- FJAC(K,K) = TWO + TEMP*H**2/TWO
- IF (K .NE. 1) FJAC(K,K-1) = -ONE
- IF (K .NE. N) FJAC(K,K+1) = -ONE
- 310 CONTINUE
- GO TO 490
-C
-C DISCRETE INTEGRAL EQUATION FUNCTION.
-C
- 320 CONTINUE
- H = ONE/FLOAT(N+1)
- DO 340 K = 1, N
- TK = FLOAT(K)*H
- DO 330 J = 1, N
- TJ = FLOAT(J)*H
- TEMP = THREE*(X(J) + TJ + ONE)**2
- FJAC(K,J) = H*AMIN1(TJ*(ONE-TK),TK*(ONE-TJ))*TEMP/TWO
- 330 CONTINUE
- FJAC(K,K) = FJAC(K,K) + ONE
- 340 CONTINUE
- GO TO 490
-C
-C TRIGONOMETRIC FUNCTION.
-C
- 350 CONTINUE
- DO 370 J = 1, N
- TEMP = SIN(X(J))
- DO 360 K = 1, N
- FJAC(K,J) = TEMP
- 360 CONTINUE
- FJAC(J,J) = FLOAT(J+1)*TEMP - COS(X(J))
- 370 CONTINUE
- GO TO 490
-C
-C VARIABLY DIMENSIONED FUNCTION.
-C
- 380 CONTINUE
- SUM = ZERO
- DO 390 J = 1, N
- SUM = SUM + FLOAT(J)*(X(J) - ONE)
- 390 CONTINUE
- TEMP = ONE + SIX*SUM**2
- DO 410 K = 1, N
- DO 400 J = K, N
- FJAC(K,J) = FLOAT(K*J)*TEMP
- FJAC(J,K) = FJAC(K,J)
- 400 CONTINUE
- FJAC(K,K) = FJAC(K,K) + ONE
- 410 CONTINUE
- GO TO 490
-C
-C BROYDEN TRIDIAGONAL FUNCTION.
-C
- 420 CONTINUE
- DO 440 K = 1, N
- DO 430 J = 1, N
- FJAC(K,J) = ZERO
- 430 CONTINUE
- FJAC(K,K) = THREE - FOUR*X(K)
- IF (K .NE. 1) FJAC(K,K-1) = -ONE
- IF (K .NE. N) FJAC(K,K+1) = -TWO
- 440 CONTINUE
- GO TO 490
-C
-C BROYDEN BANDED FUNCTION.
-C
- 450 CONTINUE
- ML = 5
- MU = 1
- DO 480 K = 1, N
- DO 460 J = 1, N
- FJAC(K,J) = ZERO
- 460 CONTINUE
- K1 = MAX0(1,K-ML)
- K2 = MIN0(K+MU,N)
- DO 470 J = K1, K2
- IF (J .NE. K) FJAC(K,J) = -(ONE + TWO*X(J))
- 470 CONTINUE
- FJAC(K,K) = TWO + FIFTN*X(K)**2
- 480 CONTINUE
- 490 CONTINUE
- RETURN
-C
-C LAST CARD OF SUBROUTINE VECJAC.
-C
- END
- SUBROUTINE INITPT(N,X,NPROB,FACTOR)
- INTEGER N,NPROB
- REAL FACTOR
- REAL X(N)
-C **********
-C
-C SUBROUTINE INITPT
-C
-C THIS SUBROUTINE SPECIFIES THE STANDARD STARTING POINTS FOR
-C THE FUNCTIONS DEFINED BY SUBROUTINE VECFCN. THE SUBROUTINE
-C RETURNS IN X A MULTIPLE (FACTOR) OF THE STANDARD STARTING
-C POINT. FOR THE SIXTH FUNCTION THE STANDARD STARTING POINT IS
-C ZERO, SO IN THIS CASE, IF FACTOR IS NOT UNITY, THEN THE
-C SUBROUTINE RETURNS THE VECTOR X(J) = FACTOR, J=1,...,N.
-C
-C THE SUBROUTINE STATEMENT IS
-C
-C SUBROUTINE INITPT(N,X,NPROB,FACTOR)
-C
-C WHERE
-C
-C N IS A POSITIVE INTEGER INPUT VARIABLE.
-C
-C X IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS THE STANDARD
-C STARTING POINT FOR PROBLEM NPROB MULTIPLIED BY FACTOR.
-C
-C NPROB IS A POSITIVE INTEGER INPUT VARIABLE WHICH DEFINES THE
-C NUMBER OF THE PROBLEM. NPROB MUST NOT EXCEED 14.
-C
-C FACTOR IS AN INPUT VARIABLE WHICH SPECIFIES THE MULTIPLE OF
-C THE STANDARD STARTING POINT. IF FACTOR IS UNITY, NO
-C MULTIPLICATION IS PERFORMED.
-C
-C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980.
-C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE
-C
-C **********
- INTEGER IVAR,J
- REAL C1,H,HALF,ONE,THREE,TJ,ZERO
- REAL FLOAT
- DATA ZERO,HALF,ONE,THREE,C1 /0.0E0,5.0E-1,1.0E0,3.0E0,1.2E0/
- FLOAT(IVAR) = IVAR
-C
-C SELECTION OF INITIAL POINT.
-C
- GO TO (10,20,30,40,50,60,80,100,120,120,140,160,180,180), NPROB
-C
-C ROSENBROCK FUNCTION.
-C
- 10 CONTINUE
- X(1) = -C1
- X(2) = ONE
- GO TO 200
-C
-C POWELL SINGULAR FUNCTION.
-C
- 20 CONTINUE
- X(1) = THREE
- X(2) = -ONE
- X(3) = ZERO
- X(4) = ONE
- GO TO 200
-C
-C POWELL BADLY SCALED FUNCTION.
-C
- 30 CONTINUE
- X(1) = ZERO
- X(2) = ONE
- GO TO 200
-C
-C WOOD FUNCTION.
-C
- 40 CONTINUE
- X(1) = -THREE
- X(2) = -ONE
- X(3) = -THREE
- X(4) = -ONE
- GO TO 200
-C
-C HELICAL VALLEY FUNCTION.
-C
- 50 CONTINUE
- X(1) = -ONE
- X(2) = ZERO
- X(3) = ZERO
- GO TO 200
-C
-C WATSON FUNCTION.
-C
- 60 CONTINUE
- DO 70 J = 1, N
- X(J) = ZERO
- 70 CONTINUE
- GO TO 200
-C
-C CHEBYQUAD FUNCTION.
-C
- 80 CONTINUE
- H = ONE/FLOAT(N+1)
- DO 90 J = 1, N
- X(J) = FLOAT(J)*H
- 90 CONTINUE
- GO TO 200
-C
-C BROWN ALMOST-LINEAR FUNCTION.
-C
- 100 CONTINUE
- DO 110 J = 1, N
- X(J) = HALF
- 110 CONTINUE
- GO TO 200
-C
-C DISCRETE BOUNDARY VALUE AND INTEGRAL EQUATION FUNCTIONS.
-C
- 120 CONTINUE
- H = ONE/FLOAT(N+1)
- DO 130 J = 1, N
- TJ = FLOAT(J)*H
- X(J) = TJ*(TJ - ONE)
- 130 CONTINUE
- GO TO 200
-C
-C TRIGONOMETRIC FUNCTION.
-C
- 140 CONTINUE
- H = ONE/FLOAT(N)
- DO 150 J = 1, N
- X(J) = H
- 150 CONTINUE
- GO TO 200
-C
-C VARIABLY DIMENSIONED FUNCTION.
-C
- 160 CONTINUE
- H = ONE/FLOAT(N)
- DO 170 J = 1, N
- X(J) = ONE - FLOAT(J)*H
- 170 CONTINUE
- GO TO 200
-C
-C BROYDEN TRIDIAGONAL AND BANDED FUNCTIONS.
-C
- 180 CONTINUE
- DO 190 J = 1, N
- X(J) = -ONE
- 190 CONTINUE
- 200 CONTINUE
-C
-C COMPUTE MULTIPLE OF INITIAL POINT.
-C
- IF (FACTOR .EQ. ONE) GO TO 250
- IF (NPROB .EQ. 6) GO TO 220
- DO 210 J = 1, N
- X(J) = FACTOR*X(J)
- 210 CONTINUE
- GO TO 240
- 220 CONTINUE
- DO 230 J = 1, N
- X(J) = FACTOR
- 230 CONTINUE
- 240 CONTINUE
- 250 CONTINUE
- RETURN
-C
-C LAST CARD OF SUBROUTINE INITPT.
-C
- END
- SUBROUTINE VECFCN(N,X,FVEC,NPROB)
- INTEGER N,NPROB
- REAL X(N),FVEC(N)
-C **********
-C
-C SUBROUTINE VECFCN
-C
-C THIS SUBROUTINE DEFINES FOURTEEN TEST FUNCTIONS. THE FIRST
-C FIVE TEST FUNCTIONS ARE OF DIMENSIONS 2,4,2,4,3, RESPECTIVELY,
-C WHILE THE REMAINING TEST FUNCTIONS ARE OF VARIABLE DIMENSION
-C N FOR ANY N GREATER THAN OR EQUAL TO 1 (PROBLEM 6 IS AN
-C EXCEPTION TO THIS, SINCE IT DOES NOT ALLOW N = 1).
-C
-C THE SUBROUTINE STATEMENT IS
-C
-C SUBROUTINE VECFCN(N,X,FVEC,NPROB)
-C
-C WHERE
-C
-C N IS A POSITIVE INTEGER INPUT VARIABLE.
-C
-C X IS AN INPUT ARRAY OF LENGTH N.
-C
-C FVEC IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS THE NPROB
-C FUNCTION VECTOR EVALUATED AT X.
-C
-C NPROB IS A POSITIVE INTEGER INPUT VARIABLE WHICH DEFINES THE
-C NUMBER OF THE PROBLEM. NPROB MUST NOT EXCEED 14.
-C
-C SUBPROGRAMS CALLED
-C
-C FORTRAN-SUPPLIED ... ATAN,COS,EXP,SIGN,SIN,SQRT,
-C MAX0,MIN0
-C
-C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980.
-C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE
-C
-C **********
- INTEGER I,IEV,IVAR,J,K,K1,K2,KP1,ML,MU
- REAL C1,C2,C3,C4,C5,C6,C7,C8,C9,EIGHT,FIVE,H,ONE,PROD,SUM,SUM1,
- * SUM2,TEMP,TEMP1,TEMP2,TEN,THREE,TI,TJ,TK,TPI,TWO,ZERO
- REAL FLOAT
- DATA ZERO,ONE,TWO,THREE,FIVE,EIGHT,TEN
- * /0.0E0,1.0E0,2.0E0,3.0E0,5.0E0,8.0E0,1.0E1/
- DATA C1,C2,C3,C4,C5,C6,C7,C8,C9
- * /1.0E4,1.0001E0,2.0E2,2.02E1,1.98E1,1.8E2,2.5E-1,5.0E-1,
- * 2.9E1/
- FLOAT(IVAR) = IVAR
-C
-C PROBLEM SELECTOR.
-C
- GO TO (10,20,30,40,50,60,120,170,200,220,270,300,330,350), NPROB
-C
-C ROSENBROCK FUNCTION.
-C
- 10 CONTINUE
- FVEC(1) = ONE - X(1)
- FVEC(2) = TEN*(X(2) - X(1)**2)
- GO TO 380
-C
-C POWELL SINGULAR FUNCTION.
-C
- 20 CONTINUE
- FVEC(1) = X(1) + TEN*X(2)
- FVEC(2) = SQRT(FIVE)*(X(3) - X(4))
- FVEC(3) = (X(2) - TWO*X(3))**2
- FVEC(4) = SQRT(TEN)*(X(1) - X(4))**2
- GO TO 380
-C
-C POWELL BADLY SCALED FUNCTION.
-C
- 30 CONTINUE
- FVEC(1) = C1*X(1)*X(2) - ONE
- FVEC(2) = EXP(-X(1)) + EXP(-X(2)) - C2
- GO TO 380
-C
-C WOOD FUNCTION.
-C
- 40 CONTINUE
- TEMP1 = X(2) - X(1)**2
- TEMP2 = X(4) - X(3)**2
- FVEC(1) = -C3*X(1)*TEMP1 - (ONE - X(1))
- FVEC(2) = C3*TEMP1 + C4*(X(2) - ONE) + C5*(X(4) - ONE)
- FVEC(3) = -C6*X(3)*TEMP2 - (ONE - X(3))
- FVEC(4) = C6*TEMP2 + C4*(X(4) - ONE) + C5*(X(2) - ONE)
- GO TO 380
-C
-C HELICAL VALLEY FUNCTION.
-C
- 50 CONTINUE
- TPI = EIGHT*ATAN(ONE)
- TEMP1 = SIGN(C7,X(2))
- IF (X(1) .GT. ZERO) TEMP1 = ATAN(X(2)/X(1))/TPI
- IF (X(1) .LT. ZERO) TEMP1 = ATAN(X(2)/X(1))/TPI + C8
- TEMP2 = SQRT(X(1)**2+X(2)**2)
- FVEC(1) = TEN*(X(3) - TEN*TEMP1)
- FVEC(2) = TEN*(TEMP2 - ONE)
- FVEC(3) = X(3)
- GO TO 380
-C
-C WATSON FUNCTION.
-C
- 60 CONTINUE
- DO 70 K = 1, N
- FVEC(K) = ZERO
- 70 CONTINUE
- DO 110 I = 1, 29
- TI = FLOAT(I)/C9
- SUM1 = ZERO
- TEMP = ONE
- DO 80 J = 2, N
- SUM1 = SUM1 + FLOAT(J-1)*TEMP*X(J)
- TEMP = TI*TEMP
- 80 CONTINUE
- SUM2 = ZERO
- TEMP = ONE
- DO 90 J = 1, N
- SUM2 = SUM2 + TEMP*X(J)
- TEMP = TI*TEMP
- 90 CONTINUE
- TEMP1 = SUM1 - SUM2**2 - ONE
- TEMP2 = TWO*TI*SUM2
- TEMP = ONE/TI
- DO 100 K = 1, N
- FVEC(K) = FVEC(K) + TEMP*(FLOAT(K-1) - TEMP2)*TEMP1
- TEMP = TI*TEMP
- 100 CONTINUE
- 110 CONTINUE
- TEMP = X(2) - X(1)**2 - ONE
- FVEC(1) = FVEC(1) + X(1)*(ONE - TWO*TEMP)
- FVEC(2) = FVEC(2) + TEMP
- GO TO 380
-C
-C CHEBYQUAD FUNCTION.
-C
- 120 CONTINUE
- DO 130 K = 1, N
- FVEC(K) = ZERO
- 130 CONTINUE
- DO 150 J = 1, N
- TEMP1 = ONE
- TEMP2 = TWO*X(J) - ONE
- TEMP = TWO*TEMP2
- DO 140 I = 1, N
- FVEC(I) = FVEC(I) + TEMP2
- TI = TEMP*TEMP2 - TEMP1
- TEMP1 = TEMP2
- TEMP2 = TI
- 140 CONTINUE
- 150 CONTINUE
- TK = ONE/FLOAT(N)
- IEV = -1
- DO 160 K = 1, N
- FVEC(K) = TK*FVEC(K)
- IF (IEV .GT. 0) FVEC(K) = FVEC(K) + ONE/(FLOAT(K)**2 - ONE)
- IEV = -IEV
- 160 CONTINUE
- GO TO 380
-C
-C BROWN ALMOST-LINEAR FUNCTION.
-C
- 170 CONTINUE
- SUM = -FLOAT(N+1)
- PROD = ONE
- DO 180 J = 1, N
- SUM = SUM + X(J)
- PROD = X(J)*PROD
- 180 CONTINUE
- DO 190 K = 1, N
- FVEC(K) = X(K) + SUM
- 190 CONTINUE
- FVEC(N) = PROD - ONE
- GO TO 380
-C
-C DISCRETE BOUNDARY VALUE FUNCTION.
-C
- 200 CONTINUE
- H = ONE/FLOAT(N+1)
- DO 210 K = 1, N
- TEMP = (X(K) + FLOAT(K)*H + ONE)**3
- TEMP1 = ZERO
- IF (K .NE. 1) TEMP1 = X(K-1)
- TEMP2 = ZERO
- IF (K .NE. N) TEMP2 = X(K+1)
- FVEC(K) = TWO*X(K) - TEMP1 - TEMP2 + TEMP*H**2/TWO
- 210 CONTINUE
- GO TO 380
-C
-C DISCRETE INTEGRAL EQUATION FUNCTION.
-C
- 220 CONTINUE
- H = ONE/FLOAT(N+1)
- DO 260 K = 1, N
- TK = FLOAT(K)*H
- SUM1 = ZERO
- DO 230 J = 1, K
- TJ = FLOAT(J)*H
- TEMP = (X(J) + TJ + ONE)**3
- SUM1 = SUM1 + TJ*TEMP
- 230 CONTINUE
- SUM2 = ZERO
- KP1 = K + 1
- IF (N .LT. KP1) GO TO 250
- DO 240 J = KP1, N
- TJ = FLOAT(J)*H
- TEMP = (X(J) + TJ + ONE)**3
- SUM2 = SUM2 + (ONE - TJ)*TEMP
- 240 CONTINUE
- 250 CONTINUE
- FVEC(K) = X(K) + H*((ONE - TK)*SUM1 + TK*SUM2)/TWO
- 260 CONTINUE
- GO TO 380
-C
-C TRIGONOMETRIC FUNCTION.
-C
- 270 CONTINUE
- SUM = ZERO
- DO 280 J = 1, N
- FVEC(J) = COS(X(J))
- SUM = SUM + FVEC(J)
- 280 CONTINUE
- DO 290 K = 1, N
- FVEC(K) = FLOAT(N+K) - SIN(X(K)) - SUM - FLOAT(K)*FVEC(K)
- 290 CONTINUE
- GO TO 380
-C
-C VARIABLY DIMENSIONED FUNCTION.
-C
- 300 CONTINUE
- SUM = ZERO
- DO 310 J = 1, N
- SUM = SUM + FLOAT(J)*(X(J) - ONE)
- 310 CONTINUE
- TEMP = SUM*(ONE + TWO*SUM**2)
- DO 320 K = 1, N
- FVEC(K) = X(K) - ONE + FLOAT(K)*TEMP
- 320 CONTINUE
- GO TO 380
-C
-C BROYDEN TRIDIAGONAL FUNCTION.
-C
- 330 CONTINUE
- DO 340 K = 1, N
- TEMP = (THREE - TWO*X(K))*X(K)
- TEMP1 = ZERO
- IF (K .NE. 1) TEMP1 = X(K-1)
- TEMP2 = ZERO
- IF (K .NE. N) TEMP2 = X(K+1)
- FVEC(K) = TEMP - TEMP1 - TWO*TEMP2 + ONE
- 340 CONTINUE
- GO TO 380
-C
-C BROYDEN BANDED FUNCTION.
-C
- 350 CONTINUE
- ML = 5
- MU = 1
- DO 370 K = 1, N
- K1 = MAX0(1,K-ML)
- K2 = MIN0(K+MU,N)
- TEMP = ZERO
- DO 360 J = K1, K2
- IF (J .NE. K) TEMP = TEMP + X(J)*(ONE + X(J))
- 360 CONTINUE
- FVEC(K) = X(K)*(TWO + FIVE*X(K)**2) + ONE - TEMP
- 370 CONTINUE
- 380 CONTINUE
- RETURN
-C
-C LAST CARD OF SUBROUTINE VECFCN.
-C
- END
diff --git a/CEP/PyBDSM/src/minpack/ex/file11 b/CEP/PyBDSM/src/minpack/ex/file11
deleted file mode 100644
index adbbbdd25441d8477fbd14353e02893c18db48df..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/minpack/ex/file11
+++ /dev/null
@@ -1,1033 +0,0 @@
-C **********
-C
-C THIS PROGRAM TESTS CODES FOR THE LEAST-SQUARES SOLUTION OF
-C M NONLINEAR EQUATIONS IN N VARIABLES. IT CONSISTS OF A DRIVER
-C AND AN INTERFACE SUBROUTINE FCN. THE DRIVER READS IN DATA,
-C CALLS THE NONLINEAR LEAST-SQUARES SOLVER, AND FINALLY PRINTS
-C OUT INFORMATION ON THE PERFORMANCE OF THE SOLVER. THIS IS
-C ONLY A SAMPLE DRIVER, MANY OTHER DRIVERS ARE POSSIBLE. THE
-C INTERFACE SUBROUTINE FCN IS NECESSARY TO TAKE INTO ACCOUNT THE
-C FORMS OF CALLING SEQUENCES USED BY THE FUNCTION AND JACOBIAN
-C SUBROUTINES IN THE VARIOUS NONLINEAR LEAST-SQUARES SOLVERS.
-C
-C SUBPROGRAMS CALLED
-C
-C USER-SUPPLIED ...... FCN
-C
-C MINPACK-SUPPLIED ... SPMPAR,ENORM,INITPT,LMSTR1,SSQFCN
-C
-C FORTRAN-SUPPLIED ... SQRT
-C
-C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980.
-C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE
-C
-C **********
- INTEGER I,IC,INFO,K,LDFJAC,LWA,M,N,NFEV,NJEV,NPROB,NREAD,NTRIES,
- * NWRITE
- INTEGER IWA(40),MA(60),NA(60),NF(60),NJ(60),NP(60),NX(60)
- REAL FACTOR,FNORM1,FNORM2,ONE,TEN,TOL
- REAL FJAC(40,40),FNM(60),FVEC(65),WA(265),X(40)
- REAL SPMPAR,ENORM
- EXTERNAL FCN
- COMMON /REFNUM/ NPROB,NFEV,NJEV
-C
-C LOGICAL INPUT UNIT IS ASSUMED TO BE NUMBER 5.
-C LOGICAL OUTPUT UNIT IS ASSUMED TO BE NUMBER 6.
-C
- DATA NREAD,NWRITE /5,6/
-C
- DATA ONE,TEN /1.0E0,1.0E1/
- TOL = SQRT(SPMPAR(1))
- LDFJAC = 40
- LWA = 265
- IC = 0
- 10 CONTINUE
- READ (NREAD,50) NPROB,N,M,NTRIES
- IF (NPROB .LE. 0) GO TO 30
- FACTOR = ONE
- DO 20 K = 1, NTRIES
- IC = IC + 1
- CALL INITPT(N,X,NPROB,FACTOR)
- CALL SSQFCN(M,N,X,FVEC,NPROB)
- FNORM1 = ENORM(M,FVEC)
- WRITE (NWRITE,60) NPROB,N,M
- NFEV = 0
- NJEV = 0
- CALL LMSTR1(FCN,M,N,X,FVEC,FJAC,LDFJAC,TOL,INFO,IWA,WA,
- * LWA)
- CALL SSQFCN(M,N,X,FVEC,NPROB)
- FNORM2 = ENORM(M,FVEC)
- NP(IC) = NPROB
- NA(IC) = N
- MA(IC) = M
- NF(IC) = NFEV
- NJ(IC) = NJEV
- NX(IC) = INFO
- FNM(IC) = FNORM2
- WRITE (NWRITE,70)
- * FNORM1,FNORM2,NFEV,NJEV,INFO,(X(I), I = 1, N)
- FACTOR = TEN*FACTOR
- 20 CONTINUE
- GO TO 10
- 30 CONTINUE
- WRITE (NWRITE,80) IC
- WRITE (NWRITE,90)
- DO 40 I = 1, IC
- WRITE (NWRITE,100) NP(I),NA(I),MA(I),NF(I),NJ(I),NX(I),FNM(I)
- 40 CONTINUE
- STOP
- 50 FORMAT (4I5)
- 60 FORMAT ( //// 5X, 8H PROBLEM, I5, 5X, 11H DIMENSIONS, 2I5, 5X //
- * )
- 70 FORMAT (5X, 33H INITIAL L2 NORM OF THE RESIDUALS, E15.7 // 5X,
- * 33H FINAL L2 NORM OF THE RESIDUALS , E15.7 // 5X,
- * 33H NUMBER OF FUNCTION EVALUATIONS , I10 // 5X,
- * 33H NUMBER OF JACOBIAN EVALUATIONS , I10 // 5X,
- * 15H EXIT PARAMETER, 18X, I10 // 5X,
- * 27H FINAL APPROXIMATE SOLUTION // (5X, 5E15.7))
- 80 FORMAT (12H1SUMMARY OF , I3, 16H CALLS TO LMSTR1 /)
- 90 FORMAT (49H NPROB N M NFEV NJEV INFO FINAL L2 NORM /)
- 100 FORMAT (3I5, 3I6, 2X, E15.7)
-C
-C LAST CARD OF DRIVER.
-C
- END
- SUBROUTINE FCN(M,N,X,FVEC,FJROW,IFLAG)
- INTEGER M,N,IFLAG
- REAL X(N),FVEC(M),FJROW(N)
-C **********
-C
-C THE CALLING SEQUENCE OF FCN SHOULD BE IDENTICAL TO THE
-C CALLING SEQUENCE OF THE FUNCTION SUBROUTINE IN THE NONLINEAR
-C LEAST SQUARES SOLVER. IF IFLAG = 1, FCN SHOULD ONLY CALL THE
-C TESTING FUNCTION SUBROUTINE SSQFCN. IF IFLAG = I, I .GE. 2,
-C FCN SHOULD ONLY CALL SUBROUTINE SSQJAC TO CALCULATE THE
-C (I-1)-ST ROW OF THE JACOBIAN. (THE SSQJAC SUBROUTINE PROVIDED
-C HERE FOR TESTING PURPOSES CALCULATES THE ENTIRE JACOBIAN
-C MATRIX AND IS THEREFORE CALLED ONLY WHEN IFLAG = 2.) EACH
-C CALL TO SSQFCN OR SSQJAC SHOULD SPECIFY THE APPROPRIATE
-C VALUE OF PROBLEM NUMBER (NPROB).
-C
-C SUBPROGRAMS CALLED
-C
-C MINPACK-SUPPLIED ... SSQFCN,SSQJAC
-C
-C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980.
-C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE
-C
-C **********
- INTEGER NPROB,NFEV,NJEV,J
- REAL TEMP(65,40)
- COMMON /REFNUM/ NPROB,NFEV,NJEV
- IF (IFLAG .EQ. 1) CALL SSQFCN(M,N,X,FVEC,NPROB)
- IF (IFLAG .EQ. 2) CALL SSQJAC(M,N,X,TEMP,65,NPROB)
- IF (IFLAG .EQ. 1) NFEV = NFEV + 1
- IF (IFLAG .EQ. 2) NJEV = NJEV + 1
- IF (IFLAG .EQ. 1) GO TO 120
- DO 110 J = 1, N
- FJROW(J) = TEMP(IFLAG-1,J)
- 110 CONTINUE
- 120 CONTINUE
- RETURN
-C
-C LAST CARD OF INTERFACE SUBROUTINE FCN.
-C
- END
- SUBROUTINE SSQJAC(M,N,X,FJAC,LDFJAC,NPROB)
- INTEGER M,N,LDFJAC,NPROB
- REAL X(N),FJAC(LDFJAC,N)
-C **********
-C
-C SUBROUTINE SSQJAC
-C
-C THIS SUBROUTINE DEFINES THE JACOBIAN MATRICES OF EIGHTEEN
-C NONLINEAR LEAST SQUARES PROBLEMS. THE PROBLEM DIMENSIONS ARE
-C AS DESCRIBED IN THE PROLOGUE COMMENTS OF SSQFCN.
-C
-C THE SUBROUTINE STATEMENT IS
-C
-C SUBROUTINE SSQJAC(M,N,X,FJAC,LDFJAC,NPROB)
-C
-C WHERE
-C
-C M AND N ARE POSITIVE INTEGER INPUT VARIABLES. N MUST NOT
-C EXCEED M.
-C
-C X IS AN INPUT ARRAY OF LENGTH N.
-C
-C FJAC IS AN M BY N OUTPUT ARRAY WHICH CONTAINS THE JACOBIAN
-C MATRIX OF THE NPROB FUNCTION EVALUATED AT X.
-C
-C LDFJAC IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN M
-C WHICH SPECIFIES THE LEADING DIMENSION OF THE ARRAY FJAC.
-C
-C NPROB IS A POSITIVE INTEGER VARIABLE WHICH DEFINES THE
-C NUMBER OF THE PROBLEM. NPROB MUST NOT EXCEED 18.
-C
-C SUBPROGRAMS CALLED
-C
-C FORTRAN-SUPPLIED ... ATAN,COS,EXP,SIN,SQRT
-C
-C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980.
-C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE
-C
-C **********
- INTEGER I,IVAR,J,K,MM1,NM1
- REAL C14,C20,C29,C45,C100,DIV,DX,EIGHT,FIVE,FOUR,ONE,PROD,S2,
- * TEMP,TEN,THREE,TI,TMP1,TMP2,TMP3,TMP4,TPI,TWO,ZERO
- REAL V(11)
- REAL FLOAT
- DATA ZERO,ONE,TWO,THREE,FOUR,FIVE,EIGHT,TEN,C14,C20,C29,C45,C100
- * /0.0E0,1.0E0,2.0E0,3.0E0,4.0E0,5.0E0,8.0E0,1.0E1,1.4E1,
- * 2.0E1,2.9E1,4.5E1,1.0E2/
- DATA V(1),V(2),V(3),V(4),V(5),V(6),V(7),V(8),V(9),V(10),V(11)
- * /4.0E0,2.0E0,1.0E0,5.0E-1,2.5E-1,1.67E-1,1.25E-1,1.0E-1,
- * 8.33E-2,7.14E-2,6.25E-2/
- FLOAT(IVAR) = IVAR
-C
-C JACOBIAN ROUTINE SELECTOR.
-C
- GO TO (10,40,70,130,140,150,180,190,210,230,250,310,330,350,370,
- * 400,460,480), NPROB
-C
-C LINEAR FUNCTION - FULL RANK.
-C
- 10 CONTINUE
- TEMP = TWO/FLOAT(M)
- DO 30 J = 1, N
- DO 20 I = 1, M
- FJAC(I,J) = -TEMP
- 20 CONTINUE
- FJAC(J,J) = FJAC(J,J) + ONE
- 30 CONTINUE
- GO TO 500
-C
-C LINEAR FUNCTION - RANK 1.
-C
- 40 CONTINUE
- DO 60 J = 1, N
- DO 50 I = 1, M
- FJAC(I,J) = FLOAT(I)*FLOAT(J)
- 50 CONTINUE
- 60 CONTINUE
- GO TO 500
-C
-C LINEAR FUNCTION - RANK 1 WITH ZERO COLUMNS AND ROWS.
-C
- 70 CONTINUE
- DO 90 J = 1, N
- DO 80 I = 1, M
- FJAC(I,J) = ZERO
- 80 CONTINUE
- 90 CONTINUE
- NM1 = N - 1
- MM1 = M - 1
- IF (NM1 .LT. 2) GO TO 120
- DO 110 J = 2, NM1
- DO 100 I = 2, MM1
- FJAC(I,J) = FLOAT(I-1)*FLOAT(J)
- 100 CONTINUE
- 110 CONTINUE
- 120 CONTINUE
- GO TO 500
-C
-C ROSENBROCK FUNCTION.
-C
- 130 CONTINUE
- FJAC(1,1) = -C20*X(1)
- FJAC(1,2) = TEN
- FJAC(2,1) = -ONE
- FJAC(2,2) = ZERO
- GO TO 500
-C
-C HELICAL VALLEY FUNCTION.
-C
- 140 CONTINUE
- TPI = EIGHT*ATAN(ONE)
- TEMP = X(1)**2 + X(2)**2
- TMP1 = TPI*TEMP
- TMP2 = SQRT(TEMP)
- FJAC(1,1) = C100*X(2)/TMP1
- FJAC(1,2) = -C100*X(1)/TMP1
- FJAC(1,3) = TEN
- FJAC(2,1) = TEN*X(1)/TMP2
- FJAC(2,2) = TEN*X(2)/TMP2
- FJAC(2,3) = ZERO
- FJAC(3,1) = ZERO
- FJAC(3,2) = ZERO
- FJAC(3,3) = ONE
- GO TO 500
-C
-C POWELL SINGULAR FUNCTION.
-C
- 150 CONTINUE
- DO 170 J = 1, 4
- DO 160 I = 1, 4
- FJAC(I,J) = ZERO
- 160 CONTINUE
- 170 CONTINUE
- FJAC(1,1) = ONE
- FJAC(1,2) = TEN
- FJAC(2,3) = SQRT(FIVE)
- FJAC(2,4) = -FJAC(2,3)
- FJAC(3,2) = TWO*(X(2) - TWO*X(3))
- FJAC(3,3) = -TWO*FJAC(3,2)
- FJAC(4,1) = TWO*SQRT(TEN)*(X(1) - X(4))
- FJAC(4,4) = -FJAC(4,1)
- GO TO 500
-C
-C FREUDENSTEIN AND ROTH FUNCTION.
-C
- 180 CONTINUE
- FJAC(1,1) = ONE
- FJAC(1,2) = X(2)*(TEN - THREE*X(2)) - TWO
- FJAC(2,1) = ONE
- FJAC(2,2) = X(2)*(TWO + THREE*X(2)) - C14
- GO TO 500
-C
-C BARD FUNCTION.
-C
- 190 CONTINUE
- DO 200 I = 1, 15
- TMP1 = FLOAT(I)
- TMP2 = FLOAT(16-I)
- TMP3 = TMP1
- IF (I .GT. 8) TMP3 = TMP2
- TMP4 = (X(2)*TMP2 + X(3)*TMP3)**2
- FJAC(I,1) = -ONE
- FJAC(I,2) = TMP1*TMP2/TMP4
- FJAC(I,3) = TMP1*TMP3/TMP4
- 200 CONTINUE
- GO TO 500
-C
-C KOWALIK AND OSBORNE FUNCTION.
-C
- 210 CONTINUE
- DO 220 I = 1, 11
- TMP1 = V(I)*(V(I) + X(2))
- TMP2 = V(I)*(V(I) + X(3)) + X(4)
- FJAC(I,1) = -TMP1/TMP2
- FJAC(I,2) = -V(I)*X(1)/TMP2
- FJAC(I,3) = FJAC(I,1)*FJAC(I,2)
- FJAC(I,4) = FJAC(I,3)/V(I)
- 220 CONTINUE
- GO TO 500
-C
-C MEYER FUNCTION.
-C
- 230 CONTINUE
- DO 240 I = 1, 16
- TEMP = FIVE*FLOAT(I) + C45 + X(3)
- TMP1 = X(2)/TEMP
- TMP2 = EXP(TMP1)
- FJAC(I,1) = TMP2
- FJAC(I,2) = X(1)*TMP2/TEMP
- FJAC(I,3) = -TMP1*FJAC(I,2)
- 240 CONTINUE
- GO TO 500
-C
-C WATSON FUNCTION.
-C
- 250 CONTINUE
- DO 280 I = 1, 29
- DIV = FLOAT(I)/C29
- S2 = ZERO
- DX = ONE
- DO 260 J = 1, N
- S2 = S2 + DX*X(J)
- DX = DIV*DX
- 260 CONTINUE
- TEMP = TWO*DIV*S2
- DX = ONE/DIV
- DO 270 J = 1, N
- FJAC(I,J) = DX*(FLOAT(J-1) - TEMP)
- DX = DIV*DX
- 270 CONTINUE
- 280 CONTINUE
- DO 300 J = 1, N
- DO 290 I = 30, 31
- FJAC(I,J) = ZERO
- 290 CONTINUE
- 300 CONTINUE
- FJAC(30,1) = ONE
- FJAC(31,1) = -TWO*X(1)
- FJAC(31,2) = ONE
- GO TO 500
-C
-C BOX 3-DIMENSIONAL FUNCTION.
-C
- 310 CONTINUE
- DO 320 I = 1, M
- TEMP = FLOAT(I)
- TMP1 = TEMP/TEN
- FJAC(I,1) = -TMP1*EXP(-TMP1*X(1))
- FJAC(I,2) = TMP1*EXP(-TMP1*X(2))
- FJAC(I,3) = EXP(-TEMP) - EXP(-TMP1)
- 320 CONTINUE
- GO TO 500
-C
-C JENNRICH AND SAMPSON FUNCTION.
-C
- 330 CONTINUE
- DO 340 I = 1, M
- TEMP = FLOAT(I)
- FJAC(I,1) = -TEMP*EXP(TEMP*X(1))
- FJAC(I,2) = -TEMP*EXP(TEMP*X(2))
- 340 CONTINUE
- GO TO 500
-C
-C BROWN AND DENNIS FUNCTION.
-C
- 350 CONTINUE
- DO 360 I = 1, M
- TEMP = FLOAT(I)/FIVE
- TI = SIN(TEMP)
- TMP1 = X(1) + TEMP*X(2) - EXP(TEMP)
- TMP2 = X(3) + TI*X(4) - COS(TEMP)
- FJAC(I,1) = TWO*TMP1
- FJAC(I,2) = TEMP*FJAC(I,1)
- FJAC(I,3) = TWO*TMP2
- FJAC(I,4) = TI*FJAC(I,3)
- 360 CONTINUE
- GO TO 500
-C
-C CHEBYQUAD FUNCTION.
-C
- 370 CONTINUE
- DX = ONE/FLOAT(N)
- DO 390 J = 1, N
- TMP1 = ONE
- TMP2 = TWO*X(J) - ONE
- TEMP = TWO*TMP2
- TMP3 = ZERO
- TMP4 = TWO
- DO 380 I = 1, M
- FJAC(I,J) = DX*TMP4
- TI = FOUR*TMP2 + TEMP*TMP4 - TMP3
- TMP3 = TMP4
- TMP4 = TI
- TI = TEMP*TMP2 - TMP1
- TMP1 = TMP2
- TMP2 = TI
- 380 CONTINUE
- 390 CONTINUE
- GO TO 500
-C
-C BROWN ALMOST-LINEAR FUNCTION.
-C
- 400 CONTINUE
- PROD = ONE
- DO 420 J = 1, N
- PROD = X(J)*PROD
- DO 410 I = 1, N
- FJAC(I,J) = ONE
- 410 CONTINUE
- FJAC(J,J) = TWO
- 420 CONTINUE
- DO 450 J = 1, N
- TEMP = X(J)
- IF (TEMP .NE. ZERO) GO TO 440
- TEMP = ONE
- PROD = ONE
- DO 430 K = 1, N
- IF (K .NE. J) PROD = X(K)*PROD
- 430 CONTINUE
- 440 CONTINUE
- FJAC(N,J) = PROD/TEMP
- 450 CONTINUE
- GO TO 500
-C
-C OSBORNE 1 FUNCTION.
-C
- 460 CONTINUE
- DO 470 I = 1, 33
- TEMP = TEN*FLOAT(I-1)
- TMP1 = EXP(-X(4)*TEMP)
- TMP2 = EXP(-X(5)*TEMP)
- FJAC(I,1) = -ONE
- FJAC(I,2) = -TMP1
- FJAC(I,3) = -TMP2
- FJAC(I,4) = TEMP*X(2)*TMP1
- FJAC(I,5) = TEMP*X(3)*TMP2
- 470 CONTINUE
- GO TO 500
-C
-C OSBORNE 2 FUNCTION.
-C
- 480 CONTINUE
- DO 490 I = 1, 65
- TEMP = FLOAT(I-1)/TEN
- TMP1 = EXP(-X(5)*TEMP)
- TMP2 = EXP(-X(6)*(TEMP-X(9))**2)
- TMP3 = EXP(-X(7)*(TEMP-X(10))**2)
- TMP4 = EXP(-X(8)*(TEMP-X(11))**2)
- FJAC(I,1) = -TMP1
- FJAC(I,2) = -TMP2
- FJAC(I,3) = -TMP3
- FJAC(I,4) = -TMP4
- FJAC(I,5) = TEMP*X(1)*TMP1
- FJAC(I,6) = X(2)*(TEMP - X(9))**2*TMP2
- FJAC(I,7) = X(3)*(TEMP - X(10))**2*TMP3
- FJAC(I,8) = X(4)*(TEMP - X(11))**2*TMP4
- FJAC(I,9) = -TWO*X(2)*X(6)*(TEMP - X(9))*TMP2
- FJAC(I,10) = -TWO*X(3)*X(7)*(TEMP - X(10))*TMP3
- FJAC(I,11) = -TWO*X(4)*X(8)*(TEMP - X(11))*TMP4
- 490 CONTINUE
- 500 CONTINUE
- RETURN
-C
-C LAST CARD OF SUBROUTINE SSQJAC.
-C
- END
- SUBROUTINE INITPT(N,X,NPROB,FACTOR)
- INTEGER N,NPROB
- REAL FACTOR
- REAL X(N)
-C **********
-C
-C SUBROUTINE INITPT
-C
-C THIS SUBROUTINE SPECIFIES THE STANDARD STARTING POINTS FOR THE
-C FUNCTIONS DEFINED BY SUBROUTINE SSQFCN. THE SUBROUTINE RETURNS
-C IN X A MULTIPLE (FACTOR) OF THE STANDARD STARTING POINT. FOR
-C THE 11TH FUNCTION THE STANDARD STARTING POINT IS ZERO, SO IN
-C THIS CASE, IF FACTOR IS NOT UNITY, THEN THE SUBROUTINE RETURNS
-C THE VECTOR X(J) = FACTOR, J=1,...,N.
-C
-C THE SUBROUTINE STATEMENT IS
-C
-C SUBROUTINE INITPT(N,X,NPROB,FACTOR)
-C
-C WHERE
-C
-C N IS A POSITIVE INTEGER INPUT VARIABLE.
-C
-C X IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS THE STANDARD
-C STARTING POINT FOR PROBLEM NPROB MULTIPLIED BY FACTOR.
-C
-C NPROB IS A POSITIVE INTEGER INPUT VARIABLE WHICH DEFINES THE
-C NUMBER OF THE PROBLEM. NPROB MUST NOT EXCEED 18.
-C
-C FACTOR IS AN INPUT VARIABLE WHICH SPECIFIES THE MULTIPLE OF
-C THE STANDARD STARTING POINT. IF FACTOR IS UNITY, NO
-C MULTIPLICATION IS PERFORMED.
-C
-C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980.
-C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE
-C
-C **********
- INTEGER IVAR,J
- REAL C1,C2,C3,C4,C5,C6,C7,C8,C9,C10,C11,C12,C13,C14,C15,C16,C17,
- * FIVE,H,HALF,ONE,SEVEN,TEN,THREE,TWENTY,TWNTF,TWO,ZERO
- REAL FLOAT
- DATA ZERO,HALF,ONE,TWO,THREE,FIVE,SEVEN,TEN,TWENTY,TWNTF
- * /0.0E0,5.0E-1,1.0E0,2.0E0,3.0E0,5.0E0,7.0E0,1.0E1,2.0E1,
- * 2.5E1/
- DATA C1,C2,C3,C4,C5,C6,C7,C8,C9,C10,C11,C12,C13,C14,C15,C16,C17
- * /1.2E0,2.5E-1,3.9E-1,4.15E-1,2.0E-2,4.0E3,2.5E2,3.0E-1,
- * 4.0E-1,1.5E0,1.0E-2,1.3E0,6.5E-1,7.0E-1,6.0E-1,4.5E0,
- * 5.5E0/
- FLOAT(IVAR) = IVAR
-C
-C SELECTION OF INITIAL POINT.
-C
- GO TO (10,10,10,30,40,50,60,70,80,90,100,120,130,140,150,170,
- * 190,200), NPROB
-C
-C LINEAR FUNCTION - FULL RANK OR RANK 1.
-C
- 10 CONTINUE
- DO 20 J = 1, N
- X(J) = ONE
- 20 CONTINUE
- GO TO 210
-C
-C ROSENBROCK FUNCTION.
-C
- 30 CONTINUE
- X(1) = -C1
- X(2) = ONE
- GO TO 210
-C
-C HELICAL VALLEY FUNCTION.
-C
- 40 CONTINUE
- X(1) = -ONE
- X(2) = ZERO
- X(3) = ZERO
- GO TO 210
-C
-C POWELL SINGULAR FUNCTION.
-C
- 50 CONTINUE
- X(1) = THREE
- X(2) = -ONE
- X(3) = ZERO
- X(4) = ONE
- GO TO 210
-C
-C FREUDENSTEIN AND ROTH FUNCTION.
-C
- 60 CONTINUE
- X(1) = HALF
- X(2) = -TWO
- GO TO 210
-C
-C BARD FUNCTION.
-C
- 70 CONTINUE
- X(1) = ONE
- X(2) = ONE
- X(3) = ONE
- GO TO 210
-C
-C KOWALIK AND OSBORNE FUNCTION.
-C
- 80 CONTINUE
- X(1) = C2
- X(2) = C3
- X(3) = C4
- X(4) = C3
- GO TO 210
-C
-C MEYER FUNCTION.
-C
- 90 CONTINUE
- X(1) = C5
- X(2) = C6
- X(3) = C7
- GO TO 210
-C
-C WATSON FUNCTION.
-C
- 100 CONTINUE
- DO 110 J = 1, N
- X(J) = ZERO
- 110 CONTINUE
- GO TO 210
-C
-C BOX 3-DIMENSIONAL FUNCTION.
-C
- 120 CONTINUE
- X(1) = ZERO
- X(2) = TEN
- X(3) = TWENTY
- GO TO 210
-C
-C JENNRICH AND SAMPSON FUNCTION.
-C
- 130 CONTINUE
- X(1) = C8
- X(2) = C9
- GO TO 210
-C
-C BROWN AND DENNIS FUNCTION.
-C
- 140 CONTINUE
- X(1) = TWNTF
- X(2) = FIVE
- X(3) = -FIVE
- X(4) = -ONE
- GO TO 210
-C
-C CHEBYQUAD FUNCTION.
-C
- 150 CONTINUE
- H = ONE/FLOAT(N+1)
- DO 160 J = 1, N
- X(J) = FLOAT(J)*H
- 160 CONTINUE
- GO TO 210
-C
-C BROWN ALMOST-LINEAR FUNCTION.
-C
- 170 CONTINUE
- DO 180 J = 1, N
- X(J) = HALF
- 180 CONTINUE
- GO TO 210
-C
-C OSBORNE 1 FUNCTION.
-C
- 190 CONTINUE
- X(1) = HALF
- X(2) = C10
- X(3) = -ONE
- X(4) = C11
- X(5) = C5
- GO TO 210
-C
-C OSBORNE 2 FUNCTION.
-C
- 200 CONTINUE
- X(1) = C12
- X(2) = C13
- X(3) = C13
- X(4) = C14
- X(5) = C15
- X(6) = THREE
- X(7) = FIVE
- X(8) = SEVEN
- X(9) = TWO
- X(10) = C16
- X(11) = C17
- 210 CONTINUE
-C
-C COMPUTE MULTIPLE OF INITIAL POINT.
-C
- IF (FACTOR .EQ. ONE) GO TO 260
- IF (NPROB .EQ. 11) GO TO 230
- DO 220 J = 1, N
- X(J) = FACTOR*X(J)
- 220 CONTINUE
- GO TO 250
- 230 CONTINUE
- DO 240 J = 1, N
- X(J) = FACTOR
- 240 CONTINUE
- 250 CONTINUE
- 260 CONTINUE
- RETURN
-C
-C LAST CARD OF SUBROUTINE INITPT.
-C
- END
- SUBROUTINE SSQFCN(M,N,X,FVEC,NPROB)
- INTEGER M,N,NPROB
- REAL X(N),FVEC(M)
-C **********
-C
-C SUBROUTINE SSQFCN
-C
-C THIS SUBROUTINE DEFINES THE FUNCTIONS OF EIGHTEEN NONLINEAR
-C LEAST SQUARES PROBLEMS. THE ALLOWABLE VALUES OF (M,N) FOR
-C FUNCTIONS 1,2 AND 3 ARE VARIABLE BUT WITH M .GE. N.
-C FOR FUNCTIONS 4,5,6,7,8,9 AND 10 THE VALUES OF (M,N) ARE
-C (2,2),(3,3),(4,4),(2,2),(15,3),(11,4) AND (16,3), RESPECTIVELY.
-C FUNCTION 11 (WATSON) HAS M = 31 WITH N USUALLY 6 OR 9.
-C HOWEVER, ANY N, N = 2,...,31, IS PERMITTED.
-C FUNCTIONS 12,13 AND 14 HAVE N = 3,2 AND 4, RESPECTIVELY, BUT
-C ALLOW ANY M .GE. N, WITH THE USUAL CHOICES BEING 10,10 AND 20.
-C FUNCTION 15 (CHEBYQUAD) ALLOWS M AND N VARIABLE WITH M .GE. N.
-C FUNCTION 16 (BROWN) ALLOWS N VARIABLE WITH M = N.
-C FOR FUNCTIONS 17 AND 18, THE VALUES OF (M,N) ARE
-C (33,5) AND (65,11), RESPECTIVELY.
-C
-C THE SUBROUTINE STATEMENT IS
-C
-C SUBROUTINE SSQFCN(M,N,X,FVEC,NPROB)
-C
-C WHERE
-C
-C M AND N ARE POSITIVE INTEGER INPUT VARIABLES. N MUST NOT
-C EXCEED M.
-C
-C X IS AN INPUT ARRAY OF LENGTH N.
-C
-C FVEC IS AN OUTPUT ARRAY OF LENGTH M WHICH CONTAINS THE NPROB
-C FUNCTION EVALUATED AT X.
-C
-C NPROB IS A POSITIVE INTEGER INPUT VARIABLE WHICH DEFINES THE
-C NUMBER OF THE PROBLEM. NPROB MUST NOT EXCEED 18.
-C
-C SUBPROGRAMS CALLED
-C
-C FORTRAN-SUPPLIED ... ATAN,COS,EXP,SIN,SQRT,SIGN
-C
-C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980.
-C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE
-C
-C **********
- INTEGER I,IEV,IVAR,J,NM1
- REAL C13,C14,C29,C45,DIV,DX,EIGHT,FIVE,ONE,PROD,SUM,S1,S2,TEMP,
- * TEN,TI,TMP1,TMP2,TMP3,TMP4,TPI,TWO,ZERO,ZP25,ZP5
- REAL V(11),Y1(15),Y2(11),Y3(16),Y4(33),Y5(65)
- REAL FLOAT
- DATA ZERO,ZP25,ZP5,ONE,TWO,FIVE,EIGHT,TEN,C13,C14,C29,C45
- * /0.0E0,2.5E-1,5.0E-1,1.0E0,2.0E0,5.0E0,8.0E0,1.0E1,1.3E1,
- * 1.4E1,2.9E1,4.5E1/
- DATA V(1),V(2),V(3),V(4),V(5),V(6),V(7),V(8),V(9),V(10),V(11)
- * /4.0E0,2.0E0,1.0E0,5.0E-1,2.5E-1,1.67E-1,1.25E-1,1.0E-1,
- * 8.33E-2,7.14E-2,6.25E-2/
- DATA Y1(1),Y1(2),Y1(3),Y1(4),Y1(5),Y1(6),Y1(7),Y1(8),Y1(9),
- * Y1(10),Y1(11),Y1(12),Y1(13),Y1(14),Y1(15)
- * /1.4E-1,1.8E-1,2.2E-1,2.5E-1,2.9E-1,3.2E-1,3.5E-1,3.9E-1,
- * 3.7E-1,5.8E-1,7.3E-1,9.6E-1,1.34E0,2.1E0,4.39E0/
- DATA Y2(1),Y2(2),Y2(3),Y2(4),Y2(5),Y2(6),Y2(7),Y2(8),Y2(9),
- * Y2(10),Y2(11)
- * /1.957E-1,1.947E-1,1.735E-1,1.6E-1,8.44E-2,6.27E-2,4.56E-2,
- * 3.42E-2,3.23E-2,2.35E-2,2.46E-2/
- DATA Y3(1),Y3(2),Y3(3),Y3(4),Y3(5),Y3(6),Y3(7),Y3(8),Y3(9),
- * Y3(10),Y3(11),Y3(12),Y3(13),Y3(14),Y3(15),Y3(16)
- * /3.478E4,2.861E4,2.365E4,1.963E4,1.637E4,1.372E4,1.154E4,
- * 9.744E3,8.261E3,7.03E3,6.005E3,5.147E3,4.427E3,3.82E3,
- * 3.307E3,2.872E3/
- DATA Y4(1),Y4(2),Y4(3),Y4(4),Y4(5),Y4(6),Y4(7),Y4(8),Y4(9),
- * Y4(10),Y4(11),Y4(12),Y4(13),Y4(14),Y4(15),Y4(16),Y4(17),
- * Y4(18),Y4(19),Y4(20),Y4(21),Y4(22),Y4(23),Y4(24),Y4(25),
- * Y4(26),Y4(27),Y4(28),Y4(29),Y4(30),Y4(31),Y4(32),Y4(33)
- * /8.44E-1,9.08E-1,9.32E-1,9.36E-1,9.25E-1,9.08E-1,8.81E-1,
- * 8.5E-1,8.18E-1,7.84E-1,7.51E-1,7.18E-1,6.85E-1,6.58E-1,
- * 6.28E-1,6.03E-1,5.8E-1,5.58E-1,5.38E-1,5.22E-1,5.06E-1,
- * 4.9E-1,4.78E-1,4.67E-1,4.57E-1,4.48E-1,4.38E-1,4.31E-1,
- * 4.24E-1,4.2E-1,4.14E-1,4.11E-1,4.06E-1/
- DATA Y5(1),Y5(2),Y5(3),Y5(4),Y5(5),Y5(6),Y5(7),Y5(8),Y5(9),
- * Y5(10),Y5(11),Y5(12),Y5(13),Y5(14),Y5(15),Y5(16),Y5(17),
- * Y5(18),Y5(19),Y5(20),Y5(21),Y5(22),Y5(23),Y5(24),Y5(25),
- * Y5(26),Y5(27),Y5(28),Y5(29),Y5(30),Y5(31),Y5(32),Y5(33),
- * Y5(34),Y5(35),Y5(36),Y5(37),Y5(38),Y5(39),Y5(40),Y5(41),
- * Y5(42),Y5(43),Y5(44),Y5(45),Y5(46),Y5(47),Y5(48),Y5(49),
- * Y5(50),Y5(51),Y5(52),Y5(53),Y5(54),Y5(55),Y5(56),Y5(57),
- * Y5(58),Y5(59),Y5(60),Y5(61),Y5(62),Y5(63),Y5(64),Y5(65)
- * /1.366E0,1.191E0,1.112E0,1.013E0,9.91E-1,8.85E-1,8.31E-1,
- * 8.47E-1,7.86E-1,7.25E-1,7.46E-1,6.79E-1,6.08E-1,6.55E-1,
- * 6.16E-1,6.06E-1,6.02E-1,6.26E-1,6.51E-1,7.24E-1,6.49E-1,
- * 6.49E-1,6.94E-1,6.44E-1,6.24E-1,6.61E-1,6.12E-1,5.58E-1,
- * 5.33E-1,4.95E-1,5.0E-1,4.23E-1,3.95E-1,3.75E-1,3.72E-1,
- * 3.91E-1,3.96E-1,4.05E-1,4.28E-1,4.29E-1,5.23E-1,5.62E-1,
- * 6.07E-1,6.53E-1,6.72E-1,7.08E-1,6.33E-1,6.68E-1,6.45E-1,
- * 6.32E-1,5.91E-1,5.59E-1,5.97E-1,6.25E-1,7.39E-1,7.1E-1,
- * 7.29E-1,7.2E-1,6.36E-1,5.81E-1,4.28E-1,2.92E-1,1.62E-1,
- * 9.8E-2,5.4E-2/
- FLOAT(IVAR) = IVAR
-C
-C FUNCTION ROUTINE SELECTOR.
-C
- GO TO (10,40,70,110,120,130,140,150,170,190,210,250,270,290,310,
- * 360,390,410), NPROB
-C
-C LINEAR FUNCTION - FULL RANK.
-C
- 10 CONTINUE
- SUM = ZERO
- DO 20 J = 1, N
- SUM = SUM + X(J)
- 20 CONTINUE
- TEMP = TWO*SUM/FLOAT(M) + ONE
- DO 30 I = 1, M
- FVEC(I) = -TEMP
- IF (I .LE. N) FVEC(I) = FVEC(I) + X(I)
- 30 CONTINUE
- GO TO 430
-C
-C LINEAR FUNCTION - RANK 1.
-C
- 40 CONTINUE
- SUM = ZERO
- DO 50 J = 1, N
- SUM = SUM + FLOAT(J)*X(J)
- 50 CONTINUE
- DO 60 I = 1, M
- FVEC(I) = FLOAT(I)*SUM - ONE
- 60 CONTINUE
- GO TO 430
-C
-C LINEAR FUNCTION - RANK 1 WITH ZERO COLUMNS AND ROWS.
-C
- 70 CONTINUE
- SUM = ZERO
- NM1 = N - 1
- IF (NM1 .LT. 2) GO TO 90
- DO 80 J = 2, NM1
- SUM = SUM + FLOAT(J)*X(J)
- 80 CONTINUE
- 90 CONTINUE
- DO 100 I = 1, M
- FVEC(I) = FLOAT(I-1)*SUM - ONE
- 100 CONTINUE
- FVEC(M) = -ONE
- GO TO 430
-C
-C ROSENBROCK FUNCTION.
-C
- 110 CONTINUE
- FVEC(1) = TEN*(X(2) - X(1)**2)
- FVEC(2) = ONE - X(1)
- GO TO 430
-C
-C HELICAL VALLEY FUNCTION.
-C
- 120 CONTINUE
- TPI = EIGHT*ATAN(ONE)
- TMP1 = SIGN(ZP25,X(2))
- IF (X(1) .GT. ZERO) TMP1 = ATAN(X(2)/X(1))/TPI
- IF (X(1) .LT. ZERO) TMP1 = ATAN(X(2)/X(1))/TPI + ZP5
- TMP2 = SQRT(X(1)**2+X(2)**2)
- FVEC(1) = TEN*(X(3) - TEN*TMP1)
- FVEC(2) = TEN*(TMP2 - ONE)
- FVEC(3) = X(3)
- GO TO 430
-C
-C POWELL SINGULAR FUNCTION.
-C
- 130 CONTINUE
- FVEC(1) = X(1) + TEN*X(2)
- FVEC(2) = SQRT(FIVE)*(X(3) - X(4))
- FVEC(3) = (X(2) - TWO*X(3))**2
- FVEC(4) = SQRT(TEN)*(X(1) - X(4))**2
- GO TO 430
-C
-C FREUDENSTEIN AND ROTH FUNCTION.
-C
- 140 CONTINUE
- FVEC(1) = -C13 + X(1) + ((FIVE - X(2))*X(2) - TWO)*X(2)
- FVEC(2) = -C29 + X(1) + ((ONE + X(2))*X(2) - C14)*X(2)
- GO TO 430
-C
-C BARD FUNCTION.
-C
- 150 CONTINUE
- DO 160 I = 1, 15
- TMP1 = FLOAT(I)
- TMP2 = FLOAT(16-I)
- TMP3 = TMP1
- IF (I .GT. 8) TMP3 = TMP2
- FVEC(I) = Y1(I) - (X(1) + TMP1/(X(2)*TMP2 + X(3)*TMP3))
- 160 CONTINUE
- GO TO 430
-C
-C KOWALIK AND OSBORNE FUNCTION.
-C
- 170 CONTINUE
- DO 180 I = 1, 11
- TMP1 = V(I)*(V(I) + X(2))
- TMP2 = V(I)*(V(I) + X(3)) + X(4)
- FVEC(I) = Y2(I) - X(1)*TMP1/TMP2
- 180 CONTINUE
- GO TO 430
-C
-C MEYER FUNCTION.
-C
- 190 CONTINUE
- DO 200 I = 1, 16
- TEMP = FIVE*FLOAT(I) + C45 + X(3)
- TMP1 = X(2)/TEMP
- TMP2 = EXP(TMP1)
- FVEC(I) = X(1)*TMP2 - Y3(I)
- 200 CONTINUE
- GO TO 430
-C
-C WATSON FUNCTION.
-C
- 210 CONTINUE
- DO 240 I = 1, 29
- DIV = FLOAT(I)/C29
- S1 = ZERO
- DX = ONE
- DO 220 J = 2, N
- S1 = S1 + FLOAT(J-1)*DX*X(J)
- DX = DIV*DX
- 220 CONTINUE
- S2 = ZERO
- DX = ONE
- DO 230 J = 1, N
- S2 = S2 + DX*X(J)
- DX = DIV*DX
- 230 CONTINUE
- FVEC(I) = S1 - S2**2 - ONE
- 240 CONTINUE
- FVEC(30) = X(1)
- FVEC(31) = X(2) - X(1)**2 - ONE
- GO TO 430
-C
-C BOX 3-DIMENSIONAL FUNCTION.
-C
- 250 CONTINUE
- DO 260 I = 1, M
- TEMP = FLOAT(I)
- TMP1 = TEMP/TEN
- FVEC(I) = EXP(-TMP1*X(1)) - EXP(-TMP1*X(2))
- * + (EXP(-TEMP) - EXP(-TMP1))*X(3)
- 260 CONTINUE
- GO TO 430
-C
-C JENNRICH AND SAMPSON FUNCTION.
-C
- 270 CONTINUE
- DO 280 I = 1, M
- TEMP = FLOAT(I)
- FVEC(I) = TWO + TWO*TEMP - EXP(TEMP*X(1)) - EXP(TEMP*X(2))
- 280 CONTINUE
- GO TO 430
-C
-C BROWN AND DENNIS FUNCTION.
-C
- 290 CONTINUE
- DO 300 I = 1, M
- TEMP = FLOAT(I)/FIVE
- TMP1 = X(1) + TEMP*X(2) - EXP(TEMP)
- TMP2 = X(3) + SIN(TEMP)*X(4) - COS(TEMP)
- FVEC(I) = TMP1**2 + TMP2**2
- 300 CONTINUE
- GO TO 430
-C
-C CHEBYQUAD FUNCTION.
-C
- 310 CONTINUE
- DO 320 I = 1, M
- FVEC(I) = ZERO
- 320 CONTINUE
- DO 340 J = 1, N
- TMP1 = ONE
- TMP2 = TWO*X(J) - ONE
- TEMP = TWO*TMP2
- DO 330 I = 1, M
- FVEC(I) = FVEC(I) + TMP2
- TI = TEMP*TMP2 - TMP1
- TMP1 = TMP2
- TMP2 = TI
- 330 CONTINUE
- 340 CONTINUE
- DX = ONE/FLOAT(N)
- IEV = -1
- DO 350 I = 1, M
- FVEC(I) = DX*FVEC(I)
- IF (IEV .GT. 0) FVEC(I) = FVEC(I) + ONE/(FLOAT(I)**2 - ONE)
- IEV = -IEV
- 350 CONTINUE
- GO TO 430
-C
-C BROWN ALMOST-LINEAR FUNCTION.
-C
- 360 CONTINUE
- SUM = -FLOAT(N+1)
- PROD = ONE
- DO 370 J = 1, N
- SUM = SUM + X(J)
- PROD = X(J)*PROD
- 370 CONTINUE
- DO 380 I = 1, N
- FVEC(I) = X(I) + SUM
- 380 CONTINUE
- FVEC(N) = PROD - ONE
- GO TO 430
-C
-C OSBORNE 1 FUNCTION.
-C
- 390 CONTINUE
- DO 400 I = 1, 33
- TEMP = TEN*FLOAT(I-1)
- TMP1 = EXP(-X(4)*TEMP)
- TMP2 = EXP(-X(5)*TEMP)
- FVEC(I) = Y4(I) - (X(1) + X(2)*TMP1 + X(3)*TMP2)
- 400 CONTINUE
- GO TO 430
-C
-C OSBORNE 2 FUNCTION.
-C
- 410 CONTINUE
- DO 420 I = 1, 65
- TEMP = FLOAT(I-1)/TEN
- TMP1 = EXP(-X(5)*TEMP)
- TMP2 = EXP(-X(6)*(TEMP-X(9))**2)
- TMP3 = EXP(-X(7)*(TEMP-X(10))**2)
- TMP4 = EXP(-X(8)*(TEMP-X(11))**2)
- FVEC(I) = Y5(I)
- * - (X(1)*TMP1 + X(2)*TMP2 + X(3)*TMP3 + X(4)*TMP4)
- 420 CONTINUE
- 430 CONTINUE
- RETURN
-C
-C LAST CARD OF SUBROUTINE SSQFCN.
-C
- END
diff --git a/CEP/PyBDSM/src/minpack/ex/file12 b/CEP/PyBDSM/src/minpack/ex/file12
deleted file mode 100644
index d05198892b08ad845938d006dac8a5e5f87627e6..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/minpack/ex/file12
+++ /dev/null
@@ -1,673 +0,0 @@
-C **********
-C
-C THIS PROGRAM TESTS CODES FOR THE LEAST-SQUARES SOLUTION OF
-C M NONLINEAR EQUATIONS IN N VARIABLES. IT CONSISTS OF A DRIVER
-C AND AN INTERFACE SUBROUTINE FCN. THE DRIVER READS IN DATA,
-C CALLS THE NONLINEAR LEAST-SQUARES SOLVER, AND FINALLY PRINTS
-C OUT INFORMATION ON THE PERFORMANCE OF THE SOLVER. THIS IS
-C ONLY A SAMPLE DRIVER, MANY OTHER DRIVERS ARE POSSIBLE. THE
-C INTERFACE SUBROUTINE FCN IS NECESSARY TO TAKE INTO ACCOUNT THE
-C FORMS OF CALLING SEQUENCES USED BY THE FUNCTION AND JACOBIAN
-C SUBROUTINES IN THE VARIOUS NONLINEAR LEAST-SQUARES SOLVERS.
-C
-C SUBPROGRAMS CALLED
-C
-C USER-SUPPLIED ...... FCN
-C
-C MINPACK-SUPPLIED ... SPMPAR,ENORM,INITPT,LMDIF1,SSQFCN
-C
-C FORTRAN-SUPPLIED ... SQRT
-C
-C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980.
-C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE
-C
-C **********
- INTEGER I,IC,INFO,K,LWA,M,N,NFEV,NJEV,NPROB,NREAD,NTRIES,NWRITE
- INTEGER IWA(40),MA(60),NA(60),NF(60),NJ(60),NP(60),NX(60)
- REAL FACTOR,FNORM1,FNORM2,ONE,TEN,TOL
- REAL FNM(60),FVEC(65),WA(2865),X(40)
- REAL SPMPAR,ENORM
- EXTERNAL FCN
- COMMON /REFNUM/ NPROB,NFEV,NJEV
-C
-C LOGICAL INPUT UNIT IS ASSUMED TO BE NUMBER 5.
-C LOGICAL OUTPUT UNIT IS ASSUMED TO BE NUMBER 6.
-C
- DATA NREAD,NWRITE /5,6/
-C
- DATA ONE,TEN /1.0E0,1.0E1/
- TOL = SQRT(SPMPAR(1))
- LWA = 2865
- IC = 0
- 10 CONTINUE
- READ (NREAD,50) NPROB,N,M,NTRIES
- IF (NPROB .LE. 0) GO TO 30
- FACTOR = ONE
- DO 20 K = 1, NTRIES
- IC = IC + 1
- CALL INITPT(N,X,NPROB,FACTOR)
- CALL SSQFCN(M,N,X,FVEC,NPROB)
- FNORM1 = ENORM(M,FVEC)
- WRITE (NWRITE,60) NPROB,N,M
- NFEV = 0
- NJEV = 0
- CALL LMDIF1(FCN,M,N,X,FVEC,TOL,INFO,IWA,WA,LWA)
- CALL SSQFCN(M,N,X,FVEC,NPROB)
- FNORM2 = ENORM(M,FVEC)
- NP(IC) = NPROB
- NA(IC) = N
- MA(IC) = M
- NF(IC) = NFEV
- NJEV = NJEV/N
- NJ(IC) = NJEV
- NX(IC) = INFO
- FNM(IC) = FNORM2
- WRITE (NWRITE,70)
- * FNORM1,FNORM2,NFEV,NJEV,INFO,(X(I), I = 1, N)
- FACTOR = TEN*FACTOR
- 20 CONTINUE
- GO TO 10
- 30 CONTINUE
- WRITE (NWRITE,80) IC
- WRITE (NWRITE,90)
- DO 40 I = 1, IC
- WRITE (NWRITE,100) NP(I),NA(I),MA(I),NF(I),NJ(I),NX(I),FNM(I)
- 40 CONTINUE
- STOP
- 50 FORMAT (4I5)
- 60 FORMAT ( //// 5X, 8H PROBLEM, I5, 5X, 11H DIMENSIONS, 2I5, 5X //
- * )
- 70 FORMAT (5X, 33H INITIAL L2 NORM OF THE RESIDUALS, E15.7 // 5X,
- * 33H FINAL L2 NORM OF THE RESIDUALS , E15.7 // 5X,
- * 33H NUMBER OF FUNCTION EVALUATIONS , I10 // 5X,
- * 33H NUMBER OF JACOBIAN EVALUATIONS , I10 // 5X,
- * 15H EXIT PARAMETER, 18X, I10 // 5X,
- * 27H FINAL APPROXIMATE SOLUTION // (5X, 5E15.7))
- 80 FORMAT (12H1SUMMARY OF , I3, 16H CALLS TO LMDIF1 /)
- 90 FORMAT (49H NPROB N M NFEV NJEV INFO FINAL L2 NORM /)
- 100 FORMAT (3I5, 3I6, 2X, E15.7)
-C
-C LAST CARD OF DRIVER.
-C
- END
- SUBROUTINE FCN(M,N,X,FVEC,IFLAG)
- INTEGER M,N,IFLAG
- REAL X(N),FVEC(M)
-C **********
-C
-C THE CALLING SEQUENCE OF FCN SHOULD BE IDENTICAL TO THE
-C CALLING SEQUENCE OF THE FUNCTION SUBROUTINE IN THE NONLINEAR
-C LEAST-SQUARES SOLVER. FCN SHOULD ONLY CALL THE TESTING
-C FUNCTION SUBROUTINE SSQFCN WITH THE APPROPRIATE VALUE OF
-C PROBLEM NUMBER (NPROB).
-C
-C SUBPROGRAMS CALLED
-C
-C MINPACK-SUPPLIED ... SSQFCN
-C
-C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980.
-C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE
-C
-C **********
- INTEGER NPROB,NFEV,NJEV
- COMMON /REFNUM/ NPROB,NFEV,NJEV
- CALL SSQFCN(M,N,X,FVEC,NPROB)
- IF (IFLAG .EQ. 1) NFEV = NFEV + 1
- IF (IFLAG .EQ. 2) NJEV = NJEV + 1
- RETURN
-C
-C LAST CARD OF INTERFACE SUBROUTINE FCN.
-C
- END
- SUBROUTINE SSQFCN(M,N,X,FVEC,NPROB)
- INTEGER M,N,NPROB
- REAL X(N),FVEC(M)
-C **********
-C
-C SUBROUTINE SSQFCN
-C
-C THIS SUBROUTINE DEFINES THE FUNCTIONS OF EIGHTEEN NONLINEAR
-C LEAST SQUARES PROBLEMS. THE ALLOWABLE VALUES OF (M,N) FOR
-C FUNCTIONS 1,2 AND 3 ARE VARIABLE BUT WITH M .GE. N.
-C FOR FUNCTIONS 4,5,6,7,8,9 AND 10 THE VALUES OF (M,N) ARE
-C (2,2),(3,3),(4,4),(2,2),(15,3),(11,4) AND (16,3), RESPECTIVELY.
-C FUNCTION 11 (WATSON) HAS M = 31 WITH N USUALLY 6 OR 9.
-C HOWEVER, ANY N, N = 2,...,31, IS PERMITTED.
-C FUNCTIONS 12,13 AND 14 HAVE N = 3,2 AND 4, RESPECTIVELY, BUT
-C ALLOW ANY M .GE. N, WITH THE USUAL CHOICES BEING 10,10 AND 20.
-C FUNCTION 15 (CHEBYQUAD) ALLOWS M AND N VARIABLE WITH M .GE. N.
-C FUNCTION 16 (BROWN) ALLOWS N VARIABLE WITH M = N.
-C FOR FUNCTIONS 17 AND 18, THE VALUES OF (M,N) ARE
-C (33,5) AND (65,11), RESPECTIVELY.
-C
-C THE SUBROUTINE STATEMENT IS
-C
-C SUBROUTINE SSQFCN(M,N,X,FVEC,NPROB)
-C
-C WHERE
-C
-C M AND N ARE POSITIVE INTEGER INPUT VARIABLES. N MUST NOT
-C EXCEED M.
-C
-C X IS AN INPUT ARRAY OF LENGTH N.
-C
-C FVEC IS AN OUTPUT ARRAY OF LENGTH M WHICH CONTAINS THE NPROB
-C FUNCTION EVALUATED AT X.
-C
-C NPROB IS A POSITIVE INTEGER INPUT VARIABLE WHICH DEFINES THE
-C NUMBER OF THE PROBLEM. NPROB MUST NOT EXCEED 18.
-C
-C SUBPROGRAMS CALLED
-C
-C FORTRAN-SUPPLIED ... ATAN,COS,EXP,SIN,SQRT,SIGN
-C
-C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980.
-C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE
-C
-C **********
- INTEGER I,IEV,IVAR,J,NM1
- REAL C13,C14,C29,C45,DIV,DX,EIGHT,FIVE,ONE,PROD,SUM,S1,S2,TEMP,
- * TEN,TI,TMP1,TMP2,TMP3,TMP4,TPI,TWO,ZERO,ZP25,ZP5
- REAL V(11),Y1(15),Y2(11),Y3(16),Y4(33),Y5(65)
- REAL FLOAT
- DATA ZERO,ZP25,ZP5,ONE,TWO,FIVE,EIGHT,TEN,C13,C14,C29,C45
- * /0.0E0,2.5E-1,5.0E-1,1.0E0,2.0E0,5.0E0,8.0E0,1.0E1,1.3E1,
- * 1.4E1,2.9E1,4.5E1/
- DATA V(1),V(2),V(3),V(4),V(5),V(6),V(7),V(8),V(9),V(10),V(11)
- * /4.0E0,2.0E0,1.0E0,5.0E-1,2.5E-1,1.67E-1,1.25E-1,1.0E-1,
- * 8.33E-2,7.14E-2,6.25E-2/
- DATA Y1(1),Y1(2),Y1(3),Y1(4),Y1(5),Y1(6),Y1(7),Y1(8),Y1(9),
- * Y1(10),Y1(11),Y1(12),Y1(13),Y1(14),Y1(15)
- * /1.4E-1,1.8E-1,2.2E-1,2.5E-1,2.9E-1,3.2E-1,3.5E-1,3.9E-1,
- * 3.7E-1,5.8E-1,7.3E-1,9.6E-1,1.34E0,2.1E0,4.39E0/
- DATA Y2(1),Y2(2),Y2(3),Y2(4),Y2(5),Y2(6),Y2(7),Y2(8),Y2(9),
- * Y2(10),Y2(11)
- * /1.957E-1,1.947E-1,1.735E-1,1.6E-1,8.44E-2,6.27E-2,4.56E-2,
- * 3.42E-2,3.23E-2,2.35E-2,2.46E-2/
- DATA Y3(1),Y3(2),Y3(3),Y3(4),Y3(5),Y3(6),Y3(7),Y3(8),Y3(9),
- * Y3(10),Y3(11),Y3(12),Y3(13),Y3(14),Y3(15),Y3(16)
- * /3.478E4,2.861E4,2.365E4,1.963E4,1.637E4,1.372E4,1.154E4,
- * 9.744E3,8.261E3,7.03E3,6.005E3,5.147E3,4.427E3,3.82E3,
- * 3.307E3,2.872E3/
- DATA Y4(1),Y4(2),Y4(3),Y4(4),Y4(5),Y4(6),Y4(7),Y4(8),Y4(9),
- * Y4(10),Y4(11),Y4(12),Y4(13),Y4(14),Y4(15),Y4(16),Y4(17),
- * Y4(18),Y4(19),Y4(20),Y4(21),Y4(22),Y4(23),Y4(24),Y4(25),
- * Y4(26),Y4(27),Y4(28),Y4(29),Y4(30),Y4(31),Y4(32),Y4(33)
- * /8.44E-1,9.08E-1,9.32E-1,9.36E-1,9.25E-1,9.08E-1,8.81E-1,
- * 8.5E-1,8.18E-1,7.84E-1,7.51E-1,7.18E-1,6.85E-1,6.58E-1,
- * 6.28E-1,6.03E-1,5.8E-1,5.58E-1,5.38E-1,5.22E-1,5.06E-1,
- * 4.9E-1,4.78E-1,4.67E-1,4.57E-1,4.48E-1,4.38E-1,4.31E-1,
- * 4.24E-1,4.2E-1,4.14E-1,4.11E-1,4.06E-1/
- DATA Y5(1),Y5(2),Y5(3),Y5(4),Y5(5),Y5(6),Y5(7),Y5(8),Y5(9),
- * Y5(10),Y5(11),Y5(12),Y5(13),Y5(14),Y5(15),Y5(16),Y5(17),
- * Y5(18),Y5(19),Y5(20),Y5(21),Y5(22),Y5(23),Y5(24),Y5(25),
- * Y5(26),Y5(27),Y5(28),Y5(29),Y5(30),Y5(31),Y5(32),Y5(33),
- * Y5(34),Y5(35),Y5(36),Y5(37),Y5(38),Y5(39),Y5(40),Y5(41),
- * Y5(42),Y5(43),Y5(44),Y5(45),Y5(46),Y5(47),Y5(48),Y5(49),
- * Y5(50),Y5(51),Y5(52),Y5(53),Y5(54),Y5(55),Y5(56),Y5(57),
- * Y5(58),Y5(59),Y5(60),Y5(61),Y5(62),Y5(63),Y5(64),Y5(65)
- * /1.366E0,1.191E0,1.112E0,1.013E0,9.91E-1,8.85E-1,8.31E-1,
- * 8.47E-1,7.86E-1,7.25E-1,7.46E-1,6.79E-1,6.08E-1,6.55E-1,
- * 6.16E-1,6.06E-1,6.02E-1,6.26E-1,6.51E-1,7.24E-1,6.49E-1,
- * 6.49E-1,6.94E-1,6.44E-1,6.24E-1,6.61E-1,6.12E-1,5.58E-1,
- * 5.33E-1,4.95E-1,5.0E-1,4.23E-1,3.95E-1,3.75E-1,3.72E-1,
- * 3.91E-1,3.96E-1,4.05E-1,4.28E-1,4.29E-1,5.23E-1,5.62E-1,
- * 6.07E-1,6.53E-1,6.72E-1,7.08E-1,6.33E-1,6.68E-1,6.45E-1,
- * 6.32E-1,5.91E-1,5.59E-1,5.97E-1,6.25E-1,7.39E-1,7.1E-1,
- * 7.29E-1,7.2E-1,6.36E-1,5.81E-1,4.28E-1,2.92E-1,1.62E-1,
- * 9.8E-2,5.4E-2/
- FLOAT(IVAR) = IVAR
-C
-C FUNCTION ROUTINE SELECTOR.
-C
- GO TO (10,40,70,110,120,130,140,150,170,190,210,250,270,290,310,
- * 360,390,410), NPROB
-C
-C LINEAR FUNCTION - FULL RANK.
-C
- 10 CONTINUE
- SUM = ZERO
- DO 20 J = 1, N
- SUM = SUM + X(J)
- 20 CONTINUE
- TEMP = TWO*SUM/FLOAT(M) + ONE
- DO 30 I = 1, M
- FVEC(I) = -TEMP
- IF (I .LE. N) FVEC(I) = FVEC(I) + X(I)
- 30 CONTINUE
- GO TO 430
-C
-C LINEAR FUNCTION - RANK 1.
-C
- 40 CONTINUE
- SUM = ZERO
- DO 50 J = 1, N
- SUM = SUM + FLOAT(J)*X(J)
- 50 CONTINUE
- DO 60 I = 1, M
- FVEC(I) = FLOAT(I)*SUM - ONE
- 60 CONTINUE
- GO TO 430
-C
-C LINEAR FUNCTION - RANK 1 WITH ZERO COLUMNS AND ROWS.
-C
- 70 CONTINUE
- SUM = ZERO
- NM1 = N - 1
- IF (NM1 .LT. 2) GO TO 90
- DO 80 J = 2, NM1
- SUM = SUM + FLOAT(J)*X(J)
- 80 CONTINUE
- 90 CONTINUE
- DO 100 I = 1, M
- FVEC(I) = FLOAT(I-1)*SUM - ONE
- 100 CONTINUE
- FVEC(M) = -ONE
- GO TO 430
-C
-C ROSENBROCK FUNCTION.
-C
- 110 CONTINUE
- FVEC(1) = TEN*(X(2) - X(1)**2)
- FVEC(2) = ONE - X(1)
- GO TO 430
-C
-C HELICAL VALLEY FUNCTION.
-C
- 120 CONTINUE
- TPI = EIGHT*ATAN(ONE)
- TMP1 = SIGN(ZP25,X(2))
- IF (X(1) .GT. ZERO) TMP1 = ATAN(X(2)/X(1))/TPI
- IF (X(1) .LT. ZERO) TMP1 = ATAN(X(2)/X(1))/TPI + ZP5
- TMP2 = SQRT(X(1)**2+X(2)**2)
- FVEC(1) = TEN*(X(3) - TEN*TMP1)
- FVEC(2) = TEN*(TMP2 - ONE)
- FVEC(3) = X(3)
- GO TO 430
-C
-C POWELL SINGULAR FUNCTION.
-C
- 130 CONTINUE
- FVEC(1) = X(1) + TEN*X(2)
- FVEC(2) = SQRT(FIVE)*(X(3) - X(4))
- FVEC(3) = (X(2) - TWO*X(3))**2
- FVEC(4) = SQRT(TEN)*(X(1) - X(4))**2
- GO TO 430
-C
-C FREUDENSTEIN AND ROTH FUNCTION.
-C
- 140 CONTINUE
- FVEC(1) = -C13 + X(1) + ((FIVE - X(2))*X(2) - TWO)*X(2)
- FVEC(2) = -C29 + X(1) + ((ONE + X(2))*X(2) - C14)*X(2)
- GO TO 430
-C
-C BARD FUNCTION.
-C
- 150 CONTINUE
- DO 160 I = 1, 15
- TMP1 = FLOAT(I)
- TMP2 = FLOAT(16-I)
- TMP3 = TMP1
- IF (I .GT. 8) TMP3 = TMP2
- FVEC(I) = Y1(I) - (X(1) + TMP1/(X(2)*TMP2 + X(3)*TMP3))
- 160 CONTINUE
- GO TO 430
-C
-C KOWALIK AND OSBORNE FUNCTION.
-C
- 170 CONTINUE
- DO 180 I = 1, 11
- TMP1 = V(I)*(V(I) + X(2))
- TMP2 = V(I)*(V(I) + X(3)) + X(4)
- FVEC(I) = Y2(I) - X(1)*TMP1/TMP2
- 180 CONTINUE
- GO TO 430
-C
-C MEYER FUNCTION.
-C
- 190 CONTINUE
- DO 200 I = 1, 16
- TEMP = FIVE*FLOAT(I) + C45 + X(3)
- TMP1 = X(2)/TEMP
- TMP2 = EXP(TMP1)
- FVEC(I) = X(1)*TMP2 - Y3(I)
- 200 CONTINUE
- GO TO 430
-C
-C WATSON FUNCTION.
-C
- 210 CONTINUE
- DO 240 I = 1, 29
- DIV = FLOAT(I)/C29
- S1 = ZERO
- DX = ONE
- DO 220 J = 2, N
- S1 = S1 + FLOAT(J-1)*DX*X(J)
- DX = DIV*DX
- 220 CONTINUE
- S2 = ZERO
- DX = ONE
- DO 230 J = 1, N
- S2 = S2 + DX*X(J)
- DX = DIV*DX
- 230 CONTINUE
- FVEC(I) = S1 - S2**2 - ONE
- 240 CONTINUE
- FVEC(30) = X(1)
- FVEC(31) = X(2) - X(1)**2 - ONE
- GO TO 430
-C
-C BOX 3-DIMENSIONAL FUNCTION.
-C
- 250 CONTINUE
- DO 260 I = 1, M
- TEMP = FLOAT(I)
- TMP1 = TEMP/TEN
- FVEC(I) = EXP(-TMP1*X(1)) - EXP(-TMP1*X(2))
- * + (EXP(-TEMP) - EXP(-TMP1))*X(3)
- 260 CONTINUE
- GO TO 430
-C
-C JENNRICH AND SAMPSON FUNCTION.
-C
- 270 CONTINUE
- DO 280 I = 1, M
- TEMP = FLOAT(I)
- FVEC(I) = TWO + TWO*TEMP - EXP(TEMP*X(1)) - EXP(TEMP*X(2))
- 280 CONTINUE
- GO TO 430
-C
-C BROWN AND DENNIS FUNCTION.
-C
- 290 CONTINUE
- DO 300 I = 1, M
- TEMP = FLOAT(I)/FIVE
- TMP1 = X(1) + TEMP*X(2) - EXP(TEMP)
- TMP2 = X(3) + SIN(TEMP)*X(4) - COS(TEMP)
- FVEC(I) = TMP1**2 + TMP2**2
- 300 CONTINUE
- GO TO 430
-C
-C CHEBYQUAD FUNCTION.
-C
- 310 CONTINUE
- DO 320 I = 1, M
- FVEC(I) = ZERO
- 320 CONTINUE
- DO 340 J = 1, N
- TMP1 = ONE
- TMP2 = TWO*X(J) - ONE
- TEMP = TWO*TMP2
- DO 330 I = 1, M
- FVEC(I) = FVEC(I) + TMP2
- TI = TEMP*TMP2 - TMP1
- TMP1 = TMP2
- TMP2 = TI
- 330 CONTINUE
- 340 CONTINUE
- DX = ONE/FLOAT(N)
- IEV = -1
- DO 350 I = 1, M
- FVEC(I) = DX*FVEC(I)
- IF (IEV .GT. 0) FVEC(I) = FVEC(I) + ONE/(FLOAT(I)**2 - ONE)
- IEV = -IEV
- 350 CONTINUE
- GO TO 430
-C
-C BROWN ALMOST-LINEAR FUNCTION.
-C
- 360 CONTINUE
- SUM = -FLOAT(N+1)
- PROD = ONE
- DO 370 J = 1, N
- SUM = SUM + X(J)
- PROD = X(J)*PROD
- 370 CONTINUE
- DO 380 I = 1, N
- FVEC(I) = X(I) + SUM
- 380 CONTINUE
- FVEC(N) = PROD - ONE
- GO TO 430
-C
-C OSBORNE 1 FUNCTION.
-C
- 390 CONTINUE
- DO 400 I = 1, 33
- TEMP = TEN*FLOAT(I-1)
- TMP1 = EXP(-X(4)*TEMP)
- TMP2 = EXP(-X(5)*TEMP)
- FVEC(I) = Y4(I) - (X(1) + X(2)*TMP1 + X(3)*TMP2)
- 400 CONTINUE
- GO TO 430
-C
-C OSBORNE 2 FUNCTION.
-C
- 410 CONTINUE
- DO 420 I = 1, 65
- TEMP = FLOAT(I-1)/TEN
- TMP1 = EXP(-X(5)*TEMP)
- TMP2 = EXP(-X(6)*(TEMP-X(9))**2)
- TMP3 = EXP(-X(7)*(TEMP-X(10))**2)
- TMP4 = EXP(-X(8)*(TEMP-X(11))**2)
- FVEC(I) = Y5(I)
- * - (X(1)*TMP1 + X(2)*TMP2 + X(3)*TMP3 + X(4)*TMP4)
- 420 CONTINUE
- 430 CONTINUE
- RETURN
-C
-C LAST CARD OF SUBROUTINE SSQFCN.
-C
- END
- SUBROUTINE INITPT(N,X,NPROB,FACTOR)
- INTEGER N,NPROB
- REAL FACTOR
- REAL X(N)
-C **********
-C
-C SUBROUTINE INITPT
-C
-C THIS SUBROUTINE SPECIFIES THE STANDARD STARTING POINTS FOR THE
-C FUNCTIONS DEFINED BY SUBROUTINE SSQFCN. THE SUBROUTINE RETURNS
-C IN X A MULTIPLE (FACTOR) OF THE STANDARD STARTING POINT. FOR
-C THE 11TH FUNCTION THE STANDARD STARTING POINT IS ZERO, SO IN
-C THIS CASE, IF FACTOR IS NOT UNITY, THEN THE SUBROUTINE RETURNS
-C THE VECTOR X(J) = FACTOR, J=1,...,N.
-C
-C THE SUBROUTINE STATEMENT IS
-C
-C SUBROUTINE INITPT(N,X,NPROB,FACTOR)
-C
-C WHERE
-C
-C N IS A POSITIVE INTEGER INPUT VARIABLE.
-C
-C X IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS THE STANDARD
-C STARTING POINT FOR PROBLEM NPROB MULTIPLIED BY FACTOR.
-C
-C NPROB IS A POSITIVE INTEGER INPUT VARIABLE WHICH DEFINES THE
-C NUMBER OF THE PROBLEM. NPROB MUST NOT EXCEED 18.
-C
-C FACTOR IS AN INPUT VARIABLE WHICH SPECIFIES THE MULTIPLE OF
-C THE STANDARD STARTING POINT. IF FACTOR IS UNITY, NO
-C MULTIPLICATION IS PERFORMED.
-C
-C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980.
-C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE
-C
-C **********
- INTEGER IVAR,J
- REAL C1,C2,C3,C4,C5,C6,C7,C8,C9,C10,C11,C12,C13,C14,C15,C16,C17,
- * FIVE,H,HALF,ONE,SEVEN,TEN,THREE,TWENTY,TWNTF,TWO,ZERO
- REAL FLOAT
- DATA ZERO,HALF,ONE,TWO,THREE,FIVE,SEVEN,TEN,TWENTY,TWNTF
- * /0.0E0,5.0E-1,1.0E0,2.0E0,3.0E0,5.0E0,7.0E0,1.0E1,2.0E1,
- * 2.5E1/
- DATA C1,C2,C3,C4,C5,C6,C7,C8,C9,C10,C11,C12,C13,C14,C15,C16,C17
- * /1.2E0,2.5E-1,3.9E-1,4.15E-1,2.0E-2,4.0E3,2.5E2,3.0E-1,
- * 4.0E-1,1.5E0,1.0E-2,1.3E0,6.5E-1,7.0E-1,6.0E-1,4.5E0,
- * 5.5E0/
- FLOAT(IVAR) = IVAR
-C
-C SELECTION OF INITIAL POINT.
-C
- GO TO (10,10,10,30,40,50,60,70,80,90,100,120,130,140,150,170,
- * 190,200), NPROB
-C
-C LINEAR FUNCTION - FULL RANK OR RANK 1.
-C
- 10 CONTINUE
- DO 20 J = 1, N
- X(J) = ONE
- 20 CONTINUE
- GO TO 210
-C
-C ROSENBROCK FUNCTION.
-C
- 30 CONTINUE
- X(1) = -C1
- X(2) = ONE
- GO TO 210
-C
-C HELICAL VALLEY FUNCTION.
-C
- 40 CONTINUE
- X(1) = -ONE
- X(2) = ZERO
- X(3) = ZERO
- GO TO 210
-C
-C POWELL SINGULAR FUNCTION.
-C
- 50 CONTINUE
- X(1) = THREE
- X(2) = -ONE
- X(3) = ZERO
- X(4) = ONE
- GO TO 210
-C
-C FREUDENSTEIN AND ROTH FUNCTION.
-C
- 60 CONTINUE
- X(1) = HALF
- X(2) = -TWO
- GO TO 210
-C
-C BARD FUNCTION.
-C
- 70 CONTINUE
- X(1) = ONE
- X(2) = ONE
- X(3) = ONE
- GO TO 210
-C
-C KOWALIK AND OSBORNE FUNCTION.
-C
- 80 CONTINUE
- X(1) = C2
- X(2) = C3
- X(3) = C4
- X(4) = C3
- GO TO 210
-C
-C MEYER FUNCTION.
-C
- 90 CONTINUE
- X(1) = C5
- X(2) = C6
- X(3) = C7
- GO TO 210
-C
-C WATSON FUNCTION.
-C
- 100 CONTINUE
- DO 110 J = 1, N
- X(J) = ZERO
- 110 CONTINUE
- GO TO 210
-C
-C BOX 3-DIMENSIONAL FUNCTION.
-C
- 120 CONTINUE
- X(1) = ZERO
- X(2) = TEN
- X(3) = TWENTY
- GO TO 210
-C
-C JENNRICH AND SAMPSON FUNCTION.
-C
- 130 CONTINUE
- X(1) = C8
- X(2) = C9
- GO TO 210
-C
-C BROWN AND DENNIS FUNCTION.
-C
- 140 CONTINUE
- X(1) = TWNTF
- X(2) = FIVE
- X(3) = -FIVE
- X(4) = -ONE
- GO TO 210
-C
-C CHEBYQUAD FUNCTION.
-C
- 150 CONTINUE
- H = ONE/FLOAT(N+1)
- DO 160 J = 1, N
- X(J) = FLOAT(J)*H
- 160 CONTINUE
- GO TO 210
-C
-C BROWN ALMOST-LINEAR FUNCTION.
-C
- 170 CONTINUE
- DO 180 J = 1, N
- X(J) = HALF
- 180 CONTINUE
- GO TO 210
-C
-C OSBORNE 1 FUNCTION.
-C
- 190 CONTINUE
- X(1) = HALF
- X(2) = C10
- X(3) = -ONE
- X(4) = C11
- X(5) = C5
- GO TO 210
-C
-C OSBORNE 2 FUNCTION.
-C
- 200 CONTINUE
- X(1) = C12
- X(2) = C13
- X(3) = C13
- X(4) = C14
- X(5) = C15
- X(6) = THREE
- X(7) = FIVE
- X(8) = SEVEN
- X(9) = TWO
- X(10) = C16
- X(11) = C17
- 210 CONTINUE
-C
-C COMPUTE MULTIPLE OF INITIAL POINT.
-C
- IF (FACTOR .EQ. ONE) GO TO 260
- IF (NPROB .EQ. 11) GO TO 230
- DO 220 J = 1, N
- X(J) = FACTOR*X(J)
- 220 CONTINUE
- GO TO 250
- 230 CONTINUE
- DO 240 J = 1, N
- X(J) = FACTOR
- 240 CONTINUE
- 250 CONTINUE
- 260 CONTINUE
- RETURN
-C
-C LAST CARD OF SUBROUTINE INITPT.
-C
- END
diff --git a/CEP/PyBDSM/src/minpack/ex/file13 b/CEP/PyBDSM/src/minpack/ex/file13
deleted file mode 100644
index d299bb3be5c82165f4a7570c2ee56bba60e773db..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/minpack/ex/file13
+++ /dev/null
@@ -1,858 +0,0 @@
-C **********
-C
-C THIS PROGRAM TESTS THE ABILITY OF CHKDER TO DETECT
-C INCONSISTENCIES BETWEEN FUNCTIONS AND THEIR FIRST DERIVATIVES.
-C FOURTEEN TEST FUNCTION VECTORS AND JACOBIANS ARE USED. ELEVEN OF
-C THE TESTS ARE FALSE(F), I.E. THERE ARE INCONSISTENCIES BETWEEN
-C THE FUNCTION VECTORS AND THE CORRESPONDING JACOBIANS. THREE OF
-C THE TESTS ARE TRUE(T), I.E. THERE ARE NO INCONSISTENCIES. THE
-C DRIVER READS IN DATA, CALLS CHKDER AND PRINTS OUT INFORMATION
-C REQUIRED BY AND RECEIVED FROM CHKDER.
-C
-C SUBPROGRAMS CALLED
-C
-C MINPACK SUPPLIED ... CHKDER,ERRJAC,INITPT,VECFCN
-C
-C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980.
-C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE
-C
-C **********
- INTEGER I,LDFJAC,LNP,MODE,N,NPROB,NREAD,NWRITE
- INTEGER NA(14),NP(14)
- LOGICAL A(14)
- REAL CP,ONE
- REAL DIFF(10),ERR(10),ERRMAX(14),ERRMIN(14),FJAC(10,10),
- * FVEC1(10),FVEC2(10),X1(10),X2(10)
-C
-C LOGICAL INPUT UNIT IS ASSUMED TO BE NUMBER 5.
-C LOGICAL OUTPUT UNIT IS ASSUMED TO BE NUMBER 6.
-C
- DATA NREAD,NWRITE /5,6/
-C
- DATA A(1),A(2),A(3),A(4),A(5),A(6),A(7),A(8),A(9),A(10),A(11),
- * A(12),A(13),A(14)
- * /.FALSE.,.FALSE.,.FALSE.,.TRUE.,.FALSE.,.FALSE.,.FALSE.,
- * .TRUE.,.FALSE.,.FALSE.,.FALSE.,.FALSE.,.TRUE.,.FALSE./
- DATA CP,ONE /1.23E-1,1.0E0/
- LDFJAC = 10
- 10 CONTINUE
- READ (NREAD,60) NPROB,N
- IF (NPROB .LE. 0) GO TO 40
- CALL INITPT(N,X1,NPROB,ONE)
- DO 20 I = 1, N
- X1(I) = X1(I) + CP
- CP = -CP
- 20 CONTINUE
- WRITE (NWRITE,70) NPROB,N,A(NPROB)
- MODE = 1
- CALL CHKDER(N,N,X1,FVEC1,FJAC,LDFJAC,X2,FVEC2,MODE,ERR)
- MODE = 2
- CALL VECFCN(N,X1,FVEC1,NPROB)
- CALL ERRJAC(N,X1,FJAC,LDFJAC,NPROB)
- CALL VECFCN(N,X2,FVEC2,NPROB)
- CALL CHKDER(N,N,X1,FVEC1,FJAC,LDFJAC,X2,FVEC2,MODE,ERR)
- ERRMIN(NPROB) = ERR(1)
- ERRMAX(NPROB) = ERR(1)
- DO 30 I = 1, N
- DIFF(I) = FVEC2(I) - FVEC1(I)
- IF (ERRMIN(NPROB) .GT. ERR(I)) ERRMIN(NPROB) = ERR(I)
- IF (ERRMAX(NPROB) .LT. ERR(I)) ERRMAX(NPROB) = ERR(I)
- 30 CONTINUE
- NP(NPROB) = NPROB
- LNP = NPROB
- NA(NPROB) = N
- WRITE (NWRITE,80) (FVEC1(I), I = 1, N)
- WRITE (NWRITE,90) (DIFF(I), I = 1, N)
- WRITE (NWRITE,100) (ERR(I), I = 1, N)
- GO TO 10
- 40 CONTINUE
- WRITE (NWRITE,110) LNP
- WRITE (NWRITE,120)
- DO 50 I = 1, LNP
- WRITE (NWRITE,130) NP(I),NA(I),A(I),ERRMIN(I),ERRMAX(I)
- 50 CONTINUE
- STOP
- 60 FORMAT (2I5)
- 70 FORMAT ( /// 5X, 8H PROBLEM, I5, 5X, 15H WITH DIMENSION, I5, 2X,
- * 5H IS , L1)
- 80 FORMAT ( // 5X, 25H FIRST FUNCTION VECTOR // (5X, 5E15.7))
- 90 FORMAT ( // 5X, 27H FUNCTION DIFFERENCE VECTOR // (5X, 5E15.7))
- 100 FORMAT ( // 5X, 13H ERROR VECTOR // (5X, 5E15.7))
- 110 FORMAT (12H1SUMMARY OF , I3, 16H TESTS OF CHKDER /)
- 120 FORMAT (46H NPROB N STATUS ERRMIN ERRMAX /)
- 130 FORMAT (I4, I6, 6X, L1, 3X, 2E15.7)
-C
-C LAST CARD OF DERIVATIVE CHECK TEST DRIVER.
-C
- END
- SUBROUTINE ERRJAC(N,X,FJAC,LDFJAC,NPROB)
- INTEGER N,LDFJAC,NPROB
- REAL X(N),FJAC(LDFJAC,N)
-C **********
-C
-C SUBROUTINE ERRJAC
-C
-C THIS SUBROUTINE IS DERIVED FROM VECJAC WHICH DEFINES THE
-C JACOBIAN MATRICES OF FOURTEEN TEST FUNCTIONS. THE PROBLEM
-C DIMENSIONS ARE AS DESCRIBED IN THE PROLOGUE COMMENTS OF VECFCN.
-C VARIOUS ERRORS ARE DELIBERATELY INTRODUCED TO PROVIDE A TEST
-C FOR CHKDER.
-C
-C THE SUBROUTINE STATEMENT IS
-C
-C SUBROUTINE ERRJAC(N,X,FJAC,LDFJAC,NPROB)
-C
-C WHERE
-C
-C N IS A POSITIVE INTEGER VARIABLE.
-C
-C X IS AN ARRAY OF LENGTH N.
-C
-C FJAC IS AN N BY N ARRAY. ON OUTPUT FJAC CONTAINS THE
-C JACOBIAN MATRIX, WITH VARIOUS ERRORS DELIBERATELY
-C INTRODUCED, OF THE NPROB FUNCTION EVALUATED AT X.
-C
-C LDFJAC IS A POSITIVE INTEGER VARIABLE NOT LESS THAN N
-C WHICH SPECIFIES THE LEADING DIMENSION OF THE ARRAY FJAC.
-C
-C NPROB IS A POSITIVE INTEGER VARIABLE WHICH DEFINES THE
-C NUMBER OF THE PROBLEM. NPROB MUST NOT EXCEED 14.
-C
-C SUBPROGRAMS CALLED
-C
-C FORTRAN-SUPPLIED ... ATAN,COS,EXP,AMIN1,SIN,SQRT,
-C MAX0,MIN0
-C
-C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980.
-C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE
-C
-C **********
- INTEGER I,IVAR,J,K,K1,K2,ML,MU
- REAL C1,C3,C4,C5,C6,C9,EIGHT,FIFTN,FIVE,FOUR,H,HUNDRD,ONE,PROD,
- * SIX,SUM,SUM1,SUM2,TEMP,TEMP1,TEMP2,TEMP3,TEMP4,TEN,THREE,
- * TI,TJ,TK,TPI,TWENTY,TWO,ZERO
- REAL FLOAT
- DATA ZERO,ONE,TWO,THREE,FOUR,FIVE,SIX,EIGHT,TEN,FIFTN,TWENTY,
- * HUNDRD
- * /0.0E0,1.0E0,2.0E0,3.0E0,4.0E0,5.0E0,6.0E0,8.0E0,1.0E1,
- * 1.5E1,2.0E1,1.0E2/
- DATA C1,C3,C4,C5,C6,C9 /1.0E4,2.0E2,2.02E1,1.98E1,1.8E2,2.9E1/
- FLOAT(IVAR) = IVAR
-C
-C JACOBIAN ROUTINE SELECTOR.
-C
- GO TO (10,20,50,60,90,100,200,230,290,320,350,380,420,450),
- * NPROB
-C
-C ROSENBROCK FUNCTION WITH SIGN REVERSAL AFFECTING ELEMENT (1,1).
-C
- 10 CONTINUE
- FJAC(1,1) = ONE
- FJAC(1,2) = ZERO
- FJAC(2,1) = -TWENTY*X(1)
- FJAC(2,2) = TEN
- GO TO 490
-C
-C POWELL SINGULAR FUNCTION WITH SIGN REVERSAL AFFECTING ELEMENT
-C (3,3).
-C
- 20 CONTINUE
- DO 40 K = 1, 4
- DO 30 J = 1, 4
- FJAC(K,J) = ZERO
- 30 CONTINUE
- 40 CONTINUE
- FJAC(1,1) = ONE
- FJAC(1,2) = TEN
- FJAC(2,3) = SQRT(FIVE)
- FJAC(2,4) = -FJAC(2,3)
- FJAC(3,2) = TWO*(X(2) - TWO*X(3))
- FJAC(3,3) = TWO*FJAC(3,2)
- FJAC(4,1) = TWO*SQRT(TEN)*(X(1) - X(4))
- FJAC(4,4) = -FJAC(4,1)
- GO TO 490
-C
-C POWELL BADLY SCALED FUNCTION WITH THE SIGN OF THE JACOBIAN
-C REVERSED.
-C
- 50 CONTINUE
- FJAC(1,1) = -C1*X(2)
- FJAC(1,2) = -C1*X(1)
- FJAC(2,1) = EXP(-X(1))
- FJAC(2,2) = EXP(-X(2))
- GO TO 490
-C
-C WOOD FUNCTION WITHOUT ERROR.
-C
- 60 CONTINUE
- DO 80 K = 1, 4
- DO 70 J = 1, 4
- FJAC(K,J) = ZERO
- 70 CONTINUE
- 80 CONTINUE
- TEMP1 = X(2) - THREE*X(1)**2
- TEMP2 = X(4) - THREE*X(3)**2
- FJAC(1,1) = -C3*TEMP1 + ONE
- FJAC(1,2) = -C3*X(1)
- FJAC(2,1) = -TWO*C3*X(1)
- FJAC(2,2) = C3 + C4
- FJAC(2,4) = C5
- FJAC(3,3) = -C6*TEMP2 + ONE
- FJAC(3,4) = -C6*X(3)
- FJAC(4,2) = C5
- FJAC(4,3) = -TWO*C6*X(3)
- FJAC(4,4) = C6 + C4
- GO TO 490
-C
-C HELICAL VALLEY FUNCTION WITH MULTIPLICATIVE ERROR AFFECTING
-C ELEMENTS (2,1) AND (2,2).
-C
- 90 CONTINUE
- TPI = EIGHT*ATAN(ONE)
- TEMP = X(1)**2 + X(2)**2
- TEMP1 = TPI*TEMP
- TEMP2 = SQRT(TEMP)
- FJAC(1,1) = HUNDRD*X(2)/TEMP1
- FJAC(1,2) = -HUNDRD*X(1)/TEMP1
- FJAC(1,3) = TEN
- FJAC(2,1) = FIVE*X(1)/TEMP2
- FJAC(2,2) = FIVE*X(2)/TEMP2
- FJAC(2,3) = ZERO
- FJAC(3,1) = ZERO
- FJAC(3,2) = ZERO
- FJAC(3,3) = ONE
- GO TO 490
-C
-C WATSON FUNCTION WITH SIGN REVERSALS AFFECTING THE COMPUTATION OF
-C TEMP1.
-C
- 100 CONTINUE
- DO 120 K = 1, N
- DO 110 J = K, N
- FJAC(K,J) = ZERO
- 110 CONTINUE
- 120 CONTINUE
- DO 170 I = 1, 29
- TI = FLOAT(I)/C9
- SUM1 = ZERO
- TEMP = ONE
- DO 130 J = 2, N
- SUM1 = SUM1 + FLOAT(J-1)*TEMP*X(J)
- TEMP = TI*TEMP
- 130 CONTINUE
- SUM2 = ZERO
- TEMP = ONE
- DO 140 J = 1, N
- SUM2 = SUM2 + TEMP*X(J)
- TEMP = TI*TEMP
- 140 CONTINUE
- TEMP1 = TWO*(SUM1 + SUM2**2 + ONE)
- TEMP2 = TWO*SUM2
- TEMP = TI**2
- TK = ONE
- DO 160 K = 1, N
- TJ = TK
- DO 150 J = K, N
- FJAC(K,J) = FJAC(K,J)
- * + TJ
- * *((FLOAT(K-1)/TI - TEMP2)
- * *(FLOAT(J-1)/TI - TEMP2) - TEMP1)
- TJ = TI*TJ
- 150 CONTINUE
- TK = TEMP*TK
- 160 CONTINUE
- 170 CONTINUE
- FJAC(1,1) = FJAC(1,1) + SIX*X(1)**2 - TWO*X(2) + THREE
- FJAC(1,2) = FJAC(1,2) - TWO*X(1)
- FJAC(2,2) = FJAC(2,2) + ONE
- DO 190 K = 1, N
- DO 180 J = K, N
- FJAC(J,K) = FJAC(K,J)
- 180 CONTINUE
- 190 CONTINUE
- GO TO 490
-C
-C CHEBYQUAD FUNCTION WITH JACOBIAN TWICE CORRECT SIZE.
-C
- 200 CONTINUE
- TK = ONE/FLOAT(N)
- DO 220 J = 1, N
- TEMP1 = ONE
- TEMP2 = TWO*X(J) - ONE
- TEMP = TWO*TEMP2
- TEMP3 = ZERO
- TEMP4 = TWO
- DO 210 K = 1, N
- FJAC(K,J) = TWO*TK*TEMP4
- TI = FOUR*TEMP2 + TEMP*TEMP4 - TEMP3
- TEMP3 = TEMP4
- TEMP4 = TI
- TI = TEMP*TEMP2 - TEMP1
- TEMP1 = TEMP2
- TEMP2 = TI
- 210 CONTINUE
- 220 CONTINUE
- GO TO 490
-C
-C BROWN ALMOST-LINEAR FUNCTION WITHOUT ERROR.
-C
- 230 CONTINUE
- PROD = ONE
- DO 250 J = 1, N
- PROD = X(J)*PROD
- DO 240 K = 1, N
- FJAC(K,J) = ONE
- 240 CONTINUE
- FJAC(J,J) = TWO
- 250 CONTINUE
- DO 280 J = 1, N
- TEMP = X(J)
- IF (TEMP .NE. ZERO) GO TO 270
- TEMP = ONE
- PROD = ONE
- DO 260 K = 1, N
- IF (K .NE. J) PROD = X(K)*PROD
- 260 CONTINUE
- 270 CONTINUE
- FJAC(N,J) = PROD/TEMP
- 280 CONTINUE
- GO TO 490
-C
-C DISCRETE BOUNDARY VALUE FUNCTION WITH MULTIPLICATIVE ERROR
-C AFFECTING THE JACOBIAN DIAGONAL.
-C
- 290 CONTINUE
- H = ONE/FLOAT(N+1)
- DO 310 K = 1, N
- TEMP = THREE*(X(K) + FLOAT(K)*H + ONE)**2
- DO 300 J = 1, N
- FJAC(K,J) = ZERO
- 300 CONTINUE
- FJAC(K,K) = FOUR + TEMP*H**2
- IF (K .NE. 1) FJAC(K,K-1) = -ONE
- IF (K .NE. N) FJAC(K,K+1) = -ONE
- 310 CONTINUE
- GO TO 490
-C
-C DISCRETE INTEGRAL EQUATION FUNCTION WITH SIGN ERROR AFFECTING
-C THE JACOBIAN DIAGONAL.
-C
- 320 CONTINUE
- H = ONE/FLOAT(N+1)
- DO 340 K = 1, N
- TK = FLOAT(K)*H
- DO 330 J = 1, N
- TJ = FLOAT(J)*H
- TEMP = THREE*(X(J) + TJ + ONE)**2
- FJAC(K,J) = H*AMIN1(TJ*(ONE-TK),TK*(ONE-TJ))*TEMP/TWO
- 330 CONTINUE
- FJAC(K,K) = FJAC(K,K) - ONE
- 340 CONTINUE
- GO TO 490
-C
-C TRIGONOMETRIC FUNCTION WITH SIGN ERRORS AFFECTING THE
-C OFFDIAGONAL ELEMENTS OF THE JACOBIAN.
-C
- 350 CONTINUE
- DO 370 J = 1, N
- TEMP = SIN(X(J))
- DO 360 K = 1, N
- FJAC(K,J) = -TEMP
- 360 CONTINUE
- FJAC(J,J) = FLOAT(J+1)*TEMP - COS(X(J))
- 370 CONTINUE
- GO TO 490
-C
-C VARIABLY DIMENSIONED FUNCTION WITH OPERATION ERROR AFFECTING
-C THE UPPER TRIANGULAR ELEMENTS OF THE JACOBIAN.
-C
- 380 CONTINUE
- SUM = ZERO
- DO 390 J = 1, N
- SUM = SUM + FLOAT(J)*(X(J) - ONE)
- 390 CONTINUE
- TEMP = ONE + SIX*SUM**2
- DO 410 K = 1, N
- DO 400 J = K, N
- FJAC(K,J) = FLOAT(K*J)/TEMP
- FJAC(J,K) = FJAC(K,J)
- 400 CONTINUE
- FJAC(K,K) = FJAC(K,K) + ONE
- 410 CONTINUE
- GO TO 490
-C
-C BROYDEN TRIDIAGONAL FUNCTION WITHOUT ERROR.
-C
- 420 CONTINUE
- DO 440 K = 1, N
- DO 430 J = 1, N
- FJAC(K,J) = ZERO
- 430 CONTINUE
- FJAC(K,K) = THREE - FOUR*X(K)
- IF (K .NE. 1) FJAC(K,K-1) = -ONE
- IF (K .NE. N) FJAC(K,K+1) = -TWO
- 440 CONTINUE
- GO TO 490
-C
-C BROYDEN BANDED FUNCTION WITH SIGN ERROR AFFECTING THE JACOBIAN
-C DIAGONAL.
-C
- 450 CONTINUE
- ML = 5
- MU = 1
- DO 480 K = 1, N
- DO 460 J = 1, N
- FJAC(K,J) = ZERO
- 460 CONTINUE
- K1 = MAX0(1,K-ML)
- K2 = MIN0(K+MU,N)
- DO 470 J = K1, K2
- IF (J .NE. K) FJAC(K,J) = -(ONE + TWO*X(J))
- 470 CONTINUE
- FJAC(K,K) = TWO - FIFTN*X(K)**2
- 480 CONTINUE
- 490 CONTINUE
- RETURN
-C
-C LAST CARD OF SUBROUTINE ERRJAC.
-C
- END
- SUBROUTINE INITPT(N,X,NPROB,FACTOR)
- INTEGER N,NPROB
- REAL FACTOR
- REAL X(N)
-C **********
-C
-C SUBROUTINE INITPT
-C
-C THIS SUBROUTINE SPECIFIES THE STANDARD STARTING POINTS FOR
-C THE FUNCTIONS DEFINED BY SUBROUTINE VECFCN. THE SUBROUTINE
-C RETURNS IN X A MULTIPLE (FACTOR) OF THE STANDARD STARTING
-C POINT. FOR THE SIXTH FUNCTION THE STANDARD STARTING POINT IS
-C ZERO, SO IN THIS CASE, IF FACTOR IS NOT UNITY, THEN THE
-C SUBROUTINE RETURNS THE VECTOR X(J) = FACTOR, J=1,...,N.
-C
-C THE SUBROUTINE STATEMENT IS
-C
-C SUBROUTINE INITPT(N,X,NPROB,FACTOR)
-C
-C WHERE
-C
-C N IS A POSITIVE INTEGER INPUT VARIABLE.
-C
-C X IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS THE STANDARD
-C STARTING POINT FOR PROBLEM NPROB MULTIPLIED BY FACTOR.
-C
-C NPROB IS A POSITIVE INTEGER INPUT VARIABLE WHICH DEFINES THE
-C NUMBER OF THE PROBLEM. NPROB MUST NOT EXCEED 14.
-C
-C FACTOR IS AN INPUT VARIABLE WHICH SPECIFIES THE MULTIPLE OF
-C THE STANDARD STARTING POINT. IF FACTOR IS UNITY, NO
-C MULTIPLICATION IS PERFORMED.
-C
-C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980.
-C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE
-C
-C **********
- INTEGER IVAR,J
- REAL C1,H,HALF,ONE,THREE,TJ,ZERO
- REAL FLOAT
- DATA ZERO,HALF,ONE,THREE,C1 /0.0E0,5.0E-1,1.0E0,3.0E0,1.2E0/
- FLOAT(IVAR) = IVAR
-C
-C SELECTION OF INITIAL POINT.
-C
- GO TO (10,20,30,40,50,60,80,100,120,120,140,160,180,180), NPROB
-C
-C ROSENBROCK FUNCTION.
-C
- 10 CONTINUE
- X(1) = -C1
- X(2) = ONE
- GO TO 200
-C
-C POWELL SINGULAR FUNCTION.
-C
- 20 CONTINUE
- X(1) = THREE
- X(2) = -ONE
- X(3) = ZERO
- X(4) = ONE
- GO TO 200
-C
-C POWELL BADLY SCALED FUNCTION.
-C
- 30 CONTINUE
- X(1) = ZERO
- X(2) = ONE
- GO TO 200
-C
-C WOOD FUNCTION.
-C
- 40 CONTINUE
- X(1) = -THREE
- X(2) = -ONE
- X(3) = -THREE
- X(4) = -ONE
- GO TO 200
-C
-C HELICAL VALLEY FUNCTION.
-C
- 50 CONTINUE
- X(1) = -ONE
- X(2) = ZERO
- X(3) = ZERO
- GO TO 200
-C
-C WATSON FUNCTION.
-C
- 60 CONTINUE
- DO 70 J = 1, N
- X(J) = ZERO
- 70 CONTINUE
- GO TO 200
-C
-C CHEBYQUAD FUNCTION.
-C
- 80 CONTINUE
- H = ONE/FLOAT(N+1)
- DO 90 J = 1, N
- X(J) = FLOAT(J)*H
- 90 CONTINUE
- GO TO 200
-C
-C BROWN ALMOST-LINEAR FUNCTION.
-C
- 100 CONTINUE
- DO 110 J = 1, N
- X(J) = HALF
- 110 CONTINUE
- GO TO 200
-C
-C DISCRETE BOUNDARY VALUE AND INTEGRAL EQUATION FUNCTIONS.
-C
- 120 CONTINUE
- H = ONE/FLOAT(N+1)
- DO 130 J = 1, N
- TJ = FLOAT(J)*H
- X(J) = TJ*(TJ - ONE)
- 130 CONTINUE
- GO TO 200
-C
-C TRIGONOMETRIC FUNCTION.
-C
- 140 CONTINUE
- H = ONE/FLOAT(N)
- DO 150 J = 1, N
- X(J) = H
- 150 CONTINUE
- GO TO 200
-C
-C VARIABLY DIMENSIONED FUNCTION.
-C
- 160 CONTINUE
- H = ONE/FLOAT(N)
- DO 170 J = 1, N
- X(J) = ONE - FLOAT(J)*H
- 170 CONTINUE
- GO TO 200
-C
-C BROYDEN TRIDIAGONAL AND BANDED FUNCTIONS.
-C
- 180 CONTINUE
- DO 190 J = 1, N
- X(J) = -ONE
- 190 CONTINUE
- 200 CONTINUE
-C
-C COMPUTE MULTIPLE OF INITIAL POINT.
-C
- IF (FACTOR .EQ. ONE) GO TO 250
- IF (NPROB .EQ. 6) GO TO 220
- DO 210 J = 1, N
- X(J) = FACTOR*X(J)
- 210 CONTINUE
- GO TO 240
- 220 CONTINUE
- DO 230 J = 1, N
- X(J) = FACTOR
- 230 CONTINUE
- 240 CONTINUE
- 250 CONTINUE
- RETURN
-C
-C LAST CARD OF SUBROUTINE INITPT.
-C
- END
- SUBROUTINE VECFCN(N,X,FVEC,NPROB)
- INTEGER N,NPROB
- REAL X(N),FVEC(N)
-C **********
-C
-C SUBROUTINE VECFCN
-C
-C THIS SUBROUTINE DEFINES FOURTEEN TEST FUNCTIONS. THE FIRST
-C FIVE TEST FUNCTIONS ARE OF DIMENSIONS 2,4,2,4,3, RESPECTIVELY,
-C WHILE THE REMAINING TEST FUNCTIONS ARE OF VARIABLE DIMENSION
-C N FOR ANY N GREATER THAN OR EQUAL TO 1 (PROBLEM 6 IS AN
-C EXCEPTION TO THIS, SINCE IT DOES NOT ALLOW N = 1).
-C
-C THE SUBROUTINE STATEMENT IS
-C
-C SUBROUTINE VECFCN(N,X,FVEC,NPROB)
-C
-C WHERE
-C
-C N IS A POSITIVE INTEGER INPUT VARIABLE.
-C
-C X IS AN INPUT ARRAY OF LENGTH N.
-C
-C FVEC IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS THE NPROB
-C FUNCTION VECTOR EVALUATED AT X.
-C
-C NPROB IS A POSITIVE INTEGER INPUT VARIABLE WHICH DEFINES THE
-C NUMBER OF THE PROBLEM. NPROB MUST NOT EXCEED 14.
-C
-C SUBPROGRAMS CALLED
-C
-C FORTRAN-SUPPLIED ... ATAN,COS,EXP,SIGN,SIN,SQRT,
-C MAX0,MIN0
-C
-C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980.
-C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE
-C
-C **********
- INTEGER I,IEV,IVAR,J,K,K1,K2,KP1,ML,MU
- REAL C1,C2,C3,C4,C5,C6,C7,C8,C9,EIGHT,FIVE,H,ONE,PROD,SUM,SUM1,
- * SUM2,TEMP,TEMP1,TEMP2,TEN,THREE,TI,TJ,TK,TPI,TWO,ZERO
- REAL FLOAT
- DATA ZERO,ONE,TWO,THREE,FIVE,EIGHT,TEN
- * /0.0E0,1.0E0,2.0E0,3.0E0,5.0E0,8.0E0,1.0E1/
- DATA C1,C2,C3,C4,C5,C6,C7,C8,C9
- * /1.0E4,1.0001E0,2.0E2,2.02E1,1.98E1,1.8E2,2.5E-1,5.0E-1,
- * 2.9E1/
- FLOAT(IVAR) = IVAR
-C
-C PROBLEM SELECTOR.
-C
- GO TO (10,20,30,40,50,60,120,170,200,220,270,300,330,350), NPROB
-C
-C ROSENBROCK FUNCTION.
-C
- 10 CONTINUE
- FVEC(1) = ONE - X(1)
- FVEC(2) = TEN*(X(2) - X(1)**2)
- GO TO 380
-C
-C POWELL SINGULAR FUNCTION.
-C
- 20 CONTINUE
- FVEC(1) = X(1) + TEN*X(2)
- FVEC(2) = SQRT(FIVE)*(X(3) - X(4))
- FVEC(3) = (X(2) - TWO*X(3))**2
- FVEC(4) = SQRT(TEN)*(X(1) - X(4))**2
- GO TO 380
-C
-C POWELL BADLY SCALED FUNCTION.
-C
- 30 CONTINUE
- FVEC(1) = C1*X(1)*X(2) - ONE
- FVEC(2) = EXP(-X(1)) + EXP(-X(2)) - C2
- GO TO 380
-C
-C WOOD FUNCTION.
-C
- 40 CONTINUE
- TEMP1 = X(2) - X(1)**2
- TEMP2 = X(4) - X(3)**2
- FVEC(1) = -C3*X(1)*TEMP1 - (ONE - X(1))
- FVEC(2) = C3*TEMP1 + C4*(X(2) - ONE) + C5*(X(4) - ONE)
- FVEC(3) = -C6*X(3)*TEMP2 - (ONE - X(3))
- FVEC(4) = C6*TEMP2 + C4*(X(4) - ONE) + C5*(X(2) - ONE)
- GO TO 380
-C
-C HELICAL VALLEY FUNCTION.
-C
- 50 CONTINUE
- TPI = EIGHT*ATAN(ONE)
- TEMP1 = SIGN(C7,X(2))
- IF (X(1) .GT. ZERO) TEMP1 = ATAN(X(2)/X(1))/TPI
- IF (X(1) .LT. ZERO) TEMP1 = ATAN(X(2)/X(1))/TPI + C8
- TEMP2 = SQRT(X(1)**2+X(2)**2)
- FVEC(1) = TEN*(X(3) - TEN*TEMP1)
- FVEC(2) = TEN*(TEMP2 - ONE)
- FVEC(3) = X(3)
- GO TO 380
-C
-C WATSON FUNCTION.
-C
- 60 CONTINUE
- DO 70 K = 1, N
- FVEC(K) = ZERO
- 70 CONTINUE
- DO 110 I = 1, 29
- TI = FLOAT(I)/C9
- SUM1 = ZERO
- TEMP = ONE
- DO 80 J = 2, N
- SUM1 = SUM1 + FLOAT(J-1)*TEMP*X(J)
- TEMP = TI*TEMP
- 80 CONTINUE
- SUM2 = ZERO
- TEMP = ONE
- DO 90 J = 1, N
- SUM2 = SUM2 + TEMP*X(J)
- TEMP = TI*TEMP
- 90 CONTINUE
- TEMP1 = SUM1 - SUM2**2 - ONE
- TEMP2 = TWO*TI*SUM2
- TEMP = ONE/TI
- DO 100 K = 1, N
- FVEC(K) = FVEC(K) + TEMP*(FLOAT(K-1) - TEMP2)*TEMP1
- TEMP = TI*TEMP
- 100 CONTINUE
- 110 CONTINUE
- TEMP = X(2) - X(1)**2 - ONE
- FVEC(1) = FVEC(1) + X(1)*(ONE - TWO*TEMP)
- FVEC(2) = FVEC(2) + TEMP
- GO TO 380
-C
-C CHEBYQUAD FUNCTION.
-C
- 120 CONTINUE
- DO 130 K = 1, N
- FVEC(K) = ZERO
- 130 CONTINUE
- DO 150 J = 1, N
- TEMP1 = ONE
- TEMP2 = TWO*X(J) - ONE
- TEMP = TWO*TEMP2
- DO 140 I = 1, N
- FVEC(I) = FVEC(I) + TEMP2
- TI = TEMP*TEMP2 - TEMP1
- TEMP1 = TEMP2
- TEMP2 = TI
- 140 CONTINUE
- 150 CONTINUE
- TK = ONE/FLOAT(N)
- IEV = -1
- DO 160 K = 1, N
- FVEC(K) = TK*FVEC(K)
- IF (IEV .GT. 0) FVEC(K) = FVEC(K) + ONE/(FLOAT(K)**2 - ONE)
- IEV = -IEV
- 160 CONTINUE
- GO TO 380
-C
-C BROWN ALMOST-LINEAR FUNCTION.
-C
- 170 CONTINUE
- SUM = -FLOAT(N+1)
- PROD = ONE
- DO 180 J = 1, N
- SUM = SUM + X(J)
- PROD = X(J)*PROD
- 180 CONTINUE
- DO 190 K = 1, N
- FVEC(K) = X(K) + SUM
- 190 CONTINUE
- FVEC(N) = PROD - ONE
- GO TO 380
-C
-C DISCRETE BOUNDARY VALUE FUNCTION.
-C
- 200 CONTINUE
- H = ONE/FLOAT(N+1)
- DO 210 K = 1, N
- TEMP = (X(K) + FLOAT(K)*H + ONE)**3
- TEMP1 = ZERO
- IF (K .NE. 1) TEMP1 = X(K-1)
- TEMP2 = ZERO
- IF (K .NE. N) TEMP2 = X(K+1)
- FVEC(K) = TWO*X(K) - TEMP1 - TEMP2 + TEMP*H**2/TWO
- 210 CONTINUE
- GO TO 380
-C
-C DISCRETE INTEGRAL EQUATION FUNCTION.
-C
- 220 CONTINUE
- H = ONE/FLOAT(N+1)
- DO 260 K = 1, N
- TK = FLOAT(K)*H
- SUM1 = ZERO
- DO 230 J = 1, K
- TJ = FLOAT(J)*H
- TEMP = (X(J) + TJ + ONE)**3
- SUM1 = SUM1 + TJ*TEMP
- 230 CONTINUE
- SUM2 = ZERO
- KP1 = K + 1
- IF (N .LT. KP1) GO TO 250
- DO 240 J = KP1, N
- TJ = FLOAT(J)*H
- TEMP = (X(J) + TJ + ONE)**3
- SUM2 = SUM2 + (ONE - TJ)*TEMP
- 240 CONTINUE
- 250 CONTINUE
- FVEC(K) = X(K) + H*((ONE - TK)*SUM1 + TK*SUM2)/TWO
- 260 CONTINUE
- GO TO 380
-C
-C TRIGONOMETRIC FUNCTION.
-C
- 270 CONTINUE
- SUM = ZERO
- DO 280 J = 1, N
- FVEC(J) = COS(X(J))
- SUM = SUM + FVEC(J)
- 280 CONTINUE
- DO 290 K = 1, N
- FVEC(K) = FLOAT(N+K) - SIN(X(K)) - SUM - FLOAT(K)*FVEC(K)
- 290 CONTINUE
- GO TO 380
-C
-C VARIABLY DIMENSIONED FUNCTION.
-C
- 300 CONTINUE
- SUM = ZERO
- DO 310 J = 1, N
- SUM = SUM + FLOAT(J)*(X(J) - ONE)
- 310 CONTINUE
- TEMP = SUM*(ONE + TWO*SUM**2)
- DO 320 K = 1, N
- FVEC(K) = X(K) - ONE + FLOAT(K)*TEMP
- 320 CONTINUE
- GO TO 380
-C
-C BROYDEN TRIDIAGONAL FUNCTION.
-C
- 330 CONTINUE
- DO 340 K = 1, N
- TEMP = (THREE - TWO*X(K))*X(K)
- TEMP1 = ZERO
- IF (K .NE. 1) TEMP1 = X(K-1)
- TEMP2 = ZERO
- IF (K .NE. N) TEMP2 = X(K+1)
- FVEC(K) = TEMP - TEMP1 - TWO*TEMP2 + ONE
- 340 CONTINUE
- GO TO 380
-C
-C BROYDEN BANDED FUNCTION.
-C
- 350 CONTINUE
- ML = 5
- MU = 1
- DO 370 K = 1, N
- K1 = MAX0(1,K-ML)
- K2 = MIN0(K+MU,N)
- TEMP = ZERO
- DO 360 J = K1, K2
- IF (J .NE. K) TEMP = TEMP + X(J)*(ONE + X(J))
- 360 CONTINUE
- FVEC(K) = X(K)*(TWO + FIVE*X(K)**2) + ONE - TEMP
- 370 CONTINUE
- 380 CONTINUE
- RETURN
-C
-C LAST CARD OF SUBROUTINE VECFCN.
-C
- END
diff --git a/CEP/PyBDSM/src/minpack/ex/file14 b/CEP/PyBDSM/src/minpack/ex/file14
deleted file mode 100644
index 9ad38d86ebd563b0a963afee4e7c6aa072fb4c72..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/minpack/ex/file14
+++ /dev/null
@@ -1,284 +0,0 @@
-C **********
-C
-C THIS PROGRAM CHECKS THE CONSTANTS OF MACHINE PRECISION AND
-C SMALLEST AND LARGEST MACHINE REPRESENTABLE NUMBERS SPECIFIED IN
-C FUNCTION DPMPAR, AGAINST THE CORRESPONDING HARDWARE-DETERMINED
-C MACHINE CONSTANTS OBTAINED BY DMCHAR, A SUBROUTINE DUE TO
-C W. J. CODY.
-C
-C DATA STATEMENTS IN DPMPAR CORRESPONDING TO THE MACHINE USED MUST
-C BE ACTIVATED BY REMOVING C IN COLUMN 1.
-C
-C THE PRINTED OUTPUT CONSISTS OF THE MACHINE CONSTANTS OBTAINED BY
-C DMCHAR AND COMPARISONS OF THE DPMPAR CONSTANTS WITH THEIR
-C DMCHAR COUNTERPARTS. DESCRIPTIONS OF THE MACHINE CONSTANTS ARE
-C GIVEN IN THE PROLOGUE COMMENTS OF DMCHAR.
-C
-C SUBPROGRAMS CALLED
-C
-C MINPACK-SUPPLIED ... DMCHAR,DPMPAR
-C
-C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980.
-C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE
-C
-C **********
- INTEGER IBETA,IEXP,IRND,IT,MACHEP,MAXEXP,MINEXP,NEGEP,NGRD,
- * NWRITE
- DOUBLE PRECISION DWARF,EPS,EPSMCH,EPSNEG,GIANT,XMAX,XMIN
- DOUBLE PRECISION RERR(3)
- DOUBLE PRECISION DPMPAR
-C
-C LOGICAL OUTPUT UNIT IS ASSUMED TO BE NUMBER 6.
-C
- DATA NWRITE /6/
-C
-C DETERMINE THE MACHINE CONSTANTS DYNAMICALLY FROM DMCHAR.
-C
- CALL DMCHAR(IBETA,IT,IRND,NGRD,MACHEP,NEGEP,IEXP,MINEXP,MAXEXP,
- * EPS,EPSNEG,XMIN,XMAX)
-C
-C COMPARE THE DPMPAR CONSTANTS WITH THEIR DMCHAR COUNTERPARTS AND
-C STORE THE RELATIVE DIFFERENCES IN RERR.
-C
- EPSMCH = DPMPAR(1)
- DWARF = DPMPAR(2)
- GIANT = DPMPAR(3)
- RERR(1) = (EPSMCH - EPS)/EPSMCH
- RERR(2) = (DWARF - XMIN)/DWARF
- RERR(3) = (XMAX - GIANT)/GIANT
-C
-C WRITE THE DMCHAR CONSTANTS.
-C
- WRITE (NWRITE,10)
- * IBETA,IT,IRND,NGRD,MACHEP,NEGEP,IEXP,MINEXP,MAXEXP,EPS,
- * EPSNEG,XMIN,XMAX
-C
-C WRITE THE DPMPAR CONSTANTS AND THE RELATIVE DIFFERENCES.
-C
- WRITE (NWRITE,20) EPSMCH,RERR(1),DWARF,RERR(2),GIANT,RERR(3)
- STOP
- 10 FORMAT (17H1DMCHAR CONSTANTS /// 8H IBETA =, I6 // 8H IT =,
- * I6 // 8H IRND =, I6 // 8H NGRD =, I6 // 9H MACHEP =,
- * I6 // 8H NEGEP =, I6 // 7H IEXP =, I6 // 9H MINEXP =,
- * I6 // 9H MAXEXP =, I6 // 6H EPS =, D15.7 // 9H EPSNEG =,
- * D15.7 // 7H XMIN =, D15.7 // 7H XMAX =, D15.7)
- 20 FORMAT ( /// 42H DPMPAR CONSTANTS AND RELATIVE DIFFERENCES ///
- * 9H EPSMCH =, D15.7 / 10H RERR(1) =, D15.7 //
- * 8H DWARF =, D15.7 / 10H RERR(2) =, D15.7 // 8H GIANT =,
- * D15.7 / 10H RERR(3) =, D15.7)
-C
-C LAST CARD OF DRIVER.
-C
- END
- SUBROUTINE DMCHAR(IBETA,IT,IRND,NGRD,MACHEP,NEGEP,IEXP,MINEXP,
- 1 MAXEXP,EPS,EPSNEG,XMIN,XMAX)
-C
- INTEGER I,IBETA,IEXP,IRND,IT,IZ,J,K,MACHEP,MAXEXP,MINEXP,
- 1 MX,NEGEP,NGRD
- DOUBLE PRECISION A,B,BETA,BETAIN,BETAM1,EPS,EPSNEG,ONE,XMAX,
- 1 XMIN,Y,Z,ZERO
-C
-C THIS SUBROUTINE IS INTENDED TO DETERMINE THE CHARACTERISTICS
-C OF THE FLOATING-POINT ARITHMETIC SYSTEM THAT ARE SPECIFIED
-C BELOW. THE FIRST THREE ARE DETERMINED ACCORDING TO AN
-C ALGORITHM DUE TO M. MALCOLM, CACM 15 (1972), PP. 949-951,
-C INCORPORATING SOME, BUT NOT ALL, OF THE IMPROVEMENTS
-C SUGGESTED BY M. GENTLEMAN AND S. MAROVICH, CACM 17 (1974),
-C PP. 276-277.
-C
-C
-C IBETA - THE RADIX OF THE FLOATING-POINT REPRESENTATION
-C IT - THE NUMBER OF BASE IBETA DIGITS IN THE FLOATING-POINT
-C SIGNIFICAND
-C IRND - 0 IF FLOATING-POINT ADDITION CHOPS,
-C 1 IF FLOATING-POINT ADDITION ROUNDS
-C NGRD - THE NUMBER OF GUARD DIGITS FOR MULTIPLICATION. IT IS
-C 0 IF IRND=1, OR IF IRND=0 AND ONLY IT BASE IBET
-C DIGITS PARTICIPATE IN THE POST NORMALIZATION SHIFT
-C OF THE FLOATING-POINT SIGNIFICAND IN MULTIPLICATION
-C 1 IF IRND=0 AND MORE THAN IT BASE IBETA DIGITS
-C PARTICIPATE IN THE POST NORMALIZATION SHIFT OF THE
-C FLOATING-POINT SIGNIFICAND IN MULTIPLICATION
-C MACHEP - THE LARGEST NEGATIVE INTEGER SUCH THAT
-C 1.0+FLOAT(IBETA)**MACHEP .NE. 1.0, EXCEPT THAT
-C MACHEP IS BOUNDED BELOW BY -(IT+3)
-C NEGEPS - THE LARGEST NEGATIVE INTEGER SUCH THAT
-C 1.0-FLOAT(IBETA)**NEGEPS .NE. 1.0, EXCEPT THAT
-C NEGEPS IS BOUNDED BELOW BY -(IT+3)
-C IEXP - THE NUMBER OF BITS (DECIMAL PLACES IF IBETA = 10)
-C RESERVED FOR THE REPRESENTATION OF THE EXPONENT
-C (INCLUDING THE BIAS OR SIGN) OF A FLOATING-POINT
-C NUMBER
-C MINEXP - THE LARGEST IN MAGNITUDE NEGATIVE INTEGER SUCH THAT
-C FLOAT(IBETA)**MINEXP IS A POSITIVE FLOATING-POINT
-C NUMBER
-C MAXEXP - THE LARGEST POSITIVE INTEGER EXPONENT FOR A FINITE
-C FLOATING-POINT NUMBER
-C EPS - THE SMALLEST POSITIVE FLOATING-POINT NUMBER SUCH
-C THAT 1.0+EPS .NE. 1.0. IN PARTICULAR, IF EITHER
-C IBETA = 2 OR IRND = 0, EPS = FLOAT(IBETA)**MACHEP.
-C OTHERWISE, EPS = (FLOAT(IBETA)**MACHEP)/2
-C EPSNEG - A SMALL POSITIVE FLOATING-POINT NUMBER SUCH THAT
-C 1.0-EPSNEG .NE. 1.0. IN PARTICULAR, IF IBETA = 2
-C OR IRND = 0, EPSNEG = FLOAT(IBETA)**NEGEPS.
-C OTHERWISE, EPSNEG = (IBETA**NEGEPS)/2. BECAUSE
-C NEGEPS IS BOUNDED BELOW BY -(IT+3), EPSNEG MAY NOT
-C BE THE SMALLEST NUMBER WHICH CAN ALTER 1.0 BY
-C SUBTRACTION.
-C XMIN - THE SMALLEST NON-VANISHING FLOATING-POINT POWER OF TH
-C RADIX. IN PARTICULAR, XMIN = FLOAT(IBETA)**MINEXP
-C XMAX - THE LARGEST FINITE FLOATING-POINT NUMBER. IN
-C PARTICULAR XMAX = (1.0-EPSNEG)*FLOAT(IBETA)**MAXEXP
-C NOTE - ON SOME MACHINES XMAX WILL BE ONLY THE
-C SECOND, OR PERHAPS THIRD, LARGEST NUMBER, BEING
-C TOO SMALL BY 1 OR 2 UNITS IN THE LAST DIGIT OF
-C THE SIGNIFICAND.
-C
-C LATEST REVISION - OCTOBER 22, 1979
-C
-C AUTHOR - W. J. CODY
-C ARGONNE NATIONAL LABORATORY
-C
-C-----------------------------------------------------------------
- ONE = DBLE(FLOAT(1))
- ZERO = 0.0D0
-C-----------------------------------------------------------------
-C DETERMINE IBETA,BETA ALA MALCOLM
-C-----------------------------------------------------------------
- A = ONE
- 10 A = A + A
- IF (((A+ONE)-A)-ONE .EQ. ZERO) GO TO 10
- B = ONE
- 20 B = B + B
- IF ((A+B)-A .EQ. ZERO) GO TO 20
- IBETA = INT(SNGL((A + B) - A))
- BETA = DBLE(FLOAT(IBETA))
-C-----------------------------------------------------------------
-C DETERMINE IT, IRND
-C-----------------------------------------------------------------
- IT = 0
- B = ONE
- 100 IT = IT + 1
- B = B * BETA
- IF (((B+ONE)-B)-ONE .EQ. ZERO) GO TO 100
- IRND = 0
- BETAM1 = BETA - ONE
- IF ((A+BETAM1)-A .NE. ZERO) IRND = 1
-C-----------------------------------------------------------------
-C DETERMINE NEGEP, EPSNEG
-C-----------------------------------------------------------------
- NEGEP = IT + 3
- BETAIN = ONE / BETA
- A = ONE
-C
- DO 200 I = 1, NEGEP
- A = A * BETAIN
- 200 CONTINUE
-C
- B = A
- 210 IF ((ONE-A)-ONE .NE. ZERO) GO TO 220
- A = A * BETA
- NEGEP = NEGEP - 1
- GO TO 210
- 220 NEGEP = -NEGEP
- EPSNEG = A
- IF ((IBETA .EQ. 2) .OR. (IRND .EQ. 0)) GO TO 300
- A = (A*(ONE+A)) / (ONE+ONE)
- IF ((ONE-A)-ONE .NE. ZERO) EPSNEG = A
-C-----------------------------------------------------------------
-C DETERMINE MACHEP, EPS
-C-----------------------------------------------------------------
- 300 MACHEP = -IT - 3
- A = B
- 310 IF((ONE+A)-ONE .NE. ZERO) GO TO 320
- A = A * BETA
- MACHEP = MACHEP + 1
- GO TO 310
- 320 EPS = A
- IF ((IBETA .EQ. 2) .OR. (IRND .EQ. 0)) GO TO 350
- A = (A*(ONE+A)) / (ONE+ONE)
- IF ((ONE+A)-ONE .NE. ZERO) EPS = A
-C-----------------------------------------------------------------
-C DETERMINE NGRD
-C-----------------------------------------------------------------
- 350 NGRD = 0
- IF ((IRND .EQ. 0) .AND. ((ONE+EPS)*ONE-ONE) .NE. ZERO) NGRD = 1
-C-----------------------------------------------------------------
-C DETERMINE IEXP, MINEXP, XMIN
-C
-C LOOP TO DETERMINE LARGEST I AND K = 2**I SUCH THAT
-C (1/BETA) ** (2**(I))
-C DOES NOT UNDERFLOW
-C EXIT FROM LOOP IS SIGNALED BY AN UNDERFLOW.
-C-----------------------------------------------------------------
- I = 0
- K = 1
- Z = BETAIN
- 400 Y = Z
- Z = Y * Y
-C-----------------------------------------------------------------
-C CHECK FOR UNDERFLOW HERE
-C-----------------------------------------------------------------
- A = Z * ONE
- IF ((A+A .EQ. ZERO) .OR. (DABS(Z) .GE. Y)) GO TO 410
- I = I + 1
- K = K + K
- GO TO 400
- 410 IF (IBETA .EQ. 10) GO TO 420
- IEXP = I + 1
- MX = K + K
- GO TO 450
-C-----------------------------------------------------------------
-C FOR DECIMAL MACHINES ONLY
-C-----------------------------------------------------------------
- 420 IEXP = 2
- IZ = IBETA
- 430 IF (K .LT. IZ) GO TO 440
- IZ = IZ * IBETA
- IEXP = IEXP + 1
- GO TO 430
- 440 MX = IZ + IZ - 1
-C-----------------------------------------------------------------
-C LOOP TO DETERMINE MINEXP, XMIN
-C EXIT FROM LOOP IS SIGNALED BY AN UNDERFLOW.
-C-----------------------------------------------------------------
- 450 XMIN = Y
- Y = Y * BETAIN
-C-----------------------------------------------------------------
-C CHECK FOR UNDERFLOW HERE
-C-----------------------------------------------------------------
- A = Y * ONE
- IF (((A+A) .EQ. ZERO) .OR. (DABS(Y) .GE. XMIN)) GO TO 460
- K = K + 1
- GO TO 450
- 460 MINEXP = -K
-C-----------------------------------------------------------------
-C DETERMINE MAXEXP, XMAX
-C-----------------------------------------------------------------
- IF ((MX .GT. K+K-3) .OR. (IBETA .EQ. 10)) GO TO 500
- MX = MX + MX
- IEXP = IEXP + 1
- 500 MAXEXP = MX + MINEXP
-C-----------------------------------------------------------------
-C ADJUST FOR MACHINES WITH IMPLICIT LEADING
-C BIT IN BINARY SIGNIFICAND AND MACHINES WITH
-C RADIX POINT AT EXTREME RIGHT OF SIGNIFICAND
-C-----------------------------------------------------------------
- I = MAXEXP + MINEXP
- IF ((IBETA .EQ. 2) .AND. (I .EQ. 0)) MAXEXP = MAXEXP - 1
- IF (I .GT. 20) MAXEXP = MAXEXP - 1
- IF (A .NE. Y) MAXEXP = MAXEXP - 2
- XMAX = ONE - EPSNEG
- IF (XMAX*ONE .NE. XMAX) XMAX = ONE - BETA * EPSNEG
- XMAX = XMAX / (BETA * BETA * BETA * XMIN)
- I = MAXEXP + MINEXP + 3
- IF (I .LE. 0) GO TO 520
-C
- DO 510 J = 1, I
- IF (IBETA .EQ. 2) XMAX = XMAX + XMAX
- IF (IBETA .NE. 2) XMAX = XMAX * BETA
- 510 CONTINUE
-C
- 520 RETURN
-C ---------- LAST CARD OF DMCHAR ----------
- END
diff --git a/CEP/PyBDSM/src/minpack/ex/file15 b/CEP/PyBDSM/src/minpack/ex/file15
deleted file mode 100644
index 13312c75b4a21fd3a29bb139acc6e9218909d6c0..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/minpack/ex/file15
+++ /dev/null
@@ -1,552 +0,0 @@
-C **********
-C
-C THIS PROGRAM TESTS CODES FOR THE SOLUTION OF N NONLINEAR
-C EQUATIONS IN N VARIABLES. IT CONSISTS OF A DRIVER AND AN
-C INTERFACE SUBROUTINE FCN. THE DRIVER READS IN DATA, CALLS THE
-C NONLINEAR EQUATION SOLVER, AND FINALLY PRINTS OUT INFORMATION
-C ON THE PERFORMANCE OF THE SOLVER. THIS IS ONLY A SAMPLE DRIVER,
-C MANY OTHER DRIVERS ARE POSSIBLE. THE INTERFACE SUBROUTINE FCN
-C IS NECESSARY TO TAKE INTO ACCOUNT THE FORMS OF CALLING
-C SEQUENCES USED BY THE FUNCTION SUBROUTINES IN THE VARIOUS
-C NONLINEAR EQUATION SOLVERS.
-C
-C SUBPROGRAMS CALLED
-C
-C USER-SUPPLIED ...... FCN
-C
-C MINPACK-SUPPLIED ... DPMPAR,ENORM,HYBRD1,INITPT,VECFCN
-C
-C FORTRAN-SUPPLIED ... DSQRT
-C
-C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980.
-C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE
-C
-C **********
- INTEGER I,IC,INFO,K,LWA,N,NFEV,NPROB,NREAD,NTRIES,NWRITE
- INTEGER NA(60),NF(60),NP(60),NX(60)
- DOUBLE PRECISION FACTOR,FNORM1,FNORM2,ONE,TEN,TOL
- DOUBLE PRECISION FNM(60),FVEC(40),WA(2660),X(40)
- DOUBLE PRECISION DPMPAR,ENORM
- EXTERNAL FCN
- COMMON /REFNUM/ NPROB,NFEV
-C
-C LOGICAL INPUT UNIT IS ASSUMED TO BE NUMBER 5.
-C LOGICAL OUTPUT UNIT IS ASSUMED TO BE NUMBER 6.
-C
- DATA NREAD,NWRITE /5,6/
-C
- DATA ONE,TEN /1.0D0,1.0D1/
- TOL = DSQRT(DPMPAR(1))
- LWA = 2660
- IC = 0
- 10 CONTINUE
- READ (NREAD,50) NPROB,N,NTRIES
- IF (NPROB .LE. 0) GO TO 30
- FACTOR = ONE
- DO 20 K = 1, NTRIES
- IC = IC + 1
- CALL INITPT(N,X,NPROB,FACTOR)
- CALL VECFCN(N,X,FVEC,NPROB)
- FNORM1 = ENORM(N,FVEC)
- WRITE (NWRITE,60) NPROB,N
- NFEV = 0
- CALL HYBRD1(FCN,N,X,FVEC,TOL,INFO,WA,LWA)
- FNORM2 = ENORM(N,FVEC)
- NP(IC) = NPROB
- NA(IC) = N
- NF(IC) = NFEV
- NX(IC) = INFO
- FNM(IC) = FNORM2
- WRITE (NWRITE,70) FNORM1,FNORM2,NFEV,INFO,(X(I), I = 1, N)
- FACTOR = TEN*FACTOR
- 20 CONTINUE
- GO TO 10
- 30 CONTINUE
- WRITE (NWRITE,80) IC
- WRITE (NWRITE,90)
- DO 40 I = 1, IC
- WRITE (NWRITE,100) NP(I),NA(I),NF(I),NX(I),FNM(I)
- 40 CONTINUE
- STOP
- 50 FORMAT (3I5)
- 60 FORMAT ( //// 5X, 8H PROBLEM, I5, 5X, 10H DIMENSION, I5, 5X //)
- 70 FORMAT (5X, 33H INITIAL L2 NORM OF THE RESIDUALS, D15.7 // 5X,
- * 33H FINAL L2 NORM OF THE RESIDUALS , D15.7 // 5X,
- * 33H NUMBER OF FUNCTION EVALUATIONS , I10 // 5X,
- * 15H EXIT PARAMETER, 18X, I10 // 5X,
- * 27H FINAL APPROXIMATE SOLUTION // (5X, 5D15.7))
- 80 FORMAT (12H1SUMMARY OF , I3, 16H CALLS TO HYBRD1 /)
- 90 FORMAT (39H NPROB N NFEV INFO FINAL L2 NORM /)
- 100 FORMAT (I4, I6, I7, I6, 1X, D15.7)
-C
-C LAST CARD OF DRIVER.
-C
- END
- SUBROUTINE FCN(N,X,FVEC,IFLAG)
- INTEGER N,IFLAG
- DOUBLE PRECISION X(N),FVEC(N)
-C **********
-C
-C THE CALLING SEQUENCE OF FCN SHOULD BE IDENTICAL TO THE
-C CALLING SEQUENCE OF THE FUNCTION SUBROUTINE IN THE NONLINEAR
-C EQUATION SOLVER. FCN SHOULD ONLY CALL THE TESTING FUNCTION
-C SUBROUTINE VECFCN WITH THE APPROPRIATE VALUE OF PROBLEM
-C NUMBER (NPROB).
-C
-C SUBPROGRAMS CALLED
-C
-C MINPACK-SUPPLIED ... VECFCN
-C
-C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980.
-C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE
-C
-C **********
- INTEGER NPROB,NFEV
- COMMON /REFNUM/ NPROB,NFEV
- CALL VECFCN(N,X,FVEC,NPROB)
- NFEV = NFEV + 1
- RETURN
-C
-C LAST CARD OF INTERFACE SUBROUTINE FCN.
-C
- END
- SUBROUTINE VECFCN(N,X,FVEC,NPROB)
- INTEGER N,NPROB
- DOUBLE PRECISION X(N),FVEC(N)
-C **********
-C
-C SUBROUTINE VECFCN
-C
-C THIS SUBROUTINE DEFINES FOURTEEN TEST FUNCTIONS. THE FIRST
-C FIVE TEST FUNCTIONS ARE OF DIMENSIONS 2,4,2,4,3, RESPECTIVELY,
-C WHILE THE REMAINING TEST FUNCTIONS ARE OF VARIABLE DIMENSION
-C N FOR ANY N GREATER THAN OR EQUAL TO 1 (PROBLEM 6 IS AN
-C EXCEPTION TO THIS, SINCE IT DOES NOT ALLOW N = 1).
-C
-C THE SUBROUTINE STATEMENT IS
-C
-C SUBROUTINE VECFCN(N,X,FVEC,NPROB)
-C
-C WHERE
-C
-C N IS A POSITIVE INTEGER INPUT VARIABLE.
-C
-C X IS AN INPUT ARRAY OF LENGTH N.
-C
-C FVEC IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS THE NPROB
-C FUNCTION VECTOR EVALUATED AT X.
-C
-C NPROB IS A POSITIVE INTEGER INPUT VARIABLE WHICH DEFINES THE
-C NUMBER OF THE PROBLEM. NPROB MUST NOT EXCEED 14.
-C
-C SUBPROGRAMS CALLED
-C
-C FORTRAN-SUPPLIED ... DATAN,DCOS,DEXP,DSIGN,DSIN,DSQRT,
-C MAX0,MIN0
-C
-C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980.
-C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE
-C
-C **********
- INTEGER I,IEV,IVAR,J,K,K1,K2,KP1,ML,MU
- DOUBLE PRECISION C1,C2,C3,C4,C5,C6,C7,C8,C9,EIGHT,FIVE,H,ONE,
- * PROD,SUM,SUM1,SUM2,TEMP,TEMP1,TEMP2,TEN,THREE,
- * TI,TJ,TK,TPI,TWO,ZERO
- DOUBLE PRECISION DFLOAT
- DATA ZERO,ONE,TWO,THREE,FIVE,EIGHT,TEN
- * /0.0D0,1.0D0,2.0D0,3.0D0,5.0D0,8.0D0,1.0D1/
- DATA C1,C2,C3,C4,C5,C6,C7,C8,C9
- * /1.0D4,1.0001D0,2.0D2,2.02D1,1.98D1,1.8D2,2.5D-1,5.0D-1,
- * 2.9D1/
- DFLOAT(IVAR) = IVAR
-C
-C PROBLEM SELECTOR.
-C
- GO TO (10,20,30,40,50,60,120,170,200,220,270,300,330,350), NPROB
-C
-C ROSENBROCK FUNCTION.
-C
- 10 CONTINUE
- FVEC(1) = ONE - X(1)
- FVEC(2) = TEN*(X(2) - X(1)**2)
- GO TO 380
-C
-C POWELL SINGULAR FUNCTION.
-C
- 20 CONTINUE
- FVEC(1) = X(1) + TEN*X(2)
- FVEC(2) = DSQRT(FIVE)*(X(3) - X(4))
- FVEC(3) = (X(2) - TWO*X(3))**2
- FVEC(4) = DSQRT(TEN)*(X(1) - X(4))**2
- GO TO 380
-C
-C POWELL BADLY SCALED FUNCTION.
-C
- 30 CONTINUE
- FVEC(1) = C1*X(1)*X(2) - ONE
- FVEC(2) = DEXP(-X(1)) + DEXP(-X(2)) - C2
- GO TO 380
-C
-C WOOD FUNCTION.
-C
- 40 CONTINUE
- TEMP1 = X(2) - X(1)**2
- TEMP2 = X(4) - X(3)**2
- FVEC(1) = -C3*X(1)*TEMP1 - (ONE - X(1))
- FVEC(2) = C3*TEMP1 + C4*(X(2) - ONE) + C5*(X(4) - ONE)
- FVEC(3) = -C6*X(3)*TEMP2 - (ONE - X(3))
- FVEC(4) = C6*TEMP2 + C4*(X(4) - ONE) + C5*(X(2) - ONE)
- GO TO 380
-C
-C HELICAL VALLEY FUNCTION.
-C
- 50 CONTINUE
- TPI = EIGHT*DATAN(ONE)
- TEMP1 = DSIGN(C7,X(2))
- IF (X(1) .GT. ZERO) TEMP1 = DATAN(X(2)/X(1))/TPI
- IF (X(1) .LT. ZERO) TEMP1 = DATAN(X(2)/X(1))/TPI + C8
- TEMP2 = DSQRT(X(1)**2+X(2)**2)
- FVEC(1) = TEN*(X(3) - TEN*TEMP1)
- FVEC(2) = TEN*(TEMP2 - ONE)
- FVEC(3) = X(3)
- GO TO 380
-C
-C WATSON FUNCTION.
-C
- 60 CONTINUE
- DO 70 K = 1, N
- FVEC(K) = ZERO
- 70 CONTINUE
- DO 110 I = 1, 29
- TI = DFLOAT(I)/C9
- SUM1 = ZERO
- TEMP = ONE
- DO 80 J = 2, N
- SUM1 = SUM1 + DFLOAT(J-1)*TEMP*X(J)
- TEMP = TI*TEMP
- 80 CONTINUE
- SUM2 = ZERO
- TEMP = ONE
- DO 90 J = 1, N
- SUM2 = SUM2 + TEMP*X(J)
- TEMP = TI*TEMP
- 90 CONTINUE
- TEMP1 = SUM1 - SUM2**2 - ONE
- TEMP2 = TWO*TI*SUM2
- TEMP = ONE/TI
- DO 100 K = 1, N
- FVEC(K) = FVEC(K) + TEMP*(DFLOAT(K-1) - TEMP2)*TEMP1
- TEMP = TI*TEMP
- 100 CONTINUE
- 110 CONTINUE
- TEMP = X(2) - X(1)**2 - ONE
- FVEC(1) = FVEC(1) + X(1)*(ONE - TWO*TEMP)
- FVEC(2) = FVEC(2) + TEMP
- GO TO 380
-C
-C CHEBYQUAD FUNCTION.
-C
- 120 CONTINUE
- DO 130 K = 1, N
- FVEC(K) = ZERO
- 130 CONTINUE
- DO 150 J = 1, N
- TEMP1 = ONE
- TEMP2 = TWO*X(J) - ONE
- TEMP = TWO*TEMP2
- DO 140 I = 1, N
- FVEC(I) = FVEC(I) + TEMP2
- TI = TEMP*TEMP2 - TEMP1
- TEMP1 = TEMP2
- TEMP2 = TI
- 140 CONTINUE
- 150 CONTINUE
- TK = ONE/DFLOAT(N)
- IEV = -1
- DO 160 K = 1, N
- FVEC(K) = TK*FVEC(K)
- IF (IEV .GT. 0) FVEC(K) = FVEC(K) + ONE/(DFLOAT(K)**2 - ONE)
- IEV = -IEV
- 160 CONTINUE
- GO TO 380
-C
-C BROWN ALMOST-LINEAR FUNCTION.
-C
- 170 CONTINUE
- SUM = -DFLOAT(N+1)
- PROD = ONE
- DO 180 J = 1, N
- SUM = SUM + X(J)
- PROD = X(J)*PROD
- 180 CONTINUE
- DO 190 K = 1, N
- FVEC(K) = X(K) + SUM
- 190 CONTINUE
- FVEC(N) = PROD - ONE
- GO TO 380
-C
-C DISCRETE BOUNDARY VALUE FUNCTION.
-C
- 200 CONTINUE
- H = ONE/DFLOAT(N+1)
- DO 210 K = 1, N
- TEMP = (X(K) + DFLOAT(K)*H + ONE)**3
- TEMP1 = ZERO
- IF (K .NE. 1) TEMP1 = X(K-1)
- TEMP2 = ZERO
- IF (K .NE. N) TEMP2 = X(K+1)
- FVEC(K) = TWO*X(K) - TEMP1 - TEMP2 + TEMP*H**2/TWO
- 210 CONTINUE
- GO TO 380
-C
-C DISCRETE INTEGRAL EQUATION FUNCTION.
-C
- 220 CONTINUE
- H = ONE/DFLOAT(N+1)
- DO 260 K = 1, N
- TK = DFLOAT(K)*H
- SUM1 = ZERO
- DO 230 J = 1, K
- TJ = DFLOAT(J)*H
- TEMP = (X(J) + TJ + ONE)**3
- SUM1 = SUM1 + TJ*TEMP
- 230 CONTINUE
- SUM2 = ZERO
- KP1 = K + 1
- IF (N .LT. KP1) GO TO 250
- DO 240 J = KP1, N
- TJ = DFLOAT(J)*H
- TEMP = (X(J) + TJ + ONE)**3
- SUM2 = SUM2 + (ONE - TJ)*TEMP
- 240 CONTINUE
- 250 CONTINUE
- FVEC(K) = X(K) + H*((ONE - TK)*SUM1 + TK*SUM2)/TWO
- 260 CONTINUE
- GO TO 380
-C
-C TRIGONOMETRIC FUNCTION.
-C
- 270 CONTINUE
- SUM = ZERO
- DO 280 J = 1, N
- FVEC(J) = DCOS(X(J))
- SUM = SUM + FVEC(J)
- 280 CONTINUE
- DO 290 K = 1, N
- FVEC(K) = DFLOAT(N+K) - DSIN(X(K)) - SUM - DFLOAT(K)*FVEC(K)
- 290 CONTINUE
- GO TO 380
-C
-C VARIABLY DIMENSIONED FUNCTION.
-C
- 300 CONTINUE
- SUM = ZERO
- DO 310 J = 1, N
- SUM = SUM + DFLOAT(J)*(X(J) - ONE)
- 310 CONTINUE
- TEMP = SUM*(ONE + TWO*SUM**2)
- DO 320 K = 1, N
- FVEC(K) = X(K) - ONE + DFLOAT(K)*TEMP
- 320 CONTINUE
- GO TO 380
-C
-C BROYDEN TRIDIAGONAL FUNCTION.
-C
- 330 CONTINUE
- DO 340 K = 1, N
- TEMP = (THREE - TWO*X(K))*X(K)
- TEMP1 = ZERO
- IF (K .NE. 1) TEMP1 = X(K-1)
- TEMP2 = ZERO
- IF (K .NE. N) TEMP2 = X(K+1)
- FVEC(K) = TEMP - TEMP1 - TWO*TEMP2 + ONE
- 340 CONTINUE
- GO TO 380
-C
-C BROYDEN BANDED FUNCTION.
-C
- 350 CONTINUE
- ML = 5
- MU = 1
- DO 370 K = 1, N
- K1 = MAX0(1,K-ML)
- K2 = MIN0(K+MU,N)
- TEMP = ZERO
- DO 360 J = K1, K2
- IF (J .NE. K) TEMP = TEMP + X(J)*(ONE + X(J))
- 360 CONTINUE
- FVEC(K) = X(K)*(TWO + FIVE*X(K)**2) + ONE - TEMP
- 370 CONTINUE
- 380 CONTINUE
- RETURN
-C
-C LAST CARD OF SUBROUTINE VECFCN.
-C
- END
- SUBROUTINE INITPT(N,X,NPROB,FACTOR)
- INTEGER N,NPROB
- DOUBLE PRECISION FACTOR
- DOUBLE PRECISION X(N)
-C **********
-C
-C SUBROUTINE INITPT
-C
-C THIS SUBROUTINE SPECIFIES THE STANDARD STARTING POINTS FOR
-C THE FUNCTIONS DEFINED BY SUBROUTINE VECFCN. THE SUBROUTINE
-C RETURNS IN X A MULTIPLE (FACTOR) OF THE STANDARD STARTING
-C POINT. FOR THE SIXTH FUNCTION THE STANDARD STARTING POINT IS
-C ZERO, SO IN THIS CASE, IF FACTOR IS NOT UNITY, THEN THE
-C SUBROUTINE RETURNS THE VECTOR X(J) = FACTOR, J=1,...,N.
-C
-C THE SUBROUTINE STATEMENT IS
-C
-C SUBROUTINE INITPT(N,X,NPROB,FACTOR)
-C
-C WHERE
-C
-C N IS A POSITIVE INTEGER INPUT VARIABLE.
-C
-C X IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS THE STANDARD
-C STARTING POINT FOR PROBLEM NPROB MULTIPLIED BY FACTOR.
-C
-C NPROB IS A POSITIVE INTEGER INPUT VARIABLE WHICH DEFINES THE
-C NUMBER OF THE PROBLEM. NPROB MUST NOT EXCEED 14.
-C
-C FACTOR IS AN INPUT VARIABLE WHICH SPECIFIES THE MULTIPLE OF
-C THE STANDARD STARTING POINT. IF FACTOR IS UNITY, NO
-C MULTIPLICATION IS PERFORMED.
-C
-C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980.
-C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE
-C
-C **********
- INTEGER IVAR,J
- DOUBLE PRECISION C1,H,HALF,ONE,THREE,TJ,ZERO
- DOUBLE PRECISION DFLOAT
- DATA ZERO,HALF,ONE,THREE,C1 /0.0D0,5.0D-1,1.0D0,3.0D0,1.2D0/
- DFLOAT(IVAR) = IVAR
-C
-C SELECTION OF INITIAL POINT.
-C
- GO TO (10,20,30,40,50,60,80,100,120,120,140,160,180,180), NPROB
-C
-C ROSENBROCK FUNCTION.
-C
- 10 CONTINUE
- X(1) = -C1
- X(2) = ONE
- GO TO 200
-C
-C POWELL SINGULAR FUNCTION.
-C
- 20 CONTINUE
- X(1) = THREE
- X(2) = -ONE
- X(3) = ZERO
- X(4) = ONE
- GO TO 200
-C
-C POWELL BADLY SCALED FUNCTION.
-C
- 30 CONTINUE
- X(1) = ZERO
- X(2) = ONE
- GO TO 200
-C
-C WOOD FUNCTION.
-C
- 40 CONTINUE
- X(1) = -THREE
- X(2) = -ONE
- X(3) = -THREE
- X(4) = -ONE
- GO TO 200
-C
-C HELICAL VALLEY FUNCTION.
-C
- 50 CONTINUE
- X(1) = -ONE
- X(2) = ZERO
- X(3) = ZERO
- GO TO 200
-C
-C WATSON FUNCTION.
-C
- 60 CONTINUE
- DO 70 J = 1, N
- X(J) = ZERO
- 70 CONTINUE
- GO TO 200
-C
-C CHEBYQUAD FUNCTION.
-C
- 80 CONTINUE
- H = ONE/DFLOAT(N+1)
- DO 90 J = 1, N
- X(J) = DFLOAT(J)*H
- 90 CONTINUE
- GO TO 200
-C
-C BROWN ALMOST-LINEAR FUNCTION.
-C
- 100 CONTINUE
- DO 110 J = 1, N
- X(J) = HALF
- 110 CONTINUE
- GO TO 200
-C
-C DISCRETE BOUNDARY VALUE AND INTEGRAL EQUATION FUNCTIONS.
-C
- 120 CONTINUE
- H = ONE/DFLOAT(N+1)
- DO 130 J = 1, N
- TJ = DFLOAT(J)*H
- X(J) = TJ*(TJ - ONE)
- 130 CONTINUE
- GO TO 200
-C
-C TRIGONOMETRIC FUNCTION.
-C
- 140 CONTINUE
- H = ONE/DFLOAT(N)
- DO 150 J = 1, N
- X(J) = H
- 150 CONTINUE
- GO TO 200
-C
-C VARIABLY DIMENSIONED FUNCTION.
-C
- 160 CONTINUE
- H = ONE/DFLOAT(N)
- DO 170 J = 1, N
- X(J) = ONE - DFLOAT(J)*H
- 170 CONTINUE
- GO TO 200
-C
-C BROYDEN TRIDIAGONAL AND BANDED FUNCTIONS.
-C
- 180 CONTINUE
- DO 190 J = 1, N
- X(J) = -ONE
- 190 CONTINUE
- 200 CONTINUE
-C
-C COMPUTE MULTIPLE OF INITIAL POINT.
-C
- IF (FACTOR .EQ. ONE) GO TO 250
- IF (NPROB .EQ. 6) GO TO 220
- DO 210 J = 1, N
- X(J) = FACTOR*X(J)
- 210 CONTINUE
- GO TO 240
- 220 CONTINUE
- DO 230 J = 1, N
- X(J) = FACTOR
- 230 CONTINUE
- 240 CONTINUE
- 250 CONTINUE
- RETURN
-C
-C LAST CARD OF SUBROUTINE INITPT.
-C
- END
diff --git a/CEP/PyBDSM/src/minpack/ex/file16 b/CEP/PyBDSM/src/minpack/ex/file16
deleted file mode 100644
index 165efe3f9ca0ca858ae1fc82f3e1b656c643e550..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/minpack/ex/file16
+++ /dev/null
@@ -1,881 +0,0 @@
-C **********
-C
-C THIS PROGRAM TESTS CODES FOR THE SOLUTION OF N NONLINEAR
-C EQUATIONS IN N VARIABLES. IT CONSISTS OF A DRIVER AND AN
-C INTERFACE SUBROUTINE FCN. THE DRIVER READS IN DATA, CALLS THE
-C NONLINEAR EQUATION SOLVER, AND FINALLY PRINTS OUT INFORMATION
-C ON THE PERFORMANCE OF THE SOLVER. THIS IS ONLY A SAMPLE DRIVER,
-C MANY OTHER DRIVERS ARE POSSIBLE. THE INTERFACE SUBROUTINE FCN
-C IS NECESSARY TO TAKE INTO ACCOUNT THE FORMS OF CALLING
-C SEQUENCES USED BY THE FUNCTION AND JACOBIAN SUBROUTINES IN
-C THE VARIOUS NONLINEAR EQUATION SOLVERS.
-C
-C SUBPROGRAMS CALLED
-C
-C USER-SUPPLIED ...... FCN
-C
-C MINPACK-SUPPLIED ... DPMPAR,ENORM,HYBRJ1,INITPT,VECFCN
-C
-C FORTRAN-SUPPLIED ... DSQRT
-C
-C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980.
-C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE
-C
-C **********
- INTEGER I,IC,INFO,K,LDFJAC,LWA,N,NFEV,NJEV,NPROB,NREAD,NTRIES,
- 1 NWRITE
- INTEGER NA(60),NF(60),NJ(60),NP(60),NX(60)
- DOUBLE PRECISION FACTOR,FNORM1,FNORM2,ONE,TEN,TOL
- DOUBLE PRECISION FNM(60),FJAC(40,40),FVEC(40),WA(1060),X(40)
- DOUBLE PRECISION DPMPAR,ENORM
- EXTERNAL FCN
- COMMON /REFNUM/ NPROB,NFEV,NJEV
-C
-C LOGICAL INPUT UNIT IS ASSUMED TO BE NUMBER 5.
-C LOGICAL OUTPUT UNIT IS ASSUMED TO BE NUMBER 6.
-C
- DATA NREAD,NWRITE /5,6/
-C
- DATA ONE,TEN /1.0D0,1.0D1/
- TOL = DSQRT(DPMPAR(1))
- LDFJAC = 40
- LWA = 1060
- IC = 0
- 10 CONTINUE
- READ (NREAD,50) NPROB,N,NTRIES
- IF (NPROB .LE. 0) GO TO 30
- FACTOR = ONE
- DO 20 K = 1, NTRIES
- IC = IC + 1
- CALL INITPT(N,X,NPROB,FACTOR)
- CALL VECFCN(N,X,FVEC,NPROB)
- FNORM1 = ENORM(N,FVEC)
- WRITE (NWRITE,60) NPROB,N
- NFEV = 0
- NJEV = 0
- CALL HYBRJ1(FCN,N,X,FVEC,FJAC,LDFJAC,TOL,INFO,WA,LWA)
- FNORM2 = ENORM(N,FVEC)
- NP(IC) = NPROB
- NA(IC) = N
- NF(IC) = NFEV
- NJ(IC) = NJEV
- NX(IC) = INFO
- FNM(IC) = FNORM2
- WRITE (NWRITE,70)
- 1 FNORM1,FNORM2,NFEV,NJEV,INFO,(X(I), I = 1, N)
- FACTOR = TEN*FACTOR
- 20 CONTINUE
- GO TO 10
- 30 CONTINUE
- WRITE (NWRITE,80) IC
- WRITE (NWRITE,90)
- DO 40 I = 1, IC
- WRITE (NWRITE,100) NP(I),NA(I),NF(I),NJ(I),NX(I),FNM(I)
- 40 CONTINUE
- STOP
- 50 FORMAT (3I5)
- 60 FORMAT ( //// 5X, 8H PROBLEM, I5, 5X, 10H DIMENSION, I5, 5X //)
- 70 FORMAT (5X, 33H INITIAL L2 NORM OF THE RESIDUALS, D15.7 // 5X,
- 1 33H FINAL L2 NORM OF THE RESIDUALS , D15.7 // 5X,
- 2 33H NUMBER OF FUNCTION EVALUATIONS , I10 // 5X,
- 3 33H NUMBER OF JACOBIAN EVALUATIONS , I10 // 5X,
- 4 15H EXIT PARAMETER, 18X, I10 // 5X,
- 5 27H FINAL APPROXIMATE SOLUTION // (5X, 5D15.7))
- 80 FORMAT (12H1SUMMARY OF , I3, 16H CALLS TO HYBRJ1 /)
- 90 FORMAT (46H NPROB N NFEV NJEV INFO FINAL L2 NORM /)
- 100 FORMAT (I4, I6, 2I7, I6, 1X, D15.7)
-C
-C LAST CARD OF DRIVER.
-C
- END
- SUBROUTINE FCN(N,X,FVEC,FJAC,LDFJAC,IFLAG)
- INTEGER N,LDFJAC,IFLAG
- DOUBLE PRECISION X(N),FVEC(N),FJAC(LDFJAC,N)
-C **********
-C
-C THE CALLING SEQUENCE OF FCN SHOULD BE IDENTICAL TO THE
-C CALLING SEQUENCE OF THE FUNCTION SUBROUTINE IN THE NONLINEAR
-C EQUATION SOLVER. FCN SHOULD ONLY CALL THE TESTING FUNCTION
-C AND JACOBIAN SUBROUTINES VECFCN AND VECJAC WITH THE
-C APPROPRIATE VALUE OF PROBLEM NUMBER (NPROB).
-C
-C SUBPROGRAMS CALLED
-C
-C MINPACK-SUPPLIED ... VECFCN,VECJAC
-C
-C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980.
-C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE
-C
-C **********
- INTEGER NPROB,NFEV,NJEV
- COMMON /REFNUM/ NPROB,NFEV,NJEV
- IF (IFLAG .EQ. 1) CALL VECFCN(N,X,FVEC,NPROB)
- IF (IFLAG .EQ. 2) CALL VECJAC(N,X,FJAC,LDFJAC,NPROB)
- IF (IFLAG .EQ. 1) NFEV = NFEV + 1
- IF (IFLAG .EQ. 2) NJEV = NJEV + 1
- RETURN
-C
-C LAST CARD OF INTERFACE SUBROUTINE FCN.
-C
- END
- SUBROUTINE VECJAC(N,X,FJAC,LDFJAC,NPROB)
- INTEGER N,LDFJAC,NPROB
- DOUBLE PRECISION X(N),FJAC(LDFJAC,N)
-C **********
-C
-C SUBROUTINE VECJAC
-C
-C THIS SUBROUTINE DEFINES THE JACOBIAN MATRICES OF FOURTEEN
-C TEST FUNCTIONS. THE PROBLEM DIMENSIONS ARE AS DESCRIBED
-C IN THE PROLOGUE COMMENTS OF VECFCN.
-C
-C THE SUBROUTINE STATEMENT IS
-C
-C SUBROUTINE VECJAC(N,X,FJAC,LDFJAC,NPROB)
-C
-C WHERE
-C
-C N IS A POSITIVE INTEGER VARIABLE.
-C
-C X IS AN ARRAY OF LENGTH N.
-C
-C FJAC IS AN N BY N ARRAY. ON OUTPUT FJAC CONTAINS THE
-C JACOBIAN MATRIX OF THE NPROB FUNCTION EVALUATED AT X.
-C
-C LDFJAC IS A POSITIVE INTEGER VARIABLE NOT LESS THAN N
-C WHICH SPECIFIES THE LEADING DIMENSION OF THE ARRAY FJAC.
-C
-C NPROB IS A POSITIVE INTEGER VARIABLE WHICH DEFINES THE
-C NUMBER OF THE PROBLEM. NPROB MUST NOT EXCEED 14.
-C
-C SUBPROGRAMS CALLED
-C
-C FORTRAN-SUPPLIED ... DATAN,DCOS,DEXP,DMIN1,DSIN,DSQRT,
-C MAX0,MIN0
-C
-C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980.
-C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE
-C
-C **********
- INTEGER I,IVAR,J,K,K1,K2,ML,MU
- DOUBLE PRECISION C1,C3,C4,C5,C6,C9,EIGHT,FIFTN,FIVE,FOUR,H,
- * HUNDRD,ONE,PROD,SIX,SUM,SUM1,SUM2,TEMP,TEMP1,
- * TEMP2,TEMP3,TEMP4,TEN,THREE,TI,TJ,TK,TPI,
- * TWENTY,TWO,ZERO
- DOUBLE PRECISION DFLOAT
- DATA ZERO,ONE,TWO,THREE,FOUR,FIVE,SIX,EIGHT,TEN,FIFTN,TWENTY,
- * HUNDRD
- * /0.0D0,1.0D0,2.0D0,3.0D0,4.0D0,5.0D0,6.0D0,8.0D0,1.0D1,
- * 1.5D1,2.0D1,1.0D2/
- DATA C1,C3,C4,C5,C6,C9 /1.0D4,2.0D2,2.02D1,1.98D1,1.8D2,2.9D1/
- DFLOAT(IVAR) = IVAR
-C
-C JACOBIAN ROUTINE SELECTOR.
-C
- GO TO (10,20,50,60,90,100,200,230,290,320,350,380,420,450),
- * NPROB
-C
-C ROSENBROCK FUNCTION.
-C
- 10 CONTINUE
- FJAC(1,1) = -ONE
- FJAC(1,2) = ZERO
- FJAC(2,1) = -TWENTY*X(1)
- FJAC(2,2) = TEN
- GO TO 490
-C
-C POWELL SINGULAR FUNCTION.
-C
- 20 CONTINUE
- DO 40 K = 1, 4
- DO 30 J = 1, 4
- FJAC(K,J) = ZERO
- 30 CONTINUE
- 40 CONTINUE
- FJAC(1,1) = ONE
- FJAC(1,2) = TEN
- FJAC(2,3) = DSQRT(FIVE)
- FJAC(2,4) = -FJAC(2,3)
- FJAC(3,2) = TWO*(X(2) - TWO*X(3))
- FJAC(3,3) = -TWO*FJAC(3,2)
- FJAC(4,1) = TWO*DSQRT(TEN)*(X(1) - X(4))
- FJAC(4,4) = -FJAC(4,1)
- GO TO 490
-C
-C POWELL BADLY SCALED FUNCTION.
-C
- 50 CONTINUE
- FJAC(1,1) = C1*X(2)
- FJAC(1,2) = C1*X(1)
- FJAC(2,1) = -DEXP(-X(1))
- FJAC(2,2) = -DEXP(-X(2))
- GO TO 490
-C
-C WOOD FUNCTION.
-C
- 60 CONTINUE
- DO 80 K = 1, 4
- DO 70 J = 1, 4
- FJAC(K,J) = ZERO
- 70 CONTINUE
- 80 CONTINUE
- TEMP1 = X(2) - THREE*X(1)**2
- TEMP2 = X(4) - THREE*X(3)**2
- FJAC(1,1) = -C3*TEMP1 + ONE
- FJAC(1,2) = -C3*X(1)
- FJAC(2,1) = -TWO*C3*X(1)
- FJAC(2,2) = C3 + C4
- FJAC(2,4) = C5
- FJAC(3,3) = -C6*TEMP2 + ONE
- FJAC(3,4) = -C6*X(3)
- FJAC(4,2) = C5
- FJAC(4,3) = -TWO*C6*X(3)
- FJAC(4,4) = C6 + C4
- GO TO 490
-C
-C HELICAL VALLEY FUNCTION.
-C
- 90 CONTINUE
- TPI = EIGHT*DATAN(ONE)
- TEMP = X(1)**2 + X(2)**2
- TEMP1 = TPI*TEMP
- TEMP2 = DSQRT(TEMP)
- FJAC(1,1) = HUNDRD*X(2)/TEMP1
- FJAC(1,2) = -HUNDRD*X(1)/TEMP1
- FJAC(1,3) = TEN
- FJAC(2,1) = TEN*X(1)/TEMP2
- FJAC(2,2) = TEN*X(2)/TEMP2
- FJAC(2,3) = ZERO
- FJAC(3,1) = ZERO
- FJAC(3,2) = ZERO
- FJAC(3,3) = ONE
- GO TO 490
-C
-C WATSON FUNCTION.
-C
- 100 CONTINUE
- DO 120 K = 1, N
- DO 110 J = K, N
- FJAC(K,J) = ZERO
- 110 CONTINUE
- 120 CONTINUE
- DO 170 I = 1, 29
- TI = DFLOAT(I)/C9
- SUM1 = ZERO
- TEMP = ONE
- DO 130 J = 2, N
- SUM1 = SUM1 + DFLOAT(J-1)*TEMP*X(J)
- TEMP = TI*TEMP
- 130 CONTINUE
- SUM2 = ZERO
- TEMP = ONE
- DO 140 J = 1, N
- SUM2 = SUM2 + TEMP*X(J)
- TEMP = TI*TEMP
- 140 CONTINUE
- TEMP1 = TWO*(SUM1 - SUM2**2 - ONE)
- TEMP2 = TWO*SUM2
- TEMP = TI**2
- TK = ONE
- DO 160 K = 1, N
- TJ = TK
- DO 150 J = K, N
- FJAC(K,J) = FJAC(K,J)
- * + TJ
- * *((DFLOAT(K-1)/TI - TEMP2)
- * *(DFLOAT(J-1)/TI - TEMP2) - TEMP1)
- TJ = TI*TJ
- 150 CONTINUE
- TK = TEMP*TK
- 160 CONTINUE
- 170 CONTINUE
- FJAC(1,1) = FJAC(1,1) + SIX*X(1)**2 - TWO*X(2) + THREE
- FJAC(1,2) = FJAC(1,2) - TWO*X(1)
- FJAC(2,2) = FJAC(2,2) + ONE
- DO 190 K = 1, N
- DO 180 J = K, N
- FJAC(J,K) = FJAC(K,J)
- 180 CONTINUE
- 190 CONTINUE
- GO TO 490
-C
-C CHEBYQUAD FUNCTION.
-C
- 200 CONTINUE
- TK = ONE/DFLOAT(N)
- DO 220 J = 1, N
- TEMP1 = ONE
- TEMP2 = TWO*X(J) - ONE
- TEMP = TWO*TEMP2
- TEMP3 = ZERO
- TEMP4 = TWO
- DO 210 K = 1, N
- FJAC(K,J) = TK*TEMP4
- TI = FOUR*TEMP2 + TEMP*TEMP4 - TEMP3
- TEMP3 = TEMP4
- TEMP4 = TI
- TI = TEMP*TEMP2 - TEMP1
- TEMP1 = TEMP2
- TEMP2 = TI
- 210 CONTINUE
- 220 CONTINUE
- GO TO 490
-C
-C BROWN ALMOST-LINEAR FUNCTION.
-C
- 230 CONTINUE
- PROD = ONE
- DO 250 J = 1, N
- PROD = X(J)*PROD
- DO 240 K = 1, N
- FJAC(K,J) = ONE
- 240 CONTINUE
- FJAC(J,J) = TWO
- 250 CONTINUE
- DO 280 J = 1, N
- TEMP = X(J)
- IF (TEMP .NE. ZERO) GO TO 270
- TEMP = ONE
- PROD = ONE
- DO 260 K = 1, N
- IF (K .NE. J) PROD = X(K)*PROD
- 260 CONTINUE
- 270 CONTINUE
- FJAC(N,J) = PROD/TEMP
- 280 CONTINUE
- GO TO 490
-C
-C DISCRETE BOUNDARY VALUE FUNCTION.
-C
- 290 CONTINUE
- H = ONE/DFLOAT(N+1)
- DO 310 K = 1, N
- TEMP = THREE*(X(K) + DFLOAT(K)*H + ONE)**2
- DO 300 J = 1, N
- FJAC(K,J) = ZERO
- 300 CONTINUE
- FJAC(K,K) = TWO + TEMP*H**2/TWO
- IF (K .NE. 1) FJAC(K,K-1) = -ONE
- IF (K .NE. N) FJAC(K,K+1) = -ONE
- 310 CONTINUE
- GO TO 490
-C
-C DISCRETE INTEGRAL EQUATION FUNCTION.
-C
- 320 CONTINUE
- H = ONE/DFLOAT(N+1)
- DO 340 K = 1, N
- TK = DFLOAT(K)*H
- DO 330 J = 1, N
- TJ = DFLOAT(J)*H
- TEMP = THREE*(X(J) + TJ + ONE)**2
- FJAC(K,J) = H*DMIN1(TJ*(ONE-TK),TK*(ONE-TJ))*TEMP/TWO
- 330 CONTINUE
- FJAC(K,K) = FJAC(K,K) + ONE
- 340 CONTINUE
- GO TO 490
-C
-C TRIGONOMETRIC FUNCTION.
-C
- 350 CONTINUE
- DO 370 J = 1, N
- TEMP = DSIN(X(J))
- DO 360 K = 1, N
- FJAC(K,J) = TEMP
- 360 CONTINUE
- FJAC(J,J) = DFLOAT(J+1)*TEMP - DCOS(X(J))
- 370 CONTINUE
- GO TO 490
-C
-C VARIABLY DIMENSIONED FUNCTION.
-C
- 380 CONTINUE
- SUM = ZERO
- DO 390 J = 1, N
- SUM = SUM + DFLOAT(J)*(X(J) - ONE)
- 390 CONTINUE
- TEMP = ONE + SIX*SUM**2
- DO 410 K = 1, N
- DO 400 J = K, N
- FJAC(K,J) = DFLOAT(K*J)*TEMP
- FJAC(J,K) = FJAC(K,J)
- 400 CONTINUE
- FJAC(K,K) = FJAC(K,K) + ONE
- 410 CONTINUE
- GO TO 490
-C
-C BROYDEN TRIDIAGONAL FUNCTION.
-C
- 420 CONTINUE
- DO 440 K = 1, N
- DO 430 J = 1, N
- FJAC(K,J) = ZERO
- 430 CONTINUE
- FJAC(K,K) = THREE - FOUR*X(K)
- IF (K .NE. 1) FJAC(K,K-1) = -ONE
- IF (K .NE. N) FJAC(K,K+1) = -TWO
- 440 CONTINUE
- GO TO 490
-C
-C BROYDEN BANDED FUNCTION.
-C
- 450 CONTINUE
- ML = 5
- MU = 1
- DO 480 K = 1, N
- DO 460 J = 1, N
- FJAC(K,J) = ZERO
- 460 CONTINUE
- K1 = MAX0(1,K-ML)
- K2 = MIN0(K+MU,N)
- DO 470 J = K1, K2
- IF (J .NE. K) FJAC(K,J) = -(ONE + TWO*X(J))
- 470 CONTINUE
- FJAC(K,K) = TWO + FIFTN*X(K)**2
- 480 CONTINUE
- 490 CONTINUE
- RETURN
-C
-C LAST CARD OF SUBROUTINE VECJAC.
-C
- END
- SUBROUTINE INITPT(N,X,NPROB,FACTOR)
- INTEGER N,NPROB
- DOUBLE PRECISION FACTOR
- DOUBLE PRECISION X(N)
-C **********
-C
-C SUBROUTINE INITPT
-C
-C THIS SUBROUTINE SPECIFIES THE STANDARD STARTING POINTS FOR
-C THE FUNCTIONS DEFINED BY SUBROUTINE VECFCN. THE SUBROUTINE
-C RETURNS IN X A MULTIPLE (FACTOR) OF THE STANDARD STARTING
-C POINT. FOR THE SIXTH FUNCTION THE STANDARD STARTING POINT IS
-C ZERO, SO IN THIS CASE, IF FACTOR IS NOT UNITY, THEN THE
-C SUBROUTINE RETURNS THE VECTOR X(J) = FACTOR, J=1,...,N.
-C
-C THE SUBROUTINE STATEMENT IS
-C
-C SUBROUTINE INITPT(N,X,NPROB,FACTOR)
-C
-C WHERE
-C
-C N IS A POSITIVE INTEGER INPUT VARIABLE.
-C
-C X IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS THE STANDARD
-C STARTING POINT FOR PROBLEM NPROB MULTIPLIED BY FACTOR.
-C
-C NPROB IS A POSITIVE INTEGER INPUT VARIABLE WHICH DEFINES THE
-C NUMBER OF THE PROBLEM. NPROB MUST NOT EXCEED 14.
-C
-C FACTOR IS AN INPUT VARIABLE WHICH SPECIFIES THE MULTIPLE OF
-C THE STANDARD STARTING POINT. IF FACTOR IS UNITY, NO
-C MULTIPLICATION IS PERFORMED.
-C
-C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980.
-C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE
-C
-C **********
- INTEGER IVAR,J
- DOUBLE PRECISION C1,H,HALF,ONE,THREE,TJ,ZERO
- DOUBLE PRECISION DFLOAT
- DATA ZERO,HALF,ONE,THREE,C1 /0.0D0,5.0D-1,1.0D0,3.0D0,1.2D0/
- DFLOAT(IVAR) = IVAR
-C
-C SELECTION OF INITIAL POINT.
-C
- GO TO (10,20,30,40,50,60,80,100,120,120,140,160,180,180), NPROB
-C
-C ROSENBROCK FUNCTION.
-C
- 10 CONTINUE
- X(1) = -C1
- X(2) = ONE
- GO TO 200
-C
-C POWELL SINGULAR FUNCTION.
-C
- 20 CONTINUE
- X(1) = THREE
- X(2) = -ONE
- X(3) = ZERO
- X(4) = ONE
- GO TO 200
-C
-C POWELL BADLY SCALED FUNCTION.
-C
- 30 CONTINUE
- X(1) = ZERO
- X(2) = ONE
- GO TO 200
-C
-C WOOD FUNCTION.
-C
- 40 CONTINUE
- X(1) = -THREE
- X(2) = -ONE
- X(3) = -THREE
- X(4) = -ONE
- GO TO 200
-C
-C HELICAL VALLEY FUNCTION.
-C
- 50 CONTINUE
- X(1) = -ONE
- X(2) = ZERO
- X(3) = ZERO
- GO TO 200
-C
-C WATSON FUNCTION.
-C
- 60 CONTINUE
- DO 70 J = 1, N
- X(J) = ZERO
- 70 CONTINUE
- GO TO 200
-C
-C CHEBYQUAD FUNCTION.
-C
- 80 CONTINUE
- H = ONE/DFLOAT(N+1)
- DO 90 J = 1, N
- X(J) = DFLOAT(J)*H
- 90 CONTINUE
- GO TO 200
-C
-C BROWN ALMOST-LINEAR FUNCTION.
-C
- 100 CONTINUE
- DO 110 J = 1, N
- X(J) = HALF
- 110 CONTINUE
- GO TO 200
-C
-C DISCRETE BOUNDARY VALUE AND INTEGRAL EQUATION FUNCTIONS.
-C
- 120 CONTINUE
- H = ONE/DFLOAT(N+1)
- DO 130 J = 1, N
- TJ = DFLOAT(J)*H
- X(J) = TJ*(TJ - ONE)
- 130 CONTINUE
- GO TO 200
-C
-C TRIGONOMETRIC FUNCTION.
-C
- 140 CONTINUE
- H = ONE/DFLOAT(N)
- DO 150 J = 1, N
- X(J) = H
- 150 CONTINUE
- GO TO 200
-C
-C VARIABLY DIMENSIONED FUNCTION.
-C
- 160 CONTINUE
- H = ONE/DFLOAT(N)
- DO 170 J = 1, N
- X(J) = ONE - DFLOAT(J)*H
- 170 CONTINUE
- GO TO 200
-C
-C BROYDEN TRIDIAGONAL AND BANDED FUNCTIONS.
-C
- 180 CONTINUE
- DO 190 J = 1, N
- X(J) = -ONE
- 190 CONTINUE
- 200 CONTINUE
-C
-C COMPUTE MULTIPLE OF INITIAL POINT.
-C
- IF (FACTOR .EQ. ONE) GO TO 250
- IF (NPROB .EQ. 6) GO TO 220
- DO 210 J = 1, N
- X(J) = FACTOR*X(J)
- 210 CONTINUE
- GO TO 240
- 220 CONTINUE
- DO 230 J = 1, N
- X(J) = FACTOR
- 230 CONTINUE
- 240 CONTINUE
- 250 CONTINUE
- RETURN
-C
-C LAST CARD OF SUBROUTINE INITPT.
-C
- END
- SUBROUTINE VECFCN(N,X,FVEC,NPROB)
- INTEGER N,NPROB
- DOUBLE PRECISION X(N),FVEC(N)
-C **********
-C
-C SUBROUTINE VECFCN
-C
-C THIS SUBROUTINE DEFINES FOURTEEN TEST FUNCTIONS. THE FIRST
-C FIVE TEST FUNCTIONS ARE OF DIMENSIONS 2,4,2,4,3, RESPECTIVELY,
-C WHILE THE REMAINING TEST FUNCTIONS ARE OF VARIABLE DIMENSION
-C N FOR ANY N GREATER THAN OR EQUAL TO 1 (PROBLEM 6 IS AN
-C EXCEPTION TO THIS, SINCE IT DOES NOT ALLOW N = 1).
-C
-C THE SUBROUTINE STATEMENT IS
-C
-C SUBROUTINE VECFCN(N,X,FVEC,NPROB)
-C
-C WHERE
-C
-C N IS A POSITIVE INTEGER INPUT VARIABLE.
-C
-C X IS AN INPUT ARRAY OF LENGTH N.
-C
-C FVEC IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS THE NPROB
-C FUNCTION VECTOR EVALUATED AT X.
-C
-C NPROB IS A POSITIVE INTEGER INPUT VARIABLE WHICH DEFINES THE
-C NUMBER OF THE PROBLEM. NPROB MUST NOT EXCEED 14.
-C
-C SUBPROGRAMS CALLED
-C
-C FORTRAN-SUPPLIED ... DATAN,DCOS,DEXP,DSIGN,DSIN,DSQRT,
-C MAX0,MIN0
-C
-C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980.
-C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE
-C
-C **********
- INTEGER I,IEV,IVAR,J,K,K1,K2,KP1,ML,MU
- DOUBLE PRECISION C1,C2,C3,C4,C5,C6,C7,C8,C9,EIGHT,FIVE,H,ONE,
- * PROD,SUM,SUM1,SUM2,TEMP,TEMP1,TEMP2,TEN,THREE,
- * TI,TJ,TK,TPI,TWO,ZERO
- DOUBLE PRECISION DFLOAT
- DATA ZERO,ONE,TWO,THREE,FIVE,EIGHT,TEN
- * /0.0D0,1.0D0,2.0D0,3.0D0,5.0D0,8.0D0,1.0D1/
- DATA C1,C2,C3,C4,C5,C6,C7,C8,C9
- * /1.0D4,1.0001D0,2.0D2,2.02D1,1.98D1,1.8D2,2.5D-1,5.0D-1,
- * 2.9D1/
- DFLOAT(IVAR) = IVAR
-C
-C PROBLEM SELECTOR.
-C
- GO TO (10,20,30,40,50,60,120,170,200,220,270,300,330,350), NPROB
-C
-C ROSENBROCK FUNCTION.
-C
- 10 CONTINUE
- FVEC(1) = ONE - X(1)
- FVEC(2) = TEN*(X(2) - X(1)**2)
- GO TO 380
-C
-C POWELL SINGULAR FUNCTION.
-C
- 20 CONTINUE
- FVEC(1) = X(1) + TEN*X(2)
- FVEC(2) = DSQRT(FIVE)*(X(3) - X(4))
- FVEC(3) = (X(2) - TWO*X(3))**2
- FVEC(4) = DSQRT(TEN)*(X(1) - X(4))**2
- GO TO 380
-C
-C POWELL BADLY SCALED FUNCTION.
-C
- 30 CONTINUE
- FVEC(1) = C1*X(1)*X(2) - ONE
- FVEC(2) = DEXP(-X(1)) + DEXP(-X(2)) - C2
- GO TO 380
-C
-C WOOD FUNCTION.
-C
- 40 CONTINUE
- TEMP1 = X(2) - X(1)**2
- TEMP2 = X(4) - X(3)**2
- FVEC(1) = -C3*X(1)*TEMP1 - (ONE - X(1))
- FVEC(2) = C3*TEMP1 + C4*(X(2) - ONE) + C5*(X(4) - ONE)
- FVEC(3) = -C6*X(3)*TEMP2 - (ONE - X(3))
- FVEC(4) = C6*TEMP2 + C4*(X(4) - ONE) + C5*(X(2) - ONE)
- GO TO 380
-C
-C HELICAL VALLEY FUNCTION.
-C
- 50 CONTINUE
- TPI = EIGHT*DATAN(ONE)
- TEMP1 = DSIGN(C7,X(2))
- IF (X(1) .GT. ZERO) TEMP1 = DATAN(X(2)/X(1))/TPI
- IF (X(1) .LT. ZERO) TEMP1 = DATAN(X(2)/X(1))/TPI + C8
- TEMP2 = DSQRT(X(1)**2+X(2)**2)
- FVEC(1) = TEN*(X(3) - TEN*TEMP1)
- FVEC(2) = TEN*(TEMP2 - ONE)
- FVEC(3) = X(3)
- GO TO 380
-C
-C WATSON FUNCTION.
-C
- 60 CONTINUE
- DO 70 K = 1, N
- FVEC(K) = ZERO
- 70 CONTINUE
- DO 110 I = 1, 29
- TI = DFLOAT(I)/C9
- SUM1 = ZERO
- TEMP = ONE
- DO 80 J = 2, N
- SUM1 = SUM1 + DFLOAT(J-1)*TEMP*X(J)
- TEMP = TI*TEMP
- 80 CONTINUE
- SUM2 = ZERO
- TEMP = ONE
- DO 90 J = 1, N
- SUM2 = SUM2 + TEMP*X(J)
- TEMP = TI*TEMP
- 90 CONTINUE
- TEMP1 = SUM1 - SUM2**2 - ONE
- TEMP2 = TWO*TI*SUM2
- TEMP = ONE/TI
- DO 100 K = 1, N
- FVEC(K) = FVEC(K) + TEMP*(DFLOAT(K-1) - TEMP2)*TEMP1
- TEMP = TI*TEMP
- 100 CONTINUE
- 110 CONTINUE
- TEMP = X(2) - X(1)**2 - ONE
- FVEC(1) = FVEC(1) + X(1)*(ONE - TWO*TEMP)
- FVEC(2) = FVEC(2) + TEMP
- GO TO 380
-C
-C CHEBYQUAD FUNCTION.
-C
- 120 CONTINUE
- DO 130 K = 1, N
- FVEC(K) = ZERO
- 130 CONTINUE
- DO 150 J = 1, N
- TEMP1 = ONE
- TEMP2 = TWO*X(J) - ONE
- TEMP = TWO*TEMP2
- DO 140 I = 1, N
- FVEC(I) = FVEC(I) + TEMP2
- TI = TEMP*TEMP2 - TEMP1
- TEMP1 = TEMP2
- TEMP2 = TI
- 140 CONTINUE
- 150 CONTINUE
- TK = ONE/DFLOAT(N)
- IEV = -1
- DO 160 K = 1, N
- FVEC(K) = TK*FVEC(K)
- IF (IEV .GT. 0) FVEC(K) = FVEC(K) + ONE/(DFLOAT(K)**2 - ONE)
- IEV = -IEV
- 160 CONTINUE
- GO TO 380
-C
-C BROWN ALMOST-LINEAR FUNCTION.
-C
- 170 CONTINUE
- SUM = -DFLOAT(N+1)
- PROD = ONE
- DO 180 J = 1, N
- SUM = SUM + X(J)
- PROD = X(J)*PROD
- 180 CONTINUE
- DO 190 K = 1, N
- FVEC(K) = X(K) + SUM
- 190 CONTINUE
- FVEC(N) = PROD - ONE
- GO TO 380
-C
-C DISCRETE BOUNDARY VALUE FUNCTION.
-C
- 200 CONTINUE
- H = ONE/DFLOAT(N+1)
- DO 210 K = 1, N
- TEMP = (X(K) + DFLOAT(K)*H + ONE)**3
- TEMP1 = ZERO
- IF (K .NE. 1) TEMP1 = X(K-1)
- TEMP2 = ZERO
- IF (K .NE. N) TEMP2 = X(K+1)
- FVEC(K) = TWO*X(K) - TEMP1 - TEMP2 + TEMP*H**2/TWO
- 210 CONTINUE
- GO TO 380
-C
-C DISCRETE INTEGRAL EQUATION FUNCTION.
-C
- 220 CONTINUE
- H = ONE/DFLOAT(N+1)
- DO 260 K = 1, N
- TK = DFLOAT(K)*H
- SUM1 = ZERO
- DO 230 J = 1, K
- TJ = DFLOAT(J)*H
- TEMP = (X(J) + TJ + ONE)**3
- SUM1 = SUM1 + TJ*TEMP
- 230 CONTINUE
- SUM2 = ZERO
- KP1 = K + 1
- IF (N .LT. KP1) GO TO 250
- DO 240 J = KP1, N
- TJ = DFLOAT(J)*H
- TEMP = (X(J) + TJ + ONE)**3
- SUM2 = SUM2 + (ONE - TJ)*TEMP
- 240 CONTINUE
- 250 CONTINUE
- FVEC(K) = X(K) + H*((ONE - TK)*SUM1 + TK*SUM2)/TWO
- 260 CONTINUE
- GO TO 380
-C
-C TRIGONOMETRIC FUNCTION.
-C
- 270 CONTINUE
- SUM = ZERO
- DO 280 J = 1, N
- FVEC(J) = DCOS(X(J))
- SUM = SUM + FVEC(J)
- 280 CONTINUE
- DO 290 K = 1, N
- FVEC(K) = DFLOAT(N+K) - DSIN(X(K)) - SUM - DFLOAT(K)*FVEC(K)
- 290 CONTINUE
- GO TO 380
-C
-C VARIABLY DIMENSIONED FUNCTION.
-C
- 300 CONTINUE
- SUM = ZERO
- DO 310 J = 1, N
- SUM = SUM + DFLOAT(J)*(X(J) - ONE)
- 310 CONTINUE
- TEMP = SUM*(ONE + TWO*SUM**2)
- DO 320 K = 1, N
- FVEC(K) = X(K) - ONE + DFLOAT(K)*TEMP
- 320 CONTINUE
- GO TO 380
-C
-C BROYDEN TRIDIAGONAL FUNCTION.
-C
- 330 CONTINUE
- DO 340 K = 1, N
- TEMP = (THREE - TWO*X(K))*X(K)
- TEMP1 = ZERO
- IF (K .NE. 1) TEMP1 = X(K-1)
- TEMP2 = ZERO
- IF (K .NE. N) TEMP2 = X(K+1)
- FVEC(K) = TEMP - TEMP1 - TWO*TEMP2 + ONE
- 340 CONTINUE
- GO TO 380
-C
-C BROYDEN BANDED FUNCTION.
-C
- 350 CONTINUE
- ML = 5
- MU = 1
- DO 370 K = 1, N
- K1 = MAX0(1,K-ML)
- K2 = MIN0(K+MU,N)
- TEMP = ZERO
- DO 360 J = K1, K2
- IF (J .NE. K) TEMP = TEMP + X(J)*(ONE + X(J))
- 360 CONTINUE
- FVEC(K) = X(K)*(TWO + FIVE*X(K)**2) + ONE - TEMP
- 370 CONTINUE
- 380 CONTINUE
- RETURN
-C
-C LAST CARD OF SUBROUTINE VECFCN.
-C
- END
diff --git a/CEP/PyBDSM/src/minpack/ex/file17 b/CEP/PyBDSM/src/minpack/ex/file17
deleted file mode 100644
index e901bacbea9ad25c6b9c9cccea698a43d257f5fc..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/minpack/ex/file17
+++ /dev/null
@@ -1,1025 +0,0 @@
-C **********
-C
-C THIS PROGRAM TESTS CODES FOR THE LEAST-SQUARES SOLUTION OF
-C M NONLINEAR EQUATIONS IN N VARIABLES. IT CONSISTS OF A DRIVER
-C AND AN INTERFACE SUBROUTINE FCN. THE DRIVER READS IN DATA,
-C CALLS THE NONLINEAR LEAST-SQUARES SOLVER, AND FINALLY PRINTS
-C OUT INFORMATION ON THE PERFORMANCE OF THE SOLVER. THIS IS
-C ONLY A SAMPLE DRIVER, MANY OTHER DRIVERS ARE POSSIBLE. THE
-C INTERFACE SUBROUTINE FCN IS NECESSARY TO TAKE INTO ACCOUNT THE
-C FORMS OF CALLING SEQUENCES USED BY THE FUNCTION AND JACOBIAN
-C SUBROUTINES IN THE VARIOUS NONLINEAR LEAST-SQUARES SOLVERS.
-C
-C SUBPROGRAMS CALLED
-C
-C USER-SUPPLIED ...... FCN
-C
-C MINPACK-SUPPLIED ... DPMPAR,ENORM,INITPT,LMDER1,SSQFCN
-C
-C FORTRAN-SUPPLIED ... DSQRT
-C
-C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980.
-C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE
-C
-C **********
- INTEGER I,IC,INFO,K,LDFJAC,LWA,M,N,NFEV,NJEV,NPROB,NREAD,NTRIES,
- * NWRITE
- INTEGER IWA(40),MA(60),NA(60),NF(60),NJ(60),NP(60),NX(60)
- DOUBLE PRECISION FACTOR,FNORM1,FNORM2,ONE,TEN,TOL
- DOUBLE PRECISION FJAC(65,40),FNM(60),FVEC(65),WA(265),X(40)
- DOUBLE PRECISION DPMPAR,ENORM
- EXTERNAL FCN
- COMMON /REFNUM/ NPROB,NFEV,NJEV
-C
-C LOGICAL INPUT UNIT IS ASSUMED TO BE NUMBER 5.
-C LOGICAL OUTPUT UNIT IS ASSUMED TO BE NUMBER 6.
-C
- DATA NREAD,NWRITE /5,6/
-C
- DATA ONE,TEN /1.0D0,1.0D1/
- TOL = DSQRT(DPMPAR(1))
- LDFJAC = 65
- LWA = 265
- IC = 0
- 10 CONTINUE
- READ (NREAD,50) NPROB,N,M,NTRIES
- IF (NPROB .LE. 0) GO TO 30
- FACTOR = ONE
- DO 20 K = 1, NTRIES
- IC = IC + 1
- CALL INITPT(N,X,NPROB,FACTOR)
- CALL SSQFCN(M,N,X,FVEC,NPROB)
- FNORM1 = ENORM(M,FVEC)
- WRITE (NWRITE,60) NPROB,N,M
- NFEV = 0
- NJEV = 0
- CALL LMDER1(FCN,M,N,X,FVEC,FJAC,LDFJAC,TOL,INFO,IWA,WA,
- * LWA)
- CALL SSQFCN(M,N,X,FVEC,NPROB)
- FNORM2 = ENORM(M,FVEC)
- NP(IC) = NPROB
- NA(IC) = N
- MA(IC) = M
- NF(IC) = NFEV
- NJ(IC) = NJEV
- NX(IC) = INFO
- FNM(IC) = FNORM2
- WRITE (NWRITE,70)
- * FNORM1,FNORM2,NFEV,NJEV,INFO,(X(I), I = 1, N)
- FACTOR = TEN*FACTOR
- 20 CONTINUE
- GO TO 10
- 30 CONTINUE
- WRITE (NWRITE,80) IC
- WRITE (NWRITE,90)
- DO 40 I = 1, IC
- WRITE (NWRITE,100) NP(I),NA(I),MA(I),NF(I),NJ(I),NX(I),FNM(I)
- 40 CONTINUE
- STOP
- 50 FORMAT (4I5)
- 60 FORMAT ( //// 5X, 8H PROBLEM, I5, 5X, 11H DIMENSIONS, 2I5, 5X //
- * )
- 70 FORMAT (5X, 33H INITIAL L2 NORM OF THE RESIDUALS, D15.7 // 5X,
- * 33H FINAL L2 NORM OF THE RESIDUALS , D15.7 // 5X,
- * 33H NUMBER OF FUNCTION EVALUATIONS , I10 // 5X,
- * 33H NUMBER OF JACOBIAN EVALUATIONS , I10 // 5X,
- * 15H EXIT PARAMETER, 18X, I10 // 5X,
- * 27H FINAL APPROXIMATE SOLUTION // (5X, 5D15.7))
- 80 FORMAT (12H1SUMMARY OF , I3, 16H CALLS TO LMDER1 /)
- 90 FORMAT (49H NPROB N M NFEV NJEV INFO FINAL L2 NORM /)
- 100 FORMAT (3I5, 3I6, 1X, D15.7)
-C
-C LAST CARD OF DRIVER.
-C
- END
- SUBROUTINE FCN(M,N,X,FVEC,FJAC,LDFJAC,IFLAG)
- INTEGER M,N,LDFJAC,IFLAG
- DOUBLE PRECISION X(N),FVEC(M),FJAC(LDFJAC,N)
-C **********
-C
-C THE CALLING SEQUENCE OF FCN SHOULD BE IDENTICAL TO THE
-C CALLING SEQUENCE OF THE FUNCTION SUBROUTINE IN THE NONLINEAR
-C LEAST-SQUARES SOLVER. FCN SHOULD ONLY CALL THE TESTING
-C FUNCTION AND JACOBIAN SUBROUTINES SSQFCN AND SSQJAC WITH
-C THE APPROPRIATE VALUE OF PROBLEM NUMBER (NPROB).
-C
-C SUBPROGRAMS CALLED
-C
-C MINPACK-SUPPLIED ... SSQFCN,SSQJAC
-C
-C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980.
-C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE
-C
-C **********
- INTEGER NPROB,NFEV,NJEV
- COMMON /REFNUM/ NPROB,NFEV,NJEV
- IF (IFLAG .EQ. 1) CALL SSQFCN(M,N,X,FVEC,NPROB)
- IF (IFLAG .EQ. 2) CALL SSQJAC(M,N,X,FJAC,LDFJAC,NPROB)
- IF (IFLAG .EQ. 1) NFEV = NFEV + 1
- IF (IFLAG .EQ. 2) NJEV = NJEV + 1
- RETURN
-C
-C LAST CARD OF INTERFACE SUBROUTINE FCN.
-C
- END
- SUBROUTINE SSQJAC(M,N,X,FJAC,LDFJAC,NPROB)
- INTEGER M,N,LDFJAC,NPROB
- DOUBLE PRECISION X(N),FJAC(LDFJAC,N)
-C **********
-C
-C SUBROUTINE SSQJAC
-C
-C THIS SUBROUTINE DEFINES THE JACOBIAN MATRICES OF EIGHTEEN
-C NONLINEAR LEAST SQUARES PROBLEMS. THE PROBLEM DIMENSIONS ARE
-C AS DESCRIBED IN THE PROLOGUE COMMENTS OF SSQFCN.
-C
-C THE SUBROUTINE STATEMENT IS
-C
-C SUBROUTINE SSQJAC(M,N,X,FJAC,LDFJAC,NPROB)
-C
-C WHERE
-C
-C M AND N ARE POSITIVE INTEGER INPUT VARIABLES. N MUST NOT
-C EXCEED M.
-C
-C X IS AN INPUT ARRAY OF LENGTH N.
-C
-C FJAC IS AN M BY N OUTPUT ARRAY WHICH CONTAINS THE JACOBIAN
-C MATRIX OF THE NPROB FUNCTION EVALUATED AT X.
-C
-C LDFJAC IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN M
-C WHICH SPECIFIES THE LEADING DIMENSION OF THE ARRAY FJAC.
-C
-C NPROB IS A POSITIVE INTEGER VARIABLE WHICH DEFINES THE
-C NUMBER OF THE PROBLEM. NPROB MUST NOT EXCEED 18.
-C
-C SUBPROGRAMS CALLED
-C
-C FORTRAN-SUPPLIED ... DATAN,DCOS,DEXP,DSIN,DSQRT
-C
-C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980.
-C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE
-C
-C **********
- INTEGER I,IVAR,J,K,MM1,NM1
- DOUBLE PRECISION C14,C20,C29,C45,C100,DIV,DX,EIGHT,FIVE,FOUR,
- * ONE,PROD,S2,TEMP,TEN,THREE,TI,TMP1,TMP2,TMP3,
- * TMP4,TPI,TWO,ZERO
- DOUBLE PRECISION V(11)
- DOUBLE PRECISION DFLOAT
- DATA ZERO,ONE,TWO,THREE,FOUR,FIVE,EIGHT,TEN,C14,C20,C29,C45,C100
- * /0.0D0,1.0D0,2.0D0,3.0D0,4.0D0,5.0D0,8.0D0,1.0D1,1.4D1,
- * 2.0D1,2.9D1,4.5D1,1.0D2/
- DATA V(1),V(2),V(3),V(4),V(5),V(6),V(7),V(8),V(9),V(10),V(11)
- * /4.0D0,2.0D0,1.0D0,5.0D-1,2.5D-1,1.67D-1,1.25D-1,1.0D-1,
- * 8.33D-2,7.14D-2,6.25D-2/
- DFLOAT(IVAR) = IVAR
-C
-C JACOBIAN ROUTINE SELECTOR.
-C
- GO TO (10,40,70,130,140,150,180,190,210,230,250,310,330,350,370,
- * 400,460,480), NPROB
-C
-C LINEAR FUNCTION - FULL RANK.
-C
- 10 CONTINUE
- TEMP = TWO/DFLOAT(M)
- DO 30 J = 1, N
- DO 20 I = 1, M
- FJAC(I,J) = -TEMP
- 20 CONTINUE
- FJAC(J,J) = FJAC(J,J) + ONE
- 30 CONTINUE
- GO TO 500
-C
-C LINEAR FUNCTION - RANK 1.
-C
- 40 CONTINUE
- DO 60 J = 1, N
- DO 50 I = 1, M
- FJAC(I,J) = DFLOAT(I)*DFLOAT(J)
- 50 CONTINUE
- 60 CONTINUE
- GO TO 500
-C
-C LINEAR FUNCTION - RANK 1 WITH ZERO COLUMNS AND ROWS.
-C
- 70 CONTINUE
- DO 90 J = 1, N
- DO 80 I = 1, M
- FJAC(I,J) = ZERO
- 80 CONTINUE
- 90 CONTINUE
- NM1 = N - 1
- MM1 = M - 1
- IF (NM1 .LT. 2) GO TO 120
- DO 110 J = 2, NM1
- DO 100 I = 2, MM1
- FJAC(I,J) = DFLOAT(I-1)*DFLOAT(J)
- 100 CONTINUE
- 110 CONTINUE
- 120 CONTINUE
- GO TO 500
-C
-C ROSENBROCK FUNCTION.
-C
- 130 CONTINUE
- FJAC(1,1) = -C20*X(1)
- FJAC(1,2) = TEN
- FJAC(2,1) = -ONE
- FJAC(2,2) = ZERO
- GO TO 500
-C
-C HELICAL VALLEY FUNCTION.
-C
- 140 CONTINUE
- TPI = EIGHT*DATAN(ONE)
- TEMP = X(1)**2 + X(2)**2
- TMP1 = TPI*TEMP
- TMP2 = DSQRT(TEMP)
- FJAC(1,1) = C100*X(2)/TMP1
- FJAC(1,2) = -C100*X(1)/TMP1
- FJAC(1,3) = TEN
- FJAC(2,1) = TEN*X(1)/TMP2
- FJAC(2,2) = TEN*X(2)/TMP2
- FJAC(2,3) = ZERO
- FJAC(3,1) = ZERO
- FJAC(3,2) = ZERO
- FJAC(3,3) = ONE
- GO TO 500
-C
-C POWELL SINGULAR FUNCTION.
-C
- 150 CONTINUE
- DO 170 J = 1, 4
- DO 160 I = 1, 4
- FJAC(I,J) = ZERO
- 160 CONTINUE
- 170 CONTINUE
- FJAC(1,1) = ONE
- FJAC(1,2) = TEN
- FJAC(2,3) = DSQRT(FIVE)
- FJAC(2,4) = -FJAC(2,3)
- FJAC(3,2) = TWO*(X(2) - TWO*X(3))
- FJAC(3,3) = -TWO*FJAC(3,2)
- FJAC(4,1) = TWO*DSQRT(TEN)*(X(1) - X(4))
- FJAC(4,4) = -FJAC(4,1)
- GO TO 500
-C
-C FREUDENSTEIN AND ROTH FUNCTION.
-C
- 180 CONTINUE
- FJAC(1,1) = ONE
- FJAC(1,2) = X(2)*(TEN - THREE*X(2)) - TWO
- FJAC(2,1) = ONE
- FJAC(2,2) = X(2)*(TWO + THREE*X(2)) - C14
- GO TO 500
-C
-C BARD FUNCTION.
-C
- 190 CONTINUE
- DO 200 I = 1, 15
- TMP1 = DFLOAT(I)
- TMP2 = DFLOAT(16-I)
- TMP3 = TMP1
- IF (I .GT. 8) TMP3 = TMP2
- TMP4 = (X(2)*TMP2 + X(3)*TMP3)**2
- FJAC(I,1) = -ONE
- FJAC(I,2) = TMP1*TMP2/TMP4
- FJAC(I,3) = TMP1*TMP3/TMP4
- 200 CONTINUE
- GO TO 500
-C
-C KOWALIK AND OSBORNE FUNCTION.
-C
- 210 CONTINUE
- DO 220 I = 1, 11
- TMP1 = V(I)*(V(I) + X(2))
- TMP2 = V(I)*(V(I) + X(3)) + X(4)
- FJAC(I,1) = -TMP1/TMP2
- FJAC(I,2) = -V(I)*X(1)/TMP2
- FJAC(I,3) = FJAC(I,1)*FJAC(I,2)
- FJAC(I,4) = FJAC(I,3)/V(I)
- 220 CONTINUE
- GO TO 500
-C
-C MEYER FUNCTION.
-C
- 230 CONTINUE
- DO 240 I = 1, 16
- TEMP = FIVE*DFLOAT(I) + C45 + X(3)
- TMP1 = X(2)/TEMP
- TMP2 = DEXP(TMP1)
- FJAC(I,1) = TMP2
- FJAC(I,2) = X(1)*TMP2/TEMP
- FJAC(I,3) = -TMP1*FJAC(I,2)
- 240 CONTINUE
- GO TO 500
-C
-C WATSON FUNCTION.
-C
- 250 CONTINUE
- DO 280 I = 1, 29
- DIV = DFLOAT(I)/C29
- S2 = ZERO
- DX = ONE
- DO 260 J = 1, N
- S2 = S2 + DX*X(J)
- DX = DIV*DX
- 260 CONTINUE
- TEMP = TWO*DIV*S2
- DX = ONE/DIV
- DO 270 J = 1, N
- FJAC(I,J) = DX*(DFLOAT(J-1) - TEMP)
- DX = DIV*DX
- 270 CONTINUE
- 280 CONTINUE
- DO 300 J = 1, N
- DO 290 I = 30, 31
- FJAC(I,J) = ZERO
- 290 CONTINUE
- 300 CONTINUE
- FJAC(30,1) = ONE
- FJAC(31,1) = -TWO*X(1)
- FJAC(31,2) = ONE
- GO TO 500
-C
-C BOX 3-DIMENSIONAL FUNCTION.
-C
- 310 CONTINUE
- DO 320 I = 1, M
- TEMP = DFLOAT(I)
- TMP1 = TEMP/TEN
- FJAC(I,1) = -TMP1*DEXP(-TMP1*X(1))
- FJAC(I,2) = TMP1*DEXP(-TMP1*X(2))
- FJAC(I,3) = DEXP(-TEMP) - DEXP(-TMP1)
- 320 CONTINUE
- GO TO 500
-C
-C JENNRICH AND SAMPSON FUNCTION.
-C
- 330 CONTINUE
- DO 340 I = 1, M
- TEMP = DFLOAT(I)
- FJAC(I,1) = -TEMP*DEXP(TEMP*X(1))
- FJAC(I,2) = -TEMP*DEXP(TEMP*X(2))
- 340 CONTINUE
- GO TO 500
-C
-C BROWN AND DENNIS FUNCTION.
-C
- 350 CONTINUE
- DO 360 I = 1, M
- TEMP = DFLOAT(I)/FIVE
- TI = DSIN(TEMP)
- TMP1 = X(1) + TEMP*X(2) - DEXP(TEMP)
- TMP2 = X(3) + TI*X(4) - DCOS(TEMP)
- FJAC(I,1) = TWO*TMP1
- FJAC(I,2) = TEMP*FJAC(I,1)
- FJAC(I,3) = TWO*TMP2
- FJAC(I,4) = TI*FJAC(I,3)
- 360 CONTINUE
- GO TO 500
-C
-C CHEBYQUAD FUNCTION.
-C
- 370 CONTINUE
- DX = ONE/DFLOAT(N)
- DO 390 J = 1, N
- TMP1 = ONE
- TMP2 = TWO*X(J) - ONE
- TEMP = TWO*TMP2
- TMP3 = ZERO
- TMP4 = TWO
- DO 380 I = 1, M
- FJAC(I,J) = DX*TMP4
- TI = FOUR*TMP2 + TEMP*TMP4 - TMP3
- TMP3 = TMP4
- TMP4 = TI
- TI = TEMP*TMP2 - TMP1
- TMP1 = TMP2
- TMP2 = TI
- 380 CONTINUE
- 390 CONTINUE
- GO TO 500
-C
-C BROWN ALMOST-LINEAR FUNCTION.
-C
- 400 CONTINUE
- PROD = ONE
- DO 420 J = 1, N
- PROD = X(J)*PROD
- DO 410 I = 1, N
- FJAC(I,J) = ONE
- 410 CONTINUE
- FJAC(J,J) = TWO
- 420 CONTINUE
- DO 450 J = 1, N
- TEMP = X(J)
- IF (TEMP .NE. ZERO) GO TO 440
- TEMP = ONE
- PROD = ONE
- DO 430 K = 1, N
- IF (K .NE. J) PROD = X(K)*PROD
- 430 CONTINUE
- 440 CONTINUE
- FJAC(N,J) = PROD/TEMP
- 450 CONTINUE
- GO TO 500
-C
-C OSBORNE 1 FUNCTION.
-C
- 460 CONTINUE
- DO 470 I = 1, 33
- TEMP = TEN*DFLOAT(I-1)
- TMP1 = DEXP(-X(4)*TEMP)
- TMP2 = DEXP(-X(5)*TEMP)
- FJAC(I,1) = -ONE
- FJAC(I,2) = -TMP1
- FJAC(I,3) = -TMP2
- FJAC(I,4) = TEMP*X(2)*TMP1
- FJAC(I,5) = TEMP*X(3)*TMP2
- 470 CONTINUE
- GO TO 500
-C
-C OSBORNE 2 FUNCTION.
-C
- 480 CONTINUE
- DO 490 I = 1, 65
- TEMP = DFLOAT(I-1)/TEN
- TMP1 = DEXP(-X(5)*TEMP)
- TMP2 = DEXP(-X(6)*(TEMP-X(9))**2)
- TMP3 = DEXP(-X(7)*(TEMP-X(10))**2)
- TMP4 = DEXP(-X(8)*(TEMP-X(11))**2)
- FJAC(I,1) = -TMP1
- FJAC(I,2) = -TMP2
- FJAC(I,3) = -TMP3
- FJAC(I,4) = -TMP4
- FJAC(I,5) = TEMP*X(1)*TMP1
- FJAC(I,6) = X(2)*(TEMP - X(9))**2*TMP2
- FJAC(I,7) = X(3)*(TEMP - X(10))**2*TMP3
- FJAC(I,8) = X(4)*(TEMP - X(11))**2*TMP4
- FJAC(I,9) = -TWO*X(2)*X(6)*(TEMP - X(9))*TMP2
- FJAC(I,10) = -TWO*X(3)*X(7)*(TEMP - X(10))*TMP3
- FJAC(I,11) = -TWO*X(4)*X(8)*(TEMP - X(11))*TMP4
- 490 CONTINUE
- 500 CONTINUE
- RETURN
-C
-C LAST CARD OF SUBROUTINE SSQJAC.
-C
- END
- SUBROUTINE INITPT(N,X,NPROB,FACTOR)
- INTEGER N,NPROB
- DOUBLE PRECISION FACTOR
- DOUBLE PRECISION X(N)
-C **********
-C
-C SUBROUTINE INITPT
-C
-C THIS SUBROUTINE SPECIFIES THE STANDARD STARTING POINTS FOR THE
-C FUNCTIONS DEFINED BY SUBROUTINE SSQFCN. THE SUBROUTINE RETURNS
-C IN X A MULTIPLE (FACTOR) OF THE STANDARD STARTING POINT. FOR
-C THE 11TH FUNCTION THE STANDARD STARTING POINT IS ZERO, SO IN
-C THIS CASE, IF FACTOR IS NOT UNITY, THEN THE SUBROUTINE RETURNS
-C THE VECTOR X(J) = FACTOR, J=1,...,N.
-C
-C THE SUBROUTINE STATEMENT IS
-C
-C SUBROUTINE INITPT(N,X,NPROB,FACTOR)
-C
-C WHERE
-C
-C N IS A POSITIVE INTEGER INPUT VARIABLE.
-C
-C X IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS THE STANDARD
-C STARTING POINT FOR PROBLEM NPROB MULTIPLIED BY FACTOR.
-C
-C NPROB IS A POSITIVE INTEGER INPUT VARIABLE WHICH DEFINES THE
-C NUMBER OF THE PROBLEM. NPROB MUST NOT EXCEED 18.
-C
-C FACTOR IS AN INPUT VARIABLE WHICH SPECIFIES THE MULTIPLE OF
-C THE STANDARD STARTING POINT. IF FACTOR IS UNITY, NO
-C MULTIPLICATION IS PERFORMED.
-C
-C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980.
-C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE
-C
-C **********
- INTEGER IVAR,J
- DOUBLE PRECISION C1,C2,C3,C4,C5,C6,C7,C8,C9,C10,C11,C12,C13,C14,
- * C15,C16,C17,FIVE,H,HALF,ONE,SEVEN,TEN,THREE,
- * TWENTY,TWNTF,TWO,ZERO
- DOUBLE PRECISION DFLOAT
- DATA ZERO,HALF,ONE,TWO,THREE,FIVE,SEVEN,TEN,TWENTY,TWNTF
- * /0.0D0,5.0D-1,1.0D0,2.0D0,3.0D0,5.0D0,7.0D0,1.0D1,2.0D1,
- * 2.5D1/
- DATA C1,C2,C3,C4,C5,C6,C7,C8,C9,C10,C11,C12,C13,C14,C15,C16,C17
- * /1.2D0,2.5D-1,3.9D-1,4.15D-1,2.0D-2,4.0D3,2.5D2,3.0D-1,
- * 4.0D-1,1.5D0,1.0D-2,1.3D0,6.5D-1,7.0D-1,6.0D-1,4.5D0,
- * 5.5D0/
- DFLOAT(IVAR) = IVAR
-C
-C SELECTION OF INITIAL POINT.
-C
- GO TO (10,10,10,30,40,50,60,70,80,90,100,120,130,140,150,170,
- * 190,200), NPROB
-C
-C LINEAR FUNCTION - FULL RANK OR RANK 1.
-C
- 10 CONTINUE
- DO 20 J = 1, N
- X(J) = ONE
- 20 CONTINUE
- GO TO 210
-C
-C ROSENBROCK FUNCTION.
-C
- 30 CONTINUE
- X(1) = -C1
- X(2) = ONE
- GO TO 210
-C
-C HELICAL VALLEY FUNCTION.
-C
- 40 CONTINUE
- X(1) = -ONE
- X(2) = ZERO
- X(3) = ZERO
- GO TO 210
-C
-C POWELL SINGULAR FUNCTION.
-C
- 50 CONTINUE
- X(1) = THREE
- X(2) = -ONE
- X(3) = ZERO
- X(4) = ONE
- GO TO 210
-C
-C FREUDENSTEIN AND ROTH FUNCTION.
-C
- 60 CONTINUE
- X(1) = HALF
- X(2) = -TWO
- GO TO 210
-C
-C BARD FUNCTION.
-C
- 70 CONTINUE
- X(1) = ONE
- X(2) = ONE
- X(3) = ONE
- GO TO 210
-C
-C KOWALIK AND OSBORNE FUNCTION.
-C
- 80 CONTINUE
- X(1) = C2
- X(2) = C3
- X(3) = C4
- X(4) = C3
- GO TO 210
-C
-C MEYER FUNCTION.
-C
- 90 CONTINUE
- X(1) = C5
- X(2) = C6
- X(3) = C7
- GO TO 210
-C
-C WATSON FUNCTION.
-C
- 100 CONTINUE
- DO 110 J = 1, N
- X(J) = ZERO
- 110 CONTINUE
- GO TO 210
-C
-C BOX 3-DIMENSIONAL FUNCTION.
-C
- 120 CONTINUE
- X(1) = ZERO
- X(2) = TEN
- X(3) = TWENTY
- GO TO 210
-C
-C JENNRICH AND SAMPSON FUNCTION.
-C
- 130 CONTINUE
- X(1) = C8
- X(2) = C9
- GO TO 210
-C
-C BROWN AND DENNIS FUNCTION.
-C
- 140 CONTINUE
- X(1) = TWNTF
- X(2) = FIVE
- X(3) = -FIVE
- X(4) = -ONE
- GO TO 210
-C
-C CHEBYQUAD FUNCTION.
-C
- 150 CONTINUE
- H = ONE/DFLOAT(N+1)
- DO 160 J = 1, N
- X(J) = DFLOAT(J)*H
- 160 CONTINUE
- GO TO 210
-C
-C BROWN ALMOST-LINEAR FUNCTION.
-C
- 170 CONTINUE
- DO 180 J = 1, N
- X(J) = HALF
- 180 CONTINUE
- GO TO 210
-C
-C OSBORNE 1 FUNCTION.
-C
- 190 CONTINUE
- X(1) = HALF
- X(2) = C10
- X(3) = -ONE
- X(4) = C11
- X(5) = C5
- GO TO 210
-C
-C OSBORNE 2 FUNCTION.
-C
- 200 CONTINUE
- X(1) = C12
- X(2) = C13
- X(3) = C13
- X(4) = C14
- X(5) = C15
- X(6) = THREE
- X(7) = FIVE
- X(8) = SEVEN
- X(9) = TWO
- X(10) = C16
- X(11) = C17
- 210 CONTINUE
-C
-C COMPUTE MULTIPLE OF INITIAL POINT.
-C
- IF (FACTOR .EQ. ONE) GO TO 260
- IF (NPROB .EQ. 11) GO TO 230
- DO 220 J = 1, N
- X(J) = FACTOR*X(J)
- 220 CONTINUE
- GO TO 250
- 230 CONTINUE
- DO 240 J = 1, N
- X(J) = FACTOR
- 240 CONTINUE
- 250 CONTINUE
- 260 CONTINUE
- RETURN
-C
-C LAST CARD OF SUBROUTINE INITPT.
-C
- END
- SUBROUTINE SSQFCN(M,N,X,FVEC,NPROB)
- INTEGER M,N,NPROB
- DOUBLE PRECISION X(N),FVEC(M)
-C **********
-C
-C SUBROUTINE SSQFCN
-C
-C THIS SUBROUTINE DEFINES THE FUNCTIONS OF EIGHTEEN NONLINEAR
-C LEAST SQUARES PROBLEMS. THE ALLOWABLE VALUES OF (M,N) FOR
-C FUNCTIONS 1,2 AND 3 ARE VARIABLE BUT WITH M .GE. N.
-C FOR FUNCTIONS 4,5,6,7,8,9 AND 10 THE VALUES OF (M,N) ARE
-C (2,2),(3,3),(4,4),(2,2),(15,3),(11,4) AND (16,3), RESPECTIVELY.
-C FUNCTION 11 (WATSON) HAS M = 31 WITH N USUALLY 6 OR 9.
-C HOWEVER, ANY N, N = 2,...,31, IS PERMITTED.
-C FUNCTIONS 12,13 AND 14 HAVE N = 3,2 AND 4, RESPECTIVELY, BUT
-C ALLOW ANY M .GE. N, WITH THE USUAL CHOICES BEING 10,10 AND 20.
-C FUNCTION 15 (CHEBYQUAD) ALLOWS M AND N VARIABLE WITH M .GE. N.
-C FUNCTION 16 (BROWN) ALLOWS N VARIABLE WITH M = N.
-C FOR FUNCTIONS 17 AND 18, THE VALUES OF (M,N) ARE
-C (33,5) AND (65,11), RESPECTIVELY.
-C
-C THE SUBROUTINE STATEMENT IS
-C
-C SUBROUTINE SSQFCN(M,N,X,FVEC,NPROB)
-C
-C WHERE
-C
-C M AND N ARE POSITIVE INTEGER INPUT VARIABLES. N MUST NOT
-C EXCEED M.
-C
-C X IS AN INPUT ARRAY OF LENGTH N.
-C
-C FVEC IS AN OUTPUT ARRAY OF LENGTH M WHICH CONTAINS THE NPROB
-C FUNCTION EVALUATED AT X.
-C
-C NPROB IS A POSITIVE INTEGER INPUT VARIABLE WHICH DEFINES THE
-C NUMBER OF THE PROBLEM. NPROB MUST NOT EXCEED 18.
-C
-C SUBPROGRAMS CALLED
-C
-C FORTRAN-SUPPLIED ... DATAN,DCOS,DEXP,DSIN,DSQRT,DSIGN
-C
-C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980.
-C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE
-C
-C **********
- INTEGER I,IEV,IVAR,J,NM1
- DOUBLE PRECISION C13,C14,C29,C45,DIV,DX,EIGHT,FIVE,ONE,PROD,SUM,
- * S1,S2,TEMP,TEN,TI,TMP1,TMP2,TMP3,TMP4,TPI,TWO,
- * ZERO,ZP25,ZP5
- DOUBLE PRECISION V(11),Y1(15),Y2(11),Y3(16),Y4(33),Y5(65)
- DOUBLE PRECISION DFLOAT
- DATA ZERO,ZP25,ZP5,ONE,TWO,FIVE,EIGHT,TEN,C13,C14,C29,C45
- * /0.0D0,2.5D-1,5.0D-1,1.0D0,2.0D0,5.0D0,8.0D0,1.0D1,1.3D1,
- * 1.4D1,2.9D1,4.5D1/
- DATA V(1),V(2),V(3),V(4),V(5),V(6),V(7),V(8),V(9),V(10),V(11)
- * /4.0D0,2.0D0,1.0D0,5.0D-1,2.5D-1,1.67D-1,1.25D-1,1.0D-1,
- * 8.33D-2,7.14D-2,6.25D-2/
- DATA Y1(1),Y1(2),Y1(3),Y1(4),Y1(5),Y1(6),Y1(7),Y1(8),Y1(9),
- * Y1(10),Y1(11),Y1(12),Y1(13),Y1(14),Y1(15)
- * /1.4D-1,1.8D-1,2.2D-1,2.5D-1,2.9D-1,3.2D-1,3.5D-1,3.9D-1,
- * 3.7D-1,5.8D-1,7.3D-1,9.6D-1,1.34D0,2.1D0,4.39D0/
- DATA Y2(1),Y2(2),Y2(3),Y2(4),Y2(5),Y2(6),Y2(7),Y2(8),Y2(9),
- * Y2(10),Y2(11)
- * /1.957D-1,1.947D-1,1.735D-1,1.6D-1,8.44D-2,6.27D-2,4.56D-2,
- * 3.42D-2,3.23D-2,2.35D-2,2.46D-2/
- DATA Y3(1),Y3(2),Y3(3),Y3(4),Y3(5),Y3(6),Y3(7),Y3(8),Y3(9),
- * Y3(10),Y3(11),Y3(12),Y3(13),Y3(14),Y3(15),Y3(16)
- * /3.478D4,2.861D4,2.365D4,1.963D4,1.637D4,1.372D4,1.154D4,
- * 9.744D3,8.261D3,7.03D3,6.005D3,5.147D3,4.427D3,3.82D3,
- * 3.307D3,2.872D3/
- DATA Y4(1),Y4(2),Y4(3),Y4(4),Y4(5),Y4(6),Y4(7),Y4(8),Y4(9),
- * Y4(10),Y4(11),Y4(12),Y4(13),Y4(14),Y4(15),Y4(16),Y4(17),
- * Y4(18),Y4(19),Y4(20),Y4(21),Y4(22),Y4(23),Y4(24),Y4(25),
- * Y4(26),Y4(27),Y4(28),Y4(29),Y4(30),Y4(31),Y4(32),Y4(33)
- * /8.44D-1,9.08D-1,9.32D-1,9.36D-1,9.25D-1,9.08D-1,8.81D-1,
- * 8.5D-1,8.18D-1,7.84D-1,7.51D-1,7.18D-1,6.85D-1,6.58D-1,
- * 6.28D-1,6.03D-1,5.8D-1,5.58D-1,5.38D-1,5.22D-1,5.06D-1,
- * 4.9D-1,4.78D-1,4.67D-1,4.57D-1,4.48D-1,4.38D-1,4.31D-1,
- * 4.24D-1,4.2D-1,4.14D-1,4.11D-1,4.06D-1/
- DATA Y5(1),Y5(2),Y5(3),Y5(4),Y5(5),Y5(6),Y5(7),Y5(8),Y5(9),
- * Y5(10),Y5(11),Y5(12),Y5(13),Y5(14),Y5(15),Y5(16),Y5(17),
- * Y5(18),Y5(19),Y5(20),Y5(21),Y5(22),Y5(23),Y5(24),Y5(25),
- * Y5(26),Y5(27),Y5(28),Y5(29),Y5(30),Y5(31),Y5(32),Y5(33),
- * Y5(34),Y5(35),Y5(36),Y5(37),Y5(38),Y5(39),Y5(40),Y5(41),
- * Y5(42),Y5(43),Y5(44),Y5(45),Y5(46),Y5(47),Y5(48),Y5(49),
- * Y5(50),Y5(51),Y5(52),Y5(53),Y5(54),Y5(55),Y5(56),Y5(57),
- * Y5(58),Y5(59),Y5(60),Y5(61),Y5(62),Y5(63),Y5(64),Y5(65)
- * /1.366D0,1.191D0,1.112D0,1.013D0,9.91D-1,8.85D-1,8.31D-1,
- * 8.47D-1,7.86D-1,7.25D-1,7.46D-1,6.79D-1,6.08D-1,6.55D-1,
- * 6.16D-1,6.06D-1,6.02D-1,6.26D-1,6.51D-1,7.24D-1,6.49D-1,
- * 6.49D-1,6.94D-1,6.44D-1,6.24D-1,6.61D-1,6.12D-1,5.58D-1,
- * 5.33D-1,4.95D-1,5.0D-1,4.23D-1,3.95D-1,3.75D-1,3.72D-1,
- * 3.91D-1,3.96D-1,4.05D-1,4.28D-1,4.29D-1,5.23D-1,5.62D-1,
- * 6.07D-1,6.53D-1,6.72D-1,7.08D-1,6.33D-1,6.68D-1,6.45D-1,
- * 6.32D-1,5.91D-1,5.59D-1,5.97D-1,6.25D-1,7.39D-1,7.1D-1,
- * 7.29D-1,7.2D-1,6.36D-1,5.81D-1,4.28D-1,2.92D-1,1.62D-1,
- * 9.8D-2,5.4D-2/
- DFLOAT(IVAR) = IVAR
-C
-C FUNCTION ROUTINE SELECTOR.
-C
- GO TO (10,40,70,110,120,130,140,150,170,190,210,250,270,290,310,
- * 360,390,410), NPROB
-C
-C LINEAR FUNCTION - FULL RANK.
-C
- 10 CONTINUE
- SUM = ZERO
- DO 20 J = 1, N
- SUM = SUM + X(J)
- 20 CONTINUE
- TEMP = TWO*SUM/DFLOAT(M) + ONE
- DO 30 I = 1, M
- FVEC(I) = -TEMP
- IF (I .LE. N) FVEC(I) = FVEC(I) + X(I)
- 30 CONTINUE
- GO TO 430
-C
-C LINEAR FUNCTION - RANK 1.
-C
- 40 CONTINUE
- SUM = ZERO
- DO 50 J = 1, N
- SUM = SUM + DFLOAT(J)*X(J)
- 50 CONTINUE
- DO 60 I = 1, M
- FVEC(I) = DFLOAT(I)*SUM - ONE
- 60 CONTINUE
- GO TO 430
-C
-C LINEAR FUNCTION - RANK 1 WITH ZERO COLUMNS AND ROWS.
-C
- 70 CONTINUE
- SUM = ZERO
- NM1 = N - 1
- IF (NM1 .LT. 2) GO TO 90
- DO 80 J = 2, NM1
- SUM = SUM + DFLOAT(J)*X(J)
- 80 CONTINUE
- 90 CONTINUE
- DO 100 I = 1, M
- FVEC(I) = DFLOAT(I-1)*SUM - ONE
- 100 CONTINUE
- FVEC(M) = -ONE
- GO TO 430
-C
-C ROSENBROCK FUNCTION.
-C
- 110 CONTINUE
- FVEC(1) = TEN*(X(2) - X(1)**2)
- FVEC(2) = ONE - X(1)
- GO TO 430
-C
-C HELICAL VALLEY FUNCTION.
-C
- 120 CONTINUE
- TPI = EIGHT*DATAN(ONE)
- TMP1 = DSIGN(ZP25,X(2))
- IF (X(1) .GT. ZERO) TMP1 = DATAN(X(2)/X(1))/TPI
- IF (X(1) .LT. ZERO) TMP1 = DATAN(X(2)/X(1))/TPI + ZP5
- TMP2 = DSQRT(X(1)**2+X(2)**2)
- FVEC(1) = TEN*(X(3) - TEN*TMP1)
- FVEC(2) = TEN*(TMP2 - ONE)
- FVEC(3) = X(3)
- GO TO 430
-C
-C POWELL SINGULAR FUNCTION.
-C
- 130 CONTINUE
- FVEC(1) = X(1) + TEN*X(2)
- FVEC(2) = DSQRT(FIVE)*(X(3) - X(4))
- FVEC(3) = (X(2) - TWO*X(3))**2
- FVEC(4) = DSQRT(TEN)*(X(1) - X(4))**2
- GO TO 430
-C
-C FREUDENSTEIN AND ROTH FUNCTION.
-C
- 140 CONTINUE
- FVEC(1) = -C13 + X(1) + ((FIVE - X(2))*X(2) - TWO)*X(2)
- FVEC(2) = -C29 + X(1) + ((ONE + X(2))*X(2) - C14)*X(2)
- GO TO 430
-C
-C BARD FUNCTION.
-C
- 150 CONTINUE
- DO 160 I = 1, 15
- TMP1 = DFLOAT(I)
- TMP2 = DFLOAT(16-I)
- TMP3 = TMP1
- IF (I .GT. 8) TMP3 = TMP2
- FVEC(I) = Y1(I) - (X(1) + TMP1/(X(2)*TMP2 + X(3)*TMP3))
- 160 CONTINUE
- GO TO 430
-C
-C KOWALIK AND OSBORNE FUNCTION.
-C
- 170 CONTINUE
- DO 180 I = 1, 11
- TMP1 = V(I)*(V(I) + X(2))
- TMP2 = V(I)*(V(I) + X(3)) + X(4)
- FVEC(I) = Y2(I) - X(1)*TMP1/TMP2
- 180 CONTINUE
- GO TO 430
-C
-C MEYER FUNCTION.
-C
- 190 CONTINUE
- DO 200 I = 1, 16
- TEMP = FIVE*DFLOAT(I) + C45 + X(3)
- TMP1 = X(2)/TEMP
- TMP2 = DEXP(TMP1)
- FVEC(I) = X(1)*TMP2 - Y3(I)
- 200 CONTINUE
- GO TO 430
-C
-C WATSON FUNCTION.
-C
- 210 CONTINUE
- DO 240 I = 1, 29
- DIV = DFLOAT(I)/C29
- S1 = ZERO
- DX = ONE
- DO 220 J = 2, N
- S1 = S1 + DFLOAT(J-1)*DX*X(J)
- DX = DIV*DX
- 220 CONTINUE
- S2 = ZERO
- DX = ONE
- DO 230 J = 1, N
- S2 = S2 + DX*X(J)
- DX = DIV*DX
- 230 CONTINUE
- FVEC(I) = S1 - S2**2 - ONE
- 240 CONTINUE
- FVEC(30) = X(1)
- FVEC(31) = X(2) - X(1)**2 - ONE
- GO TO 430
-C
-C BOX 3-DIMENSIONAL FUNCTION.
-C
- 250 CONTINUE
- DO 260 I = 1, M
- TEMP = DFLOAT(I)
- TMP1 = TEMP/TEN
- FVEC(I) = DEXP(-TMP1*X(1)) - DEXP(-TMP1*X(2))
- * + (DEXP(-TEMP) - DEXP(-TMP1))*X(3)
- 260 CONTINUE
- GO TO 430
-C
-C JENNRICH AND SAMPSON FUNCTION.
-C
- 270 CONTINUE
- DO 280 I = 1, M
- TEMP = DFLOAT(I)
- FVEC(I) = TWO + TWO*TEMP - DEXP(TEMP*X(1)) - DEXP(TEMP*X(2))
- 280 CONTINUE
- GO TO 430
-C
-C BROWN AND DENNIS FUNCTION.
-C
- 290 CONTINUE
- DO 300 I = 1, M
- TEMP = DFLOAT(I)/FIVE
- TMP1 = X(1) + TEMP*X(2) - DEXP(TEMP)
- TMP2 = X(3) + DSIN(TEMP)*X(4) - DCOS(TEMP)
- FVEC(I) = TMP1**2 + TMP2**2
- 300 CONTINUE
- GO TO 430
-C
-C CHEBYQUAD FUNCTION.
-C
- 310 CONTINUE
- DO 320 I = 1, M
- FVEC(I) = ZERO
- 320 CONTINUE
- DO 340 J = 1, N
- TMP1 = ONE
- TMP2 = TWO*X(J) - ONE
- TEMP = TWO*TMP2
- DO 330 I = 1, M
- FVEC(I) = FVEC(I) + TMP2
- TI = TEMP*TMP2 - TMP1
- TMP1 = TMP2
- TMP2 = TI
- 330 CONTINUE
- 340 CONTINUE
- DX = ONE/DFLOAT(N)
- IEV = -1
- DO 350 I = 1, M
- FVEC(I) = DX*FVEC(I)
- IF (IEV .GT. 0) FVEC(I) = FVEC(I) + ONE/(DFLOAT(I)**2 - ONE)
- IEV = -IEV
- 350 CONTINUE
- GO TO 430
-C
-C BROWN ALMOST-LINEAR FUNCTION.
-C
- 360 CONTINUE
- SUM = -DFLOAT(N+1)
- PROD = ONE
- DO 370 J = 1, N
- SUM = SUM + X(J)
- PROD = X(J)*PROD
- 370 CONTINUE
- DO 380 I = 1, N
- FVEC(I) = X(I) + SUM
- 380 CONTINUE
- FVEC(N) = PROD - ONE
- GO TO 430
-C
-C OSBORNE 1 FUNCTION.
-C
- 390 CONTINUE
- DO 400 I = 1, 33
- TEMP = TEN*DFLOAT(I-1)
- TMP1 = DEXP(-X(4)*TEMP)
- TMP2 = DEXP(-X(5)*TEMP)
- FVEC(I) = Y4(I) - (X(1) + X(2)*TMP1 + X(3)*TMP2)
- 400 CONTINUE
- GO TO 430
-C
-C OSBORNE 2 FUNCTION.
-C
- 410 CONTINUE
- DO 420 I = 1, 65
- TEMP = DFLOAT(I-1)/TEN
- TMP1 = DEXP(-X(5)*TEMP)
- TMP2 = DEXP(-X(6)*(TEMP-X(9))**2)
- TMP3 = DEXP(-X(7)*(TEMP-X(10))**2)
- TMP4 = DEXP(-X(8)*(TEMP-X(11))**2)
- FVEC(I) = Y5(I)
- * - (X(1)*TMP1 + X(2)*TMP2 + X(3)*TMP3 + X(4)*TMP4)
- 420 CONTINUE
- 430 CONTINUE
- RETURN
-C
-C LAST CARD OF SUBROUTINE SSQFCN.
-C
- END
diff --git a/CEP/PyBDSM/src/minpack/ex/file18 b/CEP/PyBDSM/src/minpack/ex/file18
deleted file mode 100644
index 7497b7fb5c9ca24669ef69b4cc19d92a8a0d6d9d..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/minpack/ex/file18
+++ /dev/null
@@ -1,1036 +0,0 @@
-C **********
-C
-C THIS PROGRAM TESTS CODES FOR THE LEAST-SQUARES SOLUTION OF
-C M NONLINEAR EQUATIONS IN N VARIABLES. IT CONSISTS OF A DRIVER
-C AND AN INTERFACE SUBROUTINE FCN. THE DRIVER READS IN DATA,
-C CALLS THE NONLINEAR LEAST-SQUARES SOLVER, AND FINALLY PRINTS
-C OUT INFORMATION ON THE PERFORMANCE OF THE SOLVER. THIS IS
-C ONLY A SAMPLE DRIVER, MANY OTHER DRIVERS ARE POSSIBLE. THE
-C INTERFACE SUBROUTINE FCN IS NECESSARY TO TAKE INTO ACCOUNT THE
-C FORMS OF CALLING SEQUENCES USED BY THE FUNCTION AND JACOBIAN
-C SUBROUTINES IN THE VARIOUS NONLINEAR LEAST-SQUARES SOLVERS.
-C
-C SUBPROGRAMS CALLED
-C
-C USER-SUPPLIED ...... FCN
-C
-C MINPACK-SUPPLIED ... DPMPAR,ENORM,INITPT,LMSTR1,SSQFCN
-C
-C FORTRAN-SUPPLIED ... DSQRT
-C
-C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980.
-C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE
-C
-C **********
- INTEGER I,IC,INFO,K,LDFJAC,LWA,M,N,NFEV,NJEV,NPROB,NREAD,NTRIES,
- * NWRITE
- INTEGER IWA(40),MA(60),NA(60),NF(60),NJ(60),NP(60),NX(60)
- DOUBLE PRECISION FACTOR,FNORM1,FNORM2,ONE,TEN,TOL
- DOUBLE PRECISION FJAC(40,40),FNM(60),FVEC(65),WA(265),X(40)
- DOUBLE PRECISION DPMPAR,ENORM
- EXTERNAL FCN
- COMMON /REFNUM/ NPROB,NFEV,NJEV
-C
-C LOGICAL INPUT UNIT IS ASSUMED TO BE NUMBER 5.
-C LOGICAL OUTPUT UNIT IS ASSUMED TO BE NUMBER 6.
-C
- DATA NREAD,NWRITE /5,6/
-C
- DATA ONE,TEN /1.0D0,1.0D1/
- TOL = DSQRT(DPMPAR(1))
- LDFJAC = 40
- LWA = 265
- IC = 0
- 10 CONTINUE
- READ (NREAD,50) NPROB,N,M,NTRIES
- IF (NPROB .LE. 0) GO TO 30
- FACTOR = ONE
- DO 20 K = 1, NTRIES
- IC = IC + 1
- CALL INITPT(N,X,NPROB,FACTOR)
- CALL SSQFCN(M,N,X,FVEC,NPROB)
- FNORM1 = ENORM(M,FVEC)
- WRITE (NWRITE,60) NPROB,N,M
- NFEV = 0
- NJEV = 0
- CALL LMSTR1(FCN,M,N,X,FVEC,FJAC,LDFJAC,TOL,INFO,IWA,WA,
- * LWA)
- CALL SSQFCN(M,N,X,FVEC,NPROB)
- FNORM2 = ENORM(M,FVEC)
- NP(IC) = NPROB
- NA(IC) = N
- MA(IC) = M
- NF(IC) = NFEV
- NJ(IC) = NJEV
- NX(IC) = INFO
- FNM(IC) = FNORM2
- WRITE (NWRITE,70)
- * FNORM1,FNORM2,NFEV,NJEV,INFO,(X(I), I = 1, N)
- FACTOR = TEN*FACTOR
- 20 CONTINUE
- GO TO 10
- 30 CONTINUE
- WRITE (NWRITE,80) IC
- WRITE (NWRITE,90)
- DO 40 I = 1, IC
- WRITE (NWRITE,100) NP(I),NA(I),MA(I),NF(I),NJ(I),NX(I),FNM(I)
- 40 CONTINUE
- STOP
- 50 FORMAT (4I5)
- 60 FORMAT ( //// 5X, 8H PROBLEM, I5, 5X, 11H DIMENSIONS, 2I5, 5X //
- * )
- 70 FORMAT (5X, 33H INITIAL L2 NORM OF THE RESIDUALS, D15.7 // 5X,
- * 33H FINAL L2 NORM OF THE RESIDUALS , D15.7 // 5X,
- * 33H NUMBER OF FUNCTION EVALUATIONS , I10 // 5X,
- * 33H NUMBER OF JACOBIAN EVALUATIONS , I10 // 5X,
- * 15H EXIT PARAMETER, 18X, I10 // 5X,
- * 27H FINAL APPROXIMATE SOLUTION // (5X, 5D15.7))
- 80 FORMAT (12H1SUMMARY OF , I3, 16H CALLS TO LMSTR1 /)
- 90 FORMAT (49H NPROB N M NFEV NJEV INFO FINAL L2 NORM /)
- 100 FORMAT (3I5, 3I6, 1X, D15.7)
-C
-C LAST CARD OF DRIVER.
-C
- END
- SUBROUTINE FCN(M,N,X,FVEC,FJROW,IFLAG)
- INTEGER M,N,IFLAG
- DOUBLE PRECISION X(N),FVEC(M),FJROW(N)
-C **********
-C
-C THE CALLING SEQUENCE OF FCN SHOULD BE IDENTICAL TO THE
-C CALLING SEQUENCE OF THE FUNCTION SUBROUTINE IN THE NONLINEAR
-C LEAST SQUARES SOLVER. IF IFLAG = 1, FCN SHOULD ONLY CALL THE
-C TESTING FUNCTION SUBROUTINE SSQFCN. IF IFLAG = I, I .GE. 2,
-C FCN SHOULD ONLY CALL SUBROUTINE SSQJAC TO CALCULATE THE
-C (I-1)-ST ROW OF THE JACOBIAN. (THE SSQJAC SUBROUTINE PROVIDED
-C HERE FOR TESTING PURPOSES CALCULATES THE ENTIRE JACOBIAN
-C MATRIX AND IS THEREFORE CALLED ONLY WHEN IFLAG = 2.) EACH
-C CALL TO SSQFCN OR SSQJAC SHOULD SPECIFY THE APPROPRIATE
-C VALUE OF PROBLEM NUMBER (NPROB).
-C
-C SUBPROGRAMS CALLED
-C
-C MINPACK-SUPPLIED ... SSQFCN,SSQJAC
-C
-C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980.
-C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE
-C
-C **********
- INTEGER NPROB,NFEV,NJEV,J
- DOUBLE PRECISION TEMP(65,40)
- COMMON /REFNUM/ NPROB,NFEV,NJEV
- IF (IFLAG .EQ. 1) CALL SSQFCN(M,N,X,FVEC,NPROB)
- IF (IFLAG .EQ. 2) CALL SSQJAC(M,N,X,TEMP,65,NPROB)
- IF (IFLAG .EQ. 1) NFEV = NFEV + 1
- IF (IFLAG .EQ. 2) NJEV = NJEV + 1
- IF (IFLAG .EQ. 1) GO TO 120
- DO 110 J = 1, N
- FJROW(J) = TEMP(IFLAG-1,J)
- 110 CONTINUE
- 120 CONTINUE
- RETURN
-C
-C LAST CARD OF INTERFACE SUBROUTINE FCN.
-C
- END
- SUBROUTINE SSQJAC(M,N,X,FJAC,LDFJAC,NPROB)
- INTEGER M,N,LDFJAC,NPROB
- DOUBLE PRECISION X(N),FJAC(LDFJAC,N)
-C **********
-C
-C SUBROUTINE SSQJAC
-C
-C THIS SUBROUTINE DEFINES THE JACOBIAN MATRICES OF EIGHTEEN
-C NONLINEAR LEAST SQUARES PROBLEMS. THE PROBLEM DIMENSIONS ARE
-C AS DESCRIBED IN THE PROLOGUE COMMENTS OF SSQFCN.
-C
-C THE SUBROUTINE STATEMENT IS
-C
-C SUBROUTINE SSQJAC(M,N,X,FJAC,LDFJAC,NPROB)
-C
-C WHERE
-C
-C M AND N ARE POSITIVE INTEGER INPUT VARIABLES. N MUST NOT
-C EXCEED M.
-C
-C X IS AN INPUT ARRAY OF LENGTH N.
-C
-C FJAC IS AN M BY N OUTPUT ARRAY WHICH CONTAINS THE JACOBIAN
-C MATRIX OF THE NPROB FUNCTION EVALUATED AT X.
-C
-C LDFJAC IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN M
-C WHICH SPECIFIES THE LEADING DIMENSION OF THE ARRAY FJAC.
-C
-C NPROB IS A POSITIVE INTEGER VARIABLE WHICH DEFINES THE
-C NUMBER OF THE PROBLEM. NPROB MUST NOT EXCEED 18.
-C
-C SUBPROGRAMS CALLED
-C
-C FORTRAN-SUPPLIED ... DATAN,DCOS,DEXP,DSIN,DSQRT
-C
-C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980.
-C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE
-C
-C **********
- INTEGER I,IVAR,J,K,MM1,NM1
- DOUBLE PRECISION C14,C20,C29,C45,C100,DIV,DX,EIGHT,FIVE,FOUR,
- * ONE,PROD,S2,TEMP,TEN,THREE,TI,TMP1,TMP2,TMP3,
- * TMP4,TPI,TWO,ZERO
- DOUBLE PRECISION V(11)
- DOUBLE PRECISION DFLOAT
- DATA ZERO,ONE,TWO,THREE,FOUR,FIVE,EIGHT,TEN,C14,C20,C29,C45,C100
- * /0.0D0,1.0D0,2.0D0,3.0D0,4.0D0,5.0D0,8.0D0,1.0D1,1.4D1,
- * 2.0D1,2.9D1,4.5D1,1.0D2/
- DATA V(1),V(2),V(3),V(4),V(5),V(6),V(7),V(8),V(9),V(10),V(11)
- * /4.0D0,2.0D0,1.0D0,5.0D-1,2.5D-1,1.67D-1,1.25D-1,1.0D-1,
- * 8.33D-2,7.14D-2,6.25D-2/
- DFLOAT(IVAR) = IVAR
-C
-C JACOBIAN ROUTINE SELECTOR.
-C
- GO TO (10,40,70,130,140,150,180,190,210,230,250,310,330,350,370,
- * 400,460,480), NPROB
-C
-C LINEAR FUNCTION - FULL RANK.
-C
- 10 CONTINUE
- TEMP = TWO/DFLOAT(M)
- DO 30 J = 1, N
- DO 20 I = 1, M
- FJAC(I,J) = -TEMP
- 20 CONTINUE
- FJAC(J,J) = FJAC(J,J) + ONE
- 30 CONTINUE
- GO TO 500
-C
-C LINEAR FUNCTION - RANK 1.
-C
- 40 CONTINUE
- DO 60 J = 1, N
- DO 50 I = 1, M
- FJAC(I,J) = DFLOAT(I)*DFLOAT(J)
- 50 CONTINUE
- 60 CONTINUE
- GO TO 500
-C
-C LINEAR FUNCTION - RANK 1 WITH ZERO COLUMNS AND ROWS.
-C
- 70 CONTINUE
- DO 90 J = 1, N
- DO 80 I = 1, M
- FJAC(I,J) = ZERO
- 80 CONTINUE
- 90 CONTINUE
- NM1 = N - 1
- MM1 = M - 1
- IF (NM1 .LT. 2) GO TO 120
- DO 110 J = 2, NM1
- DO 100 I = 2, MM1
- FJAC(I,J) = DFLOAT(I-1)*DFLOAT(J)
- 100 CONTINUE
- 110 CONTINUE
- 120 CONTINUE
- GO TO 500
-C
-C ROSENBROCK FUNCTION.
-C
- 130 CONTINUE
- FJAC(1,1) = -C20*X(1)
- FJAC(1,2) = TEN
- FJAC(2,1) = -ONE
- FJAC(2,2) = ZERO
- GO TO 500
-C
-C HELICAL VALLEY FUNCTION.
-C
- 140 CONTINUE
- TPI = EIGHT*DATAN(ONE)
- TEMP = X(1)**2 + X(2)**2
- TMP1 = TPI*TEMP
- TMP2 = DSQRT(TEMP)
- FJAC(1,1) = C100*X(2)/TMP1
- FJAC(1,2) = -C100*X(1)/TMP1
- FJAC(1,3) = TEN
- FJAC(2,1) = TEN*X(1)/TMP2
- FJAC(2,2) = TEN*X(2)/TMP2
- FJAC(2,3) = ZERO
- FJAC(3,1) = ZERO
- FJAC(3,2) = ZERO
- FJAC(3,3) = ONE
- GO TO 500
-C
-C POWELL SINGULAR FUNCTION.
-C
- 150 CONTINUE
- DO 170 J = 1, 4
- DO 160 I = 1, 4
- FJAC(I,J) = ZERO
- 160 CONTINUE
- 170 CONTINUE
- FJAC(1,1) = ONE
- FJAC(1,2) = TEN
- FJAC(2,3) = DSQRT(FIVE)
- FJAC(2,4) = -FJAC(2,3)
- FJAC(3,2) = TWO*(X(2) - TWO*X(3))
- FJAC(3,3) = -TWO*FJAC(3,2)
- FJAC(4,1) = TWO*DSQRT(TEN)*(X(1) - X(4))
- FJAC(4,4) = -FJAC(4,1)
- GO TO 500
-C
-C FREUDENSTEIN AND ROTH FUNCTION.
-C
- 180 CONTINUE
- FJAC(1,1) = ONE
- FJAC(1,2) = X(2)*(TEN - THREE*X(2)) - TWO
- FJAC(2,1) = ONE
- FJAC(2,2) = X(2)*(TWO + THREE*X(2)) - C14
- GO TO 500
-C
-C BARD FUNCTION.
-C
- 190 CONTINUE
- DO 200 I = 1, 15
- TMP1 = DFLOAT(I)
- TMP2 = DFLOAT(16-I)
- TMP3 = TMP1
- IF (I .GT. 8) TMP3 = TMP2
- TMP4 = (X(2)*TMP2 + X(3)*TMP3)**2
- FJAC(I,1) = -ONE
- FJAC(I,2) = TMP1*TMP2/TMP4
- FJAC(I,3) = TMP1*TMP3/TMP4
- 200 CONTINUE
- GO TO 500
-C
-C KOWALIK AND OSBORNE FUNCTION.
-C
- 210 CONTINUE
- DO 220 I = 1, 11
- TMP1 = V(I)*(V(I) + X(2))
- TMP2 = V(I)*(V(I) + X(3)) + X(4)
- FJAC(I,1) = -TMP1/TMP2
- FJAC(I,2) = -V(I)*X(1)/TMP2
- FJAC(I,3) = FJAC(I,1)*FJAC(I,2)
- FJAC(I,4) = FJAC(I,3)/V(I)
- 220 CONTINUE
- GO TO 500
-C
-C MEYER FUNCTION.
-C
- 230 CONTINUE
- DO 240 I = 1, 16
- TEMP = FIVE*DFLOAT(I) + C45 + X(3)
- TMP1 = X(2)/TEMP
- TMP2 = DEXP(TMP1)
- FJAC(I,1) = TMP2
- FJAC(I,2) = X(1)*TMP2/TEMP
- FJAC(I,3) = -TMP1*FJAC(I,2)
- 240 CONTINUE
- GO TO 500
-C
-C WATSON FUNCTION.
-C
- 250 CONTINUE
- DO 280 I = 1, 29
- DIV = DFLOAT(I)/C29
- S2 = ZERO
- DX = ONE
- DO 260 J = 1, N
- S2 = S2 + DX*X(J)
- DX = DIV*DX
- 260 CONTINUE
- TEMP = TWO*DIV*S2
- DX = ONE/DIV
- DO 270 J = 1, N
- FJAC(I,J) = DX*(DFLOAT(J-1) - TEMP)
- DX = DIV*DX
- 270 CONTINUE
- 280 CONTINUE
- DO 300 J = 1, N
- DO 290 I = 30, 31
- FJAC(I,J) = ZERO
- 290 CONTINUE
- 300 CONTINUE
- FJAC(30,1) = ONE
- FJAC(31,1) = -TWO*X(1)
- FJAC(31,2) = ONE
- GO TO 500
-C
-C BOX 3-DIMENSIONAL FUNCTION.
-C
- 310 CONTINUE
- DO 320 I = 1, M
- TEMP = DFLOAT(I)
- TMP1 = TEMP/TEN
- FJAC(I,1) = -TMP1*DEXP(-TMP1*X(1))
- FJAC(I,2) = TMP1*DEXP(-TMP1*X(2))
- FJAC(I,3) = DEXP(-TEMP) - DEXP(-TMP1)
- 320 CONTINUE
- GO TO 500
-C
-C JENNRICH AND SAMPSON FUNCTION.
-C
- 330 CONTINUE
- DO 340 I = 1, M
- TEMP = DFLOAT(I)
- FJAC(I,1) = -TEMP*DEXP(TEMP*X(1))
- FJAC(I,2) = -TEMP*DEXP(TEMP*X(2))
- 340 CONTINUE
- GO TO 500
-C
-C BROWN AND DENNIS FUNCTION.
-C
- 350 CONTINUE
- DO 360 I = 1, M
- TEMP = DFLOAT(I)/FIVE
- TI = DSIN(TEMP)
- TMP1 = X(1) + TEMP*X(2) - DEXP(TEMP)
- TMP2 = X(3) + TI*X(4) - DCOS(TEMP)
- FJAC(I,1) = TWO*TMP1
- FJAC(I,2) = TEMP*FJAC(I,1)
- FJAC(I,3) = TWO*TMP2
- FJAC(I,4) = TI*FJAC(I,3)
- 360 CONTINUE
- GO TO 500
-C
-C CHEBYQUAD FUNCTION.
-C
- 370 CONTINUE
- DX = ONE/DFLOAT(N)
- DO 390 J = 1, N
- TMP1 = ONE
- TMP2 = TWO*X(J) - ONE
- TEMP = TWO*TMP2
- TMP3 = ZERO
- TMP4 = TWO
- DO 380 I = 1, M
- FJAC(I,J) = DX*TMP4
- TI = FOUR*TMP2 + TEMP*TMP4 - TMP3
- TMP3 = TMP4
- TMP4 = TI
- TI = TEMP*TMP2 - TMP1
- TMP1 = TMP2
- TMP2 = TI
- 380 CONTINUE
- 390 CONTINUE
- GO TO 500
-C
-C BROWN ALMOST-LINEAR FUNCTION.
-C
- 400 CONTINUE
- PROD = ONE
- DO 420 J = 1, N
- PROD = X(J)*PROD
- DO 410 I = 1, N
- FJAC(I,J) = ONE
- 410 CONTINUE
- FJAC(J,J) = TWO
- 420 CONTINUE
- DO 450 J = 1, N
- TEMP = X(J)
- IF (TEMP .NE. ZERO) GO TO 440
- TEMP = ONE
- PROD = ONE
- DO 430 K = 1, N
- IF (K .NE. J) PROD = X(K)*PROD
- 430 CONTINUE
- 440 CONTINUE
- FJAC(N,J) = PROD/TEMP
- 450 CONTINUE
- GO TO 500
-C
-C OSBORNE 1 FUNCTION.
-C
- 460 CONTINUE
- DO 470 I = 1, 33
- TEMP = TEN*DFLOAT(I-1)
- TMP1 = DEXP(-X(4)*TEMP)
- TMP2 = DEXP(-X(5)*TEMP)
- FJAC(I,1) = -ONE
- FJAC(I,2) = -TMP1
- FJAC(I,3) = -TMP2
- FJAC(I,4) = TEMP*X(2)*TMP1
- FJAC(I,5) = TEMP*X(3)*TMP2
- 470 CONTINUE
- GO TO 500
-C
-C OSBORNE 2 FUNCTION.
-C
- 480 CONTINUE
- DO 490 I = 1, 65
- TEMP = DFLOAT(I-1)/TEN
- TMP1 = DEXP(-X(5)*TEMP)
- TMP2 = DEXP(-X(6)*(TEMP-X(9))**2)
- TMP3 = DEXP(-X(7)*(TEMP-X(10))**2)
- TMP4 = DEXP(-X(8)*(TEMP-X(11))**2)
- FJAC(I,1) = -TMP1
- FJAC(I,2) = -TMP2
- FJAC(I,3) = -TMP3
- FJAC(I,4) = -TMP4
- FJAC(I,5) = TEMP*X(1)*TMP1
- FJAC(I,6) = X(2)*(TEMP - X(9))**2*TMP2
- FJAC(I,7) = X(3)*(TEMP - X(10))**2*TMP3
- FJAC(I,8) = X(4)*(TEMP - X(11))**2*TMP4
- FJAC(I,9) = -TWO*X(2)*X(6)*(TEMP - X(9))*TMP2
- FJAC(I,10) = -TWO*X(3)*X(7)*(TEMP - X(10))*TMP3
- FJAC(I,11) = -TWO*X(4)*X(8)*(TEMP - X(11))*TMP4
- 490 CONTINUE
- 500 CONTINUE
- RETURN
-C
-C LAST CARD OF SUBROUTINE SSQJAC.
-C
- END
- SUBROUTINE INITPT(N,X,NPROB,FACTOR)
- INTEGER N,NPROB
- DOUBLE PRECISION FACTOR
- DOUBLE PRECISION X(N)
-C **********
-C
-C SUBROUTINE INITPT
-C
-C THIS SUBROUTINE SPECIFIES THE STANDARD STARTING POINTS FOR THE
-C FUNCTIONS DEFINED BY SUBROUTINE SSQFCN. THE SUBROUTINE RETURNS
-C IN X A MULTIPLE (FACTOR) OF THE STANDARD STARTING POINT. FOR
-C THE 11TH FUNCTION THE STANDARD STARTING POINT IS ZERO, SO IN
-C THIS CASE, IF FACTOR IS NOT UNITY, THEN THE SUBROUTINE RETURNS
-C THE VECTOR X(J) = FACTOR, J=1,...,N.
-C
-C THE SUBROUTINE STATEMENT IS
-C
-C SUBROUTINE INITPT(N,X,NPROB,FACTOR)
-C
-C WHERE
-C
-C N IS A POSITIVE INTEGER INPUT VARIABLE.
-C
-C X IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS THE STANDARD
-C STARTING POINT FOR PROBLEM NPROB MULTIPLIED BY FACTOR.
-C
-C NPROB IS A POSITIVE INTEGER INPUT VARIABLE WHICH DEFINES THE
-C NUMBER OF THE PROBLEM. NPROB MUST NOT EXCEED 18.
-C
-C FACTOR IS AN INPUT VARIABLE WHICH SPECIFIES THE MULTIPLE OF
-C THE STANDARD STARTING POINT. IF FACTOR IS UNITY, NO
-C MULTIPLICATION IS PERFORMED.
-C
-C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980.
-C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE
-C
-C **********
- INTEGER IVAR,J
- DOUBLE PRECISION C1,C2,C3,C4,C5,C6,C7,C8,C9,C10,C11,C12,C13,C14,
- * C15,C16,C17,FIVE,H,HALF,ONE,SEVEN,TEN,THREE,
- * TWENTY,TWNTF,TWO,ZERO
- DOUBLE PRECISION DFLOAT
- DATA ZERO,HALF,ONE,TWO,THREE,FIVE,SEVEN,TEN,TWENTY,TWNTF
- * /0.0D0,5.0D-1,1.0D0,2.0D0,3.0D0,5.0D0,7.0D0,1.0D1,2.0D1,
- * 2.5D1/
- DATA C1,C2,C3,C4,C5,C6,C7,C8,C9,C10,C11,C12,C13,C14,C15,C16,C17
- * /1.2D0,2.5D-1,3.9D-1,4.15D-1,2.0D-2,4.0D3,2.5D2,3.0D-1,
- * 4.0D-1,1.5D0,1.0D-2,1.3D0,6.5D-1,7.0D-1,6.0D-1,4.5D0,
- * 5.5D0/
- DFLOAT(IVAR) = IVAR
-C
-C SELECTION OF INITIAL POINT.
-C
- GO TO (10,10,10,30,40,50,60,70,80,90,100,120,130,140,150,170,
- * 190,200), NPROB
-C
-C LINEAR FUNCTION - FULL RANK OR RANK 1.
-C
- 10 CONTINUE
- DO 20 J = 1, N
- X(J) = ONE
- 20 CONTINUE
- GO TO 210
-C
-C ROSENBROCK FUNCTION.
-C
- 30 CONTINUE
- X(1) = -C1
- X(2) = ONE
- GO TO 210
-C
-C HELICAL VALLEY FUNCTION.
-C
- 40 CONTINUE
- X(1) = -ONE
- X(2) = ZERO
- X(3) = ZERO
- GO TO 210
-C
-C POWELL SINGULAR FUNCTION.
-C
- 50 CONTINUE
- X(1) = THREE
- X(2) = -ONE
- X(3) = ZERO
- X(4) = ONE
- GO TO 210
-C
-C FREUDENSTEIN AND ROTH FUNCTION.
-C
- 60 CONTINUE
- X(1) = HALF
- X(2) = -TWO
- GO TO 210
-C
-C BARD FUNCTION.
-C
- 70 CONTINUE
- X(1) = ONE
- X(2) = ONE
- X(3) = ONE
- GO TO 210
-C
-C KOWALIK AND OSBORNE FUNCTION.
-C
- 80 CONTINUE
- X(1) = C2
- X(2) = C3
- X(3) = C4
- X(4) = C3
- GO TO 210
-C
-C MEYER FUNCTION.
-C
- 90 CONTINUE
- X(1) = C5
- X(2) = C6
- X(3) = C7
- GO TO 210
-C
-C WATSON FUNCTION.
-C
- 100 CONTINUE
- DO 110 J = 1, N
- X(J) = ZERO
- 110 CONTINUE
- GO TO 210
-C
-C BOX 3-DIMENSIONAL FUNCTION.
-C
- 120 CONTINUE
- X(1) = ZERO
- X(2) = TEN
- X(3) = TWENTY
- GO TO 210
-C
-C JENNRICH AND SAMPSON FUNCTION.
-C
- 130 CONTINUE
- X(1) = C8
- X(2) = C9
- GO TO 210
-C
-C BROWN AND DENNIS FUNCTION.
-C
- 140 CONTINUE
- X(1) = TWNTF
- X(2) = FIVE
- X(3) = -FIVE
- X(4) = -ONE
- GO TO 210
-C
-C CHEBYQUAD FUNCTION.
-C
- 150 CONTINUE
- H = ONE/DFLOAT(N+1)
- DO 160 J = 1, N
- X(J) = DFLOAT(J)*H
- 160 CONTINUE
- GO TO 210
-C
-C BROWN ALMOST-LINEAR FUNCTION.
-C
- 170 CONTINUE
- DO 180 J = 1, N
- X(J) = HALF
- 180 CONTINUE
- GO TO 210
-C
-C OSBORNE 1 FUNCTION.
-C
- 190 CONTINUE
- X(1) = HALF
- X(2) = C10
- X(3) = -ONE
- X(4) = C11
- X(5) = C5
- GO TO 210
-C
-C OSBORNE 2 FUNCTION.
-C
- 200 CONTINUE
- X(1) = C12
- X(2) = C13
- X(3) = C13
- X(4) = C14
- X(5) = C15
- X(6) = THREE
- X(7) = FIVE
- X(8) = SEVEN
- X(9) = TWO
- X(10) = C16
- X(11) = C17
- 210 CONTINUE
-C
-C COMPUTE MULTIPLE OF INITIAL POINT.
-C
- IF (FACTOR .EQ. ONE) GO TO 260
- IF (NPROB .EQ. 11) GO TO 230
- DO 220 J = 1, N
- X(J) = FACTOR*X(J)
- 220 CONTINUE
- GO TO 250
- 230 CONTINUE
- DO 240 J = 1, N
- X(J) = FACTOR
- 240 CONTINUE
- 250 CONTINUE
- 260 CONTINUE
- RETURN
-C
-C LAST CARD OF SUBROUTINE INITPT.
-C
- END
- SUBROUTINE SSQFCN(M,N,X,FVEC,NPROB)
- INTEGER M,N,NPROB
- DOUBLE PRECISION X(N),FVEC(M)
-C **********
-C
-C SUBROUTINE SSQFCN
-C
-C THIS SUBROUTINE DEFINES THE FUNCTIONS OF EIGHTEEN NONLINEAR
-C LEAST SQUARES PROBLEMS. THE ALLOWABLE VALUES OF (M,N) FOR
-C FUNCTIONS 1,2 AND 3 ARE VARIABLE BUT WITH M .GE. N.
-C FOR FUNCTIONS 4,5,6,7,8,9 AND 10 THE VALUES OF (M,N) ARE
-C (2,2),(3,3),(4,4),(2,2),(15,3),(11,4) AND (16,3), RESPECTIVELY.
-C FUNCTION 11 (WATSON) HAS M = 31 WITH N USUALLY 6 OR 9.
-C HOWEVER, ANY N, N = 2,...,31, IS PERMITTED.
-C FUNCTIONS 12,13 AND 14 HAVE N = 3,2 AND 4, RESPECTIVELY, BUT
-C ALLOW ANY M .GE. N, WITH THE USUAL CHOICES BEING 10,10 AND 20.
-C FUNCTION 15 (CHEBYQUAD) ALLOWS M AND N VARIABLE WITH M .GE. N.
-C FUNCTION 16 (BROWN) ALLOWS N VARIABLE WITH M = N.
-C FOR FUNCTIONS 17 AND 18, THE VALUES OF (M,N) ARE
-C (33,5) AND (65,11), RESPECTIVELY.
-C
-C THE SUBROUTINE STATEMENT IS
-C
-C SUBROUTINE SSQFCN(M,N,X,FVEC,NPROB)
-C
-C WHERE
-C
-C M AND N ARE POSITIVE INTEGER INPUT VARIABLES. N MUST NOT
-C EXCEED M.
-C
-C X IS AN INPUT ARRAY OF LENGTH N.
-C
-C FVEC IS AN OUTPUT ARRAY OF LENGTH M WHICH CONTAINS THE NPROB
-C FUNCTION EVALUATED AT X.
-C
-C NPROB IS A POSITIVE INTEGER INPUT VARIABLE WHICH DEFINES THE
-C NUMBER OF THE PROBLEM. NPROB MUST NOT EXCEED 18.
-C
-C SUBPROGRAMS CALLED
-C
-C FORTRAN-SUPPLIED ... DATAN,DCOS,DEXP,DSIN,DSQRT,DSIGN
-C
-C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980.
-C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE
-C
-C **********
- INTEGER I,IEV,IVAR,J,NM1
- DOUBLE PRECISION C13,C14,C29,C45,DIV,DX,EIGHT,FIVE,ONE,PROD,SUM,
- * S1,S2,TEMP,TEN,TI,TMP1,TMP2,TMP3,TMP4,TPI,TWO,
- * ZERO,ZP25,ZP5
- DOUBLE PRECISION V(11),Y1(15),Y2(11),Y3(16),Y4(33),Y5(65)
- DOUBLE PRECISION DFLOAT
- DATA ZERO,ZP25,ZP5,ONE,TWO,FIVE,EIGHT,TEN,C13,C14,C29,C45
- * /0.0D0,2.5D-1,5.0D-1,1.0D0,2.0D0,5.0D0,8.0D0,1.0D1,1.3D1,
- * 1.4D1,2.9D1,4.5D1/
- DATA V(1),V(2),V(3),V(4),V(5),V(6),V(7),V(8),V(9),V(10),V(11)
- * /4.0D0,2.0D0,1.0D0,5.0D-1,2.5D-1,1.67D-1,1.25D-1,1.0D-1,
- * 8.33D-2,7.14D-2,6.25D-2/
- DATA Y1(1),Y1(2),Y1(3),Y1(4),Y1(5),Y1(6),Y1(7),Y1(8),Y1(9),
- * Y1(10),Y1(11),Y1(12),Y1(13),Y1(14),Y1(15)
- * /1.4D-1,1.8D-1,2.2D-1,2.5D-1,2.9D-1,3.2D-1,3.5D-1,3.9D-1,
- * 3.7D-1,5.8D-1,7.3D-1,9.6D-1,1.34D0,2.1D0,4.39D0/
- DATA Y2(1),Y2(2),Y2(3),Y2(4),Y2(5),Y2(6),Y2(7),Y2(8),Y2(9),
- * Y2(10),Y2(11)
- * /1.957D-1,1.947D-1,1.735D-1,1.6D-1,8.44D-2,6.27D-2,4.56D-2,
- * 3.42D-2,3.23D-2,2.35D-2,2.46D-2/
- DATA Y3(1),Y3(2),Y3(3),Y3(4),Y3(5),Y3(6),Y3(7),Y3(8),Y3(9),
- * Y3(10),Y3(11),Y3(12),Y3(13),Y3(14),Y3(15),Y3(16)
- * /3.478D4,2.861D4,2.365D4,1.963D4,1.637D4,1.372D4,1.154D4,
- * 9.744D3,8.261D3,7.03D3,6.005D3,5.147D3,4.427D3,3.82D3,
- * 3.307D3,2.872D3/
- DATA Y4(1),Y4(2),Y4(3),Y4(4),Y4(5),Y4(6),Y4(7),Y4(8),Y4(9),
- * Y4(10),Y4(11),Y4(12),Y4(13),Y4(14),Y4(15),Y4(16),Y4(17),
- * Y4(18),Y4(19),Y4(20),Y4(21),Y4(22),Y4(23),Y4(24),Y4(25),
- * Y4(26),Y4(27),Y4(28),Y4(29),Y4(30),Y4(31),Y4(32),Y4(33)
- * /8.44D-1,9.08D-1,9.32D-1,9.36D-1,9.25D-1,9.08D-1,8.81D-1,
- * 8.5D-1,8.18D-1,7.84D-1,7.51D-1,7.18D-1,6.85D-1,6.58D-1,
- * 6.28D-1,6.03D-1,5.8D-1,5.58D-1,5.38D-1,5.22D-1,5.06D-1,
- * 4.9D-1,4.78D-1,4.67D-1,4.57D-1,4.48D-1,4.38D-1,4.31D-1,
- * 4.24D-1,4.2D-1,4.14D-1,4.11D-1,4.06D-1/
- DATA Y5(1),Y5(2),Y5(3),Y5(4),Y5(5),Y5(6),Y5(7),Y5(8),Y5(9),
- * Y5(10),Y5(11),Y5(12),Y5(13),Y5(14),Y5(15),Y5(16),Y5(17),
- * Y5(18),Y5(19),Y5(20),Y5(21),Y5(22),Y5(23),Y5(24),Y5(25),
- * Y5(26),Y5(27),Y5(28),Y5(29),Y5(30),Y5(31),Y5(32),Y5(33),
- * Y5(34),Y5(35),Y5(36),Y5(37),Y5(38),Y5(39),Y5(40),Y5(41),
- * Y5(42),Y5(43),Y5(44),Y5(45),Y5(46),Y5(47),Y5(48),Y5(49),
- * Y5(50),Y5(51),Y5(52),Y5(53),Y5(54),Y5(55),Y5(56),Y5(57),
- * Y5(58),Y5(59),Y5(60),Y5(61),Y5(62),Y5(63),Y5(64),Y5(65)
- * /1.366D0,1.191D0,1.112D0,1.013D0,9.91D-1,8.85D-1,8.31D-1,
- * 8.47D-1,7.86D-1,7.25D-1,7.46D-1,6.79D-1,6.08D-1,6.55D-1,
- * 6.16D-1,6.06D-1,6.02D-1,6.26D-1,6.51D-1,7.24D-1,6.49D-1,
- * 6.49D-1,6.94D-1,6.44D-1,6.24D-1,6.61D-1,6.12D-1,5.58D-1,
- * 5.33D-1,4.95D-1,5.0D-1,4.23D-1,3.95D-1,3.75D-1,3.72D-1,
- * 3.91D-1,3.96D-1,4.05D-1,4.28D-1,4.29D-1,5.23D-1,5.62D-1,
- * 6.07D-1,6.53D-1,6.72D-1,7.08D-1,6.33D-1,6.68D-1,6.45D-1,
- * 6.32D-1,5.91D-1,5.59D-1,5.97D-1,6.25D-1,7.39D-1,7.1D-1,
- * 7.29D-1,7.2D-1,6.36D-1,5.81D-1,4.28D-1,2.92D-1,1.62D-1,
- * 9.8D-2,5.4D-2/
- DFLOAT(IVAR) = IVAR
-C
-C FUNCTION ROUTINE SELECTOR.
-C
- GO TO (10,40,70,110,120,130,140,150,170,190,210,250,270,290,310,
- * 360,390,410), NPROB
-C
-C LINEAR FUNCTION - FULL RANK.
-C
- 10 CONTINUE
- SUM = ZERO
- DO 20 J = 1, N
- SUM = SUM + X(J)
- 20 CONTINUE
- TEMP = TWO*SUM/DFLOAT(M) + ONE
- DO 30 I = 1, M
- FVEC(I) = -TEMP
- IF (I .LE. N) FVEC(I) = FVEC(I) + X(I)
- 30 CONTINUE
- GO TO 430
-C
-C LINEAR FUNCTION - RANK 1.
-C
- 40 CONTINUE
- SUM = ZERO
- DO 50 J = 1, N
- SUM = SUM + DFLOAT(J)*X(J)
- 50 CONTINUE
- DO 60 I = 1, M
- FVEC(I) = DFLOAT(I)*SUM - ONE
- 60 CONTINUE
- GO TO 430
-C
-C LINEAR FUNCTION - RANK 1 WITH ZERO COLUMNS AND ROWS.
-C
- 70 CONTINUE
- SUM = ZERO
- NM1 = N - 1
- IF (NM1 .LT. 2) GO TO 90
- DO 80 J = 2, NM1
- SUM = SUM + DFLOAT(J)*X(J)
- 80 CONTINUE
- 90 CONTINUE
- DO 100 I = 1, M
- FVEC(I) = DFLOAT(I-1)*SUM - ONE
- 100 CONTINUE
- FVEC(M) = -ONE
- GO TO 430
-C
-C ROSENBROCK FUNCTION.
-C
- 110 CONTINUE
- FVEC(1) = TEN*(X(2) - X(1)**2)
- FVEC(2) = ONE - X(1)
- GO TO 430
-C
-C HELICAL VALLEY FUNCTION.
-C
- 120 CONTINUE
- TPI = EIGHT*DATAN(ONE)
- TMP1 = DSIGN(ZP25,X(2))
- IF (X(1) .GT. ZERO) TMP1 = DATAN(X(2)/X(1))/TPI
- IF (X(1) .LT. ZERO) TMP1 = DATAN(X(2)/X(1))/TPI + ZP5
- TMP2 = DSQRT(X(1)**2+X(2)**2)
- FVEC(1) = TEN*(X(3) - TEN*TMP1)
- FVEC(2) = TEN*(TMP2 - ONE)
- FVEC(3) = X(3)
- GO TO 430
-C
-C POWELL SINGULAR FUNCTION.
-C
- 130 CONTINUE
- FVEC(1) = X(1) + TEN*X(2)
- FVEC(2) = DSQRT(FIVE)*(X(3) - X(4))
- FVEC(3) = (X(2) - TWO*X(3))**2
- FVEC(4) = DSQRT(TEN)*(X(1) - X(4))**2
- GO TO 430
-C
-C FREUDENSTEIN AND ROTH FUNCTION.
-C
- 140 CONTINUE
- FVEC(1) = -C13 + X(1) + ((FIVE - X(2))*X(2) - TWO)*X(2)
- FVEC(2) = -C29 + X(1) + ((ONE + X(2))*X(2) - C14)*X(2)
- GO TO 430
-C
-C BARD FUNCTION.
-C
- 150 CONTINUE
- DO 160 I = 1, 15
- TMP1 = DFLOAT(I)
- TMP2 = DFLOAT(16-I)
- TMP3 = TMP1
- IF (I .GT. 8) TMP3 = TMP2
- FVEC(I) = Y1(I) - (X(1) + TMP1/(X(2)*TMP2 + X(3)*TMP3))
- 160 CONTINUE
- GO TO 430
-C
-C KOWALIK AND OSBORNE FUNCTION.
-C
- 170 CONTINUE
- DO 180 I = 1, 11
- TMP1 = V(I)*(V(I) + X(2))
- TMP2 = V(I)*(V(I) + X(3)) + X(4)
- FVEC(I) = Y2(I) - X(1)*TMP1/TMP2
- 180 CONTINUE
- GO TO 430
-C
-C MEYER FUNCTION.
-C
- 190 CONTINUE
- DO 200 I = 1, 16
- TEMP = FIVE*DFLOAT(I) + C45 + X(3)
- TMP1 = X(2)/TEMP
- TMP2 = DEXP(TMP1)
- FVEC(I) = X(1)*TMP2 - Y3(I)
- 200 CONTINUE
- GO TO 430
-C
-C WATSON FUNCTION.
-C
- 210 CONTINUE
- DO 240 I = 1, 29
- DIV = DFLOAT(I)/C29
- S1 = ZERO
- DX = ONE
- DO 220 J = 2, N
- S1 = S1 + DFLOAT(J-1)*DX*X(J)
- DX = DIV*DX
- 220 CONTINUE
- S2 = ZERO
- DX = ONE
- DO 230 J = 1, N
- S2 = S2 + DX*X(J)
- DX = DIV*DX
- 230 CONTINUE
- FVEC(I) = S1 - S2**2 - ONE
- 240 CONTINUE
- FVEC(30) = X(1)
- FVEC(31) = X(2) - X(1)**2 - ONE
- GO TO 430
-C
-C BOX 3-DIMENSIONAL FUNCTION.
-C
- 250 CONTINUE
- DO 260 I = 1, M
- TEMP = DFLOAT(I)
- TMP1 = TEMP/TEN
- FVEC(I) = DEXP(-TMP1*X(1)) - DEXP(-TMP1*X(2))
- * + (DEXP(-TEMP) - DEXP(-TMP1))*X(3)
- 260 CONTINUE
- GO TO 430
-C
-C JENNRICH AND SAMPSON FUNCTION.
-C
- 270 CONTINUE
- DO 280 I = 1, M
- TEMP = DFLOAT(I)
- FVEC(I) = TWO + TWO*TEMP - DEXP(TEMP*X(1)) - DEXP(TEMP*X(2))
- 280 CONTINUE
- GO TO 430
-C
-C BROWN AND DENNIS FUNCTION.
-C
- 290 CONTINUE
- DO 300 I = 1, M
- TEMP = DFLOAT(I)/FIVE
- TMP1 = X(1) + TEMP*X(2) - DEXP(TEMP)
- TMP2 = X(3) + DSIN(TEMP)*X(4) - DCOS(TEMP)
- FVEC(I) = TMP1**2 + TMP2**2
- 300 CONTINUE
- GO TO 430
-C
-C CHEBYQUAD FUNCTION.
-C
- 310 CONTINUE
- DO 320 I = 1, M
- FVEC(I) = ZERO
- 320 CONTINUE
- DO 340 J = 1, N
- TMP1 = ONE
- TMP2 = TWO*X(J) - ONE
- TEMP = TWO*TMP2
- DO 330 I = 1, M
- FVEC(I) = FVEC(I) + TMP2
- TI = TEMP*TMP2 - TMP1
- TMP1 = TMP2
- TMP2 = TI
- 330 CONTINUE
- 340 CONTINUE
- DX = ONE/DFLOAT(N)
- IEV = -1
- DO 350 I = 1, M
- FVEC(I) = DX*FVEC(I)
- IF (IEV .GT. 0) FVEC(I) = FVEC(I) + ONE/(DFLOAT(I)**2 - ONE)
- IEV = -IEV
- 350 CONTINUE
- GO TO 430
-C
-C BROWN ALMOST-LINEAR FUNCTION.
-C
- 360 CONTINUE
- SUM = -DFLOAT(N+1)
- PROD = ONE
- DO 370 J = 1, N
- SUM = SUM + X(J)
- PROD = X(J)*PROD
- 370 CONTINUE
- DO 380 I = 1, N
- FVEC(I) = X(I) + SUM
- 380 CONTINUE
- FVEC(N) = PROD - ONE
- GO TO 430
-C
-C OSBORNE 1 FUNCTION.
-C
- 390 CONTINUE
- DO 400 I = 1, 33
- TEMP = TEN*DFLOAT(I-1)
- TMP1 = DEXP(-X(4)*TEMP)
- TMP2 = DEXP(-X(5)*TEMP)
- FVEC(I) = Y4(I) - (X(1) + X(2)*TMP1 + X(3)*TMP2)
- 400 CONTINUE
- GO TO 430
-C
-C OSBORNE 2 FUNCTION.
-C
- 410 CONTINUE
- DO 420 I = 1, 65
- TEMP = DFLOAT(I-1)/TEN
- TMP1 = DEXP(-X(5)*TEMP)
- TMP2 = DEXP(-X(6)*(TEMP-X(9))**2)
- TMP3 = DEXP(-X(7)*(TEMP-X(10))**2)
- TMP4 = DEXP(-X(8)*(TEMP-X(11))**2)
- FVEC(I) = Y5(I)
- * - (X(1)*TMP1 + X(2)*TMP2 + X(3)*TMP3 + X(4)*TMP4)
- 420 CONTINUE
- 430 CONTINUE
- RETURN
-C
-C LAST CARD OF SUBROUTINE SSQFCN.
-C
- END
diff --git a/CEP/PyBDSM/src/minpack/ex/file19 b/CEP/PyBDSM/src/minpack/ex/file19
deleted file mode 100644
index 9e1ba549a0d822c7e245c995521d4b5b79a5f6e8..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/minpack/ex/file19
+++ /dev/null
@@ -1,675 +0,0 @@
-C **********
-C
-C THIS PROGRAM TESTS CODES FOR THE LEAST-SQUARES SOLUTION OF
-C M NONLINEAR EQUATIONS IN N VARIABLES. IT CONSISTS OF A DRIVER
-C AND AN INTERFACE SUBROUTINE FCN. THE DRIVER READS IN DATA,
-C CALLS THE NONLINEAR LEAST-SQUARES SOLVER, AND FINALLY PRINTS
-C OUT INFORMATION ON THE PERFORMANCE OF THE SOLVER. THIS IS
-C ONLY A SAMPLE DRIVER, MANY OTHER DRIVERS ARE POSSIBLE. THE
-C INTERFACE SUBROUTINE FCN IS NECESSARY TO TAKE INTO ACCOUNT THE
-C FORMS OF CALLING SEQUENCES USED BY THE FUNCTION AND JACOBIAN
-C SUBROUTINES IN THE VARIOUS NONLINEAR LEAST-SQUARES SOLVERS.
-C
-C SUBPROGRAMS CALLED
-C
-C USER-SUPPLIED ...... FCN
-C
-C MINPACK-SUPPLIED ... DPMPAR,ENORM,INITPT,LMDIF1,SSQFCN
-C
-C FORTRAN-SUPPLIED ... DSQRT
-C
-C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980.
-C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE
-C
-C **********
- INTEGER I,IC,INFO,K,LWA,M,N,NFEV,NJEV,NPROB,NREAD,NTRIES,NWRITE
- INTEGER IWA(40),MA(60),NA(60),NF(60),NJ(60),NP(60),NX(60)
- DOUBLE PRECISION FACTOR,FNORM1,FNORM2,ONE,TEN,TOL
- DOUBLE PRECISION FNM(60),FVEC(65),WA(2865),X(40)
- DOUBLE PRECISION DPMPAR,ENORM
- EXTERNAL FCN
- COMMON /REFNUM/ NPROB,NFEV,NJEV
-C
-C LOGICAL INPUT UNIT IS ASSUMED TO BE NUMBER 5.
-C LOGICAL OUTPUT UNIT IS ASSUMED TO BE NUMBER 6.
-C
- DATA NREAD,NWRITE /5,6/
-C
- DATA ONE,TEN /1.0D0,1.0D1/
- TOL = DSQRT(DPMPAR(1))
- LWA = 2865
- IC = 0
- 10 CONTINUE
- READ (NREAD,50) NPROB,N,M,NTRIES
- IF (NPROB .LE. 0) GO TO 30
- FACTOR = ONE
- DO 20 K = 1, NTRIES
- IC = IC + 1
- CALL INITPT(N,X,NPROB,FACTOR)
- CALL SSQFCN(M,N,X,FVEC,NPROB)
- FNORM1 = ENORM(M,FVEC)
- WRITE (NWRITE,60) NPROB,N,M
- NFEV = 0
- NJEV = 0
- CALL LMDIF1(FCN,M,N,X,FVEC,TOL,INFO,IWA,WA,LWA)
- CALL SSQFCN(M,N,X,FVEC,NPROB)
- FNORM2 = ENORM(M,FVEC)
- NP(IC) = NPROB
- NA(IC) = N
- MA(IC) = M
- NF(IC) = NFEV
- NJEV = NJEV/N
- NJ(IC) = NJEV
- NX(IC) = INFO
- FNM(IC) = FNORM2
- WRITE (NWRITE,70)
- * FNORM1,FNORM2,NFEV,NJEV,INFO,(X(I), I = 1, N)
- FACTOR = TEN*FACTOR
- 20 CONTINUE
- GO TO 10
- 30 CONTINUE
- WRITE (NWRITE,80) IC
- WRITE (NWRITE,90)
- DO 40 I = 1, IC
- WRITE (NWRITE,100) NP(I),NA(I),MA(I),NF(I),NJ(I),NX(I),FNM(I)
- 40 CONTINUE
- STOP
- 50 FORMAT (4I5)
- 60 FORMAT ( //// 5X, 8H PROBLEM, I5, 5X, 11H DIMENSIONS, 2I5, 5X //
- * )
- 70 FORMAT (5X, 33H INITIAL L2 NORM OF THE RESIDUALS, D15.7 // 5X,
- * 33H FINAL L2 NORM OF THE RESIDUALS , D15.7 // 5X,
- * 33H NUMBER OF FUNCTION EVALUATIONS , I10 // 5X,
- * 33H NUMBER OF JACOBIAN EVALUATIONS , I10 // 5X,
- * 15H EXIT PARAMETER, 18X, I10 // 5X,
- * 27H FINAL APPROXIMATE SOLUTION // (5X, 5D15.7))
- 80 FORMAT (12H1SUMMARY OF , I3, 16H CALLS TO LMDIF1 /)
- 90 FORMAT (49H NPROB N M NFEV NJEV INFO FINAL L2 NORM /)
- 100 FORMAT (3I5, 3I6, 1X, D15.7)
-C
-C LAST CARD OF DRIVER.
-C
- END
- SUBROUTINE FCN(M,N,X,FVEC,IFLAG)
- INTEGER M,N,IFLAG
- DOUBLE PRECISION X(N),FVEC(M)
-C **********
-C
-C THE CALLING SEQUENCE OF FCN SHOULD BE IDENTICAL TO THE
-C CALLING SEQUENCE OF THE FUNCTION SUBROUTINE IN THE NONLINEAR
-C LEAST-SQUARES SOLVER. FCN SHOULD ONLY CALL THE TESTING
-C FUNCTION SUBROUTINE SSQFCN WITH THE APPROPRIATE VALUE OF
-C PROBLEM NUMBER (NPROB).
-C
-C SUBPROGRAMS CALLED
-C
-C MINPACK-SUPPLIED ... SSQFCN
-C
-C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980.
-C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE
-C
-C **********
- INTEGER NPROB,NFEV,NJEV
- COMMON /REFNUM/ NPROB,NFEV,NJEV
- CALL SSQFCN(M,N,X,FVEC,NPROB)
- IF (IFLAG .EQ. 1) NFEV = NFEV + 1
- IF (IFLAG .EQ. 2) NJEV = NJEV + 1
- RETURN
-C
-C LAST CARD OF INTERFACE SUBROUTINE FCN.
-C
- END
- SUBROUTINE SSQFCN(M,N,X,FVEC,NPROB)
- INTEGER M,N,NPROB
- DOUBLE PRECISION X(N),FVEC(M)
-C **********
-C
-C SUBROUTINE SSQFCN
-C
-C THIS SUBROUTINE DEFINES THE FUNCTIONS OF EIGHTEEN NONLINEAR
-C LEAST SQUARES PROBLEMS. THE ALLOWABLE VALUES OF (M,N) FOR
-C FUNCTIONS 1,2 AND 3 ARE VARIABLE BUT WITH M .GE. N.
-C FOR FUNCTIONS 4,5,6,7,8,9 AND 10 THE VALUES OF (M,N) ARE
-C (2,2),(3,3),(4,4),(2,2),(15,3),(11,4) AND (16,3), RESPECTIVELY.
-C FUNCTION 11 (WATSON) HAS M = 31 WITH N USUALLY 6 OR 9.
-C HOWEVER, ANY N, N = 2,...,31, IS PERMITTED.
-C FUNCTIONS 12,13 AND 14 HAVE N = 3,2 AND 4, RESPECTIVELY, BUT
-C ALLOW ANY M .GE. N, WITH THE USUAL CHOICES BEING 10,10 AND 20.
-C FUNCTION 15 (CHEBYQUAD) ALLOWS M AND N VARIABLE WITH M .GE. N.
-C FUNCTION 16 (BROWN) ALLOWS N VARIABLE WITH M = N.
-C FOR FUNCTIONS 17 AND 18, THE VALUES OF (M,N) ARE
-C (33,5) AND (65,11), RESPECTIVELY.
-C
-C THE SUBROUTINE STATEMENT IS
-C
-C SUBROUTINE SSQFCN(M,N,X,FVEC,NPROB)
-C
-C WHERE
-C
-C M AND N ARE POSITIVE INTEGER INPUT VARIABLES. N MUST NOT
-C EXCEED M.
-C
-C X IS AN INPUT ARRAY OF LENGTH N.
-C
-C FVEC IS AN OUTPUT ARRAY OF LENGTH M WHICH CONTAINS THE NPROB
-C FUNCTION EVALUATED AT X.
-C
-C NPROB IS A POSITIVE INTEGER INPUT VARIABLE WHICH DEFINES THE
-C NUMBER OF THE PROBLEM. NPROB MUST NOT EXCEED 18.
-C
-C SUBPROGRAMS CALLED
-C
-C FORTRAN-SUPPLIED ... DATAN,DCOS,DEXP,DSIN,DSQRT,DSIGN
-C
-C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980.
-C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE
-C
-C **********
- INTEGER I,IEV,IVAR,J,NM1
- DOUBLE PRECISION C13,C14,C29,C45,DIV,DX,EIGHT,FIVE,ONE,PROD,SUM,
- * S1,S2,TEMP,TEN,TI,TMP1,TMP2,TMP3,TMP4,TPI,TWO,
- * ZERO,ZP25,ZP5
- DOUBLE PRECISION V(11),Y1(15),Y2(11),Y3(16),Y4(33),Y5(65)
- DOUBLE PRECISION DFLOAT
- DATA ZERO,ZP25,ZP5,ONE,TWO,FIVE,EIGHT,TEN,C13,C14,C29,C45
- * /0.0D0,2.5D-1,5.0D-1,1.0D0,2.0D0,5.0D0,8.0D0,1.0D1,1.3D1,
- * 1.4D1,2.9D1,4.5D1/
- DATA V(1),V(2),V(3),V(4),V(5),V(6),V(7),V(8),V(9),V(10),V(11)
- * /4.0D0,2.0D0,1.0D0,5.0D-1,2.5D-1,1.67D-1,1.25D-1,1.0D-1,
- * 8.33D-2,7.14D-2,6.25D-2/
- DATA Y1(1),Y1(2),Y1(3),Y1(4),Y1(5),Y1(6),Y1(7),Y1(8),Y1(9),
- * Y1(10),Y1(11),Y1(12),Y1(13),Y1(14),Y1(15)
- * /1.4D-1,1.8D-1,2.2D-1,2.5D-1,2.9D-1,3.2D-1,3.5D-1,3.9D-1,
- * 3.7D-1,5.8D-1,7.3D-1,9.6D-1,1.34D0,2.1D0,4.39D0/
- DATA Y2(1),Y2(2),Y2(3),Y2(4),Y2(5),Y2(6),Y2(7),Y2(8),Y2(9),
- * Y2(10),Y2(11)
- * /1.957D-1,1.947D-1,1.735D-1,1.6D-1,8.44D-2,6.27D-2,4.56D-2,
- * 3.42D-2,3.23D-2,2.35D-2,2.46D-2/
- DATA Y3(1),Y3(2),Y3(3),Y3(4),Y3(5),Y3(6),Y3(7),Y3(8),Y3(9),
- * Y3(10),Y3(11),Y3(12),Y3(13),Y3(14),Y3(15),Y3(16)
- * /3.478D4,2.861D4,2.365D4,1.963D4,1.637D4,1.372D4,1.154D4,
- * 9.744D3,8.261D3,7.03D3,6.005D3,5.147D3,4.427D3,3.82D3,
- * 3.307D3,2.872D3/
- DATA Y4(1),Y4(2),Y4(3),Y4(4),Y4(5),Y4(6),Y4(7),Y4(8),Y4(9),
- * Y4(10),Y4(11),Y4(12),Y4(13),Y4(14),Y4(15),Y4(16),Y4(17),
- * Y4(18),Y4(19),Y4(20),Y4(21),Y4(22),Y4(23),Y4(24),Y4(25),
- * Y4(26),Y4(27),Y4(28),Y4(29),Y4(30),Y4(31),Y4(32),Y4(33)
- * /8.44D-1,9.08D-1,9.32D-1,9.36D-1,9.25D-1,9.08D-1,8.81D-1,
- * 8.5D-1,8.18D-1,7.84D-1,7.51D-1,7.18D-1,6.85D-1,6.58D-1,
- * 6.28D-1,6.03D-1,5.8D-1,5.58D-1,5.38D-1,5.22D-1,5.06D-1,
- * 4.9D-1,4.78D-1,4.67D-1,4.57D-1,4.48D-1,4.38D-1,4.31D-1,
- * 4.24D-1,4.2D-1,4.14D-1,4.11D-1,4.06D-1/
- DATA Y5(1),Y5(2),Y5(3),Y5(4),Y5(5),Y5(6),Y5(7),Y5(8),Y5(9),
- * Y5(10),Y5(11),Y5(12),Y5(13),Y5(14),Y5(15),Y5(16),Y5(17),
- * Y5(18),Y5(19),Y5(20),Y5(21),Y5(22),Y5(23),Y5(24),Y5(25),
- * Y5(26),Y5(27),Y5(28),Y5(29),Y5(30),Y5(31),Y5(32),Y5(33),
- * Y5(34),Y5(35),Y5(36),Y5(37),Y5(38),Y5(39),Y5(40),Y5(41),
- * Y5(42),Y5(43),Y5(44),Y5(45),Y5(46),Y5(47),Y5(48),Y5(49),
- * Y5(50),Y5(51),Y5(52),Y5(53),Y5(54),Y5(55),Y5(56),Y5(57),
- * Y5(58),Y5(59),Y5(60),Y5(61),Y5(62),Y5(63),Y5(64),Y5(65)
- * /1.366D0,1.191D0,1.112D0,1.013D0,9.91D-1,8.85D-1,8.31D-1,
- * 8.47D-1,7.86D-1,7.25D-1,7.46D-1,6.79D-1,6.08D-1,6.55D-1,
- * 6.16D-1,6.06D-1,6.02D-1,6.26D-1,6.51D-1,7.24D-1,6.49D-1,
- * 6.49D-1,6.94D-1,6.44D-1,6.24D-1,6.61D-1,6.12D-1,5.58D-1,
- * 5.33D-1,4.95D-1,5.0D-1,4.23D-1,3.95D-1,3.75D-1,3.72D-1,
- * 3.91D-1,3.96D-1,4.05D-1,4.28D-1,4.29D-1,5.23D-1,5.62D-1,
- * 6.07D-1,6.53D-1,6.72D-1,7.08D-1,6.33D-1,6.68D-1,6.45D-1,
- * 6.32D-1,5.91D-1,5.59D-1,5.97D-1,6.25D-1,7.39D-1,7.1D-1,
- * 7.29D-1,7.2D-1,6.36D-1,5.81D-1,4.28D-1,2.92D-1,1.62D-1,
- * 9.8D-2,5.4D-2/
- DFLOAT(IVAR) = IVAR
-C
-C FUNCTION ROUTINE SELECTOR.
-C
- GO TO (10,40,70,110,120,130,140,150,170,190,210,250,270,290,310,
- * 360,390,410), NPROB
-C
-C LINEAR FUNCTION - FULL RANK.
-C
- 10 CONTINUE
- SUM = ZERO
- DO 20 J = 1, N
- SUM = SUM + X(J)
- 20 CONTINUE
- TEMP = TWO*SUM/DFLOAT(M) + ONE
- DO 30 I = 1, M
- FVEC(I) = -TEMP
- IF (I .LE. N) FVEC(I) = FVEC(I) + X(I)
- 30 CONTINUE
- GO TO 430
-C
-C LINEAR FUNCTION - RANK 1.
-C
- 40 CONTINUE
- SUM = ZERO
- DO 50 J = 1, N
- SUM = SUM + DFLOAT(J)*X(J)
- 50 CONTINUE
- DO 60 I = 1, M
- FVEC(I) = DFLOAT(I)*SUM - ONE
- 60 CONTINUE
- GO TO 430
-C
-C LINEAR FUNCTION - RANK 1 WITH ZERO COLUMNS AND ROWS.
-C
- 70 CONTINUE
- SUM = ZERO
- NM1 = N - 1
- IF (NM1 .LT. 2) GO TO 90
- DO 80 J = 2, NM1
- SUM = SUM + DFLOAT(J)*X(J)
- 80 CONTINUE
- 90 CONTINUE
- DO 100 I = 1, M
- FVEC(I) = DFLOAT(I-1)*SUM - ONE
- 100 CONTINUE
- FVEC(M) = -ONE
- GO TO 430
-C
-C ROSENBROCK FUNCTION.
-C
- 110 CONTINUE
- FVEC(1) = TEN*(X(2) - X(1)**2)
- FVEC(2) = ONE - X(1)
- GO TO 430
-C
-C HELICAL VALLEY FUNCTION.
-C
- 120 CONTINUE
- TPI = EIGHT*DATAN(ONE)
- TMP1 = DSIGN(ZP25,X(2))
- IF (X(1) .GT. ZERO) TMP1 = DATAN(X(2)/X(1))/TPI
- IF (X(1) .LT. ZERO) TMP1 = DATAN(X(2)/X(1))/TPI + ZP5
- TMP2 = DSQRT(X(1)**2+X(2)**2)
- FVEC(1) = TEN*(X(3) - TEN*TMP1)
- FVEC(2) = TEN*(TMP2 - ONE)
- FVEC(3) = X(3)
- GO TO 430
-C
-C POWELL SINGULAR FUNCTION.
-C
- 130 CONTINUE
- FVEC(1) = X(1) + TEN*X(2)
- FVEC(2) = DSQRT(FIVE)*(X(3) - X(4))
- FVEC(3) = (X(2) - TWO*X(3))**2
- FVEC(4) = DSQRT(TEN)*(X(1) - X(4))**2
- GO TO 430
-C
-C FREUDENSTEIN AND ROTH FUNCTION.
-C
- 140 CONTINUE
- FVEC(1) = -C13 + X(1) + ((FIVE - X(2))*X(2) - TWO)*X(2)
- FVEC(2) = -C29 + X(1) + ((ONE + X(2))*X(2) - C14)*X(2)
- GO TO 430
-C
-C BARD FUNCTION.
-C
- 150 CONTINUE
- DO 160 I = 1, 15
- TMP1 = DFLOAT(I)
- TMP2 = DFLOAT(16-I)
- TMP3 = TMP1
- IF (I .GT. 8) TMP3 = TMP2
- FVEC(I) = Y1(I) - (X(1) + TMP1/(X(2)*TMP2 + X(3)*TMP3))
- 160 CONTINUE
- GO TO 430
-C
-C KOWALIK AND OSBORNE FUNCTION.
-C
- 170 CONTINUE
- DO 180 I = 1, 11
- TMP1 = V(I)*(V(I) + X(2))
- TMP2 = V(I)*(V(I) + X(3)) + X(4)
- FVEC(I) = Y2(I) - X(1)*TMP1/TMP2
- 180 CONTINUE
- GO TO 430
-C
-C MEYER FUNCTION.
-C
- 190 CONTINUE
- DO 200 I = 1, 16
- TEMP = FIVE*DFLOAT(I) + C45 + X(3)
- TMP1 = X(2)/TEMP
- TMP2 = DEXP(TMP1)
- FVEC(I) = X(1)*TMP2 - Y3(I)
- 200 CONTINUE
- GO TO 430
-C
-C WATSON FUNCTION.
-C
- 210 CONTINUE
- DO 240 I = 1, 29
- DIV = DFLOAT(I)/C29
- S1 = ZERO
- DX = ONE
- DO 220 J = 2, N
- S1 = S1 + DFLOAT(J-1)*DX*X(J)
- DX = DIV*DX
- 220 CONTINUE
- S2 = ZERO
- DX = ONE
- DO 230 J = 1, N
- S2 = S2 + DX*X(J)
- DX = DIV*DX
- 230 CONTINUE
- FVEC(I) = S1 - S2**2 - ONE
- 240 CONTINUE
- FVEC(30) = X(1)
- FVEC(31) = X(2) - X(1)**2 - ONE
- GO TO 430
-C
-C BOX 3-DIMENSIONAL FUNCTION.
-C
- 250 CONTINUE
- DO 260 I = 1, M
- TEMP = DFLOAT(I)
- TMP1 = TEMP/TEN
- FVEC(I) = DEXP(-TMP1*X(1)) - DEXP(-TMP1*X(2))
- * + (DEXP(-TEMP) - DEXP(-TMP1))*X(3)
- 260 CONTINUE
- GO TO 430
-C
-C JENNRICH AND SAMPSON FUNCTION.
-C
- 270 CONTINUE
- DO 280 I = 1, M
- TEMP = DFLOAT(I)
- FVEC(I) = TWO + TWO*TEMP - DEXP(TEMP*X(1)) - DEXP(TEMP*X(2))
- 280 CONTINUE
- GO TO 430
-C
-C BROWN AND DENNIS FUNCTION.
-C
- 290 CONTINUE
- DO 300 I = 1, M
- TEMP = DFLOAT(I)/FIVE
- TMP1 = X(1) + TEMP*X(2) - DEXP(TEMP)
- TMP2 = X(3) + DSIN(TEMP)*X(4) - DCOS(TEMP)
- FVEC(I) = TMP1**2 + TMP2**2
- 300 CONTINUE
- GO TO 430
-C
-C CHEBYQUAD FUNCTION.
-C
- 310 CONTINUE
- DO 320 I = 1, M
- FVEC(I) = ZERO
- 320 CONTINUE
- DO 340 J = 1, N
- TMP1 = ONE
- TMP2 = TWO*X(J) - ONE
- TEMP = TWO*TMP2
- DO 330 I = 1, M
- FVEC(I) = FVEC(I) + TMP2
- TI = TEMP*TMP2 - TMP1
- TMP1 = TMP2
- TMP2 = TI
- 330 CONTINUE
- 340 CONTINUE
- DX = ONE/DFLOAT(N)
- IEV = -1
- DO 350 I = 1, M
- FVEC(I) = DX*FVEC(I)
- IF (IEV .GT. 0) FVEC(I) = FVEC(I) + ONE/(DFLOAT(I)**2 - ONE)
- IEV = -IEV
- 350 CONTINUE
- GO TO 430
-C
-C BROWN ALMOST-LINEAR FUNCTION.
-C
- 360 CONTINUE
- SUM = -DFLOAT(N+1)
- PROD = ONE
- DO 370 J = 1, N
- SUM = SUM + X(J)
- PROD = X(J)*PROD
- 370 CONTINUE
- DO 380 I = 1, N
- FVEC(I) = X(I) + SUM
- 380 CONTINUE
- FVEC(N) = PROD - ONE
- GO TO 430
-C
-C OSBORNE 1 FUNCTION.
-C
- 390 CONTINUE
- DO 400 I = 1, 33
- TEMP = TEN*DFLOAT(I-1)
- TMP1 = DEXP(-X(4)*TEMP)
- TMP2 = DEXP(-X(5)*TEMP)
- FVEC(I) = Y4(I) - (X(1) + X(2)*TMP1 + X(3)*TMP2)
- 400 CONTINUE
- GO TO 430
-C
-C OSBORNE 2 FUNCTION.
-C
- 410 CONTINUE
- DO 420 I = 1, 65
- TEMP = DFLOAT(I-1)/TEN
- TMP1 = DEXP(-X(5)*TEMP)
- TMP2 = DEXP(-X(6)*(TEMP-X(9))**2)
- TMP3 = DEXP(-X(7)*(TEMP-X(10))**2)
- TMP4 = DEXP(-X(8)*(TEMP-X(11))**2)
- FVEC(I) = Y5(I)
- * - (X(1)*TMP1 + X(2)*TMP2 + X(3)*TMP3 + X(4)*TMP4)
- 420 CONTINUE
- 430 CONTINUE
- RETURN
-C
-C LAST CARD OF SUBROUTINE SSQFCN.
-C
- END
- SUBROUTINE INITPT(N,X,NPROB,FACTOR)
- INTEGER N,NPROB
- DOUBLE PRECISION FACTOR
- DOUBLE PRECISION X(N)
-C **********
-C
-C SUBROUTINE INITPT
-C
-C THIS SUBROUTINE SPECIFIES THE STANDARD STARTING POINTS FOR THE
-C FUNCTIONS DEFINED BY SUBROUTINE SSQFCN. THE SUBROUTINE RETURNS
-C IN X A MULTIPLE (FACTOR) OF THE STANDARD STARTING POINT. FOR
-C THE 11TH FUNCTION THE STANDARD STARTING POINT IS ZERO, SO IN
-C THIS CASE, IF FACTOR IS NOT UNITY, THEN THE SUBROUTINE RETURNS
-C THE VECTOR X(J) = FACTOR, J=1,...,N.
-C
-C THE SUBROUTINE STATEMENT IS
-C
-C SUBROUTINE INITPT(N,X,NPROB,FACTOR)
-C
-C WHERE
-C
-C N IS A POSITIVE INTEGER INPUT VARIABLE.
-C
-C X IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS THE STANDARD
-C STARTING POINT FOR PROBLEM NPROB MULTIPLIED BY FACTOR.
-C
-C NPROB IS A POSITIVE INTEGER INPUT VARIABLE WHICH DEFINES THE
-C NUMBER OF THE PROBLEM. NPROB MUST NOT EXCEED 18.
-C
-C FACTOR IS AN INPUT VARIABLE WHICH SPECIFIES THE MULTIPLE OF
-C THE STANDARD STARTING POINT. IF FACTOR IS UNITY, NO
-C MULTIPLICATION IS PERFORMED.
-C
-C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980.
-C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE
-C
-C **********
- INTEGER IVAR,J
- DOUBLE PRECISION C1,C2,C3,C4,C5,C6,C7,C8,C9,C10,C11,C12,C13,C14,
- * C15,C16,C17,FIVE,H,HALF,ONE,SEVEN,TEN,THREE,
- * TWENTY,TWNTF,TWO,ZERO
- DOUBLE PRECISION DFLOAT
- DATA ZERO,HALF,ONE,TWO,THREE,FIVE,SEVEN,TEN,TWENTY,TWNTF
- * /0.0D0,5.0D-1,1.0D0,2.0D0,3.0D0,5.0D0,7.0D0,1.0D1,2.0D1,
- * 2.5D1/
- DATA C1,C2,C3,C4,C5,C6,C7,C8,C9,C10,C11,C12,C13,C14,C15,C16,C17
- * /1.2D0,2.5D-1,3.9D-1,4.15D-1,2.0D-2,4.0D3,2.5D2,3.0D-1,
- * 4.0D-1,1.5D0,1.0D-2,1.3D0,6.5D-1,7.0D-1,6.0D-1,4.5D0,
- * 5.5D0/
- DFLOAT(IVAR) = IVAR
-C
-C SELECTION OF INITIAL POINT.
-C
- GO TO (10,10,10,30,40,50,60,70,80,90,100,120,130,140,150,170,
- * 190,200), NPROB
-C
-C LINEAR FUNCTION - FULL RANK OR RANK 1.
-C
- 10 CONTINUE
- DO 20 J = 1, N
- X(J) = ONE
- 20 CONTINUE
- GO TO 210
-C
-C ROSENBROCK FUNCTION.
-C
- 30 CONTINUE
- X(1) = -C1
- X(2) = ONE
- GO TO 210
-C
-C HELICAL VALLEY FUNCTION.
-C
- 40 CONTINUE
- X(1) = -ONE
- X(2) = ZERO
- X(3) = ZERO
- GO TO 210
-C
-C POWELL SINGULAR FUNCTION.
-C
- 50 CONTINUE
- X(1) = THREE
- X(2) = -ONE
- X(3) = ZERO
- X(4) = ONE
- GO TO 210
-C
-C FREUDENSTEIN AND ROTH FUNCTION.
-C
- 60 CONTINUE
- X(1) = HALF
- X(2) = -TWO
- GO TO 210
-C
-C BARD FUNCTION.
-C
- 70 CONTINUE
- X(1) = ONE
- X(2) = ONE
- X(3) = ONE
- GO TO 210
-C
-C KOWALIK AND OSBORNE FUNCTION.
-C
- 80 CONTINUE
- X(1) = C2
- X(2) = C3
- X(3) = C4
- X(4) = C3
- GO TO 210
-C
-C MEYER FUNCTION.
-C
- 90 CONTINUE
- X(1) = C5
- X(2) = C6
- X(3) = C7
- GO TO 210
-C
-C WATSON FUNCTION.
-C
- 100 CONTINUE
- DO 110 J = 1, N
- X(J) = ZERO
- 110 CONTINUE
- GO TO 210
-C
-C BOX 3-DIMENSIONAL FUNCTION.
-C
- 120 CONTINUE
- X(1) = ZERO
- X(2) = TEN
- X(3) = TWENTY
- GO TO 210
-C
-C JENNRICH AND SAMPSON FUNCTION.
-C
- 130 CONTINUE
- X(1) = C8
- X(2) = C9
- GO TO 210
-C
-C BROWN AND DENNIS FUNCTION.
-C
- 140 CONTINUE
- X(1) = TWNTF
- X(2) = FIVE
- X(3) = -FIVE
- X(4) = -ONE
- GO TO 210
-C
-C CHEBYQUAD FUNCTION.
-C
- 150 CONTINUE
- H = ONE/DFLOAT(N+1)
- DO 160 J = 1, N
- X(J) = DFLOAT(J)*H
- 160 CONTINUE
- GO TO 210
-C
-C BROWN ALMOST-LINEAR FUNCTION.
-C
- 170 CONTINUE
- DO 180 J = 1, N
- X(J) = HALF
- 180 CONTINUE
- GO TO 210
-C
-C OSBORNE 1 FUNCTION.
-C
- 190 CONTINUE
- X(1) = HALF
- X(2) = C10
- X(3) = -ONE
- X(4) = C11
- X(5) = C5
- GO TO 210
-C
-C OSBORNE 2 FUNCTION.
-C
- 200 CONTINUE
- X(1) = C12
- X(2) = C13
- X(3) = C13
- X(4) = C14
- X(5) = C15
- X(6) = THREE
- X(7) = FIVE
- X(8) = SEVEN
- X(9) = TWO
- X(10) = C16
- X(11) = C17
- 210 CONTINUE
-C
-C COMPUTE MULTIPLE OF INITIAL POINT.
-C
- IF (FACTOR .EQ. ONE) GO TO 260
- IF (NPROB .EQ. 11) GO TO 230
- DO 220 J = 1, N
- X(J) = FACTOR*X(J)
- 220 CONTINUE
- GO TO 250
- 230 CONTINUE
- DO 240 J = 1, N
- X(J) = FACTOR
- 240 CONTINUE
- 250 CONTINUE
- 260 CONTINUE
- RETURN
-C
-C LAST CARD OF SUBROUTINE INITPT.
-C
- END
diff --git a/CEP/PyBDSM/src/minpack/ex/file20 b/CEP/PyBDSM/src/minpack/ex/file20
deleted file mode 100644
index e7c61a34c999093abcd6ee64af78308ac5a3369d..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/minpack/ex/file20
+++ /dev/null
@@ -1,860 +0,0 @@
-C **********
-C
-C THIS PROGRAM TESTS THE ABILITY OF CHKDER TO DETECT
-C INCONSISTENCIES BETWEEN FUNCTIONS AND THEIR FIRST DERIVATIVES.
-C FOURTEEN TEST FUNCTION VECTORS AND JACOBIANS ARE USED. ELEVEN OF
-C THE TESTS ARE FALSE(F), I.E. THERE ARE INCONSISTENCIES BETWEEN
-C THE FUNCTION VECTORS AND THE CORRESPONDING JACOBIANS. THREE OF
-C THE TESTS ARE TRUE(T), I.E. THERE ARE NO INCONSISTENCIES. THE
-C DRIVER READS IN DATA, CALLS CHKDER AND PRINTS OUT INFORMATION
-C REQUIRED BY AND RECEIVED FROM CHKDER.
-C
-C SUBPROGRAMS CALLED
-C
-C MINPACK SUPPLIED ... CHKDER,ERRJAC,INITPT,VECFCN
-C
-C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980.
-C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE
-C
-C **********
- INTEGER I,LDFJAC,LNP,MODE,N,NPROB,NREAD,NWRITE
- INTEGER NA(14),NP(14)
- LOGICAL A(14)
- DOUBLE PRECISION CP,ONE
- DOUBLE PRECISION DIFF(10),ERR(10),ERRMAX(14),ERRMIN(14),
- * FJAC(10,10),FVEC1(10),FVEC2(10),X1(10),X2(10)
-C
-C LOGICAL INPUT UNIT IS ASSUMED TO BE NUMBER 5.
-C LOGICAL OUTPUT UNIT IS ASSUMED TO BE NUMBER 6.
-C
- DATA NREAD,NWRITE /5,6/
-C
- DATA A(1),A(2),A(3),A(4),A(5),A(6),A(7),A(8),A(9),A(10),A(11),
- * A(12),A(13),A(14)
- * /.FALSE.,.FALSE.,.FALSE.,.TRUE.,.FALSE.,.FALSE.,.FALSE.,
- * .TRUE.,.FALSE.,.FALSE.,.FALSE.,.FALSE.,.TRUE.,.FALSE./
- DATA CP,ONE /1.23D-1,1.0D0/
- LDFJAC = 10
- 10 CONTINUE
- READ (NREAD,60) NPROB,N
- IF (NPROB .LE. 0) GO TO 40
- CALL INITPT(N,X1,NPROB,ONE)
- DO 20 I = 1, N
- X1(I) = X1(I) + CP
- CP = -CP
- 20 CONTINUE
- WRITE (NWRITE,70) NPROB,N,A(NPROB)
- MODE = 1
- CALL CHKDER(N,N,X1,FVEC1,FJAC,LDFJAC,X2,FVEC2,MODE,ERR)
- MODE = 2
- CALL VECFCN(N,X1,FVEC1,NPROB)
- CALL ERRJAC(N,X1,FJAC,LDFJAC,NPROB)
- CALL VECFCN(N,X2,FVEC2,NPROB)
- CALL CHKDER(N,N,X1,FVEC1,FJAC,LDFJAC,X2,FVEC2,MODE,ERR)
- ERRMIN(NPROB) = ERR(1)
- ERRMAX(NPROB) = ERR(1)
- DO 30 I = 1, N
- DIFF(I) = FVEC2(I) - FVEC1(I)
- IF (ERRMIN(NPROB) .GT. ERR(I)) ERRMIN(NPROB) = ERR(I)
- IF (ERRMAX(NPROB) .LT. ERR(I)) ERRMAX(NPROB) = ERR(I)
- 30 CONTINUE
- NP(NPROB) = NPROB
- LNP = NPROB
- NA(NPROB) = N
- WRITE (NWRITE,80) (FVEC1(I), I = 1, N)
- WRITE (NWRITE,90) (DIFF(I), I = 1, N)
- WRITE (NWRITE,100) (ERR(I), I = 1, N)
- GO TO 10
- 40 CONTINUE
- WRITE (NWRITE,110) LNP
- WRITE (NWRITE,120)
- DO 50 I = 1, LNP
- WRITE (NWRITE,130) NP(I),NA(I),A(I),ERRMIN(I),ERRMAX(I)
- 50 CONTINUE
- STOP
- 60 FORMAT (2I5)
- 70 FORMAT ( /// 5X, 8H PROBLEM, I5, 5X, 15H WITH DIMENSION, I5, 2X,
- * 5H IS , L1)
- 80 FORMAT ( // 5X, 25H FIRST FUNCTION VECTOR // (5X, 5D15.7))
- 90 FORMAT ( // 5X, 27H FUNCTION DIFFERENCE VECTOR // (5X, 5D15.7))
- 100 FORMAT ( // 5X, 13H ERROR VECTOR // (5X, 5D15.7))
- 110 FORMAT (12H1SUMMARY OF , I3, 16H TESTS OF CHKDER /)
- 120 FORMAT (46H NPROB N STATUS ERRMIN ERRMAX /)
- 130 FORMAT (I4, I6, 6X, L1, 3X, 2D15.7)
-C
-C LAST CARD OF DERIVATIVE CHECK TEST DRIVER.
-C
- END
- SUBROUTINE ERRJAC(N,X,FJAC,LDFJAC,NPROB)
- INTEGER N,LDFJAC,NPROB
- DOUBLE PRECISION X(N),FJAC(LDFJAC,N)
-C **********
-C
-C SUBROUTINE ERRJAC
-C
-C THIS SUBROUTINE IS DERIVED FROM VECJAC WHICH DEFINES THE
-C JACOBIAN MATRICES OF FOURTEEN TEST FUNCTIONS. THE PROBLEM
-C DIMENSIONS ARE AS DESCRIBED IN THE PROLOGUE COMMENTS OF VECFCN.
-C VARIOUS ERRORS ARE DELIBERATELY INTRODUCED TO PROVIDE A TEST
-C FOR CHKDER.
-C
-C THE SUBROUTINE STATEMENT IS
-C
-C SUBROUTINE ERRJAC(N,X,FJAC,LDFJAC,NPROB)
-C
-C WHERE
-C
-C N IS A POSITIVE INTEGER VARIABLE.
-C
-C X IS AN ARRAY OF LENGTH N.
-C
-C FJAC IS AN N BY N ARRAY. ON OUTPUT FJAC CONTAINS THE
-C JACOBIAN MATRIX, WITH VARIOUS ERRORS DELIBERATELY
-C INTRODUCED, OF THE NPROB FUNCTION EVALUATED AT X.
-C
-C LDFJAC IS A POSITIVE INTEGER VARIABLE NOT LESS THAN N
-C WHICH SPECIFIES THE LEADING DIMENSION OF THE ARRAY FJAC.
-C
-C NPROB IS A POSITIVE INTEGER VARIABLE WHICH DEFINES THE
-C NUMBER OF THE PROBLEM. NPROB MUST NOT EXCEED 14.
-C
-C SUBPROGRAMS CALLED
-C
-C FORTRAN-SUPPLIED ... DATAN,DCOS,DEXP,DMIN1,DSIN,DSQRT,
-C MAX0,MIN0
-C
-C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980.
-C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE
-C
-C **********
- INTEGER I,IVAR,J,K,K1,K2,ML,MU
- DOUBLE PRECISION C1,C3,C4,C5,C6,C9,EIGHT,FIFTN,FIVE,FOUR,H,
- * HUNDRD,ONE,PROD,SIX,SUM,SUM1,SUM2,TEMP,TEMP1,
- * TEMP2,TEMP3,TEMP4,TEN,THREE,TI,TJ,TK,TPI,
- * TWENTY,TWO,ZERO
- DOUBLE PRECISION DFLOAT
- DATA ZERO,ONE,TWO,THREE,FOUR,FIVE,SIX,EIGHT,TEN,FIFTN,TWENTY,
- * HUNDRD
- * /0.0D0,1.0D0,2.0D0,3.0D0,4.0D0,5.0D0,6.0D0,8.0D0,1.0D1,
- * 1.5D1,2.0D1,1.0D2/
- DATA C1,C3,C4,C5,C6,C9 /1.0D4,2.0D2,2.02D1,1.98D1,1.8D2,2.9D1/
- DFLOAT(IVAR) = IVAR
-C
-C JACOBIAN ROUTINE SELECTOR.
-C
- GO TO (10,20,50,60,90,100,200,230,290,320,350,380,420,450),
- * NPROB
-C
-C ROSENBROCK FUNCTION WITH SIGN REVERSAL AFFECTING ELEMENT (1,1).
-C
- 10 CONTINUE
- FJAC(1,1) = ONE
- FJAC(1,2) = ZERO
- FJAC(2,1) = -TWENTY*X(1)
- FJAC(2,2) = TEN
- GO TO 490
-C
-C POWELL SINGULAR FUNCTION WITH SIGN REVERSAL AFFECTING ELEMENT
-C (3,3).
-C
- 20 CONTINUE
- DO 40 K = 1, 4
- DO 30 J = 1, 4
- FJAC(K,J) = ZERO
- 30 CONTINUE
- 40 CONTINUE
- FJAC(1,1) = ONE
- FJAC(1,2) = TEN
- FJAC(2,3) = DSQRT(FIVE)
- FJAC(2,4) = -FJAC(2,3)
- FJAC(3,2) = TWO*(X(2) - TWO*X(3))
- FJAC(3,3) = TWO*FJAC(3,2)
- FJAC(4,1) = TWO*DSQRT(TEN)*(X(1) - X(4))
- FJAC(4,4) = -FJAC(4,1)
- GO TO 490
-C
-C POWELL BADLY SCALED FUNCTION WITH THE SIGN OF THE JACOBIAN
-C REVERSED.
-C
- 50 CONTINUE
- FJAC(1,1) = -C1*X(2)
- FJAC(1,2) = -C1*X(1)
- FJAC(2,1) = DEXP(-X(1))
- FJAC(2,2) = DEXP(-X(2))
- GO TO 490
-C
-C WOOD FUNCTION WITHOUT ERROR.
-C
- 60 CONTINUE
- DO 80 K = 1, 4
- DO 70 J = 1, 4
- FJAC(K,J) = ZERO
- 70 CONTINUE
- 80 CONTINUE
- TEMP1 = X(2) - THREE*X(1)**2
- TEMP2 = X(4) - THREE*X(3)**2
- FJAC(1,1) = -C3*TEMP1 + ONE
- FJAC(1,2) = -C3*X(1)
- FJAC(2,1) = -TWO*C3*X(1)
- FJAC(2,2) = C3 + C4
- FJAC(2,4) = C5
- FJAC(3,3) = -C6*TEMP2 + ONE
- FJAC(3,4) = -C6*X(3)
- FJAC(4,2) = C5
- FJAC(4,3) = -TWO*C6*X(3)
- FJAC(4,4) = C6 + C4
- GO TO 490
-C
-C HELICAL VALLEY FUNCTION WITH MULTIPLICATIVE ERROR AFFECTING
-C ELEMENTS (2,1) AND (2,2).
-C
- 90 CONTINUE
- TPI = EIGHT*DATAN(ONE)
- TEMP = X(1)**2 + X(2)**2
- TEMP1 = TPI*TEMP
- TEMP2 = DSQRT(TEMP)
- FJAC(1,1) = HUNDRD*X(2)/TEMP1
- FJAC(1,2) = -HUNDRD*X(1)/TEMP1
- FJAC(1,3) = TEN
- FJAC(2,1) = FIVE*X(1)/TEMP2
- FJAC(2,2) = FIVE*X(2)/TEMP2
- FJAC(2,3) = ZERO
- FJAC(3,1) = ZERO
- FJAC(3,2) = ZERO
- FJAC(3,3) = ONE
- GO TO 490
-C
-C WATSON FUNCTION WITH SIGN REVERSALS AFFECTING THE COMPUTATION OF
-C TEMP1.
-C
- 100 CONTINUE
- DO 120 K = 1, N
- DO 110 J = K, N
- FJAC(K,J) = ZERO
- 110 CONTINUE
- 120 CONTINUE
- DO 170 I = 1, 29
- TI = DFLOAT(I)/C9
- SUM1 = ZERO
- TEMP = ONE
- DO 130 J = 2, N
- SUM1 = SUM1 + DFLOAT(J-1)*TEMP*X(J)
- TEMP = TI*TEMP
- 130 CONTINUE
- SUM2 = ZERO
- TEMP = ONE
- DO 140 J = 1, N
- SUM2 = SUM2 + TEMP*X(J)
- TEMP = TI*TEMP
- 140 CONTINUE
- TEMP1 = TWO*(SUM1 + SUM2**2 + ONE)
- TEMP2 = TWO*SUM2
- TEMP = TI**2
- TK = ONE
- DO 160 K = 1, N
- TJ = TK
- DO 150 J = K, N
- FJAC(K,J) = FJAC(K,J)
- * + TJ
- * *((DFLOAT(K-1)/TI - TEMP2)
- * *(DFLOAT(J-1)/TI - TEMP2) - TEMP1)
- TJ = TI*TJ
- 150 CONTINUE
- TK = TEMP*TK
- 160 CONTINUE
- 170 CONTINUE
- FJAC(1,1) = FJAC(1,1) + SIX*X(1)**2 - TWO*X(2) + THREE
- FJAC(1,2) = FJAC(1,2) - TWO*X(1)
- FJAC(2,2) = FJAC(2,2) + ONE
- DO 190 K = 1, N
- DO 180 J = K, N
- FJAC(J,K) = FJAC(K,J)
- 180 CONTINUE
- 190 CONTINUE
- GO TO 490
-C
-C CHEBYQUAD FUNCTION WITH JACOBIAN TWICE CORRECT SIZE.
-C
- 200 CONTINUE
- TK = ONE/DFLOAT(N)
- DO 220 J = 1, N
- TEMP1 = ONE
- TEMP2 = TWO*X(J) - ONE
- TEMP = TWO*TEMP2
- TEMP3 = ZERO
- TEMP4 = TWO
- DO 210 K = 1, N
- FJAC(K,J) = TWO*TK*TEMP4
- TI = FOUR*TEMP2 + TEMP*TEMP4 - TEMP3
- TEMP3 = TEMP4
- TEMP4 = TI
- TI = TEMP*TEMP2 - TEMP1
- TEMP1 = TEMP2
- TEMP2 = TI
- 210 CONTINUE
- 220 CONTINUE
- GO TO 490
-C
-C BROWN ALMOST-LINEAR FUNCTION WITHOUT ERROR.
-C
- 230 CONTINUE
- PROD = ONE
- DO 250 J = 1, N
- PROD = X(J)*PROD
- DO 240 K = 1, N
- FJAC(K,J) = ONE
- 240 CONTINUE
- FJAC(J,J) = TWO
- 250 CONTINUE
- DO 280 J = 1, N
- TEMP = X(J)
- IF (TEMP .NE. ZERO) GO TO 270
- TEMP = ONE
- PROD = ONE
- DO 260 K = 1, N
- IF (K .NE. J) PROD = X(K)*PROD
- 260 CONTINUE
- 270 CONTINUE
- FJAC(N,J) = PROD/TEMP
- 280 CONTINUE
- GO TO 490
-C
-C DISCRETE BOUNDARY VALUE FUNCTION WITH MULTIPLICATIVE ERROR
-C AFFECTING THE JACOBIAN DIAGONAL.
-C
- 290 CONTINUE
- H = ONE/DFLOAT(N+1)
- DO 310 K = 1, N
- TEMP = THREE*(X(K) + DFLOAT(K)*H + ONE)**2
- DO 300 J = 1, N
- FJAC(K,J) = ZERO
- 300 CONTINUE
- FJAC(K,K) = FOUR + TEMP*H**2
- IF (K .NE. 1) FJAC(K,K-1) = -ONE
- IF (K .NE. N) FJAC(K,K+1) = -ONE
- 310 CONTINUE
- GO TO 490
-C
-C DISCRETE INTEGRAL EQUATION FUNCTION WITH SIGN ERROR AFFECTING
-C THE JACOBIAN DIAGONAL.
-C
- 320 CONTINUE
- H = ONE/DFLOAT(N+1)
- DO 340 K = 1, N
- TK = DFLOAT(K)*H
- DO 330 J = 1, N
- TJ = DFLOAT(J)*H
- TEMP = THREE*(X(J) + TJ + ONE)**2
- FJAC(K,J) = H*DMIN1(TJ*(ONE-TK),TK*(ONE-TJ))*TEMP/TWO
- 330 CONTINUE
- FJAC(K,K) = FJAC(K,K) - ONE
- 340 CONTINUE
- GO TO 490
-C
-C TRIGONOMETRIC FUNCTION WITH SIGN ERRORS AFFECTING THE
-C OFFDIAGONAL ELEMENTS OF THE JACOBIAN.
-C
- 350 CONTINUE
- DO 370 J = 1, N
- TEMP = DSIN(X(J))
- DO 360 K = 1, N
- FJAC(K,J) = -TEMP
- 360 CONTINUE
- FJAC(J,J) = DFLOAT(J+1)*TEMP - DCOS(X(J))
- 370 CONTINUE
- GO TO 490
-C
-C VARIABLY DIMENSIONED FUNCTION WITH OPERATION ERROR AFFECTING
-C THE UPPER TRIANGULAR ELEMENTS OF THE JACOBIAN.
-C
- 380 CONTINUE
- SUM = ZERO
- DO 390 J = 1, N
- SUM = SUM + DFLOAT(J)*(X(J) - ONE)
- 390 CONTINUE
- TEMP = ONE + SIX*SUM**2
- DO 410 K = 1, N
- DO 400 J = K, N
- FJAC(K,J) = DFLOAT(K*J)/TEMP
- FJAC(J,K) = FJAC(K,J)
- 400 CONTINUE
- FJAC(K,K) = FJAC(K,K) + ONE
- 410 CONTINUE
- GO TO 490
-C
-C BROYDEN TRIDIAGONAL FUNCTION WITHOUT ERROR.
-C
- 420 CONTINUE
- DO 440 K = 1, N
- DO 430 J = 1, N
- FJAC(K,J) = ZERO
- 430 CONTINUE
- FJAC(K,K) = THREE - FOUR*X(K)
- IF (K .NE. 1) FJAC(K,K-1) = -ONE
- IF (K .NE. N) FJAC(K,K+1) = -TWO
- 440 CONTINUE
- GO TO 490
-C
-C BROYDEN BANDED FUNCTION WITH SIGN ERROR AFFECTING THE JACOBIAN
-C DIAGONAL.
-C
- 450 CONTINUE
- ML = 5
- MU = 1
- DO 480 K = 1, N
- DO 460 J = 1, N
- FJAC(K,J) = ZERO
- 460 CONTINUE
- K1 = MAX0(1,K-ML)
- K2 = MIN0(K+MU,N)
- DO 470 J = K1, K2
- IF (J .NE. K) FJAC(K,J) = -(ONE + TWO*X(J))
- 470 CONTINUE
- FJAC(K,K) = TWO - FIFTN*X(K)**2
- 480 CONTINUE
- 490 CONTINUE
- RETURN
-C
-C LAST CARD OF SUBROUTINE ERRJAC.
-C
- END
- SUBROUTINE INITPT(N,X,NPROB,FACTOR)
- INTEGER N,NPROB
- DOUBLE PRECISION FACTOR
- DOUBLE PRECISION X(N)
-C **********
-C
-C SUBROUTINE INITPT
-C
-C THIS SUBROUTINE SPECIFIES THE STANDARD STARTING POINTS FOR
-C THE FUNCTIONS DEFINED BY SUBROUTINE VECFCN. THE SUBROUTINE
-C RETURNS IN X A MULTIPLE (FACTOR) OF THE STANDARD STARTING
-C POINT. FOR THE SIXTH FUNCTION THE STANDARD STARTING POINT IS
-C ZERO, SO IN THIS CASE, IF FACTOR IS NOT UNITY, THEN THE
-C SUBROUTINE RETURNS THE VECTOR X(J) = FACTOR, J=1,...,N.
-C
-C THE SUBROUTINE STATEMENT IS
-C
-C SUBROUTINE INITPT(N,X,NPROB,FACTOR)
-C
-C WHERE
-C
-C N IS A POSITIVE INTEGER INPUT VARIABLE.
-C
-C X IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS THE STANDARD
-C STARTING POINT FOR PROBLEM NPROB MULTIPLIED BY FACTOR.
-C
-C NPROB IS A POSITIVE INTEGER INPUT VARIABLE WHICH DEFINES THE
-C NUMBER OF THE PROBLEM. NPROB MUST NOT EXCEED 14.
-C
-C FACTOR IS AN INPUT VARIABLE WHICH SPECIFIES THE MULTIPLE OF
-C THE STANDARD STARTING POINT. IF FACTOR IS UNITY, NO
-C MULTIPLICATION IS PERFORMED.
-C
-C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980.
-C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE
-C
-C **********
- INTEGER IVAR,J
- DOUBLE PRECISION C1,H,HALF,ONE,THREE,TJ,ZERO
- DOUBLE PRECISION DFLOAT
- DATA ZERO,HALF,ONE,THREE,C1 /0.0D0,5.0D-1,1.0D0,3.0D0,1.2D0/
- DFLOAT(IVAR) = IVAR
-C
-C SELECTION OF INITIAL POINT.
-C
- GO TO (10,20,30,40,50,60,80,100,120,120,140,160,180,180), NPROB
-C
-C ROSENBROCK FUNCTION.
-C
- 10 CONTINUE
- X(1) = -C1
- X(2) = ONE
- GO TO 200
-C
-C POWELL SINGULAR FUNCTION.
-C
- 20 CONTINUE
- X(1) = THREE
- X(2) = -ONE
- X(3) = ZERO
- X(4) = ONE
- GO TO 200
-C
-C POWELL BADLY SCALED FUNCTION.
-C
- 30 CONTINUE
- X(1) = ZERO
- X(2) = ONE
- GO TO 200
-C
-C WOOD FUNCTION.
-C
- 40 CONTINUE
- X(1) = -THREE
- X(2) = -ONE
- X(3) = -THREE
- X(4) = -ONE
- GO TO 200
-C
-C HELICAL VALLEY FUNCTION.
-C
- 50 CONTINUE
- X(1) = -ONE
- X(2) = ZERO
- X(3) = ZERO
- GO TO 200
-C
-C WATSON FUNCTION.
-C
- 60 CONTINUE
- DO 70 J = 1, N
- X(J) = ZERO
- 70 CONTINUE
- GO TO 200
-C
-C CHEBYQUAD FUNCTION.
-C
- 80 CONTINUE
- H = ONE/DFLOAT(N+1)
- DO 90 J = 1, N
- X(J) = DFLOAT(J)*H
- 90 CONTINUE
- GO TO 200
-C
-C BROWN ALMOST-LINEAR FUNCTION.
-C
- 100 CONTINUE
- DO 110 J = 1, N
- X(J) = HALF
- 110 CONTINUE
- GO TO 200
-C
-C DISCRETE BOUNDARY VALUE AND INTEGRAL EQUATION FUNCTIONS.
-C
- 120 CONTINUE
- H = ONE/DFLOAT(N+1)
- DO 130 J = 1, N
- TJ = DFLOAT(J)*H
- X(J) = TJ*(TJ - ONE)
- 130 CONTINUE
- GO TO 200
-C
-C TRIGONOMETRIC FUNCTION.
-C
- 140 CONTINUE
- H = ONE/DFLOAT(N)
- DO 150 J = 1, N
- X(J) = H
- 150 CONTINUE
- GO TO 200
-C
-C VARIABLY DIMENSIONED FUNCTION.
-C
- 160 CONTINUE
- H = ONE/DFLOAT(N)
- DO 170 J = 1, N
- X(J) = ONE - DFLOAT(J)*H
- 170 CONTINUE
- GO TO 200
-C
-C BROYDEN TRIDIAGONAL AND BANDED FUNCTIONS.
-C
- 180 CONTINUE
- DO 190 J = 1, N
- X(J) = -ONE
- 190 CONTINUE
- 200 CONTINUE
-C
-C COMPUTE MULTIPLE OF INITIAL POINT.
-C
- IF (FACTOR .EQ. ONE) GO TO 250
- IF (NPROB .EQ. 6) GO TO 220
- DO 210 J = 1, N
- X(J) = FACTOR*X(J)
- 210 CONTINUE
- GO TO 240
- 220 CONTINUE
- DO 230 J = 1, N
- X(J) = FACTOR
- 230 CONTINUE
- 240 CONTINUE
- 250 CONTINUE
- RETURN
-C
-C LAST CARD OF SUBROUTINE INITPT.
-C
- END
- SUBROUTINE VECFCN(N,X,FVEC,NPROB)
- INTEGER N,NPROB
- DOUBLE PRECISION X(N),FVEC(N)
-C **********
-C
-C SUBROUTINE VECFCN
-C
-C THIS SUBROUTINE DEFINES FOURTEEN TEST FUNCTIONS. THE FIRST
-C FIVE TEST FUNCTIONS ARE OF DIMENSIONS 2,4,2,4,3, RESPECTIVELY,
-C WHILE THE REMAINING TEST FUNCTIONS ARE OF VARIABLE DIMENSION
-C N FOR ANY N GREATER THAN OR EQUAL TO 1 (PROBLEM 6 IS AN
-C EXCEPTION TO THIS, SINCE IT DOES NOT ALLOW N = 1).
-C
-C THE SUBROUTINE STATEMENT IS
-C
-C SUBROUTINE VECFCN(N,X,FVEC,NPROB)
-C
-C WHERE
-C
-C N IS A POSITIVE INTEGER INPUT VARIABLE.
-C
-C X IS AN INPUT ARRAY OF LENGTH N.
-C
-C FVEC IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS THE NPROB
-C FUNCTION VECTOR EVALUATED AT X.
-C
-C NPROB IS A POSITIVE INTEGER INPUT VARIABLE WHICH DEFINES THE
-C NUMBER OF THE PROBLEM. NPROB MUST NOT EXCEED 14.
-C
-C SUBPROGRAMS CALLED
-C
-C FORTRAN-SUPPLIED ... DATAN,DCOS,DEXP,DSIGN,DSIN,DSQRT,
-C MAX0,MIN0
-C
-C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980.
-C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE
-C
-C **********
- INTEGER I,IEV,IVAR,J,K,K1,K2,KP1,ML,MU
- DOUBLE PRECISION C1,C2,C3,C4,C5,C6,C7,C8,C9,EIGHT,FIVE,H,ONE,
- * PROD,SUM,SUM1,SUM2,TEMP,TEMP1,TEMP2,TEN,THREE,
- * TI,TJ,TK,TPI,TWO,ZERO
- DOUBLE PRECISION DFLOAT
- DATA ZERO,ONE,TWO,THREE,FIVE,EIGHT,TEN
- * /0.0D0,1.0D0,2.0D0,3.0D0,5.0D0,8.0D0,1.0D1/
- DATA C1,C2,C3,C4,C5,C6,C7,C8,C9
- * /1.0D4,1.0001D0,2.0D2,2.02D1,1.98D1,1.8D2,2.5D-1,5.0D-1,
- * 2.9D1/
- DFLOAT(IVAR) = IVAR
-C
-C PROBLEM SELECTOR.
-C
- GO TO (10,20,30,40,50,60,120,170,200,220,270,300,330,350), NPROB
-C
-C ROSENBROCK FUNCTION.
-C
- 10 CONTINUE
- FVEC(1) = ONE - X(1)
- FVEC(2) = TEN*(X(2) - X(1)**2)
- GO TO 380
-C
-C POWELL SINGULAR FUNCTION.
-C
- 20 CONTINUE
- FVEC(1) = X(1) + TEN*X(2)
- FVEC(2) = DSQRT(FIVE)*(X(3) - X(4))
- FVEC(3) = (X(2) - TWO*X(3))**2
- FVEC(4) = DSQRT(TEN)*(X(1) - X(4))**2
- GO TO 380
-C
-C POWELL BADLY SCALED FUNCTION.
-C
- 30 CONTINUE
- FVEC(1) = C1*X(1)*X(2) - ONE
- FVEC(2) = DEXP(-X(1)) + DEXP(-X(2)) - C2
- GO TO 380
-C
-C WOOD FUNCTION.
-C
- 40 CONTINUE
- TEMP1 = X(2) - X(1)**2
- TEMP2 = X(4) - X(3)**2
- FVEC(1) = -C3*X(1)*TEMP1 - (ONE - X(1))
- FVEC(2) = C3*TEMP1 + C4*(X(2) - ONE) + C5*(X(4) - ONE)
- FVEC(3) = -C6*X(3)*TEMP2 - (ONE - X(3))
- FVEC(4) = C6*TEMP2 + C4*(X(4) - ONE) + C5*(X(2) - ONE)
- GO TO 380
-C
-C HELICAL VALLEY FUNCTION.
-C
- 50 CONTINUE
- TPI = EIGHT*DATAN(ONE)
- TEMP1 = DSIGN(C7,X(2))
- IF (X(1) .GT. ZERO) TEMP1 = DATAN(X(2)/X(1))/TPI
- IF (X(1) .LT. ZERO) TEMP1 = DATAN(X(2)/X(1))/TPI + C8
- TEMP2 = DSQRT(X(1)**2+X(2)**2)
- FVEC(1) = TEN*(X(3) - TEN*TEMP1)
- FVEC(2) = TEN*(TEMP2 - ONE)
- FVEC(3) = X(3)
- GO TO 380
-C
-C WATSON FUNCTION.
-C
- 60 CONTINUE
- DO 70 K = 1, N
- FVEC(K) = ZERO
- 70 CONTINUE
- DO 110 I = 1, 29
- TI = DFLOAT(I)/C9
- SUM1 = ZERO
- TEMP = ONE
- DO 80 J = 2, N
- SUM1 = SUM1 + DFLOAT(J-1)*TEMP*X(J)
- TEMP = TI*TEMP
- 80 CONTINUE
- SUM2 = ZERO
- TEMP = ONE
- DO 90 J = 1, N
- SUM2 = SUM2 + TEMP*X(J)
- TEMP = TI*TEMP
- 90 CONTINUE
- TEMP1 = SUM1 - SUM2**2 - ONE
- TEMP2 = TWO*TI*SUM2
- TEMP = ONE/TI
- DO 100 K = 1, N
- FVEC(K) = FVEC(K) + TEMP*(DFLOAT(K-1) - TEMP2)*TEMP1
- TEMP = TI*TEMP
- 100 CONTINUE
- 110 CONTINUE
- TEMP = X(2) - X(1)**2 - ONE
- FVEC(1) = FVEC(1) + X(1)*(ONE - TWO*TEMP)
- FVEC(2) = FVEC(2) + TEMP
- GO TO 380
-C
-C CHEBYQUAD FUNCTION.
-C
- 120 CONTINUE
- DO 130 K = 1, N
- FVEC(K) = ZERO
- 130 CONTINUE
- DO 150 J = 1, N
- TEMP1 = ONE
- TEMP2 = TWO*X(J) - ONE
- TEMP = TWO*TEMP2
- DO 140 I = 1, N
- FVEC(I) = FVEC(I) + TEMP2
- TI = TEMP*TEMP2 - TEMP1
- TEMP1 = TEMP2
- TEMP2 = TI
- 140 CONTINUE
- 150 CONTINUE
- TK = ONE/DFLOAT(N)
- IEV = -1
- DO 160 K = 1, N
- FVEC(K) = TK*FVEC(K)
- IF (IEV .GT. 0) FVEC(K) = FVEC(K) + ONE/(DFLOAT(K)**2 - ONE)
- IEV = -IEV
- 160 CONTINUE
- GO TO 380
-C
-C BROWN ALMOST-LINEAR FUNCTION.
-C
- 170 CONTINUE
- SUM = -DFLOAT(N+1)
- PROD = ONE
- DO 180 J = 1, N
- SUM = SUM + X(J)
- PROD = X(J)*PROD
- 180 CONTINUE
- DO 190 K = 1, N
- FVEC(K) = X(K) + SUM
- 190 CONTINUE
- FVEC(N) = PROD - ONE
- GO TO 380
-C
-C DISCRETE BOUNDARY VALUE FUNCTION.
-C
- 200 CONTINUE
- H = ONE/DFLOAT(N+1)
- DO 210 K = 1, N
- TEMP = (X(K) + DFLOAT(K)*H + ONE)**3
- TEMP1 = ZERO
- IF (K .NE. 1) TEMP1 = X(K-1)
- TEMP2 = ZERO
- IF (K .NE. N) TEMP2 = X(K+1)
- FVEC(K) = TWO*X(K) - TEMP1 - TEMP2 + TEMP*H**2/TWO
- 210 CONTINUE
- GO TO 380
-C
-C DISCRETE INTEGRAL EQUATION FUNCTION.
-C
- 220 CONTINUE
- H = ONE/DFLOAT(N+1)
- DO 260 K = 1, N
- TK = DFLOAT(K)*H
- SUM1 = ZERO
- DO 230 J = 1, K
- TJ = DFLOAT(J)*H
- TEMP = (X(J) + TJ + ONE)**3
- SUM1 = SUM1 + TJ*TEMP
- 230 CONTINUE
- SUM2 = ZERO
- KP1 = K + 1
- IF (N .LT. KP1) GO TO 250
- DO 240 J = KP1, N
- TJ = DFLOAT(J)*H
- TEMP = (X(J) + TJ + ONE)**3
- SUM2 = SUM2 + (ONE - TJ)*TEMP
- 240 CONTINUE
- 250 CONTINUE
- FVEC(K) = X(K) + H*((ONE - TK)*SUM1 + TK*SUM2)/TWO
- 260 CONTINUE
- GO TO 380
-C
-C TRIGONOMETRIC FUNCTION.
-C
- 270 CONTINUE
- SUM = ZERO
- DO 280 J = 1, N
- FVEC(J) = DCOS(X(J))
- SUM = SUM + FVEC(J)
- 280 CONTINUE
- DO 290 K = 1, N
- FVEC(K) = DFLOAT(N+K) - DSIN(X(K)) - SUM - DFLOAT(K)*FVEC(K)
- 290 CONTINUE
- GO TO 380
-C
-C VARIABLY DIMENSIONED FUNCTION.
-C
- 300 CONTINUE
- SUM = ZERO
- DO 310 J = 1, N
- SUM = SUM + DFLOAT(J)*(X(J) - ONE)
- 310 CONTINUE
- TEMP = SUM*(ONE + TWO*SUM**2)
- DO 320 K = 1, N
- FVEC(K) = X(K) - ONE + DFLOAT(K)*TEMP
- 320 CONTINUE
- GO TO 380
-C
-C BROYDEN TRIDIAGONAL FUNCTION.
-C
- 330 CONTINUE
- DO 340 K = 1, N
- TEMP = (THREE - TWO*X(K))*X(K)
- TEMP1 = ZERO
- IF (K .NE. 1) TEMP1 = X(K-1)
- TEMP2 = ZERO
- IF (K .NE. N) TEMP2 = X(K+1)
- FVEC(K) = TEMP - TEMP1 - TWO*TEMP2 + ONE
- 340 CONTINUE
- GO TO 380
-C
-C BROYDEN BANDED FUNCTION.
-C
- 350 CONTINUE
- ML = 5
- MU = 1
- DO 370 K = 1, N
- K1 = MAX0(1,K-ML)
- K2 = MIN0(K+MU,N)
- TEMP = ZERO
- DO 360 J = K1, K2
- IF (J .NE. K) TEMP = TEMP + X(J)*(ONE + X(J))
- 360 CONTINUE
- FVEC(K) = X(K)*(TWO + FIVE*X(K)**2) + ONE - TEMP
- 370 CONTINUE
- 380 CONTINUE
- RETURN
-C
-C LAST CARD OF SUBROUTINE VECFCN.
-C
- END
diff --git a/CEP/PyBDSM/src/minpack/ex/file21 b/CEP/PyBDSM/src/minpack/ex/file21
deleted file mode 100644
index 9d867c80b1c009a181d4e3d83744fadc005dade6..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/minpack/ex/file21
+++ /dev/null
@@ -1,23 +0,0 @@
- 1 2 3
- 2 4 3
- 3 2 2
- 4 4 3
- 5 3 3
- 6 6 2
- 6 9 2
- 7 5 3
- 7 6 3
- 7 7 3
- 7 8 1
- 7 9 1
- 8 10 3
- 8 30 1
- 8 40 1
- 9 10 3
- 10 1 3
- 10 10 3
- 11 10 3
- 12 10 3
- 13 10 3
- 14 10 3
- 0 0 0
diff --git a/CEP/PyBDSM/src/minpack/ex/file22 b/CEP/PyBDSM/src/minpack/ex/file22
deleted file mode 100644
index b3cf13812e29e181b8fc384c297c03f2790a938d..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/minpack/ex/file22
+++ /dev/null
@@ -1,29 +0,0 @@
- 1 5 10 1
- 1 5 50 1
- 2 5 10 1
- 2 5 50 1
- 3 5 10 1
- 3 5 50 1
- 4 2 2 3
- 5 3 3 3
- 6 4 4 3
- 7 2 2 3
- 8 3 15 3
- 9 4 11 3
- 10 3 16 2
- 11 6 31 3
- 11 9 31 3
- 11 12 31 3
- 12 3 10 1
- 13 2 10 1
- 14 4 20 3
- 15 1 8 3
- 15 8 8 1
- 15 9 9 1
- 15 10 10 1
- 16 10 10 3
- 16 30 30 1
- 16 40 40 1
- 17 5 33 1
- 18 11 65 1
- 0 0 0 0
diff --git a/CEP/PyBDSM/src/minpack/ex/file23 b/CEP/PyBDSM/src/minpack/ex/file23
deleted file mode 100644
index 0dff12e2af8ed3c85d8240de9ce761b4255fbdbb..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/minpack/ex/file23
+++ /dev/null
@@ -1,15 +0,0 @@
- 1 2
- 2 4
- 3 2
- 4 4
- 5 3
- 6 9
- 7 7
- 8 10
- 9 10
- 10 10
- 11 10
- 12 10
- 13 10
- 14 10
- 0 0
diff --git a/CEP/PyBDSM/src/minpack/ex/index.html b/CEP/PyBDSM/src/minpack/ex/index.html
deleted file mode 100644
index a519705928c6abacc64029c37676128c96f154c2..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/minpack/ex/index.html
+++ /dev/null
@@ -1,98 +0,0 @@
-<head>
-<title>minpack/ex</title>
-<meta name="waisindex" value="nse">
-</head>
-<h1>minpack/ex</h1>
-<p>
-Click <A HREF="http://www.netlib.org/master_counts2.html#minpack/ex">here</A> to see the number of accesses to this library.
-<p><hr>
-<pre>
-file <a href="file01">file01</a>
-for Function SPMPAR
-
-file <a href="file02">file02</a>
-for MINPACK-1
-prec single
-
-file <a href="file03">file03</a>
-for MINPACK-1 documentation
-, unfortunately, column 73 was lost at Argonne long ago
-prec single
-
-file <a href="file04">file04</a>
-for Function DPMPAR
-
-file <a href="file05">file05</a>
-for MINPACK-1
-
-file <a href="file06">file06</a>
-for MINPACK-1 documentation
-, unfortunately, column 73 was lost at Argonne long ago
-prec double
-
-file <a href="file07">file07</a>
-for SMCHAR test
-
-file <a href="file08">file08</a>
-for HYBRD test
-prec single
-
-file <a href="file09">file09</a>
-for HYBRJ test
-prec single
-
-file <a href="file10">file10</a>
-for LMDER test
-prec single
-
-file <a href="file11">file11</a>
-for LMSTR test
-prec single
-
-file <a href="file12">file12</a>
-for LMDIF test
-prec single
-
-file <a href="file13">file13</a>
-for CHKDER test
-prec single
-
-file <a href="file14">file14</a>
-for DMCHAR test
-
-file <a href="file15">file15</a>
-for HYBRD test
-prec double
-
-file <a href="file16">file16</a>
-for HYBRJ test
-prec double
-
-file <a href="file17">file17</a>
-for LMDER test
-prec double
-
-file <a href="file18">file18</a>
-for LMSTR test
-prec double
-
-file <a href="file19">file19</a>
-for LMDIF test
-prec double
-
-file <a href="file20">file20</a>
-for CHKDER test
-prec double
-
-file <a href="file21">file21</a>
-for HYBRD and HYBRJ data
-
-file <a href="file22">file22</a>
-for LMDER, LMSTR, and LMDIf data
-
-file <a href="file23">file23</a>
-for CHKDER data
-
-</pre>
-</body>
-</html>
diff --git a/CEP/PyBDSM/src/minpack/fdjac1.f b/CEP/PyBDSM/src/minpack/fdjac1.f
deleted file mode 100644
index 031ed4652817e6bdb3e799778207e894c02c5f56..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/minpack/fdjac1.f
+++ /dev/null
@@ -1,151 +0,0 @@
- 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 subroutine fdjac1
-c
-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 subroutine statement is
-c
-c subroutine fdjac1(fcn,n,x,fvec,fjac,ldfjac,iflag,ml,mu,epsfcn,
-c wa1,wa2)
-c
-c where
-c
-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
-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
-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 n is a positive integer input variable set to the number
-c of functions and variables.
-c
-c x is an input array of length n.
-c
-c fvec is an input array of length n which must contain the
-c functions evaluated at x.
-c
-c fjac is an output n by n array which contains the
-c approximation to the jacobian matrix evaluated at x.
-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 iflag is an integer variable which can be used to terminate
-c the execution of fdjac1. see description of fcn.
-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 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 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 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 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,j,k,msum
- double precision eps,epsmch,h,temp,zero
- double precision dpmpar
- data zero /0.0d0/
-c
-c epsmch is the machine precision.
-c
- epsmch = dpmpar(1)
-c
- 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
-c computation of banded approximate jacobian.
-c
- 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 subroutine fdjac1.
-c
- end
-
diff --git a/CEP/PyBDSM/src/minpack/fdjac2.f b/CEP/PyBDSM/src/minpack/fdjac2.f
deleted file mode 100644
index 218ab94c179e7517e034b7d3861c8ee4002203d8..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/minpack/fdjac2.f
+++ /dev/null
@@ -1,107 +0,0 @@
- subroutine fdjac2(fcn,m,n,x,fvec,fjac,ldfjac,iflag,epsfcn,wa)
- integer m,n,ldfjac,iflag
- double precision epsfcn
- double precision x(n),fvec(m),fjac(ldfjac,n),wa(m)
-c **********
-c
-c subroutine fdjac2
-c
-c this subroutine computes a forward-difference approximation
-c to the m by n jacobian matrix associated with a specified
-c problem of m functions in n variables.
-c
-c the subroutine statement is
-c
-c subroutine fdjac2(fcn,m,n,x,fvec,fjac,ldfjac,iflag,epsfcn,wa)
-c
-c where
-c
-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
-c subroutine fcn(m,n,x,fvec,iflag)
-c integer m,n,iflag
-c double precision x(n),fvec(m)
-c ----------
-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 fdjac2.
-c in this case set iflag to a negative integer.
-c
-c m is a positive integer input variable set to the number
-c of functions.
-c
-c n is a positive integer input variable set to the number
-c of variables. n must not exceed m.
-c
-c x is an input array of length n.
-c
-c fvec is an input array of length m which must contain the
-c functions evaluated at x.
-c
-c fjac is an output m by n array which contains the
-c approximation to the jacobian matrix evaluated at x.
-c
-c ldfjac is a positive integer input variable not less than m
-c which specifies the leading dimension of the array fjac.
-c
-c iflag is an integer variable which can be used to terminate
-c the execution of fdjac2. see description of fcn.
-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 wa is a work array of length m.
-c
-c subprograms called
-c
-c user-supplied ...... fcn
-c
-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,j
- double precision eps,epsmch,h,temp,zero
- double precision dpmpar
- data zero /0.0d0/
-c
-c epsmch is the machine precision.
-c
- epsmch = dpmpar(1)
-c
- eps = dsqrt(dmax1(epsfcn,epsmch))
- do 20 j = 1, n
- temp = x(j)
- h = eps*dabs(temp)
- if (h .eq. zero) h = eps
- x(j) = temp + h
- call fcn(m,n,x,wa,iflag)
- if (iflag .lt. 0) go to 30
- x(j) = temp
- do 10 i = 1, m
- fjac(i,j) = (wa(i) - fvec(i))/h
- 10 continue
- 20 continue
- 30 continue
- return
-c
-c last card of subroutine fdjac2.
-c
- end
diff --git a/CEP/PyBDSM/src/minpack/hybrd.f b/CEP/PyBDSM/src/minpack/hybrd.f
deleted file mode 100644
index fc0b4c26afe57b83761b7b88dc4c3f611f288a66..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/minpack/hybrd.f
+++ /dev/null
@@ -1,459 +0,0 @@
- 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 hybrd
-c
-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. the jacobian is
-c then calculated by a forward-difference approximation.
-c
-c the subroutine statement is
-c
-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. 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,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
-c the value of iflag should not be changed by fcn unless
-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
-c of functions and variables.
-c
-c x is an array of length n. on input x must contain
-c an initial estimate of the solution vector. on output x
-c contains the final estimate of the solution vector.
-c
-c fvec is an output array of length n which contains
-c the functions evaluated at the output x.
-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 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
-c must contain positive entries that serve as
-c multiplicative scale factors for the variables.
-c
-c mode is an integer input variable. if mode = 1, the
-c variables will be scaled internally. if mode = 2,
-c the scaling is specified by the input diag. other
-c values of mode are equivalent to mode = 1.
-c
-c factor is a positive input variable used in determining the
-c initial step bound. this bound is set to the product of
-c factor and the euclidean norm of diag*x if nonzero, or else
-c to factor itself. in most cases factor should lie in the
-c interval (.1,100.). 100. is a generally recommended value.
-c
-c nprint is an integer input variable that enables controlled
-c printing of iterates if it is positive. in this case,
-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. 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)
-c value of iflag. see description of fcn. otherwise,
-c info is set as follows.
-c
-c info = 0 improper input parameters.
-c
-c info = 1 relative error between two consecutive iterates
-c is at most xtol.
-c
-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.
-c
-c info = 4 iteration is not making good progress, as
-c measured by the improvement from the last
-c five jacobian evaluations.
-c
-c info = 5 iteration is not making good progress, as
-c measured by the improvement from the last
-c ten iterations.
-c
-c nfev is an integer output variable set to the number of
-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 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
-c of the final approximate jacobian, stored rowwise.
-c
-c lr is a positive integer input variable not less than
-c (n*(n+1))/2.
-c
-c qtf is an output array of length n which contains
-c the vector (q transpose)*fvec.
-c
-c wa1, wa2, wa3, and wa4 are work arrays of length n.
-c
-c subprograms called
-c
-c user-supplied ...... fcn
-c
-c minpack-supplied ... dogleg,dpmpar,enorm,fdjac1,
-c qform,qrfac,r1mpyq,r1updt
-c
-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,msum,ncfail,ncsuc,nslow1,nslow2
- integer iwa(1)
- logical jeval,sing
- double precision actred,delta,epsmch,fnorm,fnorm1,one,pnorm,
- * prered,p1,p5,p001,p0001,ratio,sum,temp,xnorm,
- * zero
- double precision dpmpar,enorm
- data one,p1,p5,p001,p0001,zero
- * /1.0d0,1.0d-1,5.0d-1,1.0d-3,1.0d-4,0.0d0/
-c
-c epsmch is the machine precision.
-c
- epsmch = dpmpar(1)
-c
- info = 0
- iflag = 0
- nfev = 0
-c
-c check the input parameters for errors.
-c
- 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
- 10 continue
- 20 continue
-c
-c evaluate the function at the starting point
-c and calculate its norm.
-c
- iflag = 1
- 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
- ncsuc = 0
- ncfail = 0
- nslow1 = 0
- nslow2 = 0
-c
-c beginning of the outer loop.
-c
- 30 continue
- jeval = .true.
-c
-c calculate the jacobian matrix.
-c
- iflag = 2
- 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.
-c
- call qrfac(n,n,fjac,ldfjac,.false.,iwa,1,wa1,wa2,wa3)
-c
-c on the first iteration and if mode is 1, scale according
-c to the norms of the columns of the initial jacobian.
-c
- if (iter .ne. 1) go to 70
- if (mode .eq. 2) go to 50
- do 40 j = 1, n
- diag(j) = wa2(j)
- if (wa2(j) .eq. zero) diag(j) = one
- 40 continue
- 50 continue
-c
-c on the first iteration, calculate the norm of the scaled x
-c and initialize the step bound delta.
-c
- do 60 j = 1, n
- wa3(j) = diag(j)*x(j)
- 60 continue
- xnorm = enorm(n,wa3)
- delta = factor*xnorm
- if (delta .eq. zero) delta = factor
- 70 continue
-c
-c form (q transpose)*fvec and store in qtf.
-c
- do 80 i = 1, n
- qtf(i) = fvec(i)
- 80 continue
- do 120 j = 1, n
- if (fjac(j,j) .eq. zero) go to 110
- sum = zero
- do 90 i = j, n
- sum = sum + fjac(i,j)*qtf(i)
- 90 continue
- temp = -sum/fjac(j,j)
- do 100 i = j, n
- qtf(i) = qtf(i) + fjac(i,j)*temp
- 100 continue
- 110 continue
- 120 continue
-c
-c copy the triangular factor of the qr factorization into r.
-c
- sing = .false.
- do 150 j = 1, n
- l = j
- jm1 = j - 1
- if (jm1 .lt. 1) go to 140
- do 130 i = 1, jm1
- r(l) = fjac(i,j)
- l = l + n - i
- 130 continue
- 140 continue
- r(l) = wa1(j)
- if (wa1(j) .eq. zero) sing = .true.
- 150 continue
-c
-c accumulate the orthogonal factor in fjac.
-c
- call qform(n,n,fjac,ldfjac,wa1)
-c
-c rescale if necessary.
-c
- if (mode .eq. 2) go to 170
- do 160 j = 1, n
- diag(j) = dmax1(diag(j),wa2(j))
- 160 continue
- 170 continue
-c
-c beginning of the inner loop.
-c
- 180 continue
-c
-c if requested, call fcn to enable printing of iterates.
-c
- if (nprint .le. 0) go to 190
- iflag = 0
- if (mod(iter-1,nprint) .eq. 0) call fcn(n,x,fvec,iflag)
- if (iflag .lt. 0) go to 300
- 190 continue
-c
-c determine the direction p.
-c
- call dogleg(n,r,lr,diag,qtf,delta,wa1,wa2,wa3)
-c
-c store the direction p and x + p. calculate the norm of p.
-c
- do 200 j = 1, n
- wa1(j) = -wa1(j)
- wa2(j) = x(j) + wa1(j)
- wa3(j) = diag(j)*wa1(j)
- 200 continue
- pnorm = enorm(n,wa3)
-c
-c on the first iteration, adjust the initial step bound.
-c
- if (iter .eq. 1) delta = dmin1(delta,pnorm)
-c
-c evaluate the function at x + p and calculate its norm.
-c
- iflag = 1
- call fcn(n,wa2,wa4,iflag)
- nfev = nfev + 1
- if (iflag .lt. 0) go to 300
- fnorm1 = enorm(n,wa4)
-c
-c compute the scaled actual reduction.
-c
- actred = -one
- if (fnorm1 .lt. fnorm) actred = one - (fnorm1/fnorm)**2
-c
-c compute the scaled predicted reduction.
-c
- l = 1
- do 220 i = 1, n
- sum = zero
- do 210 j = i, n
- sum = sum + r(l)*wa1(j)
- l = l + 1
- 210 continue
- wa3(i) = qtf(i) + sum
- 220 continue
- temp = enorm(n,wa3)
- prered = zero
- if (temp .lt. fnorm) prered = one - (temp/fnorm)**2
-c
-c compute the ratio of the actual to the predicted
-c reduction.
-c
- ratio = zero
- if (prered .gt. zero) ratio = actred/prered
-c
-c update the step bound.
-c
- if (ratio .ge. p1) go to 230
- ncsuc = 0
- ncfail = ncfail + 1
- delta = p5*delta
- go to 240
- 230 continue
- ncfail = 0
- ncsuc = ncsuc + 1
- if (ratio .ge. p5 .or. ncsuc .gt. 1)
- * delta = dmax1(delta,pnorm/p5)
- if (dabs(ratio-one) .le. p1) delta = pnorm/p5
- 240 continue
-c
-c test for successful iteration.
-c
- if (ratio .lt. p0001) go to 260
-c
-c successful iteration. update x, fvec, and their norms.
-c
- do 250 j = 1, n
- x(j) = wa2(j)
- wa2(j) = diag(j)*x(j)
- fvec(j) = wa4(j)
- 250 continue
- xnorm = enorm(n,wa2)
- fnorm = fnorm1
- iter = iter + 1
- 260 continue
-c
-c determine the progress of the iteration.
-c
- nslow1 = nslow1 + 1
- if (actred .ge. p001) nslow1 = 0
- if (jeval) nslow2 = nslow2 + 1
- if (actred .ge. p1) nslow2 = 0
-c
-c test for convergence.
-c
- if (delta .le. xtol*xnorm .or. fnorm .eq. zero) info = 1
- if (info .ne. 0) go to 300
-c
-c tests for termination and stringent tolerances.
-c
- if (nfev .ge. maxfev) info = 2
- if (p1*dmax1(p1*delta,pnorm) .le. epsmch*xnorm) info = 3
- if (nslow2 .eq. 5) info = 4
- if (nslow1 .eq. 10) info = 5
- if (info .ne. 0) go to 300
-c
-c criterion for recalculating jacobian approximation
-c by forward differences.
-c
- if (ncfail .eq. 2) go to 290
-c
-c calculate the rank one modification to the jacobian
-c and update qtf if necessary.
-c
- do 280 j = 1, n
- sum = zero
- do 270 i = 1, n
- sum = sum + fjac(i,j)*wa4(i)
- 270 continue
- wa2(j) = (sum - wa3(j))/pnorm
- wa1(j) = diag(j)*((diag(j)*wa1(j))/pnorm)
- if (ratio .ge. p0001) qtf(j) = sum
- 280 continue
-c
-c compute the qr factorization of the updated jacobian.
-c
- call r1updt(n,n,r,lr,wa1,wa2,wa3,sing)
- call r1mpyq(n,n,fjac,ldfjac,wa2,wa3)
- call r1mpyq(1,n,qtf,1,wa2,wa3)
-c
-c end of the inner loop.
-c
- jeval = .false.
- go to 180
- 290 continue
-c
-c end of the outer loop.
-c
- go to 30
- 300 continue
-c
-c termination, either normal or user imposed.
-c
- if (iflag .lt. 0) info = iflag
- iflag = 0
- if (nprint .gt. 0) call fcn(n,x,fvec,iflag)
- return
-c
-c last card of subroutine hybrd.
-c
- end
diff --git a/CEP/PyBDSM/src/minpack/hybrd1.f b/CEP/PyBDSM/src/minpack/hybrd1.f
deleted file mode 100644
index c0a859275d34d151d045f5eba5f739d31e78cb01..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/minpack/hybrd1.f
+++ /dev/null
@@ -1,123 +0,0 @@
- subroutine hybrd1(fcn,n,x,fvec,tol,info,wa,lwa)
- integer n,info,lwa
- double precision tol
- double precision x(n),fvec(n),wa(lwa)
- external fcn
-c **********
-c
-c subroutine hybrd1
-c
-c the purpose of hybrd1 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. this is done by using the
-c more general nonlinear equation solver hybrd. the user
-c must provide a subroutine which calculates the functions.
-c the jacobian is then calculated by a forward-difference
-c approximation.
-c
-c the subroutine statement is
-c
-c subroutine hybrd1(fcn,n,x,fvec,tol,info,wa,lwa)
-c
-c where
-c
-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
-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
-c the value of iflag should not be changed by fcn unless
-c the user wants to terminate execution of hybrd1.
-c in this case set iflag to a negative integer.
-c
-c n is a positive integer input variable set to the number
-c of functions and variables.
-c
-c x is an array of length n. on input x must contain
-c an initial estimate of the solution vector. on output x
-c contains the final estimate of the solution vector.
-c
-c fvec is an output array of length n which contains
-c the functions evaluated at the output x.
-c
-c tol is a nonnegative input variable. termination occurs
-c when the algorithm estimates that the relative error
-c between x and the solution is at most tol.
-c
-c info is an integer output variable. if the user has
-c terminated execution, info is set to the (negative)
-c value of iflag. see description of fcn. otherwise,
-c info is set as follows.
-c
-c info = 0 improper input parameters.
-c
-c info = 1 algorithm estimates that the relative error
-c between x and the solution is at most tol.
-c
-c info = 2 number of calls to fcn has reached or exceeded
-c 200*(n+1).
-c
-c info = 3 tol is too small. no further improvement in
-c the approximate solution x is possible.
-c
-c info = 4 iteration is not making good progress.
-c
-c wa is a work array of length lwa.
-c
-c lwa is a positive integer input variable not less than
-c (n*(3*n+13))/2.
-c
-c subprograms called
-c
-c user-supplied ...... fcn
-c
-c minpack-supplied ... hybrd
-c
-c argonne national laboratory. minpack project. march 1980.
-c burton s. garbow, kenneth e. hillstrom, jorge j. more
-c
-c **********
- integer index,j,lr,maxfev,ml,mode,mu,nfev,nprint
- double precision epsfcn,factor,one,xtol,zero
- data factor,one,zero /1.0d2,1.0d0,0.0d0/
- info = 0
-c
-c check the input parameters for errors.
-c
- if (n .le. 0 .or. tol .lt. zero .or. lwa .lt. (n*(3*n + 13))/2)
- * go to 20
-c
-c call hybrd.
-c
- maxfev = 200*(n + 1)
- xtol = tol
- ml = n - 1
- mu = n - 1
- epsfcn = zero
- mode = 2
- do 10 j = 1, n
- wa(j) = one
- 10 continue
- nprint = 0
- lr = (n*(n + 1))/2
- index = 6*n + lr
- call hybrd(fcn,n,x,fvec,xtol,maxfev,ml,mu,epsfcn,wa(1),mode,
- * factor,nprint,info,nfev,wa(index+1),n,wa(6*n+1),lr,
- * wa(n+1),wa(2*n+1),wa(3*n+1),wa(4*n+1),wa(5*n+1))
- if (info .eq. 5) info = 4
- 20 continue
- return
-c
-c last card of subroutine hybrd1.
-c
- end
diff --git a/CEP/PyBDSM/src/minpack/hybrj.f b/CEP/PyBDSM/src/minpack/hybrj.f
deleted file mode 100644
index 3070dad3fabc924ce176b3d1542e63ea05523718..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/minpack/hybrj.f
+++ /dev/null
@@ -1,440 +0,0 @@
- 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),
- * qtf(n),wa1(n),wa2(n),wa3(n),wa4(n)
-c **********
-c
-c subroutine hybrj
-c
-c the purpose of hybrj 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
-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
-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
-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 ----------
-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 ---------
-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 in this case set iflag to a negative integer.
-c
-c n is a positive integer input variable set to the number
-c of functions and variables.
-c
-c x is an array of length n. on input x must contain
-c an initial estimate of the solution vector. on output x
-c contains the final estimate of the solution vector.
-c
-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
-c diag is an array of length n. if mode = 1 (see
-c below), diag is internally set. if mode = 2, diag
-c must contain positive entries that serve as
-c multiplicative scale factors for the variables.
-c
-c mode is an integer input variable. if mode = 1, the
-c variables will be scaled internally. if mode = 2,
-c the scaling is specified by the input diag. other
-c values of mode are equivalent to mode = 1.
-c
-c factor is a positive input variable used in determining the
-c initial step bound. this bound is set to the product of
-c factor and the euclidean norm of diag*x if nonzero, or else
-c to factor itself. in most cases factor should lie in the
-c interval (.1,100.). 100. is a generally recommended value.
-c
-c nprint is an integer input variable that enables controlled
-c printing of iterates if it is positive. in this case,
-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
-c info is an integer output variable. if the user has
-c terminated execution, info is set to the (negative)
-c value of iflag. see description of fcn. otherwise,
-c info is set as follows.
-c
-c info = 0 improper input parameters.
-c
-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
-c info = 3 xtol is too small. no further improvement in
-c the approximate solution x is possible.
-c
-c info = 4 iteration is not making good progress, as
-c measured by the improvement from the last
-c five jacobian evaluations.
-c
-c info = 5 iteration is not making good progress, as
-c measured by the improvement from the last
-c ten iterations.
-c
-c nfev is an integer output variable set to the number of
-c calls to fcn with iflag = 1.
-c
-c njev is an integer output variable set to the number of
-c calls to fcn with iflag = 2.
-c
-c r is an output array of length lr which contains the
-c upper triangular matrix produced by the qr factorization
-c of the final approximate jacobian, stored rowwise.
-c
-c lr is a positive integer input variable not less than
-c (n*(n+1))/2.
-c
-c qtf is an output array of length n which contains
-c the vector (q transpose)*fvec.
-c
-c wa1, wa2, wa3, and wa4 are work arrays of length n.
-c
-c subprograms called
-c
-c user-supplied ...... fcn
-c
-c minpack-supplied ... dogleg,dpmpar,enorm,
-c qform,qrfac,r1mpyq,r1updt
-c
-c fortran-supplied ... dabs,dmax1,dmin1,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 iwa(1)
- logical jeval,sing
- double precision actred,delta,epsmch,fnorm,fnorm1,one,pnorm,
- * prered,p1,p5,p001,p0001,ratio,sum,temp,xnorm,
- * zero
- double precision dpmpar,enorm
- data one,p1,p5,p001,p0001,zero
- * /1.0d0,1.0d-1,5.0d-1,1.0d-3,1.0d-4,0.0d0/
-c
-c epsmch is the machine precision.
-c
- epsmch = dpmpar(1)
-c
- 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 (mode .ne. 2) go to 20
- do 10 j = 1, n
- if (diag(j) .le. zero) go to 300
- 10 continue
- 20 continue
-c
-c evaluate the function at the starting point
-c and calculate its norm.
-c
- iflag = 1
- call fcn(n,x,fvec,fjac,ldfjac,iflag)
- nfev = 1
- if (iflag .lt. 0) go to 300
- fnorm = enorm(n,fvec)
-c
-c initialize iteration counter and monitors.
-c
- iter = 1
- ncsuc = 0
- ncfail = 0
- nslow1 = 0
- nslow2 = 0
-c
-c beginning of the outer loop.
-c
- 30 continue
- jeval = .true.
-c
-c calculate the jacobian matrix.
-c
- iflag = 2
- call fcn(n,x,fvec,fjac,ldfjac,iflag)
- njev = njev + 1
- if (iflag .lt. 0) go to 300
-c
-c compute the qr factorization of the jacobian.
-c
- call qrfac(n,n,fjac,ldfjac,.false.,iwa,1,wa1,wa2,wa3)
-c
-c on the first iteration and if mode is 1, scale according
-c to the norms of the columns of the initial jacobian.
-c
- if (iter .ne. 1) go to 70
- if (mode .eq. 2) go to 50
- do 40 j = 1, n
- diag(j) = wa2(j)
- if (wa2(j) .eq. zero) diag(j) = one
- 40 continue
- 50 continue
-c
-c on the first iteration, calculate the norm of the scaled x
-c and initialize the step bound delta.
-c
- do 60 j = 1, n
- wa3(j) = diag(j)*x(j)
- 60 continue
- xnorm = enorm(n,wa3)
- delta = factor*xnorm
- if (delta .eq. zero) delta = factor
- 70 continue
-c
-c form (q transpose)*fvec and store in qtf.
-c
- do 80 i = 1, n
- qtf(i) = fvec(i)
- 80 continue
- do 120 j = 1, n
- if (fjac(j,j) .eq. zero) go to 110
- sum = zero
- do 90 i = j, n
- sum = sum + fjac(i,j)*qtf(i)
- 90 continue
- temp = -sum/fjac(j,j)
- do 100 i = j, n
- qtf(i) = qtf(i) + fjac(i,j)*temp
- 100 continue
- 110 continue
- 120 continue
-c
-c copy the triangular factor of the qr factorization into r.
-c
- sing = .false.
- do 150 j = 1, n
- l = j
- jm1 = j - 1
- if (jm1 .lt. 1) go to 140
- do 130 i = 1, jm1
- r(l) = fjac(i,j)
- l = l + n - i
- 130 continue
- 140 continue
- r(l) = wa1(j)
- if (wa1(j) .eq. zero) sing = .true.
- 150 continue
-c
-c accumulate the orthogonal factor in fjac.
-c
- call qform(n,n,fjac,ldfjac,wa1)
-c
-c rescale if necessary.
-c
- if (mode .eq. 2) go to 170
- do 160 j = 1, n
- diag(j) = dmax1(diag(j),wa2(j))
- 160 continue
- 170 continue
-c
-c beginning of the inner loop.
-c
- 180 continue
-c
-c if requested, call fcn to enable printing of iterates.
-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 (iflag .lt. 0) go to 300
- 190 continue
-c
-c determine the direction p.
-c
- call dogleg(n,r,lr,diag,qtf,delta,wa1,wa2,wa3)
-c
-c store the direction p and x + p. calculate the norm of p.
-c
- do 200 j = 1, n
- wa1(j) = -wa1(j)
- wa2(j) = x(j) + wa1(j)
- wa3(j) = diag(j)*wa1(j)
- 200 continue
- pnorm = enorm(n,wa3)
-c
-c on the first iteration, adjust the initial step bound.
-c
- if (iter .eq. 1) delta = dmin1(delta,pnorm)
-c
-c evaluate the function at x + p and calculate its norm.
-c
- iflag = 1
- call fcn(n,wa2,wa4,fjac,ldfjac,iflag)
- nfev = nfev + 1
- if (iflag .lt. 0) go to 300
- fnorm1 = enorm(n,wa4)
-c
-c compute the scaled actual reduction.
-c
- actred = -one
- if (fnorm1 .lt. fnorm) actred = one - (fnorm1/fnorm)**2
-c
-c compute the scaled predicted reduction.
-c
- l = 1
- do 220 i = 1, n
- sum = zero
- do 210 j = i, n
- sum = sum + r(l)*wa1(j)
- l = l + 1
- 210 continue
- wa3(i) = qtf(i) + sum
- 220 continue
- temp = enorm(n,wa3)
- prered = zero
- if (temp .lt. fnorm) prered = one - (temp/fnorm)**2
-c
-c compute the ratio of the actual to the predicted
-c reduction.
-c
- ratio = zero
- if (prered .gt. zero) ratio = actred/prered
-c
-c update the step bound.
-c
- if (ratio .ge. p1) go to 230
- ncsuc = 0
- ncfail = ncfail + 1
- delta = p5*delta
- go to 240
- 230 continue
- ncfail = 0
- ncsuc = ncsuc + 1
- if (ratio .ge. p5 .or. ncsuc .gt. 1)
- * delta = dmax1(delta,pnorm/p5)
- if (dabs(ratio-one) .le. p1) delta = pnorm/p5
- 240 continue
-c
-c test for successful iteration.
-c
- if (ratio .lt. p0001) go to 260
-c
-c successful iteration. update x, fvec, and their norms.
-c
- do 250 j = 1, n
- x(j) = wa2(j)
- wa2(j) = diag(j)*x(j)
- fvec(j) = wa4(j)
- 250 continue
- xnorm = enorm(n,wa2)
- fnorm = fnorm1
- iter = iter + 1
- 260 continue
-c
-c determine the progress of the iteration.
-c
- nslow1 = nslow1 + 1
- if (actred .ge. p001) nslow1 = 0
- if (jeval) nslow2 = nslow2 + 1
- if (actred .ge. p1) nslow2 = 0
-c
-c test for convergence.
-c
- if (delta .le. xtol*xnorm .or. fnorm .eq. zero) info = 1
- if (info .ne. 0) go to 300
-c
-c tests for termination and stringent tolerances.
-c
- if (nfev .ge. maxfev) info = 2
- if (p1*dmax1(p1*delta,pnorm) .le. epsmch*xnorm) info = 3
- if (nslow2 .eq. 5) info = 4
- if (nslow1 .eq. 10) info = 5
- if (info .ne. 0) go to 300
-c
-c criterion for recalculating jacobian.
-c
- if (ncfail .eq. 2) go to 290
-c
-c calculate the rank one modification to the jacobian
-c and update qtf if necessary.
-c
- do 280 j = 1, n
- sum = zero
- do 270 i = 1, n
- sum = sum + fjac(i,j)*wa4(i)
- 270 continue
- wa2(j) = (sum - wa3(j))/pnorm
- wa1(j) = diag(j)*((diag(j)*wa1(j))/pnorm)
- if (ratio .ge. p0001) qtf(j) = sum
- 280 continue
-c
-c compute the qr factorization of the updated jacobian.
-c
- call r1updt(n,n,r,lr,wa1,wa2,wa3,sing)
- call r1mpyq(n,n,fjac,ldfjac,wa2,wa3)
- call r1mpyq(1,n,qtf,1,wa2,wa3)
-c
-c end of the inner loop.
-c
- jeval = .false.
- go to 180
- 290 continue
-c
-c end of the outer loop.
-c
- go to 30
- 300 continue
-c
-c termination, either normal or user imposed.
-c
- if (iflag .lt. 0) info = iflag
- iflag = 0
- if (nprint .gt. 0) call fcn(n,x,fvec,fjac,ldfjac,iflag)
- return
-c
-c last card of subroutine hybrj.
-c
- end
diff --git a/CEP/PyBDSM/src/minpack/hybrj1.f b/CEP/PyBDSM/src/minpack/hybrj1.f
deleted file mode 100644
index 9f51c496572fbc16596717beae64ddcfff03f83e..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/minpack/hybrj1.f
+++ /dev/null
@@ -1,127 +0,0 @@
- subroutine hybrj1(fcn,n,x,fvec,fjac,ldfjac,tol,info,wa,lwa)
- integer n,ldfjac,info,lwa
- double precision tol
- double precision x(n),fvec(n),fjac(ldfjac,n),wa(lwa)
- external fcn
-c **********
-c
-c subroutine hybrj1
-c
-c the purpose of hybrj1 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. this is done by using the
-c more general nonlinear equation solver hybrj. the user
-c must provide a subroutine which calculates the functions
-c and the jacobian.
-c
-c the subroutine statement is
-c
-c subroutine hybrj1(fcn,n,x,fvec,fjac,ldfjac,tol,info,wa,lwa)
-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
-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 ----------
-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 ---------
-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 hybrj1.
-c in this case set iflag to a negative integer.
-c
-c n is a positive integer input variable set to the number
-c of functions and variables.
-c
-c x is an array of length n. on input x must contain
-c an initial estimate of the solution vector. on output x
-c contains the final estimate of the solution vector.
-c
-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 tol is a nonnegative input variable. termination occurs
-c when the algorithm estimates that the relative error
-c between x and the solution is at most tol.
-c
-c info is an integer output variable. if the user has
-c terminated execution, info is set to the (negative)
-c value of iflag. see description of fcn. otherwise,
-c info is set as follows.
-c
-c info = 0 improper input parameters.
-c
-c info = 1 algorithm estimates that the relative error
-c between x and the solution is at most tol.
-c
-c info = 2 number of calls to fcn with iflag = 1 has
-c reached 100*(n+1).
-c
-c info = 3 tol is too small. no further improvement in
-c the approximate solution x is possible.
-c
-c info = 4 iteration is not making good progress.
-c
-c wa is a work array of length lwa.
-c
-c lwa is a positive integer input variable not less than
-c (n*(n+13))/2.
-c
-c subprograms called
-c
-c user-supplied ...... fcn
-c
-c minpack-supplied ... hybrj
-c
-c argonne national laboratory. minpack project. march 1980.
-c burton s. garbow, kenneth e. hillstrom, jorge j. more
-c
-c **********
- integer j,lr,maxfev,mode,nfev,njev,nprint
- double precision factor,one,xtol,zero
- data factor,one,zero /1.0d2,1.0d0,0.0d0/
- info = 0
-c
-c check the input parameters for errors.
-c
- if (n .le. 0 .or. ldfjac .lt. n .or. tol .lt. zero
- * .or. lwa .lt. (n*(n + 13))/2) go to 20
-c
-c call hybrj.
-c
- maxfev = 100*(n + 1)
- xtol = tol
- mode = 2
- do 10 j = 1, n
- wa(j) = one
- 10 continue
- nprint = 0
- lr = (n*(n + 1))/2
- call hybrj(fcn,n,x,fvec,fjac,ldfjac,xtol,maxfev,wa(1),mode,
- * factor,nprint,info,nfev,njev,wa(6*n+1),lr,wa(n+1),
- * wa(2*n+1),wa(3*n+1),wa(4*n+1),wa(5*n+1))
- if (info .eq. 5) info = 4
- 20 continue
- return
-c
-c last card of subroutine hybrj1.
-c
- end
diff --git a/CEP/PyBDSM/src/minpack/index.html b/CEP/PyBDSM/src/minpack/index.html
deleted file mode 100644
index 9218f238cdf4373a65139143070f1a7fbcaffd48..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/minpack/index.html
+++ /dev/null
@@ -1,101 +0,0 @@
-<head>
-<title>minpack</title>
-<meta name="waisindex" value="nse">
-</head>
-<h1>minpack</h1>
-<p>
-Click <A HREF="http://www.netlib.org/master_counts2.html#minpack">here</A> to see the number of accesses to this library.
-<p><hr>
-<pre>
-file <a href="DISCLAIMER">disclaimer</a>
-for MINPACK copyright notice
-
-lib <a href="ex/">ex</a>
-for test programs
-
-file <a href="README">readme</a>
-for overview of minpack
-
-file <a href="chkder.f">chkder.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/minpack/chkder.f">chkder.f plus dependencies</a>
-gams F3,G4c,K6d
-for check gradients for consistency with functions
-
-file <a href="dogleg.f">dogleg.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/minpack/dogleg.f">dogleg.f plus dependencies</a>
-for determine combination of gauss-newton and gradient directions
-
-file <a href="dpmpar.f">dpmpar.f</a>
-for provide double precision machine parameters
-
-file <a href="enorm.f">enorm.f</a>
-for calculate euclidean norm of vector
-
-file <a href="fdjac1.f">fdjac1.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/minpack/fdjac1.f">fdjac1.f plus dependencies</a>
-for calculate difference approximation to jacobian (nonlinear equations)
-
-file <a href="fdjac2.f">fdjac2.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/minpack/fdjac2.f">fdjac2.f plus dependencies</a>
-for calculate difference approximation to jacobian (least squares)
-
-file <a href="hybrd.f">hybrd.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/minpack/hybrd.f">hybrd.f plus dependencies</a>
-gams F2
-for solve systems of nonlinear equations (approximate jacobian)
-
-file <a href="hybrd1.f">hybrd1.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/minpack/hybrd1.f">hybrd1.f plus dependencies</a>
-gams F2
-for easy-to-use driver for (minpack/hybrd)
-
-file <a href="hybrj.f">hybrj.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/minpack/hybrj.f">hybrj.f plus dependencies</a>
-gams F2
-for solve systems of nonlinear equations (analytic jacobian)
-
-file <a href="hybrj1.f">hybrj1.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/minpack/hybrj1.f">hybrj1.f plus dependencies</a>
-gams F2
-for easy-to-use driver for (minpack/hybrj)
-
-file <a href="lmder.f">lmder.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/minpack/lmder.f">lmder.f plus dependencies</a>
-gams K1b1a2
-for solve nonlinear least squares problem (analytic jacobian)
-
-file <a href="lmder1.f">lmder1.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/minpack/lmder1.f">lmder1.f plus dependencies</a>
-gams K1b1a2
-for easy-to-use driver for (minpack/lmder)
-
-file <a href="lmdif.f">lmdif.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/minpack/lmdif.f">lmdif.f plus dependencies</a>
-gams K1b1a1
-for solve nonlinear least squares problem (approximate jacobian)
-
-file <a href="lmdif1.f">lmdif1.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/minpack/lmdif1.f">lmdif1.f plus dependencies</a>
-gams K1b1a1
-for easy-to-use driver for (minpack/lmdif)
-
-file <a href="lmpar.f">lmpar.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/minpack/lmpar.f">lmpar.f plus dependencies</a>
-for determine levenberg-marquardt parameter
-
-file <a href="lmstr.f">lmstr.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/minpack/lmstr.f">lmstr.f plus dependencies</a>
-gams K1b1a2
-for solve nonlinear least squares problem (storage conserving)
-
-file <a href="lmstr1.f">lmstr1.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/minpack/lmstr1.f">lmstr1.f plus dependencies</a>
-gams K1b1a2
-for easy-to-use driver for (minpack/lmstr)
-
-file <a href="qform.f">qform.f</a>
-for accumulate orthogonal matrix from qr factorization
-
-file <a href="qrfac.f">qrfac.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/minpack/qrfac.f">qrfac.f plus dependencies</a>
-for compute qr factorization of rectangular matrix
-
-file <a href="qrsolv.f">qrsolv.f</a>
-for complete solution of least squares problem
-
-file <a href="rwupdt.f">rwupdt.f</a>
-for update qr factorization after row addition
-
-file <a href="r1mpyq.f">r1mpyq.f</a>
-for apply orthogonal transformations from qr factorization
-
-file <a href="r1updt.f">r1updt.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/minpack/r1updt.f">r1updt.f plus dependencies</a>
-for update qr factorization after rank-1 addition
-
-</pre>
-</body>
-</html>
diff --git a/CEP/PyBDSM/src/minpack/lmder.f b/CEP/PyBDSM/src/minpack/lmder.f
deleted file mode 100644
index 1972ed24e37e1777f82fbab320a0ca52fbe3d51f..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/minpack/lmder.f
+++ /dev/null
@@ -1,453 +0,0 @@
- subroutine lmder(fcn,m,n,x,fvec,fjac,ldfjac,ftol,xtol,gtol,
- * maxfev,diag,mode,factor,nprint,info,nfev,njev,
- * ipvt,qtf,wa1,wa2,wa3,wa4,userpar)
- external fcn,userpar
- integer m,n,ldfjac,maxfev,mode,nprint,info,nfev,njev
- integer ipvt(n)
- double precision ftol,xtol,gtol,factor
- double precision x(n),fvec(m),fjac(ldfjac,n),diag(n),qtf(n),
- * wa1(n),wa2(n),wa3(n),wa4(m)
-c **********
-c
-c subroutine lmder
-c
-c the purpose of lmder is to minimize the sum of the squares of
-c m nonlinear functions in n variables by a modification of
-c the levenberg-marquardt algorithm. the user must provide a
-c subroutine which calculates the functions and the jacobian.
-c
-c the subroutine statement is
-c
-c subroutine lmder(fcn,m,n,x,fvec,fjac,ldfjac,ftol,xtol,gtol,
-c maxfev,diag,mode,factor,nprint,info,nfev,
-c njev,ipvt,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
-c subroutine fcn(m,n,x,fvec,fjac,ldfjac,iflag)
-c integer m,n,ldfjac,iflag
-c double precision x(n),fvec(m),fjac(ldfjac,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 ----------
-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 lmder.
-c in this case set iflag to a negative integer.
-c
-c m is a positive integer input variable set to the number
-c of functions.
-c
-c n is a positive integer input variable set to the number
-c of variables. n must not exceed m.
-c
-c x is an array of length n. on input x must contain
-c an initial estimate of the solution vector. on output x
-c contains the final estimate of the solution vector.
-c
-c fvec is an output array of length m which contains
-c the functions evaluated at the output x.
-c
-c fjac is an output m by n array. the upper n by n submatrix
-c of fjac contains an upper triangular matrix r with
-c diagonal elements of nonincreasing magnitude such that
-c
-c t t t
-c p *(jac *jac)*p = r *r,
-c
-c where p is a permutation matrix and jac is the final
-c calculated jacobian. column j of p is column ipvt(j)
-c (see below) of the identity matrix. the lower trapezoidal
-c part of fjac contains information generated during
-c the computation of r.
-c
-c ldfjac is a positive integer input variable not less than m
-c which specifies the leading dimension of the array fjac.
-c
-c ftol is a nonnegative input variable. termination
-c occurs when both the actual and predicted relative
-c reductions in the sum of squares are at most ftol.
-c therefore, ftol measures the relative error desired
-c in the sum of squares.
-c
-c xtol is a nonnegative input variable. termination
-c occurs when the relative error between two consecutive
-c iterates is at most xtol. therefore, xtol measures the
-c relative error desired in the approximate solution.
-c
-c gtol is a nonnegative input variable. termination
-c occurs when the cosine of the angle between fvec and
-c any column of the jacobian is at most gtol in absolute
-c value. therefore, gtol measures the orthogonality
-c desired between the function vector and the columns
-c of the jacobian.
-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
-c diag is an array of length n. if mode = 1 (see
-c below), diag is internally set. if mode = 2, diag
-c must contain positive entries that serve as
-c multiplicative scale factors for the variables.
-c
-c mode is an integer input variable. if mode = 1, the
-c variables will be scaled internally. if mode = 2,
-c the scaling is specified by the input diag. other
-c values of mode are equivalent to mode = 1.
-c
-c factor is a positive input variable used in determining the
-c initial step bound. this bound is set to the product of
-c factor and the euclidean norm of diag*x if nonzero, or else
-c to factor itself. in most cases factor should lie in the
-c interval (.1,100.).100. is a generally recommended value.
-c
-c nprint is an integer input variable that enables controlled
-c printing of iterates if it is positive. in this case,
-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, fvec, and fjac
-c available for printing. fvec and fjac should not be
-c altered. 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)
-c value of iflag. see description of fcn. otherwise,
-c info is set as follows.
-c
-c info = 0 improper input parameters.
-c
-c info = 1 both actual and predicted relative reductions
-c in the sum of squares are at most ftol.
-c
-c info = 2 relative error between two consecutive iterates
-c is at most xtol.
-c
-c info = 3 conditions for info = 1 and info = 2 both hold.
-c
-c info = 4 the cosine of the angle between fvec and any
-c column of the jacobian is at most gtol in
-c absolute value.
-c
-c info = 5 number of calls to fcn with iflag = 1 has
-c reached maxfev.
-c
-c info = 6 ftol is too small. no further reduction in
-c the sum of squares is possible.
-c
-c info = 7 xtol is too small. no further improvement in
-c the approximate solution x is possible.
-c
-c info = 8 gtol is too small. fvec is orthogonal to the
-c columns of the jacobian to machine precision.
-c
-c nfev is an integer output variable set to the number of
-c calls to fcn with iflag = 1.
-c
-c njev is an integer output variable set to the number of
-c calls to fcn with iflag = 2.
-c
-c ipvt is an integer output array of length n. ipvt
-c defines a permutation matrix p such that jac*p = q*r,
-c where jac is the final calculated jacobian, q is
-c orthogonal (not stored), and r is upper triangular
-c with diagonal elements of nonincreasing magnitude.
-c column j of p is column ipvt(j) of the identity matrix.
-c
-c qtf is an output array of length n which contains
-c the first n elements of the vector (q transpose)*fvec.
-c
-c wa1, wa2, and wa3 are work arrays of length n.
-c
-c wa4 is a work array of length m.
-c
-c subprograms called
-c
-c user-supplied ...... fcn
-c
-c minpack-supplied ... dpmpar,enorm,lmpar,qrfac
-c
-c fortran-supplied ... dabs,dmax1,dmin1,dsqrt,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,l
- double precision actred,delta,dirder,epsmch,fnorm,fnorm1,gnorm,
- * one,par,pnorm,prered,p1,p5,p25,p75,p0001,ratio,
- * sum,temp,temp1,temp2,xnorm,zero
- double precision dpmpar,enorm
- data one,p1,p5,p25,p75,p0001,zero
- * /1.0d0,1.0d-1,5.0d-1,2.5d-1,7.5d-1,1.0d-4,0.0d0/
-c
-c epsmch is the machine precision.
-c
- epsmch = dpmpar(1)
-c
- info = 0
- iflag = 0
- nfev = 0
- njev = 0
-c
-c check the input parameters for errors.
-c
- if (n .le. 0 .or. m .lt. n .or. ldfjac .lt. m
- * .or. ftol .lt. zero .or. xtol .lt. zero .or. gtol .lt. zero
- * .or. maxfev .le. 0 .or. factor .le. zero) go to 300
- if (mode .ne. 2) go to 20
- do 10 j = 1, n
- if (diag(j) .le. zero) go to 300
- 10 continue
- 20 continue
-c
-c evaluate the function at the starting point
-c and calculate its norm.
-c
- iflag = 1
- call fcn(m,n,x,fvec,fjac,ldfjac,iflag,userpar)
- nfev = 1
- if (iflag .lt. 0) go to 300
- fnorm = enorm(m,fvec)
-c
-c initialize levenberg-marquardt parameter and iteration counter.
-c
- par = zero
- iter = 1
-c
-c beginning of the outer loop.
-c
- 30 continue
-c
-c calculate the jacobian matrix.
-c
- iflag = 2
- call fcn(m,n,x,fvec,fjac,ldfjac,iflag,userpar)
- njev = njev + 1
- if (iflag .lt. 0) go to 300
-c
-c if requested, call fcn to enable printing of iterates.
-c
- if (nprint .le. 0) go to 40
- iflag = 0
- if (mod(iter-1,nprint) .eq. 0)
- * call fcn(m,n,x,fvec,fjac,ldfjac,iflag,userpar)
- if (iflag .lt. 0) go to 300
- 40 continue
-c
-c compute the qr factorization of the jacobian.
-c
- call qrfac(m,n,fjac,ldfjac,.true.,ipvt,n,wa1,wa2,wa3)
-c
-c on the first iteration and if mode is 1, scale according
-c to the norms of the columns of the initial jacobian.
-c
- if (iter .ne. 1) go to 80
- if (mode .eq. 2) go to 60
- do 50 j = 1, n
- diag(j) = wa2(j)
- if (wa2(j) .eq. zero) diag(j) = one
- 50 continue
- 60 continue
-c
-c on the first iteration, calculate the norm of the scaled x
-c and initialize the step bound delta.
-c
- do 70 j = 1, n
- wa3(j) = diag(j)*x(j)
- 70 continue
- xnorm = enorm(n,wa3)
- delta = factor*xnorm
- if (delta .eq. zero) delta = factor
- 80 continue
-c
-c form (q transpose)*fvec and store the first n components in
-c qtf.
-c
- do 90 i = 1, m
- wa4(i) = fvec(i)
- 90 continue
- do 130 j = 1, n
- if (fjac(j,j) .eq. zero) go to 120
- sum = zero
- do 100 i = j, m
- sum = sum + fjac(i,j)*wa4(i)
- 100 continue
- temp = -sum/fjac(j,j)
- do 110 i = j, m
- wa4(i) = wa4(i) + fjac(i,j)*temp
- 110 continue
- 120 continue
- fjac(j,j) = wa1(j)
- qtf(j) = wa4(j)
- 130 continue
-c
-c compute the norm of the scaled gradient.
-c
- gnorm = zero
- if (fnorm .eq. zero) go to 170
- do 160 j = 1, n
- l = ipvt(j)
- if (wa2(l) .eq. zero) go to 150
- sum = zero
- do 140 i = 1, j
- sum = sum + fjac(i,j)*(qtf(i)/fnorm)
- 140 continue
- gnorm = dmax1(gnorm,dabs(sum/wa2(l)))
- 150 continue
- 160 continue
- 170 continue
-c
-c test for convergence of the gradient norm.
-c
- if (gnorm .le. gtol) info = 4
- if (info .ne. 0) go to 300
-c
-c rescale if necessary.
-c
- if (mode .eq. 2) go to 190
- do 180 j = 1, n
- diag(j) = dmax1(diag(j),wa2(j))
- 180 continue
- 190 continue
-c
-c beginning of the inner loop.
-c
- 200 continue
-c
-c determine the levenberg-marquardt parameter.
-c
- call lmpar(n,fjac,ldfjac,ipvt,diag,qtf,delta,par,wa1,wa2,
- * wa3,wa4)
-c
-c store the direction p and x + p. calculate the norm of p.
-c
- do 210 j = 1, n
- wa1(j) = -wa1(j)
- wa2(j) = x(j) + wa1(j)
- wa3(j) = diag(j)*wa1(j)
- 210 continue
- pnorm = enorm(n,wa3)
-c
-c on the first iteration, adjust the initial step bound.
-c
- if (iter .eq. 1) delta = dmin1(delta,pnorm)
-c
-c evaluate the function at x + p and calculate its norm.
-c
- iflag = 1
- call fcn(m,n,wa2,wa4,fjac,ldfjac,iflag,userpar)
- nfev = nfev + 1
- if (iflag .lt. 0) go to 300
- fnorm1 = enorm(m,wa4)
-c
-c compute the scaled actual reduction.
-c
- actred = -one
- if (p1*fnorm1 .lt. fnorm) actred = one - (fnorm1/fnorm)**2
-c
-c compute the scaled predicted reduction and
-c the scaled directional derivative.
-c
- do 230 j = 1, n
- wa3(j) = zero
- l = ipvt(j)
- temp = wa1(l)
- do 220 i = 1, j
- wa3(i) = wa3(i) + fjac(i,j)*temp
- 220 continue
- 230 continue
- temp1 = enorm(n,wa3)/fnorm
- temp2 = (dsqrt(par)*pnorm)/fnorm
- prered = temp1**2 + temp2**2/p5
- dirder = -(temp1**2 + temp2**2)
-c
-c compute the ratio of the actual to the predicted
-c reduction.
-c
- ratio = zero
- if (prered .ne. zero) ratio = actred/prered
-c
-c update the step bound.
-c
- if (ratio .gt. p25) go to 240
- if (actred .ge. zero) temp = p5
- if (actred .lt. zero)
- * temp = p5*dirder/(dirder + p5*actred)
- if (p1*fnorm1 .ge. fnorm .or. temp .lt. p1) temp = p1
- delta = temp*dmin1(delta,pnorm/p1)
- par = par/temp
- go to 260
- 240 continue
- if (par .ne. zero .and. ratio .lt. p75) go to 250
- delta = pnorm/p5
- par = p5*par
- 250 continue
- 260 continue
-c
-c test for successful iteration.
-c
- if (ratio .lt. p0001) go to 290
-c
-c successful iteration. update x, fvec, and their norms.
-c
- do 270 j = 1, n
- x(j) = wa2(j)
- wa2(j) = diag(j)*x(j)
- 270 continue
- do 280 i = 1, m
- fvec(i) = wa4(i)
- 280 continue
- xnorm = enorm(n,wa2)
- fnorm = fnorm1
- iter = iter + 1
- 290 continue
-c
-c tests for convergence.
-c
- if (dabs(actred) .le. ftol .and. prered .le. ftol
- * .and. p5*ratio .le. one) info = 1
- if (delta .le. xtol*xnorm) info = 2
- if (dabs(actred) .le. ftol .and. prered .le. ftol
- * .and. p5*ratio .le. one .and. info .eq. 2) info = 3
- if (info .ne. 0) go to 300
-c
-c tests for termination and stringent tolerances.
-c
- if (nfev .ge. maxfev) info = 5
- if (dabs(actred) .le. epsmch .and. prered .le. epsmch
- * .and. p5*ratio .le. one) info = 6
- if (delta .le. epsmch*xnorm) info = 7
- if (gnorm .le. epsmch) info = 8
- if (info .ne. 0) go to 300
-c
-c end of the inner loop. repeat if iteration unsuccessful.
-c
- if (ratio .lt. p0001) go to 200
-c
-c end of the outer loop.
-c
- go to 30
- 300 continue
-c
-c termination, either normal or user imposed.
-c
- if (iflag .lt. 0) info = iflag
- iflag = 0
- if (nprint .gt. 0) call fcn(m,n,x,fvec,fjac,ldfjac,iflag,userpar)
- return
-c
-c last card of subroutine lmder.
-c
- end
diff --git a/CEP/PyBDSM/src/minpack/lmder1.f b/CEP/PyBDSM/src/minpack/lmder1.f
deleted file mode 100644
index d691940fd7b76378a6752ce69fcc798575d67433..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/minpack/lmder1.f
+++ /dev/null
@@ -1,156 +0,0 @@
- subroutine lmder1(fcn,m,n,x,fvec,fjac,ldfjac,tol,info,ipvt,wa,
- * lwa)
- integer m,n,ldfjac,info,lwa
- integer ipvt(n)
- double precision tol
- double precision x(n),fvec(m),fjac(ldfjac,n),wa(lwa)
- external fcn
-c **********
-c
-c subroutine lmder1
-c
-c the purpose of lmder1 is to minimize the sum of the squares of
-c m nonlinear functions in n variables by a modification of the
-c levenberg-marquardt algorithm. this is done by using the more
-c general least-squares solver lmder. the user must provide a
-c subroutine which calculates the functions and the jacobian.
-c
-c the subroutine statement is
-c
-c subroutine lmder1(fcn,m,n,x,fvec,fjac,ldfjac,tol,info,
-c ipvt,wa,lwa)
-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
-c subroutine fcn(m,n,x,fvec,fjac,ldfjac,iflag)
-c integer m,n,ldfjac,iflag
-c double precision x(n),fvec(m),fjac(ldfjac,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 ----------
-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 lmder1.
-c in this case set iflag to a negative integer.
-c
-c m is a positive integer input variable set to the number
-c of functions.
-c
-c n is a positive integer input variable set to the number
-c of variables. n must not exceed m.
-c
-c x is an array of length n. on input x must contain
-c an initial estimate of the solution vector. on output x
-c contains the final estimate of the solution vector.
-c
-c fvec is an output array of length m which contains
-c the functions evaluated at the output x.
-c
-c fjac is an output m by n array. the upper n by n submatrix
-c of fjac contains an upper triangular matrix r with
-c diagonal elements of nonincreasing magnitude such that
-c
-c t t t
-c p *(jac *jac)*p = r *r,
-c
-c where p is a permutation matrix and jac is the final
-c calculated jacobian. column j of p is column ipvt(j)
-c (see below) of the identity matrix. the lower trapezoidal
-c part of fjac contains information generated during
-c the computation of r.
-c
-c ldfjac is a positive integer input variable not less than m
-c which specifies the leading dimension of the array fjac.
-c
-c tol is a nonnegative input variable. termination occurs
-c when the algorithm estimates either that the relative
-c error in the sum of squares is at most tol or that
-c the relative error between x and the solution is at
-c most tol.
-c
-c info is an integer output variable. if the user has
-c terminated execution, info is set to the (negative)
-c value of iflag. see description of fcn. otherwise,
-c info is set as follows.
-c
-c info = 0 improper input parameters.
-c
-c info = 1 algorithm estimates that the relative error
-c in the sum of squares is at most tol.
-c
-c info = 2 algorithm estimates that the relative error
-c between x and the solution is at most tol.
-c
-c info = 3 conditions for info = 1 and info = 2 both hold.
-c
-c info = 4 fvec is orthogonal to the columns of the
-c jacobian to machine precision.
-c
-c info = 5 number of calls to fcn with iflag = 1 has
-c reached 100*(n+1).
-c
-c info = 6 tol is too small. no further reduction in
-c the sum of squares is possible.
-c
-c info = 7 tol is too small. no further improvement in
-c the approximate solution x is possible.
-c
-c ipvt is an integer output array of length n. ipvt
-c defines a permutation matrix p such that jac*p = q*r,
-c where jac is the final calculated jacobian, q is
-c orthogonal (not stored), and r is upper triangular
-c with diagonal elements of nonincreasing magnitude.
-c column j of p is column ipvt(j) of the identity matrix.
-c
-c wa is a work array of length lwa.
-c
-c lwa is a positive integer input variable not less than 5*n+m.
-c
-c subprograms called
-c
-c user-supplied ...... fcn
-c
-c minpack-supplied ... lmder
-c
-c argonne national laboratory. minpack project. march 1980.
-c burton s. garbow, kenneth e. hillstrom, jorge j. more
-c
-c **********
- integer maxfev,mode,nfev,njev,nprint
- double precision factor,ftol,gtol,xtol,zero
- data factor,zero /1.0d2,0.0d0/
- info = 0
-c
-c check the input parameters for errors.
-c
- if (n .le. 0 .or. m .lt. n .or. ldfjac .lt. m .or. tol .lt. zero
- * .or. lwa .lt. 5*n + m) go to 10
-c
-c call lmder.
-c
- maxfev = 100*(n + 1)
- ftol = tol
- xtol = tol
- gtol = zero
- mode = 1
- nprint = 0
- call lmder(fcn,m,n,x,fvec,fjac,ldfjac,ftol,xtol,gtol,maxfev,
- * wa(1),mode,factor,nprint,info,nfev,njev,ipvt,wa(n+1),
- * wa(2*n+1),wa(3*n+1),wa(4*n+1),wa(5*n+1))
- if (info .eq. 8) info = 4
- 10 continue
- return
-c
-c last card of subroutine lmder1.
-c
- end
diff --git a/CEP/PyBDSM/src/minpack/lmdif.f b/CEP/PyBDSM/src/minpack/lmdif.f
deleted file mode 100644
index dd3d4ee2565790d8027b28f9d910e7cdc6e8f004..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/minpack/lmdif.f
+++ /dev/null
@@ -1,454 +0,0 @@
- subroutine lmdif(fcn,m,n,x,fvec,ftol,xtol,gtol,maxfev,epsfcn,
- * diag,mode,factor,nprint,info,nfev,fjac,ldfjac,
- * ipvt,qtf,wa1,wa2,wa3,wa4)
- integer m,n,maxfev,mode,nprint,info,nfev,ldfjac
- integer ipvt(n)
- double precision ftol,xtol,gtol,epsfcn,factor
- double precision x(n),fvec(m),diag(n),fjac(ldfjac,n),qtf(n),
- * wa1(n),wa2(n),wa3(n),wa4(m)
- external fcn
-c **********
-c
-c subroutine lmdif
-c
-c the purpose of lmdif is to minimize the sum of the squares of
-c m nonlinear functions in n variables by a modification of
-c the levenberg-marquardt algorithm. the user must provide a
-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 lmdif(fcn,m,n,x,fvec,ftol,xtol,gtol,maxfev,epsfcn,
-c diag,mode,factor,nprint,info,nfev,fjac,
-c ldfjac,ipvt,qtf,wa1,wa2,wa3,wa4)
-c
-c where
-c
-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
-c subroutine fcn(m,n,x,fvec,iflag)
-c integer m,n,iflag
-c double precision x(n),fvec(m)
-c ----------
-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 lmdif.
-c in this case set iflag to a negative integer.
-c
-c m is a positive integer input variable set to the number
-c of functions.
-c
-c n is a positive integer input variable set to the number
-c of variables. n must not exceed m.
-c
-c x is an array of length n. on input x must contain
-c an initial estimate of the solution vector. on output x
-c contains the final estimate of the solution vector.
-c
-c fvec is an output array of length m which contains
-c the functions evaluated at the output x.
-c
-c ftol is a nonnegative input variable. termination
-c occurs when both the actual and predicted relative
-c reductions in the sum of squares are at most ftol.
-c therefore, ftol measures the relative error desired
-c in the sum of squares.
-c
-c xtol is a nonnegative input variable. termination
-c occurs when the relative error between two consecutive
-c iterates is at most xtol. therefore, xtol measures the
-c relative error desired in the approximate solution.
-c
-c gtol is a nonnegative input variable. termination
-c occurs when the cosine of the angle between fvec and
-c any column of the jacobian is at most gtol in absolute
-c value. therefore, gtol measures the orthogonality
-c desired between the function vector and the columns
-c of the jacobian.
-c
-c maxfev is a positive integer input variable. termination
-c occurs when the number of calls to fcn is at least
-c maxfev by the end of an iteration.
-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
-c must contain positive entries that serve as
-c multiplicative scale factors for the variables.
-c
-c mode is an integer input variable. if mode = 1, the
-c variables will be scaled internally. if mode = 2,
-c the scaling is specified by the input diag. other
-c values of mode are equivalent to mode = 1.
-c
-c factor is a positive input variable used in determining the
-c initial step bound. this bound is set to the product of
-c factor and the euclidean norm of diag*x if nonzero, or else
-c to factor itself. in most cases factor should lie in the
-c interval (.1,100.). 100. is a generally recommended value.
-c
-c nprint is an integer input variable that enables controlled
-c printing of iterates if it is positive. in this case,
-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. 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)
-c value of iflag. see description of fcn. otherwise,
-c info is set as follows.
-c
-c info = 0 improper input parameters.
-c
-c info = 1 both actual and predicted relative reductions
-c in the sum of squares are at most ftol.
-c
-c info = 2 relative error between two consecutive iterates
-c is at most xtol.
-c
-c info = 3 conditions for info = 1 and info = 2 both hold.
-c
-c info = 4 the cosine of the angle between fvec and any
-c column of the jacobian is at most gtol in
-c absolute value.
-c
-c info = 5 number of calls to fcn has reached or
-c exceeded maxfev.
-c
-c info = 6 ftol is too small. no further reduction in
-c the sum of squares is possible.
-c
-c info = 7 xtol is too small. no further improvement in
-c the approximate solution x is possible.
-c
-c info = 8 gtol is too small. fvec is orthogonal to the
-c columns of the jacobian to machine precision.
-c
-c nfev is an integer output variable set to the number of
-c calls to fcn.
-c
-c fjac is an output m by n array. the upper n by n submatrix
-c of fjac contains an upper triangular matrix r with
-c diagonal elements of nonincreasing magnitude such that
-c
-c t t t
-c p *(jac *jac)*p = r *r,
-c
-c where p is a permutation matrix and jac is the final
-c calculated jacobian. column j of p is column ipvt(j)
-c (see below) of the identity matrix. the lower trapezoidal
-c part of fjac contains information generated during
-c the computation of r.
-c
-c ldfjac is a positive integer input variable not less than m
-c which specifies the leading dimension of the array fjac.
-c
-c ipvt is an integer output array of length n. ipvt
-c defines a permutation matrix p such that jac*p = q*r,
-c where jac is the final calculated jacobian, q is
-c orthogonal (not stored), and r is upper triangular
-c with diagonal elements of nonincreasing magnitude.
-c column j of p is column ipvt(j) of the identity matrix.
-c
-c qtf is an output array of length n which contains
-c the first n elements of the vector (q transpose)*fvec.
-c
-c wa1, wa2, and wa3 are work arrays of length n.
-c
-c wa4 is a work array of length m.
-c
-c subprograms called
-c
-c user-supplied ...... fcn
-c
-c minpack-supplied ... dpmpar,enorm,fdjac2,lmpar,qrfac
-c
-c fortran-supplied ... dabs,dmax1,dmin1,dsqrt,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,l
- double precision actred,delta,dirder,epsmch,fnorm,fnorm1,gnorm,
- * one,par,pnorm,prered,p1,p5,p25,p75,p0001,ratio,
- * sum,temp,temp1,temp2,xnorm,zero
- double precision dpmpar,enorm
- data one,p1,p5,p25,p75,p0001,zero
- * /1.0d0,1.0d-1,5.0d-1,2.5d-1,7.5d-1,1.0d-4,0.0d0/
-c
-c epsmch is the machine precision.
-c
- epsmch = dpmpar(1)
-c
- info = 0
- iflag = 0
- nfev = 0
-c
-c check the input parameters for errors.
-c
- if (n .le. 0 .or. m .lt. n .or. ldfjac .lt. m
- * .or. ftol .lt. zero .or. xtol .lt. zero .or. gtol .lt. zero
- * .or. maxfev .le. 0 .or. factor .le. zero) go to 300
- if (mode .ne. 2) go to 20
- do 10 j = 1, n
- if (diag(j) .le. zero) go to 300
- 10 continue
- 20 continue
-c
-c evaluate the function at the starting point
-c and calculate its norm.
-c
- iflag = 1
- call fcn(m,n,x,fvec,iflag)
- nfev = 1
- if (iflag .lt. 0) go to 300
- fnorm = enorm(m,fvec)
-c
-c initialize levenberg-marquardt parameter and iteration counter.
-c
- par = zero
- iter = 1
-c
-c beginning of the outer loop.
-c
- 30 continue
-c
-c calculate the jacobian matrix.
-c
- iflag = 2
- call fdjac2(fcn,m,n,x,fvec,fjac,ldfjac,iflag,epsfcn,wa4)
- nfev = nfev + n
- if (iflag .lt. 0) go to 300
-c
-c if requested, call fcn to enable printing of iterates.
-c
- if (nprint .le. 0) go to 40
- iflag = 0
- if (mod(iter-1,nprint) .eq. 0) call fcn(m,n,x,fvec,iflag)
- if (iflag .lt. 0) go to 300
- 40 continue
-c
-c compute the qr factorization of the jacobian.
-c
- call qrfac(m,n,fjac,ldfjac,.true.,ipvt,n,wa1,wa2,wa3)
-c
-c on the first iteration and if mode is 1, scale according
-c to the norms of the columns of the initial jacobian.
-c
- if (iter .ne. 1) go to 80
- if (mode .eq. 2) go to 60
- do 50 j = 1, n
- diag(j) = wa2(j)
- if (wa2(j) .eq. zero) diag(j) = one
- 50 continue
- 60 continue
-c
-c on the first iteration, calculate the norm of the scaled x
-c and initialize the step bound delta.
-c
- do 70 j = 1, n
- wa3(j) = diag(j)*x(j)
- 70 continue
- xnorm = enorm(n,wa3)
- delta = factor*xnorm
- if (delta .eq. zero) delta = factor
- 80 continue
-c
-c form (q transpose)*fvec and store the first n components in
-c qtf.
-c
- do 90 i = 1, m
- wa4(i) = fvec(i)
- 90 continue
- do 130 j = 1, n
- if (fjac(j,j) .eq. zero) go to 120
- sum = zero
- do 100 i = j, m
- sum = sum + fjac(i,j)*wa4(i)
- 100 continue
- temp = -sum/fjac(j,j)
- do 110 i = j, m
- wa4(i) = wa4(i) + fjac(i,j)*temp
- 110 continue
- 120 continue
- fjac(j,j) = wa1(j)
- qtf(j) = wa4(j)
- 130 continue
-c
-c compute the norm of the scaled gradient.
-c
- gnorm = zero
- if (fnorm .eq. zero) go to 170
- do 160 j = 1, n
- l = ipvt(j)
- if (wa2(l) .eq. zero) go to 150
- sum = zero
- do 140 i = 1, j
- sum = sum + fjac(i,j)*(qtf(i)/fnorm)
- 140 continue
- gnorm = dmax1(gnorm,dabs(sum/wa2(l)))
- 150 continue
- 160 continue
- 170 continue
-c
-c test for convergence of the gradient norm.
-c
- if (gnorm .le. gtol) info = 4
- if (info .ne. 0) go to 300
-c
-c rescale if necessary.
-c
- if (mode .eq. 2) go to 190
- do 180 j = 1, n
- diag(j) = dmax1(diag(j),wa2(j))
- 180 continue
- 190 continue
-c
-c beginning of the inner loop.
-c
- 200 continue
-c
-c determine the levenberg-marquardt parameter.
-c
- call lmpar(n,fjac,ldfjac,ipvt,diag,qtf,delta,par,wa1,wa2,
- * wa3,wa4)
-c
-c store the direction p and x + p. calculate the norm of p.
-c
- do 210 j = 1, n
- wa1(j) = -wa1(j)
- wa2(j) = x(j) + wa1(j)
- wa3(j) = diag(j)*wa1(j)
- 210 continue
- pnorm = enorm(n,wa3)
-c
-c on the first iteration, adjust the initial step bound.
-c
- if (iter .eq. 1) delta = dmin1(delta,pnorm)
-c
-c evaluate the function at x + p and calculate its norm.
-c
- iflag = 1
- call fcn(m,n,wa2,wa4,iflag)
- nfev = nfev + 1
- if (iflag .lt. 0) go to 300
- fnorm1 = enorm(m,wa4)
-c
-c compute the scaled actual reduction.
-c
- actred = -one
- if (p1*fnorm1 .lt. fnorm) actred = one - (fnorm1/fnorm)**2
-c
-c compute the scaled predicted reduction and
-c the scaled directional derivative.
-c
- do 230 j = 1, n
- wa3(j) = zero
- l = ipvt(j)
- temp = wa1(l)
- do 220 i = 1, j
- wa3(i) = wa3(i) + fjac(i,j)*temp
- 220 continue
- 230 continue
- temp1 = enorm(n,wa3)/fnorm
- temp2 = (dsqrt(par)*pnorm)/fnorm
- prered = temp1**2 + temp2**2/p5
- dirder = -(temp1**2 + temp2**2)
-c
-c compute the ratio of the actual to the predicted
-c reduction.
-c
- ratio = zero
- if (prered .ne. zero) ratio = actred/prered
-c
-c update the step bound.
-c
- if (ratio .gt. p25) go to 240
- if (actred .ge. zero) temp = p5
- if (actred .lt. zero)
- * temp = p5*dirder/(dirder + p5*actred)
- if (p1*fnorm1 .ge. fnorm .or. temp .lt. p1) temp = p1
- delta = temp*dmin1(delta,pnorm/p1)
- par = par/temp
- go to 260
- 240 continue
- if (par .ne. zero .and. ratio .lt. p75) go to 250
- delta = pnorm/p5
- par = p5*par
- 250 continue
- 260 continue
-c
-c test for successful iteration.
-c
- if (ratio .lt. p0001) go to 290
-c
-c successful iteration. update x, fvec, and their norms.
-c
- do 270 j = 1, n
- x(j) = wa2(j)
- wa2(j) = diag(j)*x(j)
- 270 continue
- do 280 i = 1, m
- fvec(i) = wa4(i)
- 280 continue
- xnorm = enorm(n,wa2)
- fnorm = fnorm1
- iter = iter + 1
- 290 continue
-c
-c tests for convergence.
-c
- if (dabs(actred) .le. ftol .and. prered .le. ftol
- * .and. p5*ratio .le. one) info = 1
- if (delta .le. xtol*xnorm) info = 2
- if (dabs(actred) .le. ftol .and. prered .le. ftol
- * .and. p5*ratio .le. one .and. info .eq. 2) info = 3
- if (info .ne. 0) go to 300
-c
-c tests for termination and stringent tolerances.
-c
- if (nfev .ge. maxfev) info = 5
- if (dabs(actred) .le. epsmch .and. prered .le. epsmch
- * .and. p5*ratio .le. one) info = 6
- if (delta .le. epsmch*xnorm) info = 7
- if (gnorm .le. epsmch) info = 8
- if (info .ne. 0) go to 300
-c
-c end of the inner loop. repeat if iteration unsuccessful.
-c
- if (ratio .lt. p0001) go to 200
-c
-c end of the outer loop.
-c
- go to 30
- 300 continue
-c
-c termination, either normal or user imposed.
-c
- if (iflag .lt. 0) info = iflag
- iflag = 0
- if (nprint .gt. 0) call fcn(m,n,x,fvec,iflag)
- return
-c
-c last card of subroutine lmdif.
-c
- end
diff --git a/CEP/PyBDSM/src/minpack/lmdif1.f b/CEP/PyBDSM/src/minpack/lmdif1.f
deleted file mode 100644
index 70f8aae05202ba0e8a38d6e3fb923b8635ca1103..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/minpack/lmdif1.f
+++ /dev/null
@@ -1,135 +0,0 @@
- subroutine lmdif1(fcn,m,n,x,fvec,tol,info,iwa,wa,lwa)
- integer m,n,info,lwa
- integer iwa(n)
- double precision tol
- double precision x(n),fvec(m),wa(lwa)
- external fcn
-c **********
-c
-c subroutine lmdif1
-c
-c the purpose of lmdif1 is to minimize the sum of the squares of
-c m nonlinear functions in n variables by a modification of the
-c levenberg-marquardt algorithm. this is done by using the more
-c general least-squares solver lmdif. the user must provide a
-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 lmdif1(fcn,m,n,x,fvec,tol,info,iwa,wa,lwa)
-c
-c where
-c
-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
-c subroutine fcn(m,n,x,fvec,iflag)
-c integer m,n,iflag
-c double precision x(n),fvec(m)
-c ----------
-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 lmdif1.
-c in this case set iflag to a negative integer.
-c
-c m is a positive integer input variable set to the number
-c of functions.
-c
-c n is a positive integer input variable set to the number
-c of variables. n must not exceed m.
-c
-c x is an array of length n. on input x must contain
-c an initial estimate of the solution vector. on output x
-c contains the final estimate of the solution vector.
-c
-c fvec is an output array of length m which contains
-c the functions evaluated at the output x.
-c
-c tol is a nonnegative input variable. termination occurs
-c when the algorithm estimates either that the relative
-c error in the sum of squares is at most tol or that
-c the relative error between x and the solution is at
-c most tol.
-c
-c info is an integer output variable. if the user has
-c terminated execution, info is set to the (negative)
-c value of iflag. see description of fcn. otherwise,
-c info is set as follows.
-c
-c info = 0 improper input parameters.
-c
-c info = 1 algorithm estimates that the relative error
-c in the sum of squares is at most tol.
-c
-c info = 2 algorithm estimates that the relative error
-c between x and the solution is at most tol.
-c
-c info = 3 conditions for info = 1 and info = 2 both hold.
-c
-c info = 4 fvec is orthogonal to the columns of the
-c jacobian to machine precision.
-c
-c info = 5 number of calls to fcn has reached or
-c exceeded 200*(n+1).
-c
-c info = 6 tol is too small. no further reduction in
-c the sum of squares is possible.
-c
-c info = 7 tol is too small. no further improvement in
-c the approximate solution x is possible.
-c
-c iwa is an integer work array of length n.
-c
-c wa is a work array of length lwa.
-c
-c lwa is a positive integer input variable not less than
-c m*n+5*n+m.
-c
-c subprograms called
-c
-c user-supplied ...... fcn
-c
-c minpack-supplied ... lmdif
-c
-c argonne national laboratory. minpack project. march 1980.
-c burton s. garbow, kenneth e. hillstrom, jorge j. more
-c
-c **********
- integer maxfev,mode,mp5n,nfev,nprint
- double precision epsfcn,factor,ftol,gtol,xtol,zero
- data factor,zero /1.0d2,0.0d0/
- info = 0
-c
-c check the input parameters for errors.
-c
- if (n .le. 0 .or. m .lt. n .or. tol .lt. zero
- * .or. lwa .lt. m*n + 5*n + m) go to 10
-c
-c call lmdif.
-c
- maxfev = 200*(n + 1)
- ftol = tol
- xtol = tol
- gtol = zero
- epsfcn = zero
- mode = 1
- nprint = 0
- mp5n = m + 5*n
- call lmdif(fcn,m,n,x,fvec,ftol,xtol,gtol,maxfev,epsfcn,wa(1),
- * mode,factor,nprint,info,nfev,wa(mp5n+1),m,iwa,
- * wa(n+1),wa(2*n+1),wa(3*n+1),wa(4*n+1),wa(5*n+1))
- if (info .eq. 8) info = 4
- 10 continue
- return
-c
-c last card of subroutine lmdif1.
-c
- end
diff --git a/CEP/PyBDSM/src/minpack/lmpar.f b/CEP/PyBDSM/src/minpack/lmpar.f
deleted file mode 100644
index 26c422a79e9b229dcdfef31ec5a7d23ff6c68926..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/minpack/lmpar.f
+++ /dev/null
@@ -1,264 +0,0 @@
- subroutine lmpar(n,r,ldr,ipvt,diag,qtb,delta,par,x,sdiag,wa1,
- * wa2)
- integer n,ldr
- integer ipvt(n)
- double precision delta,par
- double precision r(ldr,n),diag(n),qtb(n),x(n),sdiag(n),wa1(n),
- * wa2(n)
-c **********
-c
-c subroutine lmpar
-c
-c given an m by n matrix a, an n by n nonsingular diagonal
-c matrix d, an m-vector b, and a positive number delta,
-c the problem is to determine a value for the parameter
-c par such that if x solves the system
-c
-c a*x = b , sqrt(par)*d*x = 0 ,
-c
-c in the least squares sense, and dxnorm is the euclidean
-c norm of d*x, then either par is zero and
-c
-c (dxnorm-delta) .le. 0.1*delta ,
-c
-c or par is positive and
-c
-c abs(dxnorm-delta) .le. 0.1*delta .
-c
-c this subroutine completes the solution of the problem
-c if it is provided with the necessary information from the
-c qr factorization, with column pivoting, of a. that is, if
-c a*p = q*r, where p is a permutation matrix, q has orthogonal
-c columns, and r is an upper triangular matrix with diagonal
-c elements of nonincreasing magnitude, then lmpar expects
-c the full upper triangle of r, the permutation matrix p,
-c and the first n components of (q transpose)*b. on output
-c lmpar also provides an upper triangular matrix s such that
-c
-c t t t
-c p *(a *a + par*d*d)*p = s *s .
-c
-c s is employed within lmpar and may be of separate interest.
-c
-c only a few iterations are generally needed for convergence
-c of the algorithm. if, however, the limit of 10 iterations
-c is reached, then the output par will contain the best
-c value obtained so far.
-c
-c the subroutine statement is
-c
-c subroutine lmpar(n,r,ldr,ipvt,diag,qtb,delta,par,x,sdiag,
-c wa1,wa2)
-c
-c where
-c
-c n is a positive integer input variable set to the order of r.
-c
-c r is an n by n array. on input the full upper triangle
-c must contain the full upper triangle of the matrix r.
-c on output the full upper triangle is unaltered, and the
-c strict lower triangle contains the strict upper triangle
-c (transposed) of the upper triangular matrix s.
-c
-c ldr is a positive integer input variable not less than n
-c which specifies the leading dimension of the array r.
-c
-c ipvt is an integer input array of length n which defines the
-c permutation matrix p such that a*p = q*r. column j of p
-c is column ipvt(j) of the identity matrix.
-c
-c diag is an input array of length n which must contain the
-c diagonal elements of the matrix d.
-c
-c qtb is an input array of length n which must contain the first
-c n elements of the vector (q transpose)*b.
-c
-c delta is a positive input variable which specifies an upper
-c bound on the euclidean norm of d*x.
-c
-c par is a nonnegative variable. on input par contains an
-c initial estimate of the levenberg-marquardt parameter.
-c on output par contains the final estimate.
-c
-c x is an output array of length n which contains the least
-c squares solution of the system a*x = b, sqrt(par)*d*x = 0,
-c for the output par.
-c
-c sdiag is an output array of length n which contains the
-c diagonal elements of the upper triangular matrix s.
-c
-c wa1 and wa2 are work arrays of length n.
-c
-c subprograms called
-c
-c minpack-supplied ... dpmpar,enorm,qrsolv
-c
-c fortran-supplied ... dabs,dmax1,dmin1,dsqrt
-c
-c argonne national laboratory. minpack project. march 1980.
-c burton s. garbow, kenneth e. hillstrom, jorge j. more
-c
-c **********
- integer i,iter,j,jm1,jp1,k,l,nsing
- double precision dxnorm,dwarf,fp,gnorm,parc,parl,paru,p1,p001,
- * sum,temp,zero
- double precision dpmpar,enorm
- data p1,p001,zero /1.0d-1,1.0d-3,0.0d0/
-c
-c dwarf is the smallest positive magnitude.
-c
- dwarf = dpmpar(2)
-c
-c compute and store in x the gauss-newton direction. if the
-c jacobian is rank-deficient, obtain a least squares solution.
-c
- nsing = n
- do 10 j = 1, n
- wa1(j) = qtb(j)
- if (r(j,j) .eq. zero .and. nsing .eq. n) nsing = j - 1
- if (nsing .lt. n) wa1(j) = zero
- 10 continue
- if (nsing .lt. 1) go to 50
- do 40 k = 1, nsing
- j = nsing - k + 1
- wa1(j) = wa1(j)/r(j,j)
- temp = wa1(j)
- jm1 = j - 1
- if (jm1 .lt. 1) go to 30
- do 20 i = 1, jm1
- wa1(i) = wa1(i) - r(i,j)*temp
- 20 continue
- 30 continue
- 40 continue
- 50 continue
- do 60 j = 1, n
- l = ipvt(j)
- x(l) = wa1(j)
- 60 continue
-c
-c initialize the iteration counter.
-c evaluate the function at the origin, and test
-c for acceptance of the gauss-newton direction.
-c
- iter = 0
- do 70 j = 1, n
- wa2(j) = diag(j)*x(j)
- 70 continue
- dxnorm = enorm(n,wa2)
- fp = dxnorm - delta
- if (fp .le. p1*delta) go to 220
-c
-c if the jacobian is not rank deficient, the newton
-c step provides a lower bound, parl, for the zero of
-c the function. otherwise set this bound to zero.
-c
- parl = zero
- if (nsing .lt. n) go to 120
- do 80 j = 1, n
- l = ipvt(j)
- wa1(j) = diag(l)*(wa2(l)/dxnorm)
- 80 continue
- do 110 j = 1, n
- sum = zero
- jm1 = j - 1
- if (jm1 .lt. 1) go to 100
- do 90 i = 1, jm1
- sum = sum + r(i,j)*wa1(i)
- 90 continue
- 100 continue
- wa1(j) = (wa1(j) - sum)/r(j,j)
- 110 continue
- temp = enorm(n,wa1)
- parl = ((fp/delta)/temp)/temp
- 120 continue
-c
-c calculate an upper bound, paru, for the zero of the function.
-c
- do 140 j = 1, n
- sum = zero
- do 130 i = 1, j
- sum = sum + r(i,j)*qtb(i)
- 130 continue
- l = ipvt(j)
- wa1(j) = sum/diag(l)
- 140 continue
- gnorm = enorm(n,wa1)
- paru = gnorm/delta
- if (paru .eq. zero) paru = dwarf/dmin1(delta,p1)
-c
-c if the input par lies outside of the interval (parl,paru),
-c set par to the closer endpoint.
-c
- par = dmax1(par,parl)
- par = dmin1(par,paru)
- if (par .eq. zero) par = gnorm/dxnorm
-c
-c beginning of an iteration.
-c
- 150 continue
- iter = iter + 1
-c
-c evaluate the function at the current value of par.
-c
- if (par .eq. zero) par = dmax1(dwarf,p001*paru)
- temp = dsqrt(par)
- do 160 j = 1, n
- wa1(j) = temp*diag(j)
- 160 continue
- call qrsolv(n,r,ldr,ipvt,wa1,qtb,x,sdiag,wa2)
- do 170 j = 1, n
- wa2(j) = diag(j)*x(j)
- 170 continue
- dxnorm = enorm(n,wa2)
- temp = fp
- fp = dxnorm - delta
-c
-c if the function is small enough, accept the current value
-c of par. also test for the exceptional cases where parl
-c is zero or the number of iterations has reached 10.
-c
- if (dabs(fp) .le. p1*delta
- * .or. parl .eq. zero .and. fp .le. temp
- * .and. temp .lt. zero .or. iter .eq. 10) go to 220
-c
-c compute the newton correction.
-c
- do 180 j = 1, n
- l = ipvt(j)
- wa1(j) = diag(l)*(wa2(l)/dxnorm)
- 180 continue
- do 210 j = 1, n
- wa1(j) = wa1(j)/sdiag(j)
- temp = wa1(j)
- jp1 = j + 1
- if (n .lt. jp1) go to 200
- do 190 i = jp1, n
- wa1(i) = wa1(i) - r(i,j)*temp
- 190 continue
- 200 continue
- 210 continue
- temp = enorm(n,wa1)
- parc = ((fp/delta)/temp)/temp
-c
-c depending on the sign of the function, update parl or paru.
-c
- if (fp .gt. zero) parl = dmax1(parl,par)
- if (fp .lt. zero) paru = dmin1(paru,par)
-c
-c compute an improved estimate for par.
-c
- par = dmax1(parl,par+parc)
-c
-c end of an iteration.
-c
- go to 150
- 220 continue
-c
-c termination.
-c
- if (iter .eq. 0) par = zero
- return
-c
-c last card of subroutine lmpar.
-c
- end
diff --git a/CEP/PyBDSM/src/minpack/lmstr.f b/CEP/PyBDSM/src/minpack/lmstr.f
deleted file mode 100644
index d9a7893f855774a30e45482f464de94d6edc1975..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/minpack/lmstr.f
+++ /dev/null
@@ -1,466 +0,0 @@
- subroutine lmstr(fcn,m,n,x,fvec,fjac,ldfjac,ftol,xtol,gtol,
- * maxfev,diag,mode,factor,nprint,info,nfev,njev,
- * ipvt,qtf,wa1,wa2,wa3,wa4)
- integer m,n,ldfjac,maxfev,mode,nprint,info,nfev,njev
- integer ipvt(n)
- logical sing
- double precision ftol,xtol,gtol,factor
- double precision x(n),fvec(m),fjac(ldfjac,n),diag(n),qtf(n),
- * wa1(n),wa2(n),wa3(n),wa4(m)
-c **********
-c
-c subroutine lmstr
-c
-c the purpose of lmstr is to minimize the sum of the squares of
-c m nonlinear functions in n variables by a modification of
-c the levenberg-marquardt algorithm which uses minimal storage.
-c the user must provide a subroutine which calculates the
-c functions and the rows of the jacobian.
-c
-c the subroutine statement is
-c
-c subroutine lmstr(fcn,m,n,x,fvec,fjac,ldfjac,ftol,xtol,gtol,
-c maxfev,diag,mode,factor,nprint,info,nfev,
-c njev,ipvt,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 rows of the jacobian.
-c fcn must be declared in an external statement in the
-c user calling program, and should be written as follows.
-c
-c subroutine fcn(m,n,x,fvec,fjrow,iflag)
-c integer m,n,iflag
-c double precision x(n),fvec(m),fjrow(n)
-c ----------
-c if iflag = 1 calculate the functions at x and
-c return this vector in fvec.
-c if iflag = i calculate the (i-1)-st row of the
-c jacobian at x and return this vector in fjrow.
-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 lmstr.
-c in this case set iflag to a negative integer.
-c
-c m is a positive integer input variable set to the number
-c of functions.
-c
-c n is a positive integer input variable set to the number
-c of variables. n must not exceed m.
-c
-c x is an array of length n. on input x must contain
-c an initial estimate of the solution vector. on output x
-c contains the final estimate of the solution vector.
-c
-c fvec is an output array of length m which contains
-c the functions evaluated at the output x.
-c
-c fjac is an output n by n array. the upper triangle of fjac
-c contains an upper triangular matrix r such that
-c
-c t t t
-c p *(jac *jac)*p = r *r,
-c
-c where p is a permutation matrix and jac is the final
-c calculated jacobian. column j of p is column ipvt(j)
-c (see below) of the identity matrix. the lower triangular
-c part of fjac contains information generated during
-c the computation of r.
-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 ftol is a nonnegative input variable. termination
-c occurs when both the actual and predicted relative
-c reductions in the sum of squares are at most ftol.
-c therefore, ftol measures the relative error desired
-c in the sum of squares.
-c
-c xtol is a nonnegative input variable. termination
-c occurs when the relative error between two consecutive
-c iterates is at most xtol. therefore, xtol measures the
-c relative error desired in the approximate solution.
-c
-c gtol is a nonnegative input variable. termination
-c occurs when the cosine of the angle between fvec and
-c any column of the jacobian is at most gtol in absolute
-c value. therefore, gtol measures the orthogonality
-c desired between the function vector and the columns
-c of the jacobian.
-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
-c diag is an array of length n. if mode = 1 (see
-c below), diag is internally set. if mode = 2, diag
-c must contain positive entries that serve as
-c multiplicative scale factors for the variables.
-c
-c mode is an integer input variable. if mode = 1, the
-c variables will be scaled internally. if mode = 2,
-c the scaling is specified by the input diag. other
-c values of mode are equivalent to mode = 1.
-c
-c factor is a positive input variable used in determining the
-c initial step bound. this bound is set to the product of
-c factor and the euclidean norm of diag*x if nonzero, or else
-c to factor itself. in most cases factor should lie in the
-c interval (.1,100.). 100. is a generally recommended value.
-c
-c nprint is an integer input variable that enables controlled
-c printing of iterates if it is positive. in this case,
-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. 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)
-c value of iflag. see description of fcn. otherwise,
-c info is set as follows.
-c
-c info = 0 improper input parameters.
-c
-c info = 1 both actual and predicted relative reductions
-c in the sum of squares are at most ftol.
-c
-c info = 2 relative error between two consecutive iterates
-c is at most xtol.
-c
-c info = 3 conditions for info = 1 and info = 2 both hold.
-c
-c info = 4 the cosine of the angle between fvec and any
-c column of the jacobian is at most gtol in
-c absolute value.
-c
-c info = 5 number of calls to fcn with iflag = 1 has
-c reached maxfev.
-c
-c info = 6 ftol is too small. no further reduction in
-c the sum of squares is possible.
-c
-c info = 7 xtol is too small. no further improvement in
-c the approximate solution x is possible.
-c
-c info = 8 gtol is too small. fvec is orthogonal to the
-c columns of the jacobian to machine precision.
-c
-c nfev is an integer output variable set to the number of
-c calls to fcn with iflag = 1.
-c
-c njev is an integer output variable set to the number of
-c calls to fcn with iflag = 2.
-c
-c ipvt is an integer output array of length n. ipvt
-c defines a permutation matrix p such that jac*p = q*r,
-c where jac is the final calculated jacobian, q is
-c orthogonal (not stored), and r is upper triangular.
-c column j of p is column ipvt(j) of the identity matrix.
-c
-c qtf is an output array of length n which contains
-c the first n elements of the vector (q transpose)*fvec.
-c
-c wa1, wa2, and wa3 are work arrays of length n.
-c
-c wa4 is a work array of length m.
-c
-c subprograms called
-c
-c user-supplied ...... fcn
-c
-c minpack-supplied ... dpmpar,enorm,lmpar,qrfac,rwupdt
-c
-c fortran-supplied ... dabs,dmax1,dmin1,dsqrt,mod
-c
-c argonne national laboratory. minpack project. march 1980.
-c burton s. garbow, dudley v. goetschel, kenneth e. hillstrom,
-c jorge j. more
-c
-c **********
- integer i,iflag,iter,j,l
- double precision actred,delta,dirder,epsmch,fnorm,fnorm1,gnorm,
- * one,par,pnorm,prered,p1,p5,p25,p75,p0001,ratio,
- * sum,temp,temp1,temp2,xnorm,zero
- double precision dpmpar,enorm
- data one,p1,p5,p25,p75,p0001,zero
- * /1.0d0,1.0d-1,5.0d-1,2.5d-1,7.5d-1,1.0d-4,0.0d0/
-c
-c epsmch is the machine precision.
-c
- epsmch = dpmpar(1)
-c
- info = 0
- iflag = 0
- nfev = 0
- njev = 0
-c
-c check the input parameters for errors.
-c
- if (n .le. 0 .or. m .lt. n .or. ldfjac .lt. n
- * .or. ftol .lt. zero .or. xtol .lt. zero .or. gtol .lt. zero
- * .or. maxfev .le. 0 .or. factor .le. zero) go to 340
- if (mode .ne. 2) go to 20
- do 10 j = 1, n
- if (diag(j) .le. zero) go to 340
- 10 continue
- 20 continue
-c
-c evaluate the function at the starting point
-c and calculate its norm.
-c
- iflag = 1
- call fcn(m,n,x,fvec,wa3,iflag)
- nfev = 1
- if (iflag .lt. 0) go to 340
- fnorm = enorm(m,fvec)
-c
-c initialize levenberg-marquardt parameter and iteration counter.
-c
- par = zero
- iter = 1
-c
-c beginning of the outer loop.
-c
- 30 continue
-c
-c if requested, call fcn to enable printing of iterates.
-c
- if (nprint .le. 0) go to 40
- iflag = 0
- if (mod(iter-1,nprint) .eq. 0) call fcn(m,n,x,fvec,wa3,iflag)
- if (iflag .lt. 0) go to 340
- 40 continue
-c
-c compute the qr factorization of the jacobian matrix
-c calculated one row at a time, while simultaneously
-c forming (q transpose)*fvec and storing the first
-c n components in qtf.
-c
- do 60 j = 1, n
- qtf(j) = zero
- do 50 i = 1, n
- fjac(i,j) = zero
- 50 continue
- 60 continue
- iflag = 2
- do 70 i = 1, m
- call fcn(m,n,x,fvec,wa3,iflag)
- if (iflag .lt. 0) go to 340
- temp = fvec(i)
- call rwupdt(n,fjac,ldfjac,wa3,qtf,temp,wa1,wa2)
- iflag = iflag + 1
- 70 continue
- njev = njev + 1
-c
-c if the jacobian is rank deficient, call qrfac to
-c reorder its columns and update the components of qtf.
-c
- sing = .false.
- do 80 j = 1, n
- if (fjac(j,j) .eq. zero) sing = .true.
- ipvt(j) = j
- wa2(j) = enorm(j,fjac(1,j))
- 80 continue
- if (.not.sing) go to 130
- call qrfac(n,n,fjac,ldfjac,.true.,ipvt,n,wa1,wa2,wa3)
- do 120 j = 1, n
- if (fjac(j,j) .eq. zero) go to 110
- sum = zero
- do 90 i = j, n
- sum = sum + fjac(i,j)*qtf(i)
- 90 continue
- temp = -sum/fjac(j,j)
- do 100 i = j, n
- qtf(i) = qtf(i) + fjac(i,j)*temp
- 100 continue
- 110 continue
- fjac(j,j) = wa1(j)
- 120 continue
- 130 continue
-c
-c on the first iteration and if mode is 1, scale according
-c to the norms of the columns of the initial jacobian.
-c
- if (iter .ne. 1) go to 170
- if (mode .eq. 2) go to 150
- do 140 j = 1, n
- diag(j) = wa2(j)
- if (wa2(j) .eq. zero) diag(j) = one
- 140 continue
- 150 continue
-c
-c on the first iteration, calculate the norm of the scaled x
-c and initialize the step bound delta.
-c
- do 160 j = 1, n
- wa3(j) = diag(j)*x(j)
- 160 continue
- xnorm = enorm(n,wa3)
- delta = factor*xnorm
- if (delta .eq. zero) delta = factor
- 170 continue
-c
-c compute the norm of the scaled gradient.
-c
- gnorm = zero
- if (fnorm .eq. zero) go to 210
- do 200 j = 1, n
- l = ipvt(j)
- if (wa2(l) .eq. zero) go to 190
- sum = zero
- do 180 i = 1, j
- sum = sum + fjac(i,j)*(qtf(i)/fnorm)
- 180 continue
- gnorm = dmax1(gnorm,dabs(sum/wa2(l)))
- 190 continue
- 200 continue
- 210 continue
-c
-c test for convergence of the gradient norm.
-c
- if (gnorm .le. gtol) info = 4
- if (info .ne. 0) go to 340
-c
-c rescale if necessary.
-c
- if (mode .eq. 2) go to 230
- do 220 j = 1, n
- diag(j) = dmax1(diag(j),wa2(j))
- 220 continue
- 230 continue
-c
-c beginning of the inner loop.
-c
- 240 continue
-c
-c determine the levenberg-marquardt parameter.
-c
- call lmpar(n,fjac,ldfjac,ipvt,diag,qtf,delta,par,wa1,wa2,
- * wa3,wa4)
-c
-c store the direction p and x + p. calculate the norm of p.
-c
- do 250 j = 1, n
- wa1(j) = -wa1(j)
- wa2(j) = x(j) + wa1(j)
- wa3(j) = diag(j)*wa1(j)
- 250 continue
- pnorm = enorm(n,wa3)
-c
-c on the first iteration, adjust the initial step bound.
-c
- if (iter .eq. 1) delta = dmin1(delta,pnorm)
-c
-c evaluate the function at x + p and calculate its norm.
-c
- iflag = 1
- call fcn(m,n,wa2,wa4,wa3,iflag)
- nfev = nfev + 1
- if (iflag .lt. 0) go to 340
- fnorm1 = enorm(m,wa4)
-c
-c compute the scaled actual reduction.
-c
- actred = -one
- if (p1*fnorm1 .lt. fnorm) actred = one - (fnorm1/fnorm)**2
-c
-c compute the scaled predicted reduction and
-c the scaled directional derivative.
-c
- do 270 j = 1, n
- wa3(j) = zero
- l = ipvt(j)
- temp = wa1(l)
- do 260 i = 1, j
- wa3(i) = wa3(i) + fjac(i,j)*temp
- 260 continue
- 270 continue
- temp1 = enorm(n,wa3)/fnorm
- temp2 = (dsqrt(par)*pnorm)/fnorm
- prered = temp1**2 + temp2**2/p5
- dirder = -(temp1**2 + temp2**2)
-c
-c compute the ratio of the actual to the predicted
-c reduction.
-c
- ratio = zero
- if (prered .ne. zero) ratio = actred/prered
-c
-c update the step bound.
-c
- if (ratio .gt. p25) go to 280
- if (actred .ge. zero) temp = p5
- if (actred .lt. zero)
- * temp = p5*dirder/(dirder + p5*actred)
- if (p1*fnorm1 .ge. fnorm .or. temp .lt. p1) temp = p1
- delta = temp*dmin1(delta,pnorm/p1)
- par = par/temp
- go to 300
- 280 continue
- if (par .ne. zero .and. ratio .lt. p75) go to 290
- delta = pnorm/p5
- par = p5*par
- 290 continue
- 300 continue
-c
-c test for successful iteration.
-c
- if (ratio .lt. p0001) go to 330
-c
-c successful iteration. update x, fvec, and their norms.
-c
- do 310 j = 1, n
- x(j) = wa2(j)
- wa2(j) = diag(j)*x(j)
- 310 continue
- do 320 i = 1, m
- fvec(i) = wa4(i)
- 320 continue
- xnorm = enorm(n,wa2)
- fnorm = fnorm1
- iter = iter + 1
- 330 continue
-c
-c tests for convergence.
-c
- if (dabs(actred) .le. ftol .and. prered .le. ftol
- * .and. p5*ratio .le. one) info = 1
- if (delta .le. xtol*xnorm) info = 2
- if (dabs(actred) .le. ftol .and. prered .le. ftol
- * .and. p5*ratio .le. one .and. info .eq. 2) info = 3
- if (info .ne. 0) go to 340
-c
-c tests for termination and stringent tolerances.
-c
- if (nfev .ge. maxfev) info = 5
- if (dabs(actred) .le. epsmch .and. prered .le. epsmch
- * .and. p5*ratio .le. one) info = 6
- if (delta .le. epsmch*xnorm) info = 7
- if (gnorm .le. epsmch) info = 8
- if (info .ne. 0) go to 340
-c
-c end of the inner loop. repeat if iteration unsuccessful.
-c
- if (ratio .lt. p0001) go to 240
-c
-c end of the outer loop.
-c
- go to 30
- 340 continue
-c
-c termination, either normal or user imposed.
-c
- if (iflag .lt. 0) info = iflag
- iflag = 0
- if (nprint .gt. 0) call fcn(m,n,x,fvec,wa3,iflag)
- return
-c
-c last card of subroutine lmstr.
-c
- end
diff --git a/CEP/PyBDSM/src/minpack/lmstr1.f b/CEP/PyBDSM/src/minpack/lmstr1.f
deleted file mode 100644
index 2fa8ee1c5013bbb17b0d3dc287d6f30aee2421b1..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/minpack/lmstr1.f
+++ /dev/null
@@ -1,156 +0,0 @@
- subroutine lmstr1(fcn,m,n,x,fvec,fjac,ldfjac,tol,info,ipvt,wa,
- * lwa)
- integer m,n,ldfjac,info,lwa
- integer ipvt(n)
- double precision tol
- double precision x(n),fvec(m),fjac(ldfjac,n),wa(lwa)
- external fcn
-c **********
-c
-c subroutine lmstr1
-c
-c the purpose of lmstr1 is to minimize the sum of the squares of
-c m nonlinear functions in n variables by a modification of
-c the levenberg-marquardt algorithm which uses minimal storage.
-c this is done by using the more general least-squares solver
-c lmstr. the user must provide a subroutine which calculates
-c the functions and the rows of the jacobian.
-c
-c the subroutine statement is
-c
-c subroutine lmstr1(fcn,m,n,x,fvec,fjac,ldfjac,tol,info,
-c ipvt,wa,lwa)
-c
-c where
-c
-c fcn is the name of the user-supplied subroutine which
-c calculates the functions and the rows of the jacobian.
-c fcn must be declared in an external statement in the
-c user calling program, and should be written as follows.
-c
-c subroutine fcn(m,n,x,fvec,fjrow,iflag)
-c integer m,n,iflag
-c double precision x(n),fvec(m),fjrow(n)
-c ----------
-c if iflag = 1 calculate the functions at x and
-c return this vector in fvec.
-c if iflag = i calculate the (i-1)-st row of the
-c jacobian at x and return this vector in fjrow.
-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 lmstr1.
-c in this case set iflag to a negative integer.
-c
-c m is a positive integer input variable set to the number
-c of functions.
-c
-c n is a positive integer input variable set to the number
-c of variables. n must not exceed m.
-c
-c x is an array of length n. on input x must contain
-c an initial estimate of the solution vector. on output x
-c contains the final estimate of the solution vector.
-c
-c fvec is an output array of length m which contains
-c the functions evaluated at the output x.
-c
-c fjac is an output n by n array. the upper triangle of fjac
-c contains an upper triangular matrix r such that
-c
-c t t t
-c p *(jac *jac)*p = r *r,
-c
-c where p is a permutation matrix and jac is the final
-c calculated jacobian. column j of p is column ipvt(j)
-c (see below) of the identity matrix. the lower triangular
-c part of fjac contains information generated during
-c the computation of r.
-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 tol is a nonnegative input variable. termination occurs
-c when the algorithm estimates either that the relative
-c error in the sum of squares is at most tol or that
-c the relative error between x and the solution is at
-c most tol.
-c
-c info is an integer output variable. if the user has
-c terminated execution, info is set to the (negative)
-c value of iflag. see description of fcn. otherwise,
-c info is set as follows.
-c
-c info = 0 improper input parameters.
-c
-c info = 1 algorithm estimates that the relative error
-c in the sum of squares is at most tol.
-c
-c info = 2 algorithm estimates that the relative error
-c between x and the solution is at most tol.
-c
-c info = 3 conditions for info = 1 and info = 2 both hold.
-c
-c info = 4 fvec is orthogonal to the columns of the
-c jacobian to machine precision.
-c
-c info = 5 number of calls to fcn with iflag = 1 has
-c reached 100*(n+1).
-c
-c info = 6 tol is too small. no further reduction in
-c the sum of squares is possible.
-c
-c info = 7 tol is too small. no further improvement in
-c the approximate solution x is possible.
-c
-c ipvt is an integer output array of length n. ipvt
-c defines a permutation matrix p such that jac*p = q*r,
-c where jac is the final calculated jacobian, q is
-c orthogonal (not stored), and r is upper triangular.
-c column j of p is column ipvt(j) of the identity matrix.
-c
-c wa is a work array of length lwa.
-c
-c lwa is a positive integer input variable not less than 5*n+m.
-c
-c subprograms called
-c
-c user-supplied ...... fcn
-c
-c minpack-supplied ... lmstr
-c
-c argonne national laboratory. minpack project. march 1980.
-c burton s. garbow, dudley v. goetschel, kenneth e. hillstrom,
-c jorge j. more
-c
-c **********
- integer maxfev,mode,nfev,njev,nprint
- double precision factor,ftol,gtol,xtol,zero
- data factor,zero /1.0d2,0.0d0/
- info = 0
-c
-c check the input parameters for errors.
-c
- if (n .le. 0 .or. m .lt. n .or. ldfjac .lt. n .or. tol .lt. zero
- * .or. lwa .lt. 5*n + m) go to 10
-c
-c call lmstr.
-c
- maxfev = 100*(n + 1)
- ftol = tol
- xtol = tol
- gtol = zero
- mode = 1
- nprint = 0
- call lmstr(fcn,m,n,x,fvec,fjac,ldfjac,ftol,xtol,gtol,maxfev,
- * wa(1),mode,factor,nprint,info,nfev,njev,ipvt,wa(n+1),
- * wa(2*n+1),wa(3*n+1),wa(4*n+1),wa(5*n+1))
- if (info .eq. 8) info = 4
- 10 continue
- return
-c
-c last card of subroutine lmstr1.
-c
- end
diff --git a/CEP/PyBDSM/src/minpack/qform.f b/CEP/PyBDSM/src/minpack/qform.f
deleted file mode 100644
index 087b2478b9c5c673a13e39eb0c3d366bfca426c9..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/minpack/qform.f
+++ /dev/null
@@ -1,95 +0,0 @@
- subroutine qform(m,n,q,ldq,wa)
- integer m,n,ldq
- double precision q(ldq,m),wa(m)
-c **********
-c
-c subroutine qform
-c
-c this subroutine proceeds from the computed qr factorization of
-c an m by n matrix a to accumulate the m by m orthogonal matrix
-c q from its factored form.
-c
-c the subroutine statement is
-c
-c subroutine qform(m,n,q,ldq,wa)
-c
-c where
-c
-c m is a positive integer input variable set to the number
-c of rows of a and the order of q.
-c
-c n is a positive integer input variable set to the number
-c of columns of a.
-c
-c q is an m by m array. on input the full lower trapezoid in
-c the first min(m,n) columns of q contains the factored form.
-c on output q has been accumulated into a square matrix.
-c
-c ldq is a positive integer input variable not less than m
-c which specifies the leading dimension of the array q.
-c
-c wa is a work array of length m.
-c
-c subprograms called
-c
-c fortran-supplied ... 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,jm1,k,l,minmn,np1
- double precision one,sum,temp,zero
- data one,zero /1.0d0,0.0d0/
-c
-c zero out upper triangle of q in the first min(m,n) columns.
-c
- minmn = min0(m,n)
- if (minmn .lt. 2) go to 30
- do 20 j = 2, minmn
- jm1 = j - 1
- do 10 i = 1, jm1
- q(i,j) = zero
- 10 continue
- 20 continue
- 30 continue
-c
-c initialize remaining columns to those of the identity matrix.
-c
- np1 = n + 1
- if (m .lt. np1) go to 60
- do 50 j = np1, m
- do 40 i = 1, m
- q(i,j) = zero
- 40 continue
- q(j,j) = one
- 50 continue
- 60 continue
-c
-c accumulate q from its factored form.
-c
- do 120 l = 1, minmn
- k = minmn - l + 1
- do 70 i = k, m
- wa(i) = q(i,k)
- q(i,k) = zero
- 70 continue
- q(k,k) = one
- if (wa(k) .eq. zero) go to 110
- do 100 j = k, m
- sum = zero
- do 80 i = k, m
- sum = sum + q(i,j)*wa(i)
- 80 continue
- temp = sum/wa(k)
- do 90 i = k, m
- q(i,j) = q(i,j) - temp*wa(i)
- 90 continue
- 100 continue
- 110 continue
- 120 continue
- return
-c
-c last card of subroutine qform.
-c
- end
diff --git a/CEP/PyBDSM/src/minpack/qrfac.f b/CEP/PyBDSM/src/minpack/qrfac.f
deleted file mode 100644
index cb686086c5145b0a7303814de832960f556eadb8..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/minpack/qrfac.f
+++ /dev/null
@@ -1,164 +0,0 @@
- 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
diff --git a/CEP/PyBDSM/src/minpack/qrsolv.f b/CEP/PyBDSM/src/minpack/qrsolv.f
deleted file mode 100644
index f48954b359bc59d16765fadfbbaf0e4b5533effe..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/minpack/qrsolv.f
+++ /dev/null
@@ -1,193 +0,0 @@
- subroutine qrsolv(n,r,ldr,ipvt,diag,qtb,x,sdiag,wa)
- integer n,ldr
- integer ipvt(n)
- double precision r(ldr,n),diag(n),qtb(n),x(n),sdiag(n),wa(n)
-c **********
-c
-c subroutine qrsolv
-c
-c given an m by n matrix a, an n by n diagonal matrix d,
-c and an m-vector b, the problem is to determine an x which
-c solves the system
-c
-c a*x = b , d*x = 0 ,
-c
-c in the least squares sense.
-c
-c this subroutine completes the solution of the problem
-c if it is provided with the necessary information from the
-c qr factorization, with column pivoting, of a. that is, if
-c a*p = q*r, where p is a permutation matrix, q has orthogonal
-c columns, and r is an upper triangular matrix with diagonal
-c elements of nonincreasing magnitude, then qrsolv expects
-c the full upper triangle of r, the permutation matrix p,
-c and the first n components of (q transpose)*b. the system
-c a*x = b, d*x = 0, is then equivalent to
-c
-c t t
-c r*z = q *b , p *d*p*z = 0 ,
-c
-c where x = p*z. if this system does not have full rank,
-c then a least squares solution is obtained. on output qrsolv
-c also provides an upper triangular matrix s such that
-c
-c t t t
-c p *(a *a + d*d)*p = s *s .
-c
-c s is computed within qrsolv and may be of separate interest.
-c
-c the subroutine statement is
-c
-c subroutine qrsolv(n,r,ldr,ipvt,diag,qtb,x,sdiag,wa)
-c
-c where
-c
-c n is a positive integer input variable set to the order of r.
-c
-c r is an n by n array. on input the full upper triangle
-c must contain the full upper triangle of the matrix r.
-c on output the full upper triangle is unaltered, and the
-c strict lower triangle contains the strict upper triangle
-c (transposed) of the upper triangular matrix s.
-c
-c ldr is a positive integer input variable not less than n
-c which specifies the leading dimension of the array r.
-c
-c ipvt is an integer input array of length n which defines the
-c permutation matrix p such that a*p = q*r. column j of p
-c is column ipvt(j) of the identity matrix.
-c
-c diag is an input array of length n which must contain the
-c diagonal elements of the matrix d.
-c
-c qtb is an input array of length n which must contain the first
-c n elements of the vector (q transpose)*b.
-c
-c x is an output array of length n which contains the least
-c squares solution of the system a*x = b, d*x = 0.
-c
-c sdiag is an output array of length n which contains the
-c diagonal elements of the upper triangular matrix s.
-c
-c wa is a work array of length n.
-c
-c subprograms called
-c
-c fortran-supplied ... dabs,dsqrt
-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,kp1,l,nsing
- double precision cos,cotan,p5,p25,qtbpj,sin,sum,tan,temp,zero
- data p5,p25,zero /5.0d-1,2.5d-1,0.0d0/
-c
-c copy r and (q transpose)*b to preserve input and initialize s.
-c in particular, save the diagonal elements of r in x.
-c
- do 20 j = 1, n
- do 10 i = j, n
- r(i,j) = r(j,i)
- 10 continue
- x(j) = r(j,j)
- wa(j) = qtb(j)
- 20 continue
-c
-c eliminate the diagonal matrix d using a givens rotation.
-c
- do 100 j = 1, n
-c
-c prepare the row of d to be eliminated, locating the
-c diagonal element using p from the qr factorization.
-c
- l = ipvt(j)
- if (diag(l) .eq. zero) go to 90
- do 30 k = j, n
- sdiag(k) = zero
- 30 continue
- sdiag(j) = diag(l)
-c
-c the transformations to eliminate the row of d
-c modify only a single element of (q transpose)*b
-c beyond the first n, which is initially zero.
-c
- qtbpj = zero
- do 80 k = j, n
-c
-c determine a givens rotation which eliminates the
-c appropriate element in the current row of d.
-c
- if (sdiag(k) .eq. zero) go to 70
- if (dabs(r(k,k)) .ge. dabs(sdiag(k))) go to 40
- cotan = r(k,k)/sdiag(k)
- sin = p5/dsqrt(p25+p25*cotan**2)
- cos = sin*cotan
- go to 50
- 40 continue
- tan = sdiag(k)/r(k,k)
- cos = p5/dsqrt(p25+p25*tan**2)
- sin = cos*tan
- 50 continue
-c
-c compute the modified diagonal element of r and
-c the modified element of ((q transpose)*b,0).
-c
- r(k,k) = cos*r(k,k) + sin*sdiag(k)
- temp = cos*wa(k) + sin*qtbpj
- qtbpj = -sin*wa(k) + cos*qtbpj
- wa(k) = temp
-c
-c accumulate the tranformation in the row of s.
-c
- kp1 = k + 1
- if (n .lt. kp1) go to 70
- do 60 i = kp1, n
- temp = cos*r(i,k) + sin*sdiag(i)
- sdiag(i) = -sin*r(i,k) + cos*sdiag(i)
- r(i,k) = temp
- 60 continue
- 70 continue
- 80 continue
- 90 continue
-c
-c store the diagonal element of s and restore
-c the corresponding diagonal element of r.
-c
- sdiag(j) = r(j,j)
- r(j,j) = x(j)
- 100 continue
-c
-c solve the triangular system for z. if the system is
-c singular, then obtain a least squares solution.
-c
- nsing = n
- do 110 j = 1, n
- if (sdiag(j) .eq. zero .and. nsing .eq. n) nsing = j - 1
- if (nsing .lt. n) wa(j) = zero
- 110 continue
- if (nsing .lt. 1) go to 150
- do 140 k = 1, nsing
- j = nsing - k + 1
- sum = zero
- jp1 = j + 1
- if (nsing .lt. jp1) go to 130
- do 120 i = jp1, nsing
- sum = sum + r(i,j)*wa(i)
- 120 continue
- 130 continue
- wa(j) = (wa(j) - sum)/sdiag(j)
- 140 continue
- 150 continue
-c
-c permute the components of z back to components of x.
-c
- do 160 j = 1, n
- l = ipvt(j)
- x(l) = wa(j)
- 160 continue
- return
-c
-c last card of subroutine qrsolv.
-c
- end
diff --git a/CEP/PyBDSM/src/minpack/r1mpyq.f b/CEP/PyBDSM/src/minpack/r1mpyq.f
deleted file mode 100644
index ec99b96ce96de220e89bfc70c6185d38b9cf4b70..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/minpack/r1mpyq.f
+++ /dev/null
@@ -1,92 +0,0 @@
- subroutine r1mpyq(m,n,a,lda,v,w)
- integer m,n,lda
- double precision a(lda,n),v(n),w(n)
-c **********
-c
-c subroutine r1mpyq
-c
-c given an m by n matrix a, this subroutine computes a*q where
-c q is the product of 2*(n - 1) transformations
-c
-c gv(n-1)*...*gv(1)*gw(1)*...*gw(n-1)
-c
-c and gv(i), gw(i) are givens rotations in the (i,n) plane which
-c eliminate elements in the i-th and n-th planes, respectively.
-c q itself is not given, rather the information to recover the
-c gv, gw rotations is supplied.
-c
-c the subroutine statement is
-c
-c subroutine r1mpyq(m,n,a,lda,v,w)
-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 must contain the matrix
-c to be postmultiplied by the orthogonal matrix q
-c described above. on output a*q has replaced a.
-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 v is an input array of length n. v(i) must contain the
-c information necessary to recover the givens rotation gv(i)
-c described above.
-c
-c w is an input array of length n. w(i) must contain the
-c information necessary to recover the givens rotation gw(i)
-c described above.
-c
-c subroutines called
-c
-c fortran-supplied ... dabs,dsqrt
-c
-c argonne national laboratory. minpack project. march 1980.
-c burton s. garbow, kenneth e. hillstrom, jorge j. more
-c
-c **********
- integer i,j,nmj,nm1
- double precision cos,one,sin,temp
- data one /1.0d0/
-c
-c apply the first set of givens rotations to a.
-c
- nm1 = n - 1
- if (nm1 .lt. 1) go to 50
- do 20 nmj = 1, nm1
- j = n - nmj
- if (dabs(v(j)) .gt. one) cos = one/v(j)
- if (dabs(v(j)) .gt. one) sin = dsqrt(one-cos**2)
- if (dabs(v(j)) .le. one) sin = v(j)
- if (dabs(v(j)) .le. one) cos = dsqrt(one-sin**2)
- do 10 i = 1, m
- temp = cos*a(i,j) - sin*a(i,n)
- a(i,n) = sin*a(i,j) + cos*a(i,n)
- a(i,j) = temp
- 10 continue
- 20 continue
-c
-c apply the second set of givens rotations to a.
-c
- do 40 j = 1, nm1
- if (dabs(w(j)) .gt. one) cos = one/w(j)
- if (dabs(w(j)) .gt. one) sin = dsqrt(one-cos**2)
- if (dabs(w(j)) .le. one) sin = w(j)
- if (dabs(w(j)) .le. one) cos = dsqrt(one-sin**2)
- do 30 i = 1, m
- temp = cos*a(i,j) + sin*a(i,n)
- a(i,n) = -sin*a(i,j) + cos*a(i,n)
- a(i,j) = temp
- 30 continue
- 40 continue
- 50 continue
- return
-c
-c last card of subroutine r1mpyq.
-c
- end
diff --git a/CEP/PyBDSM/src/minpack/r1updt.f b/CEP/PyBDSM/src/minpack/r1updt.f
deleted file mode 100644
index e034973d99042e3d6871db6df2284a96b9401fc1..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/minpack/r1updt.f
+++ /dev/null
@@ -1,207 +0,0 @@
- subroutine r1updt(m,n,s,ls,u,v,w,sing)
- integer m,n,ls
- logical sing
- double precision s(ls),u(m),v(n),w(m)
-c **********
-c
-c subroutine r1updt
-c
-c given an m by n lower trapezoidal matrix s, an m-vector u,
-c and an n-vector v, the problem is to determine an
-c orthogonal matrix q such that
-c
-c t
-c (s + u*v )*q
-c
-c is again lower trapezoidal.
-c
-c this subroutine determines q as the product of 2*(n - 1)
-c transformations
-c
-c gv(n-1)*...*gv(1)*gw(1)*...*gw(n-1)
-c
-c where gv(i), gw(i) are givens rotations in the (i,n) plane
-c which eliminate elements in the i-th and n-th planes,
-c respectively. q itself is not accumulated, rather the
-c information to recover the gv, gw rotations is returned.
-c
-c the subroutine statement is
-c
-c subroutine r1updt(m,n,s,ls,u,v,w,sing)
-c
-c where
-c
-c m is a positive integer input variable set to the number
-c of rows of s.
-c
-c n is a positive integer input variable set to the number
-c of columns of s. n must not exceed m.
-c
-c s is an array of length ls. on input s must contain the lower
-c trapezoidal matrix s stored by columns. on output s contains
-c the lower trapezoidal matrix produced as described above.
-c
-c ls is a positive integer input variable not less than
-c (n*(2*m-n+1))/2.
-c
-c u is an input array of length m which must contain the
-c vector u.
-c
-c v is an array of length n. on input v must contain the vector
-c v. on output v(i) contains the information necessary to
-c recover the givens rotation gv(i) described above.
-c
-c w is an output array of length m. w(i) contains information
-c necessary to recover the givens rotation gw(i) described
-c above.
-c
-c sing is a logical output variable. sing is set true if any
-c of the diagonal elements of the output s are zero. otherwise
-c sing is set false.
-c
-c subprograms called
-c
-c minpack-supplied ... dpmpar
-c
-c fortran-supplied ... dabs,dsqrt
-c
-c argonne national laboratory. minpack project. march 1980.
-c burton s. garbow, kenneth e. hillstrom, jorge j. more,
-c john l. nazareth
-c
-c **********
- integer i,j,jj,l,nmj,nm1
- double precision cos,cotan,giant,one,p5,p25,sin,tan,tau,temp,
- * zero
- double precision dpmpar
- data one,p5,p25,zero /1.0d0,5.0d-1,2.5d-1,0.0d0/
-c
-c giant is the largest magnitude.
-c
- giant = dpmpar(3)
-c
-c initialize the diagonal element pointer.
-c
- jj = (n*(2*m - n + 1))/2 - (m - n)
-c
-c move the nontrivial part of the last column of s into w.
-c
- l = jj
- do 10 i = n, m
- w(i) = s(l)
- l = l + 1
- 10 continue
-c
-c rotate the vector v into a multiple of the n-th unit vector
-c in such a way that a spike is introduced into w.
-c
- nm1 = n - 1
- if (nm1 .lt. 1) go to 70
- do 60 nmj = 1, nm1
- j = n - nmj
- jj = jj - (m - j + 1)
- w(j) = zero
- if (v(j) .eq. zero) go to 50
-c
-c determine a givens rotation which eliminates the
-c j-th element of v.
-c
- if (dabs(v(n)) .ge. dabs(v(j))) go to 20
- cotan = v(n)/v(j)
- sin = p5/dsqrt(p25+p25*cotan**2)
- cos = sin*cotan
- tau = one
- if (dabs(cos)*giant .gt. one) tau = one/cos
- go to 30
- 20 continue
- tan = v(j)/v(n)
- cos = p5/dsqrt(p25+p25*tan**2)
- sin = cos*tan
- tau = sin
- 30 continue
-c
-c apply the transformation to v and store the information
-c necessary to recover the givens rotation.
-c
- v(n) = sin*v(j) + cos*v(n)
- v(j) = tau
-c
-c apply the transformation to s and extend the spike in w.
-c
- l = jj
- do 40 i = j, m
- temp = cos*s(l) - sin*w(i)
- w(i) = sin*s(l) + cos*w(i)
- s(l) = temp
- l = l + 1
- 40 continue
- 50 continue
- 60 continue
- 70 continue
-c
-c add the spike from the rank 1 update to w.
-c
- do 80 i = 1, m
- w(i) = w(i) + v(n)*u(i)
- 80 continue
-c
-c eliminate the spike.
-c
- sing = .false.
- if (nm1 .lt. 1) go to 140
- do 130 j = 1, nm1
- if (w(j) .eq. zero) go to 120
-c
-c determine a givens rotation which eliminates the
-c j-th element of the spike.
-c
- if (dabs(s(jj)) .ge. dabs(w(j))) go to 90
- cotan = s(jj)/w(j)
- sin = p5/dsqrt(p25+p25*cotan**2)
- cos = sin*cotan
- tau = one
- if (dabs(cos)*giant .gt. one) tau = one/cos
- go to 100
- 90 continue
- tan = w(j)/s(jj)
- cos = p5/dsqrt(p25+p25*tan**2)
- sin = cos*tan
- tau = sin
- 100 continue
-c
-c apply the transformation to s and reduce the spike in w.
-c
- l = jj
- do 110 i = j, m
- temp = cos*s(l) + sin*w(i)
- w(i) = -sin*s(l) + cos*w(i)
- s(l) = temp
- l = l + 1
- 110 continue
-c
-c store the information necessary to recover the
-c givens rotation.
-c
- w(j) = tau
- 120 continue
-c
-c test for zero diagonal elements in the output s.
-c
- if (s(jj) .eq. zero) sing = .true.
- jj = jj + (m - j + 1)
- 130 continue
- 140 continue
-c
-c move w back into the last column of the output s.
-c
- l = jj
- do 150 i = n, m
- s(l) = w(i)
- l = l + 1
- 150 continue
- if (s(jj) .eq. zero) sing = .true.
- return
-c
-c last card of subroutine r1updt.
-c
- end
diff --git a/CEP/PyBDSM/src/minpack/rwupdt.f b/CEP/PyBDSM/src/minpack/rwupdt.f
deleted file mode 100644
index 05282b556942cd9659cfa8acc57486af9d0b65cf..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/minpack/rwupdt.f
+++ /dev/null
@@ -1,113 +0,0 @@
- subroutine rwupdt(n,r,ldr,w,b,alpha,cos,sin)
- integer n,ldr
- double precision alpha
- double precision r(ldr,n),w(n),b(n),cos(n),sin(n)
-c **********
-c
-c subroutine rwupdt
-c
-c given an n by n upper triangular matrix r, this subroutine
-c computes the qr decomposition of the matrix formed when a row
-c is added to r. if the row is specified by the vector w, then
-c rwupdt determines an orthogonal matrix q such that when the
-c n+1 by n matrix composed of r augmented by w is premultiplied
-c by (q transpose), the resulting matrix is upper trapezoidal.
-c the matrix (q transpose) is the product of n transformations
-c
-c g(n)*g(n-1)* ... *g(1)
-c
-c where g(i) is a givens rotation in the (i,n+1) plane which
-c eliminates elements in the (n+1)-st plane. rwupdt also
-c computes the product (q transpose)*c where c is the
-c (n+1)-vector (b,alpha). q itself is not accumulated, rather
-c the information to recover the g rotations is supplied.
-c
-c the subroutine statement is
-c
-c subroutine rwupdt(n,r,ldr,w,b,alpha,cos,sin)
-c
-c where
-c
-c n is a positive integer input variable set to the order of r.
-c
-c r is an n by n array. on input the upper triangular part of
-c r must contain the matrix to be updated. on output r
-c contains the updated triangular matrix.
-c
-c ldr is a positive integer input variable not less than n
-c which specifies the leading dimension of the array r.
-c
-c w is an input array of length n which must contain the row
-c vector to be added to r.
-c
-c b is an array of length n. on input b must contain the
-c first n elements of the vector c. on output b contains
-c the first n elements of the vector (q transpose)*c.
-c
-c alpha is a variable. on input alpha must contain the
-c (n+1)-st element of the vector c. on output alpha contains
-c the (n+1)-st element of the vector (q transpose)*c.
-c
-c cos is an output array of length n which contains the
-c cosines of the transforming givens rotations.
-c
-c sin is an output array of length n which contains the
-c sines of the transforming givens rotations.
-c
-c subprograms called
-c
-c fortran-supplied ... dabs,dsqrt
-c
-c argonne national laboratory. minpack project. march 1980.
-c burton s. garbow, dudley v. goetschel, kenneth e. hillstrom,
-c jorge j. more
-c
-c **********
- integer i,j,jm1
- double precision cotan,one,p5,p25,rowj,tan,temp,zero
- data one,p5,p25,zero /1.0d0,5.0d-1,2.5d-1,0.0d0/
-c
- do 60 j = 1, n
- rowj = w(j)
- jm1 = j - 1
-c
-c apply the previous transformations to
-c r(i,j), i=1,2,...,j-1, and to w(j).
-c
- if (jm1 .lt. 1) go to 20
- do 10 i = 1, jm1
- temp = cos(i)*r(i,j) + sin(i)*rowj
- rowj = -sin(i)*r(i,j) + cos(i)*rowj
- r(i,j) = temp
- 10 continue
- 20 continue
-c
-c determine a givens rotation which eliminates w(j).
-c
- cos(j) = one
- sin(j) = zero
- if (rowj .eq. zero) go to 50
- if (dabs(r(j,j)) .ge. dabs(rowj)) go to 30
- cotan = r(j,j)/rowj
- sin(j) = p5/dsqrt(p25+p25*cotan**2)
- cos(j) = sin(j)*cotan
- go to 40
- 30 continue
- tan = rowj/r(j,j)
- cos(j) = p5/dsqrt(p25+p25*tan**2)
- sin(j) = cos(j)*tan
- 40 continue
-c
-c apply the current transformation to r(j,j), b(j), and alpha.
-c
- r(j,j) = cos(j)*r(j,j) + sin(j)*rowj
- temp = cos(j)*b(j) + sin(j)*alpha
- alpha = -sin(j)*b(j) + cos(j)*alpha
- b(j) = temp
- 50 continue
- 60 continue
- return
-c
-c last card of subroutine rwupdt.
-c
- end
diff --git a/CEP/PyBDSM/src/natgrid/CMakeLists.txt b/CEP/PyBDSM/src/natgrid/CMakeLists.txt
deleted file mode 100644
index 401c3075a5089cccc014b626d9fed112b90a32fa..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/natgrid/CMakeLists.txt
+++ /dev/null
@@ -1,16 +0,0 @@
-# $Id$
-
-file(GLOB _natgrid_sources Src/*.c)
-
-include_directories(${CMAKE_CURRENT_SOURCE_DIR}/Include)
-
-add_library(natgridmodule MODULE ${_natgrid_sources})
-set_target_properties(natgridmodule PROPERTIES PREFIX "")
-
-if (APPLE)
- set_target_properties(natgridmodule PROPERTIES
- LINK_FLAGS "-undefined dynamic_lookup")
-endif (APPLE)
-
-install(TARGETS natgridmodule DESTINATION ${PYTHON_INSTALL_DIR}/lofar/bdsm)
-install(FILES Lib/nat.py DESTINATION ${PYTHON_INSTALL_DIR}/lofar/bdsm)
diff --git a/CEP/PyBDSM/src/natgrid/Include/nnchead.h b/CEP/PyBDSM/src/natgrid/Include/nnchead.h
deleted file mode 100644
index 83382115e92af55a0a891244193aee1aaaba5905..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/natgrid/Include/nnchead.h
+++ /dev/null
@@ -1,67 +0,0 @@
-#include <stdio.h>
-#include <stdlib.h>
-#include <math.h>
-#ifndef __APPLE__
-#include <malloc.h>
-#endif
-
-#define SQ(x) (x) * (x)
-#define BIGNUM 1E37
-#define EPSILON 0.00001
-#define RANGE 10
-#define EQ ==
-#define NE !=
-#define AND &&
-#define OR ||
-
-extern double **points, **joints, wbit,
- horilap, vertlap, bI, bJ, nuldat,
- xstart, ystart, xend, yend,
- maxhoriz, aaa, bbb, ccc, det,
- work3[3][3], xx, sumx, sumy, sumz,
- sumx2, sumy2, sumxy, sumxz, sumyz,
- asum, nn_pi, piby2, piby32, rad2deg,
- bigtri[3][3], horilap_save, vertlap_save;
-
-extern double magx, magy, magz, magx_orig, magy_orig, magz_orig,
- maxxy[2][3], magx_auto, magy_auto, magz_auto;
-
-extern int igrad, non_neg, densi, sdip, rads, southhemi,
- extrap, adf, nndup;
-
-extern int datcnt, datcnt3, numtri, imag, numnei, iscale,
- ext, *jndx, neicnt, optim, goodflag, updir,
- scor[3][2], auto_scale,
- single_point, first_single, asflag,
- error_status;
-
-extern char tri_file[256], error_file[256], emsg[256];
-
-extern FILE *fopen(), *filee;
-
-extern void Terminate();
-extern void ErrorHnd(int, char *, FILE *, char *);
-
-void FindNeigh();
-void TriNeigh();
-void Gradient();
-void FindProp();
-double Surface();
-double Meld();
-void TooSteep();
-void TooShallow();
-void TooNarrow();
-struct datum *IMakeDatum();
-struct simp *IMakeSimp();
-struct temp *IMakeTemp();
-struct neig *IMakeNeig();
-int *IntVect();
-void FreeVecti();
-double *DoubleVect();
-void FreeVectd();
-int **IntMatrix();
-void FreeMatrixi();
-float **FloatMatrix();
-void FreeMatrixf();
-double **DoubleMatrix();
-void FreeMatrixd();
diff --git a/CEP/PyBDSM/src/natgrid/Include/nncheadd.h b/CEP/PyBDSM/src/natgrid/Include/nncheadd.h
deleted file mode 100644
index 694e39d0e011a9c1bdf56eb5827619470dbab8f0..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/natgrid/Include/nncheadd.h
+++ /dev/null
@@ -1,22 +0,0 @@
-struct asinfod
-{ int crows;
- int ccols;
- double **aspect_outd;
- double **slope_outd;
-};
-struct asinfod curasd;
-
-extern double armind(int, double *);
-extern double armaxd(int, double *);
-
-extern void Initialized(int, double [], double [], int, int,
- double [], double []);
-
-int ReadDatad(int, double *, double *, double *);
-double **MakeGridd(int, int, double *, double *);
-
-void c_nngetsloped(int, int, double *, int *);
-void c_nngetaspectd(int, int, double *, int *);
-void c_nnpntinitd(int, double [], double [], double []);
-extern void c_nnpntd(double, double, double *);
-void c_nnpntendd();
diff --git a/CEP/PyBDSM/src/natgrid/Include/nncheads.h b/CEP/PyBDSM/src/natgrid/Include/nncheads.h
deleted file mode 100644
index f67bed94209d2e305e345167125daaabf2bc59a7..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/natgrid/Include/nncheads.h
+++ /dev/null
@@ -1,13 +0,0 @@
-extern double armin(int, float *);
-extern double armax(int, float *);
-
-extern void Initialize(int, float [], float [], int, int,
- float [], float []);
-int ReadData(int, float *, float *, float *);
-float **MakeGrid(int, int, float *, float *);
-
-void c_nngetslopes(int, int, float *, int *);
-void c_nngetaspects(int, int, float *, int *);
-void c_nnpntinits(int, float [], float [], float []);
-extern void c_nnpnts(float, float, float *);
-void c_nnpntend();
diff --git a/CEP/PyBDSM/src/natgrid/Include/nnexver.h b/CEP/PyBDSM/src/natgrid/Include/nnexver.h
deleted file mode 100644
index bf13dcb1cd309f9e245e94209b4abe4811b1c7ec..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/natgrid/Include/nnexver.h
+++ /dev/null
@@ -1,5 +0,0 @@
-extern struct datum *rootdat, *curdat, *holddat;
-extern struct simp *rootsimp, *cursimp, *holdsimp, *lastsimp, *prevsimp;
-extern struct temp *roottemp, *curtemp, *lasttemp, *prevtemp;
-extern struct neig *rootneig, *curneig, *lastneig;
-extern struct asinfo curas;
diff --git a/CEP/PyBDSM/src/natgrid/Include/nnghead.h b/CEP/PyBDSM/src/natgrid/Include/nnghead.h
deleted file mode 100644
index a522190474b7d4987573e4cff5ce7883030d8d33..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/natgrid/Include/nnghead.h
+++ /dev/null
@@ -1,49 +0,0 @@
-#include <stdio.h>
-#include <stdlib.h>
-#include <math.h>
-#ifndef __APPLE__
-#include <malloc.h>
-#endif
-#include <time.h>
-
-#define RANSEED 367367
-#define BIGNUM 1E37
-#define EPSILON 0.00001
-#define EQ ==
-#define NE !=
-#define AND &&
-#define OR ||
-
-extern double **points, **joints, wbit,
- horilap, vertlap, bI, bJ, nuldat,
- xstart, ystart, xend, yend,
- maxhoriz, aaa, bbb, ccc, det,
- work3[3][3], xx, sumx, sumy, sumz,
- sumx2, sumy2, sumxy, sumxz, sumyz,
- asum, nn_pi, piby2, piby32, rad2deg,
- bigtri[3][3], horilap_save, vertlap_save;
-
-extern double magx, magy, magz, magx_orig, magy_orig, magz_orig,
- maxxy[2][3], magx_auto, magy_auto, magz_auto;
-
-extern int igrad, non_neg, densi, sdip, rads, southhemi,
- extrap, adf, nndup;
-
-extern int datcnt, datcnt3, numtri, imag, numnei, iscale,
- ext, *jndx, neicnt, optim, goodflag, updir,
- scor[3][2], auto_scale,
- single_point, first_single, asflag,
- error_status;
-
-extern char tri_file[256], error_file[256], emsg[256];
-
-extern FILE *fopen(), *filee;
-
-extern void Gradient();
-extern void ErrorHnd(int, char *, FILE *, char *);
-extern void CircOut();
-
-extern void c_nnsetc(char *, char *);
-extern void c_nngetc(char *, char *);
-extern void c_nnseti(char *, int);
-extern void c_nngeti(char *, int *);
diff --git a/CEP/PyBDSM/src/natgrid/Include/nngheadd.h b/CEP/PyBDSM/src/natgrid/Include/nngheadd.h
deleted file mode 100644
index 59b189b39a88883cec79d95024d5e9ca55a69e55..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/natgrid/Include/nngheadd.h
+++ /dev/null
@@ -1,13 +0,0 @@
-void Initialized(int, double [], double [], int, int,
- double [], double []);
-
-double armind(int, double *);
-double armaxd(int, double *);
-
-extern int ReadDatad();
-extern double **MakeGridd(int, int, double *, double *);
-
-extern void c_nnsetrd(char *, double);
-extern void c_nngetrd(char *, double *);
-
-extern void Terminate();
diff --git a/CEP/PyBDSM/src/natgrid/Include/nngheads.h b/CEP/PyBDSM/src/natgrid/Include/nngheads.h
deleted file mode 100644
index 3549d954afef843478e684cc50e43307b207a94e..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/natgrid/Include/nngheads.h
+++ /dev/null
@@ -1,13 +0,0 @@
-void Initialize(int, float [], float [], int, int,
- float [], float []);
-
-double armin(int, float *);
-double armax(int, float *);
-
-extern int ReadData();
-extern float **MakeGrid(int, int, float *, float *);
-
-extern void c_nnsetr(char *, float);
-extern void c_nngetr(char *, float *);
-
-extern void Terminate();
diff --git a/CEP/PyBDSM/src/natgrid/Include/nnmhead.h b/CEP/PyBDSM/src/natgrid/Include/nnmhead.h
deleted file mode 100644
index 9c0a2ebb5f213c473dc039c2df683e50a1e43a73..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/natgrid/Include/nnmhead.h
+++ /dev/null
@@ -1,82 +0,0 @@
-#include <stdio.h>
-#include <stdlib.h>
-#include <math.h>
-#ifndef __APPLE__
-#include <malloc.h>
-#endif
-
-#define SQ(x) (x) * (x)
-#define RANSEED 367367
-#define BIGNUM 1E37
-#define EPSILON 0.00001
-#define EQ ==
-#define NE !=
-#define AND &&
-#define OR ||
-
-double **points, **joints, wbit,
- horilap = -1., vertlap = -1., bI = 1.5, bJ = 7.0, nuldat = 0.0,
- xstart, ystart, xend, yend,
- maxhoriz, aaa, bbb, ccc, det,
- work3[3][3], xx, sumx, sumy, sumz,
- sumx2, sumy2, sumxy, sumxz, sumyz,
- asum, nn_pi, piby2, piby32, rad2deg,
- bigtri[3][3], horilap_save, vertlap_save;
-
-double magx = 1, magy = 1, magz = 1, magx_orig, magy_orig, magz_orig,
- maxxy[2][3],
- magx_auto, magy_auto, magz_auto;
-
-int igrad = 0, non_neg = 0, densi, sdip = 0, rads = 0, southhemi = 0,
- extrap = 1, adf = 0, nndup = 1;
-
-int datcnt, datcnt3, numtri, imag, numnei, iscale,
- ext, *jndx, neicnt, optim = 1, goodflag, updir = 1,
- scor[3][2] = {{1,2}, {2,0}, {0,1}}, auto_scale = 1,
- single_point = 0, first_single = 1, asflag = 1,
- error_status = 0;
-
-char tri_file[256] = {"nnalg.dat"}, error_file[256] = {"stderr"},
- emsg[256];
-
-#ifdef __linux__
-FILE *fopen(), *filee = _IO_stderr;
-#else
-FILE *fopen(), *filee = NULL;
-#endif
-
-extern void Gradient();
-extern void ErrorHnd(int, char *, FILE *, char *);
-extern void CircOut();
-
-extern void c_nnsetc(char *, char *);
-extern void c_nngetc(char *, char *);
-extern void c_nnseti(char *, int);
-extern void c_nngeti(char *, int *);
-
-extern void Terminate();
-extern void ErrorHnd(int, char *, FILE *, char *);
-
-void FindNeigh();
-void TriNeigh();
-void Gradient();
-void FindProp();
-double Surface();
-double Meld();
-void TooSteep();
-void TooShallow();
-void TooNarrow();
-struct datum *IMakeDatum();
-struct simp *IMakeSimp();
-struct temp *IMakeTemp();
-struct neig *IMakeNeig();
-int *IntVect();
-void FreeVecti();
-double *DoubleVect();
-void FreeVectd();
-int **IntMatrix();
-void FreeMatrixi();
-float **FloatMatrix();
-void FreeMatrixf();
-double **DoubleMatrix();
-void FreeMatrixd();
diff --git a/CEP/PyBDSM/src/natgrid/Include/nntpvrs.h b/CEP/PyBDSM/src/natgrid/Include/nntpvrs.h
deleted file mode 100644
index 4cccdda5d7c80ffdafd5116d7db7376747c3e795..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/natgrid/Include/nntpvrs.h
+++ /dev/null
@@ -1,5 +0,0 @@
-struct datum *rootdat, *curdat, *holddat;
-struct simp *rootsimp, *cursimp, *holdsimp, *lastsimp, *prevsimp;
-struct temp *roottemp, *curtemp, *lasttemp, *prevtemp;
-struct neig *rootneig, *curneig, *lastneig;
-struct asinfo curas;
diff --git a/CEP/PyBDSM/src/natgrid/Include/nntypes.h b/CEP/PyBDSM/src/natgrid/Include/nntypes.h
deleted file mode 100644
index e29c121165f1b6b6182c167751d42730fa9c4429..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/natgrid/Include/nntypes.h
+++ /dev/null
@@ -1,29 +0,0 @@
-struct datum
-{ double values[3];
- struct datum *nextdat;
-};
-
-struct simp
-{ int vert[3];
- double cent[3];
- struct simp *nextsimp;
-};
-
-struct temp
-{ int end[2];
- struct temp *nexttemp;
-};
-
-struct neig
-{ int neinum;
- double narea;
- double coord;
- struct neig *nextneig;
-};
-
-struct asinfo
-{ int crows;
- int ccols;
- float **aspect_out;
- float **slope_out;
-};
diff --git a/CEP/PyBDSM/src/natgrid/Include/nnuhead.h b/CEP/PyBDSM/src/natgrid/Include/nnuhead.h
deleted file mode 100644
index c23665730355bd7b7a8b80c6a66729759246c5d8..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/natgrid/Include/nnuhead.h
+++ /dev/null
@@ -1,51 +0,0 @@
-#include <stdio.h>
-#include <string.h>
-
-#define EQ ==
-#define NE !=
-#define AND &&
-#define OR ||
-
-extern int igrad, densi, non_neg, sdip, rads,
- optim, extrap, southhemi, updir, auto_scale,
- adf, nndup;
-
-extern double bI, bJ, magx, magy,
- magz, horilap, vertlap, nuldat,
- magx_auto, magy_auto, magz_auto, horilap_save,
- vertlap_save;
-
-extern char tri_file[], error_file[], emsg[];
-extern FILE *filee;
-
-/*
- * Fortran function macro. This macro is used to provide the appropriate
- * system-specific C function name for it to be Fortran callable.
- */
-#ifndef NGCALLF
-
-#ifdef UNICOS
-#define NGCALLF(reg,caps) caps
-
-#elif defined(RS6000) || defined(__hpux)
-#define NGCALLF(reg,caps) reg
-
-#else
-#ifdef __STDC__
-#define NGCALLF(reg,caps) reg##_
-#else
-#define NGCALLF(reg,caps) reg/**/_
-
-#endif /* __STDC__ */
-#endif /* UNICOS else ... */
-#endif /* NGCALLF */
-
-void c_nnsetc(char *, char *);
-void c_nngetc(char *, char *);
-void c_nnseti(char *, int);
-void c_nngeti(char *, int *);
-
-extern void ErrorHnd(int, char *, FILE *, char *);
-
-void NGCALLF(nnseti,NNSETI) (char *, int *);
-void NGCALLF(nngeti,NNGETI) (char *, int *);
diff --git a/CEP/PyBDSM/src/natgrid/Include/nnuheadd.h b/CEP/PyBDSM/src/natgrid/Include/nnuheadd.h
deleted file mode 100644
index bf75622046952e3a7a1bd56483008eb5df90ccc8..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/natgrid/Include/nnuheadd.h
+++ /dev/null
@@ -1,46 +0,0 @@
-void c_nnsetrd(char *, double);
-void c_nngetrd(char *, double *);
-
-extern void c_nngetsloped(int, int, double *, int *);
-extern void c_nngetaspectd(int, int, double *, int *);
-extern void c_nnpntinitd(int, double *, double *, double *);
-extern void c_nnpntd(double, double, double *);
-extern void c_nnpntendd();
-
-/*
- * Fortran function macro. This macro is used to provide the appropriate
- * system-specific C function name for it to be Fortran callable.
- */
-#ifndef NGCALLF
-
-#ifdef UNICOS
-#define NGCALLF(reg,caps) caps
-
-#elif defined(RS6000) || defined(__hpux)
-#define NGCALLF(reg,caps) reg
-
-#else
-#ifdef __STDC__
-#define NGCALLF(reg,caps) reg##_
-#else
-#define NGCALLF(reg,caps) reg/**/_
-
-#endif /* __STDC__ */
-#endif /* UNICOS else ... */
-#endif /* NGCALLF */
-
-/*
- * Fortran entry points.
- */
-void NGCALLF(natgridd,NATGRIDD) (int *, double *, double *, double *,
- int *, int *, double *, double *, double *, int *);
-void NGCALLF(nnsetrd,NNSETRD) (char *, double *);
-void NGCALLF(nngetrd,NNGETRD) (char *, double *);
-void NGCALLF(nngetsloped,NNGETSLOPED) (int *, int *, double *, int *);
-void NGCALLF(nngetaspectd,NNGETASPECTD) (int *, int *, double *, int *);
-void NGCALLF(nnpntinitd,NNPNTINITD) (int *, double *, double *, double *);
-void NGCALLF(nnpntd,NNPNTD) (double *, double *, double *);
-void NGCALLF(nnpntend,NNPNTEND) ();
-
-double *c_natgridd(int, double [], double [], double [],
- int, int, double [], double [], int *);
diff --git a/CEP/PyBDSM/src/natgrid/Include/nnuheads.h b/CEP/PyBDSM/src/natgrid/Include/nnuheads.h
deleted file mode 100644
index bb56e2f83729dfd2811907d7ebd3d09e388b6888..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/natgrid/Include/nnuheads.h
+++ /dev/null
@@ -1,46 +0,0 @@
-void c_nnsetr(char *, float);
-void c_nngetr(char *, float *);
-
-extern void c_nngetslopes(int, int, float *, int *);
-extern void c_nngetaspects(int, int, float *, int *);
-extern void c_nnpntinits(int, float *, float *, float *);
-extern void c_nnpnts(float, float, float *);
-extern void c_nnpntend();
-
-/*
- * Fortran function macro. This macro is used to provide the appropriate
- * system-specific C function name for it to be Fortran callable.
- */
-#ifndef NGCALLF
-
-#ifdef UNICOS
-#define NGCALLF(reg,caps) caps
-
-#elif defined(RS6000) || defined(__hpux)
-#define NGCALLF(reg,caps) reg
-
-#else
-#ifdef __STDC__
-#define NGCALLF(reg,caps) reg##_
-#else
-#define NGCALLF(reg,caps) reg/**/_
-
-#endif /* __STDC__ */
-#endif /* UNICOS else ... */
-#endif /* NGCALLF */
-
-/*
- * Fortran entry points.
- */
-void NGCALLF(natgrids,NATGRIDS) (int *, float *, float *, float *,
- int *, int *, float *, float *, float *, int *);
-void NGCALLF(nnsetr,NNSETR) (char *, float *);
-void NGCALLF(nngetr,NNGETR) (char *, float *);
-void NGCALLF(nngetslopes,NNGETSLOPES) (int *, int *, float *, int *);
-void NGCALLF(nngetaspects,NNGETASPECTS) (int *, int *, float *, int *);
-void NGCALLF(nnpntinits,NNPNTINITS) (int *, float *, float *, float *);
-void NGCALLF(nnpnts,NNPNTS) (float *, float *, float *);
-void NGCALLF(nnpntend,NNPNTEND) ();
-
-float *c_natgrids(int, float [], float [], float [],
- int, int, float [], float [], int *);
diff --git a/CEP/PyBDSM/src/natgrid/Lib/nat.py b/CEP/PyBDSM/src/natgrid/Lib/nat.py
deleted file mode 100644
index 5b8a896f1280db928580e7c63b4ebc606792ec61..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/natgrid/Lib/nat.py
+++ /dev/null
@@ -1,1839 +0,0 @@
-# Adapted for numpy/ma/cdms2 by convertcdms.py
-
-"""---------------------------------------------------------------------------------------------
-
- INTRODUCTION TO NGMATH
-
- The ngmath library is a collection of interpolators and approximators for one-dimensional, two-dimensional
- and three-dimensional data. The packages, which were obtained from NCAR, are:
-
- natgrid -- a two-dimensional random data interpolation package based on Dave Watson's nngridr.
-
- dsgrid -- a three-dimensional random data interpolator based on a simple inverse distance weighting
- algorithm.
-
- fitgrid -- an interpolation package for one-dimensional and two-dimensional gridded data based on
- Alan Cline's Fitpack. Fitpack uses splines under tension to interpolate in one and two
- dimensions.
-
- csagrid -- an approximation package for one-dimensional, two-dimensional and three-dimensional random
- data based on David Fulker's Splpack. csagrid uses cubic splines to calculate its
- approximation function.
-
- cssgrid -- an interpolation package for random data on the surface of a sphere based on the work of
- Robert Renka. cssgrid uses cubic splines to calculate its interpolation function.
-
- shgrid -- an interpolation package for random data in 3-space based on the work of Robert Renka.
- shgrid uses a modified Shepard's algorithm to calculate its interpolation function.
-
- COMPARISION OF NGMATH PACKAGES
-
- Three-dimensional packages -- shgrid, csagrid and dsgrid.
-
- shgrid is probably the package of choice for interpolation. It uses a least squares fit of biquadratics
- to construct its interpolation function. The interpolation function will pass through the original data
- points.
-
- csagrid uses a least squares fit of cubic splines to calculate its approximation function: the calculated
- surface will not necesarily pass through the original data points. The algorithm can become unstable in data
- sparse regions.
-
- dsgrid uses a weighted average algorithm and is stable in all cases, but the resultant interpolation is
- not usually smooth and execution time is very slow. dsgrid is probably best used when csagrid and shgrid
- fail or for comparative purposes.
-
- Two-dimensional packages -- natgrid, fitgrid, csagrid and dsgrid.
-
- natgrid is the package of choice in most cases. It implements a very stable algorithm and has parameters
- for adjusting the smoothness of the output surface.
-
- fitgrid offers user-settable parameters for specifiying derivatives along the boundary of the output grid
- which are not available in natgrid.
-
- csagrid produces an approximate two-dimensional surface which may be smoother than that produced by fitgrid
- and natgrid.
-
- dsgrid is not recommended for two-dimensional surfaces. natgrid is superior in all respects.
-
- One-dimensional packages -- fitgrid and csagrid.
-
- fitgrid is definitely the package of choice. It has many features not available in csagrid, such as
- interpolating parametric curves, finding integrals, handling periodic functions, allowing smoothing that
- varies from linear to a full cubic spline interpolation and specifying slopes at the end points.
-
- Interpolation on a sphere -- cssgrid.
-
- cssgrid is designed specifically for interpolating on a sphere. It uses cubic splines to calculate an
- interpolation function.
-
- NATGRID PACKAGE
-
- natgrid implements a natural neighbor interpolation method. The input for the interpolation is a set
- of randomly spaced two-dimensional coordinates with functional values at those coordinates; the output is a
- set of interpolated values at coordinates in a user specified rectangular grid. The coordinates in the output
- grid must be monotonic in each coordinate direction, but need not be evenly spaced. It is also possible to
- interpolate at a single point.
-
- natgrid uses a weighted average method that is much more sophisticated than the inverse distance weighted
- average used by dsgrid. One distinguishing quality of natural neighbor interpolation is the way in which
- a set of neighboring points (the natural neighbor) is selected to use for interpolating at a point. The
- natural neighbor selection process avoids the problems common to methods based on choosing a fixed number
- of neighboring points, or all points within a fixed distance. Another distinguishing quality of natural
- neighbor interpolation is the way that the weights are calculated for the functional values at the natural
- neighbor coordinates. These weights are based on proportionate area, rather than distances.
-
- The method of finding the natural neighbors and calculating area-based weights to produce interpolated
- values is called natural neighbor linear interpolation. This produces an interpolation surface that has a
- continous slope at all points, except at the original input points. The result of natural neighbor linear
- interpolation can be visualized as producing a snugly fit sheet stretched over all of the input points.
-
- The interpolation method in natgrid also allows for natural neighbor linear interpolation augmented by
- blending in gradient estimates. This is called natural neighbor nonlinear interpolation. It produces an
- interpolation surface that has a continuous slope at all locations; two tautness parameters can be set by
- the user to control the apparent smoothness of the output surface.
-
- NATGRID CONTENTS
-
- Access through Python to the natgrid package from NCAR's ngmath distribution is provided directly through the module
- natgridmodule.so which was generated as a Python C language extension in order to export the natgrid functions
- from the original C language library to Python.
-
- REQUIRED FILE
-
- natgridmodule.so -- the Python interface to the ngmath natgrid package.
-
- USEFUL FILES
-
- nat.py -- the object oriented interface including a general help package.
- natgridtest.py -- the code to test nat.py and to write documentation.
-
- USAGE
-
- This module is designed to use in two ways. One is through the use of the object oriented interface to the underlying
- functions. This approach is recommended for users not already familiar with the original natgrid distribtution because
- it simplifies the calls to the routines. The other method uses the original functions calling them directly from Python.
-
- ------------------- OBJECT ORIENTED APPROACH ----------------
-
- The nat module contains the Natgrid class and its single method, rgrd, which provides access to all the natgrid
- functions. The object oriented approach has been organized as a two step process.
-
- STEP 1.
-
- To make an instance, r, type:
-
- import nat
-
- r = nat.Natgrid(xi, yi, xo, yo)
- or
- r = nat.Natgrid(xi, yi, xo, yo, listOutput = 'yes')
-
- where xi, yi and xo, yo are the input and output grid coordinate arrays. The optional listOutput must
- set to anything except 'no' if xo, yo are in list format as explained below. It is the responsibility
- of the user to set listOutput if the output is in the list form.
-
- The input grid must be organized in a list format always. The size of the xi array and the yi array are
- necessarily equal. For example, if there are n randomly spaced input data points, there
- are n values in xi and n values in yi.
-
- There are two possible formats for the output grid. The output grid coordinate arrays may be a list like
- the input array or it may be a rectangular grid. The choice between the two posibilities is made according
- to requirements in subseqent calls to the method function. The first choice is required if the subsequent
- call is to the single point mode interpolation. The list can have one or more points. Of course, the list
- could describe a rectangular grid. For example, a rectangular grid with 10 x values and 20 y values can be
- rewrtten in list form with 200 x value and 200 y values. However, this form requires calling the slower
- single point interpolator. The second choice is most efficient for the basic interpolation to a rectangular
- output grid. The output grid must be monotonic but need not be equally spced.
-
- The grid coordinate arrays can be single precision (numpy.float32) or double precision (numpy.float64). The
- decision on whether to call for a single or a double precision computation subsequently is made by looking at
- the type of these arrays.
-
- To look at the default settings for the control parameters and a brief description of thier properties, type
-
- r.printDefaultParameterTable()
-
- To change a setting type the new value. For example, to set igr to 1, type
-
- r.igr = 1
-
- To find a value without printing the table, type the name. For example, to exam the value of hor, type
-
- r.hor
-
- To check the settings type
-
- r.printInstanceParameterTable() -- prints in tabular form the parameters used in subsequent calls to the method
- function rgrd.
- or
-
- printStoredParameters() -- prints the parameters in memory which may differ from the above if the user
- has made more than one instance of the Natgrid class.
-
- STEP 2.
-
- natgrid is restricted to two dimensions . Consequently, it is the user's responsibility to reduce the processing of
- higher dimensional data to a sequence of calls using only two dimensional data.
-
- The computations are divided into two groups depending on whether the output arrays are in list form or in rectilinear
- grid form. If they are in list format the single point mode is called to interpolate to those individual points. This is
- the only process possible. On the other hand, if the output goes to a rectangular grid there are more choices. In
- addition to carrying out linear and nonlinear interpolations, it is possible to request aspects and slopes. The aspect
- at a point on the interpolated surface is the direction of steepest descend. The slope is the value of the partial
- derivative taken in the direction of the aspect. The slope is measured as an angle that is zero in a horizonal surface
- and positive below the horizontal.
-
- The following examples cover the basic computations. They start with a indication of the appropriate STEP 1.
-
- Example 1: the basic natural neighbor linear interpolation
-
- As STEP 1 make an instance, r, with:
-
- import nat
-
- r = nat.Natgrid(xi, yi, xo, yo)
-
- where the xo, yo grid is rectilinear as explained above in STEP 1.
-
- Then call the primary interpolation computation to regrid the input data, dataIn, on the grid (xi, yi) to
- the output data, dataOut, on the grid (xo, yo), with
-
- dataOut = r.rgrd( dataIn )
-
- The computation is either single or double precision as determined by the precision submitted in the grid
- description in STEP 1.
-
- It is also possible to request a wrap in the input grid and the input data in the longitude direction, assumed
- to be the yi grid coordinate, by adding a keyword as
-
- dataOut = r.rgrd( dataIn, wrap = 'yes' )
-
-
- Example 2: natural neighbor linear interpolation returning the aspect and the slope.
-
- As STEP 1 make an instance, r, with:
-
- import nat
-
- r = nat.Natgrid(xi, yi, xo, yo)
-
- where the xo, yo grid is rectilinear as explained above in STEP 1.
-
- Then call the primary interpolation computation to regrid the input data, dataIn, on the grid (xi, yi) to
- the output data, dataOut, on the grid (xo, yo), while asking for the aspect and the slope on this output grid, with
-
- dataOut, a, s = r.rgrd( dataIn, aspectSlope = 'yes' )
-
- where a is the aspect, the direction of the steepest descent in degrees measured from 'north' and s is the
- slope in degrees measured from the horizontal. Necessarily, these are arrays aligned with the rectilinear
- output grid, xo, yo.
-
- The computation is either single or double precision as determined by the precision submitted in the grid
- description in STEP 1.
-
- It is also possible to request a wrap in the input grid and the input data in the longitude direction, assumed
- to be the yi grid coordinate, by adding a keyword as
-
- dataOut, a, s = r.rgrd( dataIn, aspectSlope = 'yes', wrap = 'yes' )
-
-
- Example 3: the basic natural neighbor nonlinear interpolation
-
- The procedure for the nonlinear interpolation differs from the linear case in the need to set the control
- parameter igr. Follow Example 1 and insert the following statament after making the instance, r.
-
- r.igr = 1
-
- Example 4: natural neighbor nonlinear interpolation returning the aspect and the slope.
-
- The procedure for the nonlinear interpolation differs from the linear case in the need to set the control
- parameter igr. Follow Example 2 and insert the following statament after making the instance, r.
-
- r.igr = 1
-
- Example 5: single point mode natural neighbor linear interpolation
-
- As STEP 1 make an instance, r, with:
-
- import nat
-
- r = nat.Natgrid(xi, yi, xo, yo, listOutput = 'yes')
-
- where the xo, yo output grid is in the list form (not a rectangular output grid) as explained above in
- STEP 1.
-
- To call the single point mode interpolation computation to regrid the input data, dataIn, on the grid (xi, yi)
- to the output data, dataOut, on the grid (xo, yo), type
-
- dataOut = r.rgrd( dataIn )
-
- The computation is either single or double precision as determined by the precision submitted in the grid
- description in STEP 1. In the single point mode it is not possible to request the aspect and the slope.
-
-
- Example 6: single point mode natural neighbor nonlinear interpolation
-
- The procedure for the nonlinear interpolation differs from the linear case in the need to set the control
- parameter igr. Follow Example 5 and insert the following statament after making the instance, r.
-
- r.igr = 1
-
- ------------------- ORIGINAL FUNCTION APPROACH -----------------
-
- The module natgridmodule.so exports the following functions to Python from the original ngmath C library:
-
- Single precision procedures:
-
- natgrids - primary function for gridding.
- seti - set int parameter values.
- geti - retrieve values for int parameters.
- setr - set float parameter values.
- getr - retrieve values for float parameters
- setc - set char parameter values.
- getc - retrieve values for char parameters.
- getaspects - get aspect values, if calculated by setting sdi = 1.
- getslopes - get slope values, if calculated by setting sdi = 1.
- pntinits - initiate single point mode.
- pnts - interpolate at a single point.
- pntend - terminate single point mode.
-
-
- Double precision procedures:
-
- natgridd - primary function for gridding.
- setrd - set float parameter values.
- getrd - retrieve values for float parameters
- getaspectd - get aspect values, if calculated by setting sdi = 1.
- getsloped - get slope values, if calculated by setting sdi = 1.
- pntinitd - initiate single point mode.
- pntd - interpolate at a single point.
- pntendd - terminate single point mode.
-
-
-
-
- Information on the use of the routines is available by importing natgridmodule and printing the docstring
- of interest. For example, documentation for the routine natgrids is obtained by typing
-
- import natgridmodule
- print natgridmodule.natgrids.__doc__
-
- This same information is available in the help package.
-
- A description of the control parameters is not in the natgridmodule documentation. It can be found by typing
-
- import nat
- nat.printParameterTable()
-
-
- The documentation associated with the natgridmodule.so, such as the doctrings, describe the C code.
-
- DOCUMENTATION
-
- Documentation is provided through Python's docstrings, essentially Python style program
- comments. A help package provides instructions on the use of the natgrid module. A table of contents
- is printed to the screen by typing
-
- nat.help()
-
- after importing nat.
-
- A hard copy of all the pertinent 'docstring' documentation written to the file natgridmodule.doc can
- be produced by typing
-
- nat.document()
-
-
- As an alternate to using the help package, online documentation for the natgrids function, for example,
- is available directly from the natgrids doctring by typing
-
- import natgridmodule
-
- print natgridmodule.natgrids.__doc__
-
-
- TESTING
-
- To run a test of the natgrid computations and to get a copy of this documentation, type
-
- cdat natgridtest.py
-
---------------------------------------------------------------------------------------------------------------"""
-
-# import string, math, sys, numpy, cdms2, natgridmodule
-import string, math, sys, numpy, natgridmodule
-
-# writeTestcase = 'yes'
-# try:
-# import cdms2
-# except ImportError:
-# print 'Can not write test case results to netCDF files without module cdms'
-# writeTestcase = 'no'
-writeTestcase = 'no'
-usefilled = 'yes'
-try:
- import numpy.ma
-except ImportError:
- print 'Can not convert from numpy.ma array to numpy array without module numpy.ma'
- usefilled = 'no'
-
-debug = 0
-
-class Natgrid:
-
- #-------------------------------------------------------------------------------------------------------------
- #
- # Contents of Natgrid class
- #
- #
- # Natgrid class
- # __init__ -- initialization
- # rgrd -- the regridder called from Python
- #
- # rgrdPrimary -- called by rgrd if the output grid is montonically increasing
- # rgrdSinglePoint -- called by rgrd if the output grid is random or single point mode is selected
- # setInstanceParameters -- sets the C values to the instance values
- #
- #---------------------------------------------------------------------------------------------------------------
-
- def __init__(self, xi, yi, xo, yo, listOutput = 'no'):
- """ --------------------------------------------------------------------------------------------------------
-
- routine: __init__ for class Natgrid
-
- purpose: init makes an instance of the Natgrid class while performing the following:
-
- 1. checks the argument list for the correct types.
- 2. selects single or double precision computation.
- 3. assigns the coordinate grid arrays to self data.
- 4. assigns default control parameter values from the parameter dictionary.
-
- usage: r = nat.Natgrid(xi, yi, xo, yo)
- or
- r = nat.Natgrid(xi, yi, xo, yo, listOutput = 'yes')
-
- where xi, yi and xo, yo are the input and output grid coordinate arrays. The optional listOutput is
- set to anything except 'no' if xo, yo are in list format as explained below.
-
- The input grid must be organized in a list format always. The size of the xi array and the yi array are
- necessarily equal. For example, if there are n randomly spaced input data points, there
- are n values in xi and n values in yi.
-
- There are two possible formats for the output grid. The output grid coordinate arrays may be a list like
- the input array or it may be a rectangular grid. The choice between the two posibilities is made according
- to requirements in subseqent calls to the method function. The first choice is required if the subsequent
- call is to the single point mode interpolation. The list can have one or more points. Of course, the list
- could describe a rectangular grid. For example, a rectangular grid with 10 x values and 20 y values can be
- rewrtten in list form with 200 x value and 200 y values. However, this form requires calling the slower
- single point interpolator. The second choice is most efficient for the basic interpolation to a rectangular
- output grid. The output grid must be monotonic but need not be equally spced.
-
- Note: the index in the data associated with y varies the fastest.
-
- definition: __init__(self, xi, yi, xo, yo, listOutput = 'no'):
- --------------------------------------------------------------------------------------------------------"""
-
- # ---- check the input grid argument list
-
- try:
- size = len(xi)
- except:
- msg = 'CANNOT CREATE INSTANCE - The first argument must be an array'
- raise TypeError, msg
- if size < 4:
- msg = 'CANNOT CREATE INSTANCE - The length of the input x coordindate grid must be greater than 3'
- raise ValueError, msg
-
- try:
- size = len(yi)
- except:
- msg = 'CANNOT CREATE INSTANCE - The third argument must be an array'
- raise TypeError, msg
- if size < 4:
- msg = 'CANNOT CREATE INSTANCE - The length of the input y coordindate grid must be greater than 3'
- raise ValueError, msg
-
- # set the self data for the input grid
-
- self.nxi = len(xi)
- self.nyi = len(yi)
- if self.nxi != self.nyi:
- msg = 'CANNOT CREATE INSTANCE - The length of the input x and y coordindate grids must be equal'
- raise ValueError, msg
-
- self.xi = xi
- self.yi = yi
-
-
- # ---- check the output grid argument list
-
- try:
- size = len(xo)
- except:
- msg = 'CANNOT CREATE INSTANCE - The second argument must be an array'
- raise TypeError, msg
- try:
- size = len(yo)
- except:
- msg = 'CANNOT CREATE INSTANCE - The fourth argument must be an array'
- raise TypeError, msg
-
- # set the self data for the output grid
-
- self.nxo = len(xo)
- self.nyo = len(yo)
-
- if listOutput == 'no':
- self.xo, self.yo, monotonic, self.xreverse, self.yreverse = checkdim(xo, yo) # monotonicity check
-
- if monotonic == 'no':
- msg = 'CANNOT CREATE INSTANCE - Rectangular output grid must be monotonic'
- raise ValueError, msg
- self.listOutput = 'no'
- else:
- if self.nxo != self.nyo:
- msg = 'CANNOT CREATE INSTANCE - The list type output arrays must have the same length'
- raise ValueError, msg
- else:
- self.xo = xo
- self.yo = yo
- self.xreverse = 'no'
- self.yreverse = 'no'
- self.listOutput = 'yes'
-
- # select the interpolation routines from the single or the double precision group - majority rules here
-
- numberSingles = 0
- numberDoubles = 0
-
- if xi.dtype.char == 'f':
- numberSingles = numberSingles + 1
- else:
- numberDoubles = numberDoubles + 1
- if xo.dtype.char == 'f':
- numberSingles = numberSingles + 1
- else:
- numberDoubles = numberDoubles + 1
-
- if yi.dtype.char == 'f':
- numberSingles = numberSingles + 1
- else:
- numberDoubles = numberDoubles + 1
- if yo.dtype.char == 'f':
- numberSingles = numberSingles + 1
- else:
- numberDoubles = numberDoubles + 1
-
- if debug == 1:
- print 'number Singles and Doubles : ', numberSingles, numberDoubles
-
- if numberSingles >= numberDoubles:
- self.group = 'single'
- if numberSingles < 4:
- sendmsg('Changing all the coordinate grid types to float32')
- xi = xi.astype(numpy.float32)
- xo = xo.astype(numpy.float32)
- yi = yi.astype(numpy.float32)
- yo = yo.astype(numpy.float32)
- else:
- self.group = 'double'
- if numberDoubles < 4:
- sendmsg('Changing all the coordinate grid types to float64')
- xi = xi.astype(numpy.float64)
- xo = xo.astype(numpy.float64)
- yi = yi.astype(numpy.float64)
- yo = yo.astype(numpy.float64)
-
- # set the parameter instance data to the default values
-
- defaultDict = Natgrid.makeDefaultParameterTable(self)
-
- self.adf = eval(defaultDict['adf'][2])
- self.alg = eval(defaultDict['alg'][2])
- self.asc = eval(defaultDict['asc'][2])
- self.bI = eval(defaultDict['bI'][2])
- self.bJ = eval(defaultDict['bJ'][2])
- self.dup = eval(defaultDict['dup'][2])
- self.ext = eval(defaultDict['ext'][2])
- self.hor = eval(defaultDict['hor'][2])
- self.igr = eval(defaultDict['igr'][2])
- self.magx = eval(defaultDict['magx'][2])
- self.magy = eval(defaultDict['magy'][2])
- self.magz = eval(defaultDict['magz'][2])
- self.non = eval(defaultDict['non'][2])
- self.nul = eval(defaultDict['nul'][2])
- self.rad = eval(defaultDict['rad'][2])
- self.sdi = eval(defaultDict['sdi'][2])
- self.upd = eval(defaultDict['upd'][2])
- self.ver = eval(defaultDict['ver'][2])
-
- def rgrd(self, dataIn, aspectSlope = 'no', wrap = 'no'):
- """ --------------------------------------------------------------------------------------------------------
- routine: rgrd
-
- purpose: Perform one of the following:
- 1. natural neighbor linear interpolation to a rectilinear grid
- 2. natural neighbor linear interpolation to a rectilinear grid returning aspects and slopes
- 3. natural neighbor linear interpolation to a list of points in the single point mode
- 4. natural neighbor nonlinear interpolation to a rectilinear grid
- 5. natural neighbor nonlinear interpolation to a rectilinear grid returning aspects and slopes
- 6. natural neighbor nonlinear interpolation to a list of points in the single point mode
-
- Each of the computations can be single or double precison. The choice is made by examing the precision
- in the grid coordinate arrays. In addition, the choice of the single point mode is determined by the
- set of the listOuput parameter in creating an instance of the Natgrid class.
-
- Assuming that the instance, r, has been constructed, the choice between a linear or a nonlinear
- computation is made with the control parameter igr. The default calls for a linear calculation. To
- call for a nonlinear one, type
-
- r.igr = 1
-
- usage: To interpolate the input data, dataIn, to the output data, dataOut, on the output grid, type
-
- dataOut = r.rgrd(dataIn)
-
- If the output grid is rectangular, it is possible to request the associated aspects and slopes with
-
- dataOut, aspect, slope = r.rgrd(dataIn, aspectSlope = 'yes')
-
- For global latitude-longitude grids, it is also possible to request a wrap in the input grid and the input
- data in the longitude direction, assumed to be the yi grid coordinate, (with or without associated aspects
- and slopes) with
-
- dataOut, aspect, slope = r.rgrd(dataIn, wrap = 'yes')
- or
- dataOut, aspect, slope = r.rgrd(dataIn, aspectSlope = 'yes', wrap = 'yes')
-
- definition: rgrd(self, dataIn, aspectSlope = 'no', wrap = 'no'):
- --------------------------------------------------------------------------------------------------------"""
- if self.nxi != len(dataIn):
- msg = 'CANNOT CREATE INSTANCE - The length of the input coordindate grids and the data must be equal'
- raise ValueError, msg
-
- if usefilled == 'yes':
- dataIn = numpy.ma.filled(dataIn)
-
- # set the instance values of the parameters in the c code
- Natgrid.setInstanceParameters(self)
-
- if wrap == 'yes':
- self.xi, self.yi, dataIn = Natgrid.wrapAll(self, self.xi, self.yi, dataIn)
- self.nxi = len(self.xi)
- self.nyi = len(self.yi)
-
- if dataIn.dtype.char == 'f': # single precision
- if self.group == 'double': # change the grid type to match dataIn
- self.group = 'single' # change the grid type to match dataIn
- self.xi = self.xi.astype(numpy.float32)
- self.xo = self.xo.astype(numpy.float32)
- self.yi = self.yi.astype(numpy.float32)
- self.yo = self.yo.astype(numpy.float32)
- else: # double precision
- if self.group == 'single': # change the grid type to match dataIn
- self.group = 'double' # change the grid type to match dataIn
- self.xi = self.xi.astype(numpy.float64)
- self.xo = self.xo.astype(numpy.float64)
- self.yi = self.yi.astype(numpy.float64)
- self.yo = self.yo.astype(numpy.float64)
-
- if self.listOutput == 'no': # output grid is rectangular
- t = Natgrid.rgrdPrimary(self, dataIn, aspectSlope)
-
- else: # output grid is a list
- t = Natgrid.rgrdSinglePoint(self, dataIn)
-
- return t
-
- def rgrdPrimary(self, dataIn, aspectSlope):
- """ #-------------------------------------------------------------------
- #
- #
- #-------------------------------------------------------------------------"""
- if aspectSlope != 'no':
- self.sdi = 1 # calculate aspects and slopes
-
- # set the instance values of the parameters in the c code
- #Natgrid.setInstanceParameters(self)
-
- if dataIn.dtype.char == 'f': # single precision
- if debug == 1:
- print 'In rgrdPrimary calling natgrids'
-
- dataOut, ier = natgridmodule.natgrids(self.nxi, self.xi, self.yi, dataIn, self.nxo, self.nyo, self.xo, self.yo)
-
- if ier != 0:
- msg = 'Error in return from natgrids call with -- ' + Natgrid.errorTable(self)[ier]
- raise ValueError, msg
-
- if aspectSlope != 'no':
-
- nxo = self.nxo
- nyo = self.nyo
- a = numpy.zeros((nxo, nyo), numpy.float32)
-
- for i in range(nxo):
- for j in range(nyo):
- uvtemp, ier = natgridmodule.getaspects(i, j)
- if ier != 0:
- msg = 'Error in return from getaspects call with -- ' + Natgrid.errorTable(self)[ier]
- raise ValueError, msg
- a[i,j] = uvtemp # return aspect in degrees
-
- s = numpy.zeros((nxo, nyo), numpy.float32)
-
- for i in range(nxo):
- for j in range(nyo):
- uvtemp, ier = natgridmodule.getslopes(i, j)
- if ier != 0:
- msg = 'Error in return from getslopes call with -- ' + Natgrid.errorTable(self)[ier]
- raise ValueError, msg
- s[i,j] = uvtemp # return slope in degrees
-
- else: # double precision
- if debug == 1:
- print 'In rgrdPrimary calling natgridd'
-
- dataOut, ier = natgridmodule.natgridd(self.nxi, self.xi, self.yi, dataIn, self.nxo, self.nyo, self.xo, self.yo)
- if ier != 0:
- msg = 'Error in return from natgridd call with -- ' + Natgrid.errorTable(self)[ier]
- raise ValueError, msg
-
- if aspectSlope != 'no':
-
- nxo = self.nxo
- nyo = self.nyo
- a = numpy.zeros((nxo, nyo), numpy.float64)
-
- for i in range(nxo):
- for j in range(nyo):
- uvtemp, ier = natgridmodule.getsloped(i, j)
- if ier != 0:
- msg = 'Error in return from getaspectd call with -- ' + Natgrid.errorTable(self)[ier]
- raise ValueError, msg
- a[i,j] = uvtemp # return aspect in degrees
-
- s = numpy.zeros((nxo, nyo), numpy.float64)
-
- for i in range(nxo):
- for j in range(nyo):
- s[i,j], ier = natgridmodule.getsloped(i, j)
- if ier != 0:
- msg = 'Error in return from getsloped call with -- ' + Natgrid.errorTable(self)[ier]
- raise ValueError, msg
- s[i,j] = uvtemp # return slope in degrees
-
- # is a reverse the order in the returned arrays necessary
-
- if (self.xreverse == 'yes') or (self.yreverse == 'yes'):
- needReverse = 'yes'
- else:
- needReverse = 'no'
-
- # construct the tuple for the return of what was calculated
-
- if aspectSlope != 'no':
- if needReverse == 'yes':
- dataOut = Natgrid.reverseData(self, dataOut)
- a = Natgrid.reverseData(self, a)
- s = Natgrid.reverseData(self, s)
-
- returnList = [dataOut]
- returnList.append(a)
- returnList.append(s)
-
- return tuple(returnList)
- else:
-
- if needReverse == 'yes':
- dataOut = Natgrid.reverseData(self, dataOut)
-
- return dataOut
-
- def rgrdSinglePoint(self, dataIn):
- """ #-------------------------------------------------------------------
- #
- #
- #-------------------------------------------------------------------------"""
- self.sdi = 0 # turn off calculaton of aspect and slope
-
- if dataIn.dtype.char == 'f': # single precision
- if debug == 1:
- print 'In rgrdSinglePoint using single precision computation'
-
- natgridmodule.pntinits(self.nxi, self.xi, self.yi, dataIn)
-
- dataOut = numpy.zeros((self.nxo), numpy.float32)
- for i in range(self.nxo):
- dataOut[i] = natgridmodule.pnts(self.xo[i], self.yo[i])
-
- natgridmodule.pntend()
-
- else: # double precision
- if debug == 1:
- print 'In rgrdSinglePoint using double precision computation'
-
- natgridmodule.pntinitd(self.nxi, self.xi, self.yi, dataIn)
-
- dataOut = numpy.zeros((self.nxo), numpy.float64)
- for i in range(self.nxo):
- dataOut[i] = natgridmodule.pntd(self.xo[i], self.yo[i])
-
- natgridmodule.pntendd()
-
- return dataOut
-
-
- def reverseData(self, data):
- #------------------------------------------------------------------------------
- #
- # purpose: reverse the order of th data if outgrid submitted was not increasing
- #
- # usage:
- #
- # returned: parameters
- #
- #------------------------------------------------------------------------------
-
- if self.xreverse == 'yes':
- data = data[::-1,:]
- if self.yreverse == 'yes':
- data = data[:, ::-1]
-
- return data
-
- def wrapAll(self, lat, lon, data):
- #------------------------------------------------------------------------------
- #
- # purpose: Adds much wrap in longitude to the linear form of the input data
- #
- # usage:
- #
- # passed: lat -- the latitude array
- # lon -- the longitude arraywhich requires a large wrap for natgrid
- # data -- the data at the associated linear set of points
- #
- # returned: lat, lon and data differing fom th input by the wrap
- #
- #
- #------------------------------------------------------------------------------
- if debug == 1:
- print 'entering wrapAll with array lengths: ', len(lat)
-
- # Make a wrapped grid and wrapped data
-
- lonList = list(lon) # make Python lists as intermediate step
- latList = list(lat)
- dataList = list(data)
-
- maxlon = max(lonList) # set up the wrap ranges in longitude
- minlon = min(lonList)
- distance = (maxlon - minlon)/4. # wrap first and last quarter of points
-
- minlonLow = minlon
- minlonHigh = minlon + distance
- maxlonLow = maxlon - distance
- maxlonHigh = maxlon
-
- for i in range(len(lonList)): # wrap the Python lists
- value = lonList[i]
- if (value >= minlonLow) and (value < minlonHigh):
- lonList.append(value + 360.)
- latList.append(latList[i])
- dataList.append(dataList[i])
- elif (value > maxlonLow) and (value <= maxlonHigh):
- lonList.append(value - 360.)
- latList.append(latList[i])
- dataList.append(dataList[i])
-
- if self.group == 'single': # single precision
- lon = numpy.array(lonList, numpy.float32) # convert to numpy arrays
- lat = numpy.array(latList, numpy.float32)
- data = numpy.array(dataList, numpy.float32)
- else: # double precision
- lon = numpy.array(lonList, numpy.float64) # convert to numpy arrays
- lat = numpy.array(latList, numpy.float64)
- data = numpy.array(dataList, numpy.float64)
-
- if debug == 1:
- print 'leaving wrapAll with array lengths: ', len(lat)
-
- return lat, lon, data
-
- #---------------------------------------------------------------------------------
- # **************** Control parameter manipulation functions ********************
- #---------------------------------------------------------------------------------
-
- def parameterNames(self):
- #------------------------------------------------------------------------------
- #
- # purpose: produce a list of the natgrid parameters
- #
- # usage: parameters = parameterNames(self)
- #
- # passed: self
- #
- # returned: parameters
- #
- #------------------------------------------------------------------------------
-
- parameters = ['name', '----', 'adf', 'alg', 'asc', 'bI', 'bJ', 'dup', 'ext', 'hor', 'igr', 'magx',
- 'magy', 'magz', 'non', 'nul', 'rad', 'sdi', 'upd', 'ver', 'xas', 'yas', 'zas' ]
-
- return parameters
-
- def parameterType(self):
- #--------------------------------------------------------------------------------
- #
- # purpose: produce a dictionary connecting parameter names and their data types
- #
- # usage: typeDict = parameterType(self)
- #
- # passed: self
- #
- # returned: typeDict
- #
- #---------------------------------------------------------------------------------
- typeDict = {
- 'adf':'int', 'alg':'char', 'asc':'int', 'bI':'float', 'bJ':'float', 'dup':'int', 'ext':'int',
- 'hor':'float', 'igr':'int', 'magx':'float', 'magy':'float', 'magz':'float', 'non':'int', 'nul':'float',
- 'rad':'int', 'sdi':'int', 'upd':'int', 'ver':'float', 'xas':'float', 'yas':'float', 'zas':'float' }
-
- return typeDict
-
- def makeDefaultParameterTable(self):
- #-----------------------------------------------------------------------------------
- #
- # purpose: construct the dictionary which is the default control parameters table
- #
- # usage: makeDefaultParameterTable()
- #
- # passed: self
- #
- # returned: parameterDict
- #
- #----------------------------------------------------------------------------------
-
- parameterDict = {
- 'name':('type ', ' legal values ',' default values ',' description '),
- '----':('-----', '--------------------','-----------------','------------------------------------------------------------'),
- 'adf': ('int ','0 = no or 1 = yes ',' 0 ','produce data file of algoritmic info for display? (see alg) '),
- 'alg': ('char ','any file name ',' "nnalg.dat" ','file name for algoritmic display tool (see adf) '),
- 'asc': ('int ','0 = no or 1 = yes ',' 1 ','is automatic scaling is allowed? '),
- 'bI': ('float','>= 1. ',' 1.5 ','tautness increasing effect of the gradients by increasing bI'),
- 'bJ': ('float','>= 1. ',' 7.0 ','tautness decreasing breadth of region affected by gradients '),
- 'dup': ('int ','0 = yes or 1 = no ',' 1 ','are duplicate input coordinates are allowed? '),
- 'ext': ('int ','0 = no or 1 = yes ',' 1 ','is extrapolation allowed outside the convex hull? '),
- 'hor': ('float','>= 0. ',' -1.0 ','amount of horizontal overlap from outside current region '),
- 'igr': ('int ','0 = no or 1 = yes ',' 0 ','are gradients are to be computed? '),
- 'magx':('float','> 0. ',' 1.0 ','scale factor for x coordinate values '),
- 'magy':('float','> 0. ',' 1.0 ','scale factor for y coordinate values '),
- 'magz':('float','> 0. ',' 1.0 ','scale factor for z coordinate values '),
- 'non': ('int ','0 = yes or 1 = no ',' 0 ','are interpolated values are allowed to be negative? '),
- 'nul': ('float','any float ',' 0.0 ','value for points outside the convex hull if no extrapolation'),
- 'rad': ('int ','0 = rad or 1 = deg ',' 0 ','are slopes and aspects are returned in radians or degrees? '),
- 'sdi': ('int ','0 = no or 1 = yes ',' 0 ','are slopes and aspects to be computed? '),
- 'upd': ('int ','0=N to S or 1=S to N',' 1 ','does output array from giving N to S or S to N? '),
- 'ver': ('float','>= 0. ',' -1.0 ','amount of vertical overlap from outside current region '),
- 'xas': ('float','> 0. ',' 0.0 ','scale used by automatic scaling of x in last interpolation '),
- 'yas': ('float','> 0. ',' 0.0 ','scale used by automatic scaling of y in last interpolation '),
- 'zas': ('float','> 0. ',' 0.0 ','scale used by automatic scaling of z in last interpolation ') }
-
- return parameterDict
-
-
- def makeInstanceParameterTable(self):
- #----------------------------------------------------------------------------------
- #
- # purpose: construct the dictionary which is the instance control parameters table
- #
- # usage: makeInstanceParameterTable(self)
- #
- # passed: self
- #
- # returned: parameterDict
- #
- #----------------------------------------------------------------------------------
-
- parameterDict = {
- 'name':('type ', ' legal values ',' Values ',' description '),
- '----':('-----', '-------------------','----------------','------------------------------------------------------------'),
- 'adf': ('int ','0 = no or 1 = yes ', eval('self.adf') ,'produce data file of algoritmic info for display? (see alg) '),
- 'alg': ('char ','any file name ', eval('self.alg') ,'file name for algoritmic display tool (see adf) '),
- 'asc': ('int ','0 = no or 1 = yes ', eval('self.asc') ,'is automatic scaling is allowed? '),
- 'bI': ('float','>= 1. ', eval('self.bI') ,'tautness increasing effect of the gradients by increasing bI'),
- 'bJ': ('float','>= 1. ', eval('self.bJ') ,'tautness decreasing breadth of region affected by gradients '),
- 'dup': ('int ','0 = yes or 1 = no ', eval('self.dup') ,'are duplicate input coordinates are allowed? '),
- 'ext': ('int ','0 = no or 1 = yes ', eval('self.ext') ,'is extrapolation allowed outside the convex hull? '),
- 'hor': ('float','>= 0. ', eval('self.hor') ,'amount of horizontal overlap from outside current region '),
- 'igr': ('int ','0 = no or 1 = yes ', eval('self.igr') ,'are gradients are to be computed? '),
- 'magx':('float','> 0. ', eval('self.magx'),'scale factor for x coordinate values '),
- 'magy':('float','> 0. ', eval('self.magy'),'scale factor for y coordinate values '),
- 'magz':('float','> 0. ', eval('self.magz'),'scale factor for z coordinate values '),
- 'non': ('int ','0 = yes or 1 = no ', eval('self.non') ,'are interpolated values are allowed to be negative? '),
- 'nul': ('float','any float ', eval('self.nul') ,'value for points outside the convex hull if no extrapolation'),
- 'rad': ('int ','0 = rad or 1 = deg ', eval('self.rad') ,'are slopes and aspects are returned in radians or degrees? '),
- 'sdi': ('int ','0 = no or 1 = yes ', eval('self.sdi') ,'are slopes and aspects to be computed? '),
- 'upd': ('int ','0=N to S or 1=S to N', eval('self.upd') ,'does output array from giving N to S or S to N? '),
- 'ver': ('float','>= 0. ', eval('self.ver') ,'amount of vertical overlap from outside current region '),
- 'xas': ('float','> 0. ',' 0.0 ','scale used by automatic scaling of x in last interpolation'),
- 'yas': ('float','> 0. ',' 0.0 ','scale used by automatic scaling of y in last interpolation'),
- 'zas': ('float','> 0. ',' 0.0 ','scale used by automatic scaling of z in last interpolation') }
-
- return parameterDict
-
- def printDefaultParameterTable(self):
- """ --------------------------------------------------------------------------------------------------------
-
- purpose: print the value of all the parameters
-
- usage: r.printDefaultParameterTable()
-
- where r is an instance of Natgrid
-
- passed: self
-
- returned: None
-
- --------------------------------------------------------------------------------------------------------"""
- names = Natgrid.parameterNames(self)
- names = names[2:]
-
- parameterDict = Natgrid.makeDefaultParameterTable(self)
- for item in names:
- items = (item, parameterDict[item][0], parameterDict[item][1], parameterDict[item][2], parameterDict[item][3])
- print '%-7.7s %-6.6s %-12.12s %-15.15s %s' % items
-
- return
-
- def printInstanceParameterTable(self):
- """ --------------------------------------------------------------------------------------------------------
-
- purpose: print the value of all the parameters
-
- usage: r.printInstanceParameterTable()
-
- where r is an instance of Natgrid
-
- passed: self
-
- returned: None
-
- --------------------------------------------------------------------------------------------------------"""
- names = Natgrid.parameterNames(self)
- names = names[2:]
-
- parameterDict = Natgrid.makeInstanceParameterTable(self)
- for item in names:
- items = (item, parameterDict[item][0], parameterDict[item][1], parameterDict[item][2], parameterDict[item][3])
- print '%-7.7s %-6.6s %-12.12s %-7.7s %s' % items
-
- return
- def printInstanceParameters(self):
- """ --------------------------------------------------------------------------------------------------------
-
- purpose: print the values of the current natgrid control parameters in c code
-
- usage: r. printInstanceParameters()
-
- where r is an instance of Natgrid
-
- passed: self
-
- returned: None
-
- --------------------------------------------------------------------------------------------------------"""
-
- names = Natgrid.parameterNames(self)
- names = names[2:]
-
- typeDict = Natgrid.parameterType(self)
-
- for name in names:
- if typeDict[name] == 'int':
- print 'Currently, %s = %d' % (name, eval('self.' + name))
- elif typeDict[name] == 'char':
- print 'Currently, %s = %s' % (name, eval('self.' + name))
- elif typeDict[name] == 'float':
- print 'Currently, %s = %f' % (name, eval('self.' + name))
- elif typeDict[name] == 'double':
- print 'Currently, %s = %f' % (name, eval('self.' + name))
-
- return None
-
- def setInstanceParameters(self):
- #---------------------------------------------------------------------------
- #
- # purpose: set the instance values of the current natgrid control parameters in c code
- #
- # usage: r.setInstanceParameters()
- #
- # where r is an instance of Natgrid
- #
- # passed: self
- #
- # returned: None
- #
- #----------------------------------------------------------------------------
-
- names = Natgrid.parameterNames(self)
- names = names[2:-3] # the -3 eliminates the nonsettable xas, yas and zas
-
- typeDict = Natgrid.parameterType(self)
-
- # set the current values for the natgrid control parameters
-
-
- for name in names:
- if typeDict[name] == 'int':
- natgridmodule.seti(name, eval('self.' + name))
- elif typeDict[name] == 'char':
- natgridmodule.setc(name, eval('self.' + name))
- elif typeDict[name] == 'float':
- natgridmodule.setr(name, eval('self.' + name))
- elif typeDict[name] == 'double':
- natgridmodule.setrd(name, eval('self.' + name))
-
- return None
-
- #---------------------------------------------------------------------------------
- # ***************************** Error Table ************************************
- #---------------------------------------------------------------------------------
- def errorTable(self):
-
- """ --------------------------------------------------------------------------------------------------------
-
- purpose: construct the dictionary which provides access to error messages
-
- usage: errorDict = r.errorTable()
-
- where r is an instance of Natgrid
-
- returned: errorDict
-
- --------------------------------------------------------------------------------------------------------"""
-
- errorDict = {
- 1: 'Insufficient data in gridded region to triangulate',
- 2: 'Dulpicate input data coordinates are not allowed',
- 3: 'Unable to open file for writing algorithmic',
- 4: 'WARNING: The ratio of vertical to horizontal scales too large for gradients. Rescale if gradients required',
- 5: 'WARNING: The ratio of vertical to horizontal scales too small for gradients. Rescale if gradients required',
- 6: 'WARNING: The ratio of x to y-axis breath too extreme. Change proportions or rescale. Gradients disabled',
- 7: 'Unable to allocate storage for ivector',
- 8: 'Unable to allocate storage for dvector',
- 9: 'Unable to allocate storage for **imatrix',
- 10: 'Unable to allocate storage for imatrix[]',
- 11: 'Unable to allocate storage for **fmatrix',
- 12: 'Unable to allocate storage for fmatrix[]',
- 13: 'Unable to allocate storage for **dmatrix',
- 14: 'Unable to allocate storage for dmatrix[]',
- 15: 'Unable to allocate storage for raw data',
- 16: 'Unable to allocate storage for a simplex',
- 17: 'Unable to allocate storage for temp',
- 18: 'Unable to allocate storage for neig',
- 19: 'Slopes have not been computed, set sdip',
- 20: 'Row argument out of range',
- 21: 'Column argument out of range',
- 22: 'Aspects have not been computed, set sdip',
- 23: 'Parameter name not known',
- 24: 'Can not open error file',
- 25: 'Automatic scaling done - distorted aspects not returned. Rescale data or set magx, magy and magz appropriately',
- 26: 'Automatic scaling done - distorted slopes not returned. Rescale data or set magx, magy and magz appropriately',
- 27: 'Coordinate is outside the gridded region for a single point interpolation',
- 28: 'Can not compute aspects and slopes in conjunction with single point interpolation mode',
- 29: 'Fortran DOUBLE PRECISION entries not supported on UNICOS',
- 30: 'Error number out of range' }
-
- return errorDict
-
- #---------------------------------------------------------------------------------
- # *************************** magic functions *********************************
- #---------------------------------------------------------------------------------
-
- def __setattr__(self, name, value):
- #---------------------------------------------------------------------------------
- #
- # purpose: '__setattr__' is called on every assignment to an instance attribute.
- # Consequently, it must put the value in through the __dict__ to avoid
- # calling itself and setting up an infinite recursion loop.It sets the
- # attribute called name to value in two steps.
- # One -- set the global C code control parameter
- # Two -- set the instance self data control parameter
- #
- # usage: x.name = value
- #
- # passed : name and value
- #
- # returned: None
- #
- #---------------------------------------------------------------------------------
- typeDict = Natgrid.parameterType(self)
-
- if name in typeDict.keys():
- if typeDict[name] == 'int':
- natgridmodule.seti(name, value)
- self.__dict__[name] = value
- elif typeDict[name] == 'char':
- natgridmodule.setc(name, value)
- self.__dict__[name] = value
- elif typeDict[name] == 'float':
- natgridmodule.setr(name, value)
- self.__dict__[name] = value
- elif typeDict[name] == 'double':
- natgridmodule.setrd(name, value)
- self.__dict__[name] = value
-
- else:
- self.__dict__[name] = value
-
- return None
-
- def __getattr__(self, name):
- #---------------------------------------------------------------------------------
- #
- # purpose: '__getattr__' is called only if a referenced attribute can not be found
- # in the instance. It gets the attribute from natgridmodule if possible.
- #
- # usage: x.name -- name is the oject and not a string repr
- #
- # passed : name
- #
- # returned: x.name
- #
- #---------------------------------------------------------------------------------
- typeDict = Natgrid.parameterType(self)
-
- if name in typeDict.keys():
- if typeDict[name] == 'int':
- value = natgridmodule.geti(name)
- elif typeDict[name] == 'char':
- value = natgridmodule.getc(name)
- elif typeDict[name] == 'float':
- value = natgridmodule.getr(name)
- elif typeDict[name] == 'double':
- value = natgridmodule.getrd(name)
-
- else:
- raise AttributeError, name
-
- return value
-
- #---------------------------------------------------------------------------------
- # *******************************************************************
- # **************** end of magic functions **************************
- # *******************************************************************
- #---------------------------------------------------------------------------------
-
-def printParameterTable():
- """ --------------------------------------------------------------------------------------------------------
- routine: printParameterTable
-
- purpose: print the control parameter table using the default values from outside the Natgrid class
-
- usage: import nat
- nat.printParameterTable()
-
- passed: nothing
-
- returned: None
-
- definition: printParameterTable():
---------------------------------------------------------------------------------------------------------"""
-
- names = ['name', '----', 'adf', 'alg', 'asc', 'bI', 'bJ', 'dup', 'ext', 'hor', 'igr', 'magx',
- 'magy', 'magz', 'non', 'nul', 'rad', 'sdi', 'upd', 'ver', 'xas', 'yas', 'zas' ]
-
- parameterDict = {
- 'name':('type ', ' legal values ',' default values ',' description '),
- '----':('-----', '--------------------','-----------------','------------------------------------------------------------'),
- 'adf': ('int ','0 = no or 1 = yes ',' 0 ','produce data file of algoritmic info for display? (see alg) '),
- 'alg': ('char ','any file name ',' "nnalg.dat" ','file name for algoritmic display tool (see adf) '),
- 'asc': ('int ','0 = no or 1 = yes ',' 1 ','is automatic scaling is allowed? '),
- 'bI': ('float','>= 1. ',' 1.5 ','tautness increasing effect of the gradients by increasing bI'),
- 'bJ': ('float','>= 1. ',' 7.0 ','tautness decreasing breadth of region affected by gradients '),
- 'dup': ('int ','0 = yes or 1 = no ',' 1 ','are duplicate input coordinates are allowed? '),
- 'ext': ('int ','0 = no or 1 = yes ',' 1 ','is extrapolation allowed outside the convex hull? '),
- 'hor': ('float','>= 0. ',' -1.0 ','amount of horizontal overlap from outside current region '),
- 'igr': ('int ','0 = no or 1 = yes ',' 0 ','are gradients are to be computed? '),
- 'magx':('float','> 0. ',' 1.0 ','scale factor for x coordinate values '),
- 'magy':('float','> 0. ',' 1.0 ','scale factor for y coordinate values '),
- 'magz':('float','> 0. ',' 1.0 ','scale factor for z coordinate values '),
- 'non': ('int ','0 = yes or 1 = no ',' 0 ','are interpolated values are allowed to be negative? '),
- 'nul': ('float','any float ',' 0.0 ','value for points outside the convex hull if no extrapolation'),
- 'rad': ('int ','0 = rad or 1 = deg ',' 0 ','are slopes and aspects are returned in radians or degrees? '),
- 'sdi': ('int ','0 = no or 1 = yes ',' 0 ','are slopes and aspects to be computed? '),
- 'upd': ('int ','0=N to S or 1=S to N',' 1 ','does output array from giving N to S or S to N? '),
- 'ver': ('float','>= 0. ',' -1.0 ','amount of vertical overlap from outside current region '),
- 'xas': ('float','> 0. ',' 0.0 ','scale used by automatic scaling of x in last interpolation '),
- 'yas': ('float','> 0. ',' 0.0 ','scale used by automatic scaling of y in last interpolation '),
- 'zas': ('float','> 0. ',' 0.0 ','scale used by automatic scaling of z in last interpolation ') }
-
- for item in names:
- items = (item, parameterDict[item][0], parameterDict[item][1], parameterDict[item][2], parameterDict[item][3])
- print '%-7.7s %-6.6s %-12.12s %-15.15s %s' % items
-
- return
-
-def printStoredParameters():
- """ --------------------------------------------------------------------------------------------------------
- routine: printStoredParameters
-
- purpose: print the values of the current natgrid control parameters in c code. The call
- to the method function rgrd will change them to the instance values.
-
- usage: import nat
- nat.printStoredParameters()
-
- passed: nothing
-
- returned: None
-
- definition: printStoredParameters():
---------------------------------------------------------------------------------------------------------"""
-
- names = ['name', '----', 'adf', 'alg', 'asc', 'bI', 'bJ', 'dup', 'ext', 'hor', 'igr', 'magx',
- 'magy', 'magz', 'non', 'nul', 'rad', 'sdi', 'upd', 'ver', 'xas', 'yas', 'zas' ]
- names = names[2:]
-
- typeDict = {
- 'adf':'int', 'alg':'char', 'asc':'int', 'bI':'float', 'bJ':'float', 'dup':'int', 'ext':'int',
- 'hor':'float', 'igr':'int', 'magx':'float', 'magy':'float', 'magz':'float', 'non':'int', 'nul':'float',
- 'rad':'int', 'sdi':'int', 'upd':'int', 'ver':'float', 'xas':'float', 'yas':'float', 'zas':'float' }
-
- for item in names:
- if typeDict[item] == 'int':
- print ' %s = %d' % (item, natgridmodule.geti(item))
- elif typeDict[item] == 'char':
- print ' %s = %s' % (item, natgridmodule.getc(item))
- elif typeDict[item] == 'float':
- print ' %s = %f' % (item, natgridmodule.getr(item))
- elif typeDict[item] == 'double':
- print ' %s = %f' % (item, natgridmodule.getrd(item))
-
- return None
-
-
-def checkdim(x, y):
- #------------------------------------------------------------------------------------------
- #
- # purpose: determine whether the coordinate grid is random or monotonically increasing
- #
- # usage:
- #
- # returned: x, y, monotonic, xreverse, yreverse
- #
- #-------------------------------------------------------------------------------------------
- xsize = len(x)
-
- if x[0] > x[xsize - 1]:
- x = x[::-1]
- xreverse = 'yes'
- else:
- xreverse = 'no'
-
-
- xmonotonic = 'yes' # monotonic and possibly reversed to make it montonically increasing
- for n in range(1, xsize):
- if x[n] < x[n - 1]:
- xmonotonic = 'no' # not monotonic so return the original grid
-
- ysize = len(y)
-
- if y[0] > y[ysize - 1]:
- y = y[::-1]
- yreverse = 'yes'
- else:
- yreverse = 'no'
-
-
- ymonotonic = 'yes' # monotonic and possibly reversed to make it montonically increasing
- for n in range(1, ysize):
- if y[n] < y[n - 1]:
- ymonotonic = 'no' # not monotonic so return the original grid
-
- if xmonotonic == 'yes' and ymonotonic == 'yes': # if both are monotonic the grid is monotonic
- monotonic = 'yes'
- else:
- monotonic = 'no'
- if xreverse == 'yes': # return vectors to thier original state
- x = x[::-1]
- xreverse = 'no'
- if yreverse == 'yes':
- y = y[::-1]
- yreverse = 'no'
-
- # note that x and y may be returned reversed as necessary only if monotonic is set to yes
-
- return x, y, monotonic, xreverse, yreverse
-
-#---------------------------------------------------------------------------------
-# ********************************************************************************
-# ********************************************************************************
-#---------------------------------------------------------------------------------
-
-
-
-def sendOutput(output, msg, value = None):
- """ #---------------------------------------------------------------------------------
- #
- # purpose: send the same message to the screen and to a file
- #
- # passed : msg - the string
- #
- # returned: return
- #
- #---------------------------------------------------------------------------------"""
- if value is None:
- print msg
- output.write(msg + '\n')
- else:
- print msg, `value`
- output.write(msg + ' %15.11e\n' % (value,))
-
- return None
-
-def document():
- """ #-------------------------------------------------------------------------
- #
- # purpose: 'docstrings' writes the doc strings contained in the regrid module
- # to a file as documentation for the user
- #
- # usage: import regrid2 as regrid
- # regrid.document()
- #
- # passed : nothing
- #
- # returned: nothing
- #
- #-------------------------------------------------------------------------"""
- import nat
-
- std = sys.stdout # save sys.stout to allow reassigning later
- sys.stdout = open( 'natgrid.doc', 'w')
-
- print '**********************************************************************************************\n'
- print '**************************** Overview of the CDAT interface to natgrid ***********************\n'
- print '**********************************************************************************************\n'
- print nat.__doc__
- print
- print
-
- print ' ******************** Instructions for use of the natgrids function **************************'
- print natgridmodule.natgrids.__doc__
- print
-
- print ' ******************** Instructions for use of the seti function **************************'
- print natgridmodule.seti.__doc__
- print
-
- print ' ******************** Instructions for use of the geti function **************************'
- print natgridmodule.geti.__doc__
- print
-
- print ' ******************** Instructions for use of the setr function **************************'
- print natgridmodule.setr.__doc__
- print
-
- print ' ******************** Instructions for use of the getr function **************************'
- print natgridmodule.getr.__doc__
- print
-
- print ' ******************** Instructions for use of the setc function **************************'
- print natgridmodule.setc.__doc__
- print
-
- print ' ******************** Instructions for use of the getc function **************************'
- print natgridmodule.getc.__doc__
- print
-
- print ' ******************** Instructions for use of the getaspects function **************************'
- print natgridmodule.getaspects.__doc__
- print
-
- print ' ******************** Instructions for use of the getslopes function **************************'
- print natgridmodule.getslopes.__doc__
- print
-
- print ' ******************** Instructions for use of the pntinits function **************************'
- print natgridmodule.pntinits.__doc__
- print
-
- print ' ******************** Instructions for use of the pnts function **************************'
- print natgridmodule.pnts.__doc__
- print
-
- print ' ******************** Instructions for use of the pntend function **************************'
- print natgridmodule.pntend.__doc__
- print
-
- print ' ******************** Instructions for use of the natgridd function **************************'
- print natgridmodule.natgridd.__doc__
- print
-
- print ' ******************** Instructions for use of the setrd function **************************'
- print natgridmodule.setrd.__doc__
- print
-
- print ' ******************** Instructions for use of the getrd function **************************'
- print natgridmodule.getrd.__doc__
- print
-
- print ' ******************** Instructions for use of the getaspectd function **************************'
- print natgridmodule.getaspectd.__doc__
- print
-
- print ' ******************** Instructions for use of the getsloped function **************************'
- print natgridmodule.getsloped.__doc__
- print
-
- print ' ******************** Instructions for use of the pntinitd function **************************'
- print natgridmodule.pntinitd.__doc__
- print
-
- print ' ******************** Instructions for use of the pntd function **************************'
- print natgridmodule.pntd.__doc__
- print
-
- print ' ******************** Instructions for use of the pntendd function **************************'
- print natgridmodule.pntendd.__doc__
- print
-
-
-
- sys.stdout = std
-
- return None
-
-def sendmsg(msg, value1 = None, value2 = None):
- """ #---------------------------------------------------------------------------------
- #
- # purpose: send the same message to the screen
- #
- # passed : msg - the string
- # value - the number associated with the string
- #
- # returned: return
- #
- #---------------------------------------------------------------------------------"""
-
- print '*******************************************************************'
- if value1 is None:
- print msg
- elif value2 is None:
- print msg, value1
- else:
- print msg, value1, value2
- print '*******************************************************************'
-
- return None
-
-
-def help(choice = None):
- import nat
-
- if choice is None: # get instructions for use of help
- print """ ----------------------------------------------------------------------------------------
-
- INSTRUCTIONS ON USE THE OBJECT ORIENTED INTERFACE TO THE NATGRID PACKAGE FROM NGMATH
-
- This module is built as one class, Natgrid, which sports a single method called rgrd.
-
- To get instructions on making an instance of Natgrid, type
-
- nat.help('Natgrid')
-
- To get instructions on using the control parameters, type
-
- nat.help('parameters')
-
- To print the table describing the control parameters, type
-
- nat.help('table')
-
- To get instructions on performing a regridding, type
-
- nat.help('regrid')
-
- To get instructions on calculating slopes and aspects, type
-
- nat.help('aspectSlope')
-
- To get instructions using the single point computational mode, type
-
- nat.help('singlePoint')
-
-
- INSTRUCTIONS ON USE OF ORIGINAL NATGRID PACKAGE FROM NGMATH
-
- This module is built as an interface to natgridmodule.so which exports the following functions:
-
-
- Single precision procedures:
-
- natgrids - primary function for gridding.
- seti - set int parameter values.
- geti - retrieve values for int parameters.
- setr - set float parameter values.
- getr - retrieve values for float parameters
- setc - set char parameter values.
- getc - retrieve values for char parameters.
- getaspects - get aspect values, if calculated.
- getslopes - get slope values, if calculated.
- pntinits - initiate single point mode.
- pnts - interpolate at a single point.
- pntend _ terminate single point mode.
-
-
- Double precision procedures:
-
- natgridd - primary function for gridding.
- setrd - set float parameter values.
- getrd - retrieve values for float parameters
- getaspectd - get aspect values, if calculated.
- getsloped - get slope values, if calculated.
- pntinitd - initiate single point mode.
- pntd - interpolate at a single point.
- pntendd _ terminate single point mode.
-
-
- It is feasible to use these functions directly without this module. Information is available
- through their docstrings. For example, to get the docstring for the routine natgrids, follow this
- procedure at the Python prompt:
-
- import natgridmodule
-
- print natgridmodule.natgrids.__doc__
-
- or simply type
-
- nat.help('natgrids')
-
- ------------------------------------------------------------------------------------------------------"""
-
- elif choice == 'Natgrid':
- print """ ----------------------------------------------------------------------------------------
-
- To make an instance, r, type:
-
- import nat
-
- r = nat.Natgrid(xi, yi, xo, yo)
- or
- r = nat.Natgrid(xi, yi, xo, yo, listOutput = 'yes')
-
- where xi, yi and xo, yo are the input and output grid coordinate arrays. The optional listOutput is
- set to anything except 'no' if xo, yo are in list format as explained below.
-
- The input grid must be organized in a list format always. The size of the xi array and the yi array are
- necessarily equal. For example, if there are n randomly spaced input data points, there
- are n values in xi and n values in yi.
-
- There are two possible formats for the output grid. The output grid coordinate arrays may be a list like
- the input array or it may be a rectangular grid. The choice between the two posibilities is made according
- to requirements in subseqent calls to the method function. The first choice is required if the subsequent
- call is to the single point mode interpolation. The list can have one or more points. Of course, the list
- could describe a rectangular grid. For example, a rectangular grid with 10 x values and 20 y values can be
- rewrtten in list form with 200 x value and 200 y values. However, this form requires calling the slower
- single point interpolator. The second choice is most efficient for the basic interpolation to a rectangular
- output grid. The output grid must be monotonic but need not be equally spced.
-
- The grid coordinate arrays can be single precision (numpy.float32) or double precision (numpy.float64). The
- decision on whether to call for a single or a double precision computation subsequently is made by looking at
- the type of these arrays.
-
- --------------------------------------------------------------------------------------------------------------------"""
-
-
- elif choice == 'parameters':
- print """ ----------------------------------------------------------------------------------------
-
- In the absence of an instance of the class Natgrid, a description of the control parameters can be found
- by typing
-
- import nat
- nat.printParameterTable()
-
-
- The control parameters are easily available within the class. First make an instance, r, type:
-
- import nat
-
- r = nat.Natgrid(xi, yi, xo, yo)
-
-
- To change a setting type the new value. For example, to set igr to 1, type
-
- r.igr = 1
-
- To find an individual value, type the name. For example, to exam the value of hor, type
-
- r.hor
-
- To check the settings type
-
- r.printInstanceParameterTable() -- prints the table with values and a description of the parameters
- used in subsequent calls to the method function rgrd
- or
-
- r.printInstanceParameters() -- prints a list of the parameters values used in subsequent calls to the
- the rgrd method
-
- nat. printStoredParameters() -- prints the parameters in memory which may differ from the above if the
- user has made more than one instance of the Natgrid class.
- --------------------------------------------------------------------------------------------------------------------"""
-
- elif choice == 'table':
- printParameterTable()
-
- #-----------------------------------------------------------------------------------------------------
-
- elif choice == 'regrid':
- print """ ----------------------------------------------------------------------------------------
-
- natgrid is restricted to two dimensions . Consequently, it is the user's responsibility to reduce the processing
- of higher dimensional data to a sequence of calls using only two dimensional data. A description of the basic
- natural neighbor linear interpolation and nonlinear interpolations follow.
-
- Make an instance, r, with:
-
- import nat
-
- r = nat.Natgrid(xi, yi, xo, yo)
-
- where the xo, yo grid is rectilinear as explained in the help choice 'Natgrid'.
-
- r.igr = 1 -- in order to set up the computation for nonlinear interpolation. The default value
- for igr calls for a linear interpolation.
-
- Then call the primary interpolation computation to regrid the input data, dataIn, on the grid (xi, yi) to
- the output data, dataOut, on the grid (xo, yo), with
-
- dataOut = r.rgrd( dataIn )
-
- When dealing with global data described on a latitude-longitude grid, it is also possible to request a wrap
- in the input grid and the input data in the longitude direction, assumed to be the yi grid coordinate, with
-
- dataOut = r.rgrd(dataIn, wrap = 'yes')
-
- The computation is either single or double precision as determined by the precision submitted in making
- the instance.
- --------------------------------------------------------------------------------------------------------------------"""
-
- elif choice == 'aspectSlope':
- print """ ----------------------------------------------------------------------------------------
-
- natgrid is restricted to two dimensions . Consequently, it is the user's responsibility to reduce the processing
- of higher dimensional data to a sequence of calls using only two dimensional data. A description of the basic
- natural neighbor linear and nonlinear interpolations returning the aspect and the slope at the output grid
- points follows.
-
- First make an instance, r, with:
-
- import nat
-
- r = nat.Natgrid(xi, yi, xo, yo)
-
- where the xo, yo grid is rectilinear as explained in the help choice 'Natgrid'.
-
- r.igr = 1 -- in order to set up the computation for nonlinear interpolation. The default value
- for igr calls for a linear interpolation.
-
- Then call the primary interpolation computation to regrid the input data, dataIn, on the grid (xi, yi) to
- the output data, dataOut, on the grid (xo, yo), while asking for the aspect and the slope on this output grid, with
-
- dataOut, a, s = r.rgrd( dataIn, aspectSlope = 'yes' )
-
- where a is the aspect, the direction of the steepest descent in degrees measured from 'north' and s is the
- slope in degrees measured from the horizontal. Necessarily, these are arrays aligned with the rectilinear
- output grid, xo, yo.
-
- It is also possible to request a wrap in the input grid and the input data in the longitude direction, assumed
- to be the yi grid coordinate, by adding a keyword as
-
- dataOut, a, s = r.rgrd( dataIn, aspectSlope = 'yes', wrap = 'yes' )
-
- The computation is either single or double precision as determined by the precision submitted in making
- the instance.
-
- --------------------------------------------------------------------------------------------------------------------"""
-
- elif choice == 'singlePoint':
- print """ ----------------------------------------------------------------------------------------
-
- natgrid is restricted to two dimensions . Consequently, it is the user's responsibility to reduce the processing
- of higher dimensional data to a sequence of calls using only two dimensional data. A description of the single
- point natural neighbor linear and nonlinear interpolations follows.
-
- First make an instance, r, with:
-
- import nat
-
- r = nat.Natgrid(xi, yi, xo, yo, listOutput)
-
- where the xo, yo output grid is in the list form (not a rectangular output grid) as explained
- in the help choice 'Natgrid'.
-
- r.igr = 1 -- in order to set up the computation for nonlinear interpolation. The default value
- for igr calls for a linear interpolation.
-
- Then call the single point mode interpolation computation to regrid the input data, dataIn, on the grid (xi, yi)
- to the output data, dataOut, on the grid (xo, yo), type
-
- dataOut = r.rgrd( dataIn )
-
- The single point mode is slow but it provides a choice where the interpolation is to one or more points
- rather than to a complete rectangular grid..
-
- The computation is either single or double precision as determined by the precision submitted in making
- the instance.
-
- --------------------------------------------------------------------------------------------------------------------"""
-
- elif choice == 'natgrids':
- print natgridmodule.natgrids.__doc__
- elif choice == 'seti':
- print natgridmodule.seti.__doc__
- elif choice == 'geti':
- print natgridmodule.geti.__doc__
- elif choice == 'setr':
- print natgridmodule.setr.__doc__
- elif choice == 'getr':
- print natgridmodule.getr.__doc__
- elif choice == 'setc':
- print natgridmodule.setc.__doc__
- elif choice == 'getc':
- print natgridmodule.getc.__doc__
- elif choice == 'getaspects':
- print natgridmodule.getaspects.__doc__
- elif choice == 'getslopes':
- print natgridmodule.getslopes.__doc__
- elif choice == 'pntinits':
- print natgridmodule.pntinits.__doc__
- elif choice == 'pnts':
- print natgridmodule.pnts.__doc__
- elif choice == 'pntend':
- print natgridmodule.pntend.__doc__
- elif choice == 'natgridd':
- print natgridmodule.natgridd.__doc__
- elif choice == 'setrd':
- print natgridmodule.setrd.__doc__
- elif choice == 'getrd':
- print natgridmodule.getrd.__doc__
- elif choice == 'getaspectd':
- print natgridmodule.getaspectd.__doc__
- elif choice == 'getsloped':
- print natgridmodule.getsloped.__doc__
- elif choice == 'pntinitd':
- print natgridmodule.pntinitd.__doc__
- elif choice == 'pntd':
- print natgridmodule.pntd.__doc__
- elif choice == 'pntendd':
- print natgridmodule.pntendd.__doc__
-
- else:
- print 'Your request is not in help. The help choices are: '
- print 'Natgrid, parameters, table, regrid, aspectSlope, singlePoint, natgrids, seti, geti, setr, getr, setc, getc, getaspects, getslopes, pntinits, pnts, pntend, natgridd, setrd, getrd, getaspectd, getsloped, pntinitd, pntd, pntendd'
-
- return None
-
diff --git a/CEP/PyBDSM/src/natgrid/Src/natgrid.c b/CEP/PyBDSM/src/natgrid/Src/natgrid.c
deleted file mode 100644
index 301d428aa8fe71304e99fd92f1c701713f781aae..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/natgrid/Src/natgrid.c
+++ /dev/null
@@ -1,64 +0,0 @@
-/*
- * This file contains the settings for most of the
- * global variables by way of including nnmhead.h .
- */
-
-#include "nnmhead.h"
-#include "nnghead.h"
-#include "nntypes.h"
-#include "nntpvrs.h"
-#include "nnexver.h"
-
-void Terminate()
-{
- struct simp *tmp,*tmp0;
- struct datum *dtmp,*dtmp0;
- struct neig *ntmp,*ntmp0;
- struct temp *ttmp,*ttmp0;
- tmp = rootsimp;
- while(tmp!=NULL) {
- tmp0 =tmp->nextsimp;
- free(tmp);
- tmp = tmp0;
- }
- rootsimp = cursimp = holdsimp = lastsimp = prevsimp = NULL;
- dtmp = rootdat;
- while(dtmp!=NULL) {
- dtmp0 =dtmp->nextdat;
- free(dtmp);
- dtmp = dtmp0;
- }
- rootdat = curdat = holddat = NULL;
- ntmp = rootneig;
- while(ntmp!=NULL) {
- ntmp0 =ntmp->nextneig;
- free(ntmp);
- ntmp = ntmp0;
- }
- rootneig = curneig = lastneig = NULL;
- ttmp = roottemp;
- while(ttmp!=NULL) {
- ttmp0 =ttmp->nexttemp;
- free(ttmp);
- ttmp = ttmp0;
- }
- roottemp = curtemp = lasttemp= prevtemp= NULL;
-
- if(points!=NULL) {
- FreeMatrixd(points);
- points = NULL;
- }
- if(joints!=NULL) {
- FreeMatrixd(joints);
- joints = NULL;
- }
- if(jndx != NULL) {
- FreeVecti(jndx);
- jndx = NULL;
- }
-
-
- magx = magx_orig;
- magy = magy_orig;
- magz = magz_orig;
-}
diff --git a/CEP/PyBDSM/src/natgrid/Src/natgridd.c b/CEP/PyBDSM/src/natgrid/Src/natgridd.c
deleted file mode 100644
index 6f8d0932afab01b4c62e5e575478b9287a0b1658..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/natgrid/Src/natgridd.c
+++ /dev/null
@@ -1,158 +0,0 @@
-#include "nnghead.h"
-#include "nngheadd.h"
-
-double *c_natgridd(int n, double x[], double y[], double z[],
- int nxi, int nyi, double xi[], double yi[], int *ier)
-{
- double **data_out=NULL, *rtrn_val=NULL;
-
- *ier = 0;
-
- if (single_point == 0)
- {
- asflag = 1;
- Initialized(n, x, y, nxi, nyi, xi, yi);
-
- if (ReadDatad(n,x,y,z) != 0)
- {
- *ier = error_status;
- return ( (double *) NULL);
- }
- }
-
- if (adf)
- {
- CircOut();
- if (error_status)
- {
- *ier = error_status;
- return ( (double *) NULL);
- }
- }
- if (igrad)
- {
- Gradient();
- if (error_status)
- {
- *ier = error_status;
- return ( (double *) NULL);
- }
- }
-
- data_out = MakeGridd(nxi, nyi, xi, yi);
- if (error_status)
- {
- if((data_out !=NULL)&&(data_out[0]!=NULL)) {
- free(data_out[0]);
- free(data_out);
- }
- *ier = error_status;
- return ( (double *) NULL);
- }
-
- if (single_point == 0)
- {
- Terminate();
- }
-
- horilap = -1.;
- vertlap = -1.;
-
- rtrn_val = data_out[0];
- free(data_out);
- return (rtrn_val);
-}
-void Initialized(int n, double x[], double y[], int nxi, int nyi,
- double xi[], double yi[])
-{
-
- double xil, xir, yib, yit;
-
- error_status = 0;
- datcnt = 0;
- magx_orig = magx;
- magy_orig = magy;
- magz_orig = magz;
- iscale = 0;
- magx_auto = 1.;
- magy_auto = 1.;
- magz_auto = 1.;
-
-/*
- * Find the limits of the output array.
- */
- xstart = armind(nxi, xi);
- xend = armaxd(nxi, xi);
- ystart = armind(nyi, yi);
- yend = armaxd(nyi, yi);
-
-/*
- * Find the limits of the input array.
- */
- xil = armind(n, x);
- xir = armaxd(n, x);
- yib = armind(n, y);
- yit = armaxd(n, y);
-
-/*
- * As the default (that is, unless horizontal and vertical overlaps
- * have been specifically set by the user) choose the overlap values
- * as the smallest values that will make all input data points included
- * in the overlap region.
- */
- if (horilap EQ -1.) {
- if ( (xstart >= xil) && (xend <= xir) ) {
- horilap = 1.01 * (((xstart-xil) < (xir-xend)) ?
- (xir-xend) : (xstart-xil));
- }
- else if ( (xstart >= xil) && (xend >= xir) ) {
- horilap = 1.01 * (xstart-xil);
- }
- else if ( (xstart <= xil) && (xend <= xir) ) {
- horilap = 1.01 * (xir-xend);
- }
- else if ( (xstart <= xil) && (xir <= xend) ) {
- horilap = 0.;
- }
- }
- if (horilap <= EPSILON) {
- horilap = 0.01 * (xend - xstart);
- }
- if (vertlap EQ -1.) {
- if ( (yib <= ystart) && (yend <= yit) ) {
- vertlap = 1.01 * (((ystart-yib) < (yit-yend)) ?
- (yit-yend) : (ystart-yib));
- }
- else if ( (ystart <= yib) && (yend <= yit) ) {
- vertlap = 1.01 * (yit-yend);
- }
- else if ( (yib <= ystart) && (yit <= yend) ) {
- vertlap = 1.01 * (ystart-yib);
- }
- else if ( (ystart <= yib) && (yit <= yend) ) {
- vertlap = 0.;
- }
- }
- if (vertlap <= EPSILON) {
- vertlap = 0.01 * (yend - ystart);
- }
-}
-
-double armind(int num, double *x)
-{
- int i;
- float amin;
- amin = x[0];
- for (i = 1 ; i < num ; i++)
- if (x[i] < amin) amin = x[i];
- return(amin);
-}
-double armaxd(int num, double *x)
-{
- int i;
- float amax;
- amax = x[0];
- for (i = 1 ; i < num ; i++)
- if (x[i] > amax) amax = x[i];
- return(amax);
-}
diff --git a/CEP/PyBDSM/src/natgrid/Src/natgridmodule.c b/CEP/PyBDSM/src/natgrid/Src/natgridmodule.c
deleted file mode 100755
index 012573bfe93eba7dffde6c80eb61d7ac1dac13f3..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/natgrid/Src/natgridmodule.c
+++ /dev/null
@@ -1,1587 +0,0 @@
- /************************************************************************************************
- * *
- * natgridmodule.c: a C extension which exports the following functions to Python: *
- * *
- * Single precision procedures: *
- * *
- * natgrids - primary function for gridding. *
- * seti - set int parameter values. *
- * geti - retrieve values for int parameters. *
- * setr - set float parameter values. *
- * getr - retrieve values for float parameters *
- * setc - set char parameter values. *
- * getc - retrieve values for char parameters. *
- * getaspects - get aspect values, if calculated. *
- * getslopes - get slope values, if calculated. *
- * pntinits - initiate single point mode. *
- * pnts - interpolate at a single point. *
- * pntend _ terminate single point mode. *
- * *
- * *
- * Double precision procedures: *
- * *
- * natgridd - primary function for gridding. *
- * setrd - set float parameter values. *
- * getrd - retrieve values for float parameters *
- * getaspectd - get aspect values, if calculated. *
- * getsloped - get slope values, if calculated. *
- * pntinitd - initiate single point mode. *
- * pntd - interpolate at a single point. *
- * pntendd _ terminate single point mode. *
- * *
- * where is getwts and getwtd *
- * *
- *************************************************************************************************/
-
-#include "Python.h"
-#include "numpy/arrayobject.h"
-#include <stdio.h>
-#include <stdlib.h>
-#include <string.h>
-#include <math.h>
-
-#define PRINTNATGRIDS 0
-#define WRITENATGRIDS 0
-#define PRINTPNTINITS 0
-#define WRITEPNTINITS 0
-
-static PyObject *ErrorObject; /* locally raised exception */
-
-/*---------------------------------------- Macros -----------------------------------------------*/
-
-#define onError(message) { PyErr_SetString(ErrorObject, message); return NULL; }
-
-/*--------------------------------- Function Prototypes -----------------------------------------*/
-
-/* ---- external C functions in the library ---- */
-
-extern float *c_natgrids(int npnts, float x[], float y[], float z[], int numxout, int numyout,
- float xo[], float yo[], int *ier);
-
-extern void c_nnseti(char *pnam, int ival);
-
-extern void c_nngeti(char *pnam, int *ival);
-
-extern void c_nnsetr(char *pnam, float fval);
-
-extern void c_nngetr(char *pnam, float *fval);
-
-extern void c_nnsetc(char *pnam, char *cval);
-
-extern void c_nngetc(char *pnam, char *cval);
-
-extern void c_nngetaspects(int row, int column, float *aspect, int *ier);
-
-extern void c_nngetslopes(int row, int column, float *slope, int *ier);
-
-extern void c_nnpntinits(int row, float x[], float y[], float z[]);
-
-extern void c_nnpnts(float x, float y, float *z);
-
-extern void c_nnpntend();
-
-extern double *c_natgridd(int n, double x[], double y[], double z[], int numxout, int numyout,
- double xo[], double yo[], int *ier);
-
-extern void c_nnsetrd(char *pnam, double dval);
-
-extern void c_nngetrd(char *pnam, double *dval);
-
-extern void c_nngetaspectd(int row, int column, double *aspect, int *ier);
-
-extern void c_nngetsloped(int row, int column, double *slope, int *ier);
-
-extern void c_nnpntinitd(int row, double x[], double y[], double z[]);
-
-extern void c_nnpntd(double x, double y, double *z);
-
-extern void c_nnpntendd();
-
-/* ---- functions in this file called by c extensions ---- */
-
-void write_int(int size, char *title, FILE *fp, int *data);
-
-void write_float(int size, char *title, FILE *fp, float *data);
-void print_float(int size, char *title, float *data);
-
-void write_double(int size, char *title, FILE *fp, double *data);
-void print_double(int size, char *title, double *data);
-
-
- /*************************************************************************************************
- **************************************************************************************************
- * *
- * EXPORTED MODULE METHOD-FUNCTIONS *
- * *
- * *
- **************************************************************************************************
- **************************************************************************************************/
-
-static char nat_c_natgrids__doc__[] = " \n\
- \n\
- natgrids - Primary gridding function \n\
- \n\
- natgrids is the C single precision function that does an interpolation from 2D random data \n\
- to a output grid. natgrids is called after all the desired values for the control parameters \n\
- have been set using the procedures seti, setr, setc and setd. \n\
- \n\
- natgrids returns a pointer to a linear array of data that is the interpolated grid stored in \n\
- row-major order. That is, if out is declared as \n\
- float out; \n\
- and we set: \n\
- out = natgrids(npnts, x, y, z, numxout, numyout, xo, yo, &ier); \n\
- then out[i numyout + j] is the interpolated value at coordinate point (xo[i], y[j]) for \n\
- 0 <= i < numxout and 0 <= j < numyout. The space for out is allocated internal to natgrids \n\
- and is numxout numyout floats in size. \n\
- \n\
- Prototype: \n\
- \n\
- extern float c_natgrids(int npnts, float x[], float y[], float z[], \n\
- int numxout, int numyout, float xo[], float yo[], int ier); \n\
- \n\
- Call from Python: \n\
- \n\
- out, ier = natgrids(npnts, x, y, z, numxout, numyout, xo, yo) \n\
- \n\
- where: \n\
- \n\
- npnts -- the number of input data points \n\
- \n\
- x -- array of size npnts containing the x coordinates of the input data points \n\
- \n\
- y -- array of size npnts containing the y coordinates of the input data points \n\
- \n\
- z -- array of size npnts containing the functional values of the input data points. That is, \n\
- z[j] is the value of the input function at coordinate (x[j], y[j]), for 0 <= j < npnts. \n\
- \n\
- numxout -- the number of x values in the output grid, \n\
- \n\
- numyout -- the number of y values in the output grid. \n\
- \n\
- xo -- array of size numxout containing the x coordinates of the output data grid. The values \n\
- of xo must be increasing, but need not be equally spaced. \n\
- \n\
- yo -- array of size numyout containing the y coordinates of the output data grid. The values \n\
- of yo must be increasing, but need not be equally spaced. \n\
- \n\
- ";
-static PyObject *nat_c_natgrids(PyObject *self, PyObject *args)
-{
- /* ----------------------- Declarations ------------------------------------*/
-
- /* fields which are passed from Python in the args tuple */
-
- int npnts; /* The number of input data points */
- PyArrayObject *object_x; /* Object pointer containing the x coordinates of the input data points */
- PyArrayObject *object_y; /* Object pointer containing the y coordinates of the input data points */
- PyArrayObject *object_z; /* Object pointer containing the functional values of the input data points */
-
- int numxout; /* The number of x values in the output grid */
- int numyout; /* The number of y values in the output grid */
-
- PyArrayObject *object_xo; /* Object pointer containing the x coordinates of the output data grid */
- PyArrayObject *object_yo; /* Object pointer containing the y coordinates of the output data grid */
-
- /* fields required by call to c function*/
-
- float *out; /* An array with the interpolated values at the output coordinate points */
-
- int ier; /* An error return value. If *ier is returned as 0, then no errors were detected.
- If ier is non-zero, then refer to the list in the error table for details. */
-
- /* fields required to construct the return of result to python */
-
- PyArrayObject *object_out; /* array object to accept the data and return it to Python */
- int dims[2]; /* used in creating object_out */
-
- /* declarations for writes to a file */
-
- FILE *fp; /* File used in ascii write */
- char *title[6] = { "x", "y ", "z", "xo", "yo", "result" }; /* Titles for print to file */
-
- /* ----------------------- Start Execution ------------------------------------*/
-
- if(!PyArg_ParseTuple(args, "iOOOiiOO", &npnts, &object_x, &object_y, &object_z,
- &numxout, &numyout, &object_xo, &object_yo))
- {
- PyErr_SetString(PyExc_TypeError, "Pass to natgrids is wrong.\n");
- return NULL;
- }
-
- out = (float *)c_natgrids(npnts, (float *)object_x->data, (float *)object_y->data, (float *)object_z->data,
- numxout, numyout, (float *)object_xo->data, (float *)object_yo->data, &ier);
-
- /* -------- create a NumPy array housing the C language data out ----------- */
- dims[0] = numxout;
- dims[1] = numyout;
-
- object_out = (PyArrayObject *)PyArray_FromDimsAndData(2, dims, PyArray_FLOAT, (char *)out);
-
- if (PRINTNATGRIDS == 1) {
- /* -------- print data to the screen ---------- */
- printf("npnts: %d\n", npnts);
- printf("numxout: %d\n", numxout);
- printf("numyout: %d\n", numyout);
- print_float(npnts, title[0], (float *)object_x->data);
- print_float(npnts, title[1], (float *)object_x->data);
- print_float(npnts, title[2], (float *)object_z->data);
- print_float(numxout, title[3], (float *)object_xo->data);
- print_float(numyout, title[4], (float *)object_yo->data);
- print_float(numxout*numyout, title[5], (float *)object_out->data);
- }
-
- if (WRITENATGRIDS == 1) {
- /* -------- write data to a file ----------- */
- if((fp = fopen("natgrids.asc", "w")) == NULL) {
- PyErr_SetString(PyExc_IOError, "Can not open file to write checks");
- return NULL;
- }
-
- fprintf(fp, "npnts: %d\n", npnts);
- fprintf(fp, "numxout: %d\n", numxout);
- fprintf(fp, "numyout: %d\n", numyout);
- write_float(npnts, title[0], fp, (float *)object_x->data);
- write_float(npnts, title[1], fp, (float *)object_y->data);
- write_float(npnts, title[2], fp, (float *)object_z->data);
- write_float(numxout, title[3], fp, (float *)object_xo->data);
- write_float(numyout, title[4], fp, (float *)object_yo->data);
- write_float(numxout*numyout, title[5], fp, (float *)object_out->data);
-
- fclose(fp);
- }
-
- return Py_BuildValue(("Oi"), object_out, ier);
-}
-
-static char nat_c_nnseti__doc__[] =
-" \n\
- \n\
- seti - Set int valued parameters \n\
- \n\
- seti is used to set values for any of the control parameters that take int values. The \n\
- values set by seti remain in effect until changed by subsequent calls to seti. \n\
- \n\
- Prototype: \n\
- \n\
- extern void nnseti(char pnam, int ival); \n\
- \n\
- Call from Python: \n\
- \n\
- seti(pnam, ival) \n\
- \n\
- where: \n\
- \n\
- pnam -- the name of the control parameter whic is assigned an int value. \n\
- \n\
- ival -- the value to be assigned to the control parameter whose name is pointed to by pnam. \n\
- \n\
- ";
-static PyObject *nat_c_nnseti(PyObject *self, PyObject *args)
-{
- /* ----------------------- Declarations ------------------------------------*/
-
- /* fields which are passed from Python in the args tuple */
-
- char *pnam; /* the name of the control parameter to be assigned an int value */
- int ival; /* value to be assigned to the control parameter whose name is pointed to by pnam */
-
- /* ----------------------- Start Execution ------------------------------------*/
-
- if(!PyArg_ParseTuple(args, "si", &pnam, &ival))
- {
- PyErr_SetString(PyExc_TypeError, "Pass to nnseti is wrong.\n");
- return NULL;
- }
-
- c_nnseti(pnam, ival);
-
- Py_INCREF(Py_None);
- return Py_None;
-}
-
-static char nat_c_nngeti__doc__[] =
-" \n\
- \n\
- geti - Retreive an int valued parameter \n\
- \n\
- geti is called to obtain current values for any of the int valued control parameters. \n\
- \n\
- Prototype: \n\
- \n\
- extern void c_nngeti(char pnam, int ival); \n\
- \n\
- Call from Python: \n\
- \n\
- ival = geti(pnam) \n\
- \n\
- where: \n\
- \n\
- pnam -- the name of the control parameter which is assigned an int value. \n\
- \n\
- ival -- the value currently assigned to the control parameter whose name is pointed to by pnam. \n\
- \n\
- ";
-static PyObject *nat_c_nngeti(PyObject *self, PyObject *args)
-{
- /* ----------------------- Declarations ------------------------------------*/
-
- /* fields which are passed from Python in the args tuple */
-
- char *pnam; /* the name of the control parameter whose value is to be retrieved */
-
- /* fields required by call to c function*/
-
- int ival; /* the value currently assigned to the control parameter whose name is
- pointed to by pnam */
-
- /* ----------------------- Start Execution ------------------------------------*/
-
- if(!PyArg_ParseTuple(args, "s", &pnam))
- {
- PyErr_SetString(PyExc_TypeError, "Pass to nngeti is wrong.\n");
- return NULL;
- }
-
- c_nngeti(pnam, &ival);
-
- return Py_BuildValue("i", ival);
-}
-
-static char nat_c_nnsetr__doc__[] =
-" \n\
- \n\
- setr - Set float valued parameters \n\
- \n\
- setr is used to set values for any of the control parameters that take float values. The \n\
- values set by setr remain in effect until changed by subsequent calls to setr. \n\
- \n\
- Prototype: \n\
- \n\
- extern void c_nnsetr(char pnam, float fval); \n\
- \n\
- Call from Python: \n\
- \n\
- setr(pnam, fval) \n\
- \n\
- where: \n\
- \n\
- pnam -- the name of the control parameter to be assigned an float value. \n\
- \n\
- fval -- the value to be assigned to the control parameter whose name is pointed to by pnam. \n\
- \n\
- ";
-static PyObject *nat_c_nnsetr(PyObject *self, PyObject *args)
-{
- /* ----------------------- Declarations ------------------------------------*/
-
- /* fields which are passed from Python in the args tuple */
-
- char *pnam; /* the name of the control parameter to be assigned a float value */
- float fval; /* value to be assigned to the control parameter whose name is pointed to by pnam */
-
- /* ----------------------- Start Execution ------------------------------------*/
-
- if(!PyArg_ParseTuple(args, "sf", &pnam, &fval))
- {
- PyErr_SetString(PyExc_TypeError, "Pass to nnsetr is wrong.\n");
- return NULL;
- }
-
- c_nnsetr(pnam, fval);
-
- Py_INCREF(Py_None);
- return Py_None;
-}
-
-static char nat_c_nngetr__doc__[] =
-" \n\
- \n\
- getr - Retreive an float valued parameter \n\
- \n\
- getr is called to obtain current values for any of the float valued control parameters. \n\
- \n\
- Prototype: \n\
- \n\
- extern void c_nngetr(char pnam, int fval); \n\
- \n\
- Call from Python: \n\
- \n\
- fval = getr(pnam) \n\
- \n\
- where: \n\
- \n\
- pnam -- the name of the control parameter which is assigned a float value. \n\
- \n\
- fval -- the value currently assigned to the control parameter whose name is pointed to by pnam. \n\
- \n\
- ";
-static PyObject *nat_c_nngetr(PyObject *self, PyObject *args)
-{
- /* ----------------------- Declarations ------------------------------------*/
-
- /* fields which are passed from Python in the args tuple */
-
- char *pnam; /* the name of the control parameter whose value is to be retrieved */
-
- /* fields required by call to c function*/
-
- float fval; /* the value currently assigned to the control parameter whose name is
- pointed to by pnam */
-
- /* ----------------------- Start Execution ------------------------------------*/
-
- if(!PyArg_ParseTuple(args, "s", &pnam))
- {
- PyErr_SetString(PyExc_TypeError, "Pass to nngetr is wrong.\n");
- return NULL;
- }
-
- c_nngetr(pnam, &fval);
-
- return Py_BuildValue("f", fval);
-}
-
-static char nat_c_nnsetc__doc__[] =
-" \n\
- \n\
- setc - Set char valued parameters \n\
- \n\
- setc is used to set values for any of the control parameters that take string values. The \n\
- values set by setc remain in effect until changed by subsequent calls to setc. \n\
- \n\
- Prototype: \n\
- \n\
- extern void c_nnsetc(char pnam, char cval); \n\
- \n\
- Call from Python: \n\
- \n\
- setc(pnam, cval) \n\
- \n\
- where: \n\
- \n\
- pnam -- the name of the control parameter to be assigned a char value. \n\
- \n\
- cval -- the value to be assigned to the control parameter whose name is pointed to by pnam. \n\
- \n\
- ";
-static PyObject *nat_c_nnsetc(PyObject *self, PyObject *args)
-{
- /* ----------------------- Declarations ------------------------------------*/
-
- /* fields which are passed from Python in the args tuple */
-
- char *pnam; /* the name of the control parameter to be assigned a char value */
- char *cval; /* value to be assigned to the control parameter whose name is pointed to by pnam */
-
- /* ----------------------- Start Execution ------------------------------------*/
-
- if(!PyArg_ParseTuple(args, "ss", &pnam, &cval))
- {
- PyErr_SetString(PyExc_TypeError, "Pass to nnsetc is wrong.\n");
- return NULL;
- }
-
- c_nnsetc(pnam, cval);
-
- Py_INCREF(Py_None);
- return Py_None;
-}
-
-static char nat_c_nngetc__doc__[] =
-" \n\
- \n\
- getc - Retreive an char valued parameter \n\
- \n\
- getc is called to obtain current values for any of the string valued control parameters. \n\
- \n\
- Prototype: \n\
- \n\
- extern void c_nngetc(char pnam, char cval); \n\
- \n\
- Call from Python: \n\
- \n\
- cval = getc(pnam) \n\
- \n\
- where: \n\
- \n\
- pnam -- the name of the control parameter which is assigned a string value. \n\
- \n\
- cval -- the value currently assigned to the control parameter whose name is pointed to by pnam. \n\
- \n\
- ";
-static PyObject *nat_c_nngetc(PyObject *self, PyObject *args)
-{
- /* ----------------------- Declarations ------------------------------------*/
-
- /* fields which are passed from Python in the args tuple */
-
- char *pnam; /* the name of the control parameter whose value is to be retrieved */
-
- /* fields required by call to c function*/
-
- char cval[128]; /* the value currently assigned to the control parameter whose name is
- pointed to by pnam */
-
- /* ----------------------- Start Execution ------------------------------------*/
-
- if(!PyArg_ParseTuple(args, "s", &pnam))
- {
- PyErr_SetString(PyExc_TypeError, "Pass to nngetc is wrong.\n");
- return NULL;
- }
-
- c_nngetc(pnam, cval);
-
- return Py_BuildValue("s", cval);
-}
-
-static char nat_c_nngetaspects__doc__[] =
-" \n\
- \n\
- getaspects - Retreive aspect values, if calculated \n\
- \n\
- getaspects is called to retrieve an aspect, in single-precision, at a specified coordinate \n\
- value. For further details see the module on computing aspects and slopes. \n\
- \n\
- Prototype: \n\
- \n\
- extern void c_nngetaspects(int row, int column, float aspect, int ier); \n\
- \n\
- Call from Python: \n\
- \n\
- aspect, ier = getaspects(row, column) \n\
- \n\
- where: \n\
- \n\
- row -- a subscript indexing the first dimenioned variable in the 2D grid array returned from \n\
- the most recent call to natgrids. \n\
- \n\
- column -- a subscript indexing the second dimenioned variable in the 2D grid array returned \n\
- from the most recent call to natgrids. \n\
- \n\
- aspect -- the aspect at the grid point z[i][j], where z is the output grid in the most recent \n\
- call to natgrids. \n\
- \n\
- ier -- an error return value. If ier is returned as 0, then no errors were detected. If ier \n\
- is non-zero, then refer to the list in the error table for details. \n\
- \n\
- ";
-static PyObject *nat_c_nngetaspects(PyObject *self, PyObject *args)
-{
- /* ----------------------- Declarations ------------------------------------*/
-
- /* fields which are passed from Python in the args tuple */
-
- int row; /* A subscript indexing the first dimenioned variable in the 2D grid
- array returned from the most recent call to c_natgrids */
- int column; /* A subscript indexing the second dimenioned variable in the 2D grid
- array returned from the most recent call to c_natgrids */
-
- /* fields required by call to c function*/
-
- float aspect; /* the aspect at the grid point z[i][j], where z is the output grid
- in the most recent call to c_natgrids. */
-
- int ier; /* An error return value. If *ier is returned as 0, then no errors were detected.
- If *ier is non-zero, then refer to the list in the error table for details. */
-
- /* ----------------------- Start Execution ------------------------------------*/
-
- if(!PyArg_ParseTuple(args, "ii", &row, &column))
- {
- PyErr_SetString(PyExc_TypeError, "Pass to nngetaspects is wrong.\n");
- return NULL;
- }
-
- c_nngetaspects(row, column, &aspect, &ier);
-
- return Py_BuildValue("fi", aspect, ier);
-}
-
-static char nat_c_nngetslopes__doc__[] =
-" \n\
- \n\
- getslopes - Retreive slope values, if calculated \n\
- \n\
- getslopes is called to retrieve a slope, in single-precision, at a specified coordinate \n\
- value. For further details see the module on computing slopes and slopes. \n\
- \n\
- Prototype: \n\
- \n\
- extern void c_nngetslopes(int row, int column, float slope, int ier); \n\
- \n\
- Call from Python: \n\
- \n\
- slope, ier = getslopes(row, column) \n\
- \n\
- where: \n\
- \n\
- row -- a subscript indexing the first dimenioned variable in the 2D grid array returned from \n\
- the most recent call to natgrids. \n\
- \n\
- column -- a subscript indexing the second dimenioned variable in the 2D grid array returned \n\
- from the most recent call to natgrids. \n\
- \n\
- slope -- the slope at the grid point z[i][j], where z is the output grid in the most recent \n\
- call to natgrids. \n\
- \n\
- ier -- an error return value. If ier is returned as 0, then no errors were detected. If ier \n\
- is non-zero, then refer to the list in the error table for details. \n\
- \n\
- ";
-static PyObject *nat_c_nngetslopes(PyObject *self, PyObject *args)
-{
- /* ----------------------- Declarations ------------------------------------*/
-
- /* fields which are passed from Python in the args tuple */
-
- int row; /* A subscript indexing the first dimenioned variable in the 2D grid
- array returned from the most recent call to c_natgrids */
- int column; /* A subscript indexing the second dimenioned variable in the 2D grid
- array returned from the most recent call to c_natgrids */
-
- /* fields required by call to c function*/
-
- float slope; /* the slope at the grid point z[i][j], where z is the output grid
- in the most recent call to c_natgrids. */
-
- int ier; /* An error return value. If *ier is returned as 0, then no errors were detected.
- If *ier is non-zero, then refer to the list in the error table for details. */
-
- /* ----------------------- Start Execution ------------------------------------*/
-
- if(!PyArg_ParseTuple(args, "ii", &row, &column))
- {
- PyErr_SetString(PyExc_TypeError, "Pass to nngetslopes is wrong.\n");
- return NULL;
- }
-
- c_nngetslopes(row, column, &slope, &ier);
-
- return Py_BuildValue("fi", slope, ier);
-}
-
-static char nat_c_nnpntinits__doc__[] =
-" \n\
- \n\
- pntinits - Enter single-point mode \n\
- \n\
- This function calculates all naturnal neighbor relationships in an input data array and sets \n\
- some internal parameters so that pnts can be called to interpolate at individual points. \n\
- \n\
- Prototype: \n\
- \n\
- extern void c_nnpntinits(int row, float x[], float y[], float z[]); \n\
- \n\
- Call from Python: \n\
- \n\
- pntinits(n, x, y, z) \n\
- \n\
- where: \n\
- \n\
- n -- the number of input data points \n\
- \n\
- x -- array of size npnts containing the x coordinates of the input data points \n\
- \n\
- y -- array of size npnts containing the y coordinates of the input data points \n\
- \n\
- z -- array of size npnts containing the functional values of the input data points. That is, \n\
- z[j] is the value of the input function at coordinate (x[j], y[j]), for 0 <= j < npnts. \n\
- \n\
- ";
-static PyObject *nat_c_nnpntinits(PyObject *self, PyObject *args)
-{
- /* ----------------------- Declarations ------------------------------------*/
-
- /* fields which are passed from Python in the args tuple */
-
- int npnts; /* the number of input data points (npnts > 3 )*/
-
- PyArrayObject *object_x; /* object pointer containing the x coordinates of the input data points */
- PyArrayObject *object_y; /* object pointer containing the y coordinates of the input data points */
- PyArrayObject *object_z; /* object pointer containing the functional values at the input data points */
-
- /* declarations for writes to a file */
-
- FILE *fp; /* File used in ascii write */
- char *title[3] = {"x", "y ", "z"}; /* Titles for print to file */
-
- /* ----------------------- Start Execution ------------------------------------*/
-
- if(!PyArg_ParseTuple(args, "iOOO", &npnts, &object_x, &object_y, &object_z))
- {
- PyErr_SetString(PyExc_TypeError, "Pass to nnpntinits is wrong.\n");
- return NULL;
- }
-
- /* -------- write input data to a file ----------- */
-
- c_nnpntinits(npnts, (float *)object_x->data, (float *)object_y->data, (float *)object_z->data);
-
- if (PRINTPNTINITS == 1) {
- /* -------- print data to the screen ---------- */
- printf("npnts: %d\n", npnts);
- print_float(npnts, title[0], (float *)object_x->data);
- print_float(npnts, title[1], (float *)object_x->data);
- print_float(npnts, title[2], (float *)object_z->data);
- }
-
- if (WRITEPNTINITS == 1) {
- /* -------- write data to a file ----------- */
- if((fp = fopen("pntinits.asc", "w")) == NULL) {
- PyErr_SetString(PyExc_IOError, "Can not open file to write checks");
- return NULL;
- }
-
- fprintf(fp, "npnts: %d\n", npnts);
- write_float(npnts, title[0], fp, (float *)object_x->data);
- write_float(npnts, title[1], fp, (float *)object_y->data);
- write_float(npnts, title[2], fp, (float *)object_z->data);
-
- fclose(fp);
- }
-
- Py_INCREF(Py_None);
- return Py_None;
-}
-
-static char nat_c_nnpnts__doc__[] =
-" \n\
- \n\
- pnts - Interpolate at a single point \n\
- \n\
- This function is called to interpolate at a specified point. Before calling this function, \n\
- pntinits must be called. \n\
- \n\
- Prototype: \n\
- \n\
- extern void c_nnpnts(float x, float y, float z); \n\
- \n\
- Call from Python: \n\
- \n\
- z = pnts(x, y) \n\
- \n\
- where: \n\
- \n\
- x -- x coordinate of the point where interpolation is desired. \n\
- \n\
- y -- y coordinate of the point where interpolation is desired. \n\
- \n\
- z -- the interpolated functional value at (x,y). \n\
- \n\
- ";
-static PyObject *nat_c_nnpnts(PyObject *self, PyObject *args)
-{
- /* ----------------------- Declarations ------------------------------------*/
-
- /* fields which are passed from Python in the args tuple */
-
- float x; /* x coordinate of the point where interpolation is desired */
- float y; /* y coordinate of the point where interpolation is desired */
-
- /* fields required by call to c function*/
-
- float z; /* the interpolated functional value at (x,y) */
-
- /* ----------------------- Start Execution ------------------------------------*/
-
- if(!PyArg_ParseTuple(args, "ff", &x, &y))
- {
- PyErr_SetString(PyExc_TypeError, "Pass to nnpnts is wrong.\n");
- return NULL;
- }
-
- c_nnpnts(x, y, &z);
-
- return Py_BuildValue("f", z);
-}
-
-static char nat_c_nnpntend__doc__[] =
-" \n\
- \n\
- pntend - Exit single-point mode \n\
- \n\
- This function is called to terminate interpolation at single points. It is called after having \n\
- made previous calls to pntinits and pnts. \n\
- \n\
- Prototype: \n\
- \n\
- extern void c_nnpntend(); \n\
- \n\
- Call from Python: \n\
- \n\
- pntend() \n\
- \n\
- ";
-static PyObject *nat_c_nnpntend(PyObject *self, PyObject *args)
-{
- /* ----------------------- Start Execution ------------------------------------*/
-
-
- if(!PyArg_ParseTuple(args, ""))
- {
- PyErr_SetString(PyExc_TypeError, "Pass to nnpntend is wrong.\n");
- return NULL;
- }
-
- c_nnpntend();
-
- Py_INCREF(Py_None);
- return Py_None;
-}
-
-static char nat_c_natgridd__doc__[] =
-" \n\
- \n\
- natgridd - Primary gridding function \n\
- \n\
- natgridd is the C double-precision function that does an interpolation from 2D random data \n\
- to a output grid. natgridd is called after all the desired values for the control parameters \n\
- have been set using the procedures seti, setr and setc. \n\
- \n\
- natgridd returns a pointer to a linear array of data that is the interpolated grid stored in \n\
- row-major order. That is, if out is declared as \n\
- double out; \n\
- and we set: \n\
- out = natgridd(npnts, x, y, z, numxout, numyout, xo, yo, &ier); \n\
- then out[i numyout + j] is the interpolated value at coordinate point (xo[i], y[j]) for \n\
- 0 <= i < numxout and 0 <= j < numyout. The space for out is allocated internal to natgridd \n\
- and is numxout numyout floats in size. \n\
- \n\
- Prototype: \n\
- \n\
- extern double c_natgridd(int n, double x[], double y[], double z[], int numxout, \n\
- int numyout, double xo[], double yo[], int ier); \n\
- \n\
- Call from Python: \n\
- \n\
- out, ier = natgridd(npnts, x, y, z, numxout, numyout, xi, yi) \n\
- \n\
- where: \n\
- \n\
- npnts -- the number of input data points \n\
- \n\
- x -- array of size npnts containing the x coordinates of the input data points \n\
- \n\
- y -- array of size npnts containing the y coordinates of the input data points \n\
- \n\
- z -- array of size npnts containing the functional values of the input data points. That is, \n\
- z[j] is the value of the input function at coordinate (x[j], y[j]), for 0 <= j < npnts. \n\
- \n\
- numxout -- the number of x values in the output grid, \n\
- \n\
- numyout -- the number of y values in the output grid. \n\
- \n\
- xo -- array of size numxout containing the x coordinates of the output data grid. The values \n\
- of xo must be increasing, but need not be equally spaced. \n\
- \n\
- yo -- array of size numyout containing the y coordinates of the output data grid. The values \n\
- of yo must be increasing, but need not be equally spaced. \n\
- \n\
- ";
-static PyObject *nat_c_natgridd(PyObject *self, PyObject *args)
-{
- /* ----------------------- Declarations ------------------------------------*/
-
- /* fields which are passed from Python in the args tuple */
-
- int npnts; /* the number of input data points */
-
- int numxout; /* the number of x values in the output grid */
- int numyout; /* the number of y values in the output grid */
-
- PyArrayObject *object_x; /* object pointer containing the x coordinates of the input data points */
- PyArrayObject *object_y; /* object pointer containing the y coordinates of the input data points */
- PyArrayObject *object_z; /* Object pointer containing the functional values of the input data points */
- PyArrayObject *object_xo; /* object pointer containing the x coordinates of the output data grid */
- PyArrayObject *object_yo; /* object pointer containing the y coordinates of the output data grid */
-
- /* fields required by call to c function*/
-
- double *out; /* An array with the interpolated values at the coordinate points */
-
- int ier; /* An error return value. If *ier is returned as 0, then no errors were detected.
- If *ier is non-zero, then refer to the list in the error table for details. */
-
- /* fields required to construct the return of result to python */
-
- PyArrayObject *object_out; /* array object to accept the data and return it to Python */
- int dims[2]; /* used in creating object_out */
-
- /* declarations for writes to a file */
-
- FILE *fp; /* File used in ascii write */
- char *title[6] = {"x", "y ", "z", "xo", "yo", "result"}; /* Titles for print to file */
-
- /* ----------------------- Start Execution ------------------------------------*/
-
- if(!PyArg_ParseTuple(args, "iOOOiiOO", &npnts, &object_x, &object_y, &object_z,
- &numxout, &numyout, &object_xo, &object_yo))
- {
- PyErr_SetString(PyExc_TypeError, "Pass to natgridd is wrong.\n");
- return NULL;
- }
-
- out = (double *)c_natgridd(npnts, (double *)object_x->data, (double *)object_y->data, (double *)object_z->data,
- numxout, numyout, (double *)object_xo->data, (double *)object_yo->data, &ier);
-
- /* -------- create a NumPy array housing the c language data out ----------- */
- dims[0] = numxout;
- dims[1] = numyout;
-
- object_out = (PyArrayObject *)PyArray_FromDimsAndData(2, dims, PyArray_DOUBLE, (char *)out);
-
-
- if (PRINTNATGRIDS == 1) {
- /* -------- print data to the screen ---------- */
- printf("npnts: %d\n", npnts);
- printf("numxout: %d\n", numxout);
- printf("numyout: %d\n", numyout);
- print_double(npnts, title[0], (double *)object_x->data);
- print_double(npnts, title[1], (double *)object_x->data);
- print_double(npnts, title[2], (double *)object_z->data);
- print_double(numxout, title[3], (double *)object_xo->data);
- print_double(numyout, title[4], (double *)object_yo->data);
- print_double(numxout*numyout, title[5], (double *)object_out->data);
- }
-
- if (WRITENATGRIDS == 1) {
- /* -------- write data to a file ----------- */
- if((fp = fopen("natgridd.asc", "w")) == NULL) {
- PyErr_SetString(PyExc_IOError, "Can not open file to write checks");
- return NULL;
- }
-
- fprintf(fp, "npnts: %d\n", npnts);
- fprintf(fp, "numxout: %d\n", numxout);
- fprintf(fp, "numyout: %d\n", numyout);
- write_double(npnts, title[0], fp, (double *)object_x->data);
- write_double(npnts, title[1], fp, (double *)object_y->data);
- write_double(npnts, title[2], fp, (double *)object_z->data);
- write_double(numxout, title[3], fp, (double *)object_xo->data);
- write_double(numyout, title[4], fp, (double *)object_yo->data);
- write_double(numxout*numyout, title[5], fp, (double *)object_out->data);
-
- fclose(fp);
- }
-
- return Py_BuildValue(("Oi"), object_out, ier);
-}
-
-static char nat_c_nnsetrd__doc__[] =
-" \n\
- \n\
- setrd - Set double-precision parameters values \n\
- \n\
- setrd is used to set values for any of the control parameters that take double-precision \n\
- values. The values set by setd remain in effect until changed by subsequent calls to \n\
- setrd. \n\
- \n\
- Prototype: \n\
- \n\
- extern void c_nnsetrd(char pnam, double dval); \n\
- \n\
- Call from Python: \n\
- \n\
- setrd(pnam, dval) \n\
- \n\
- where: \n\
- \n\
- pnam -- the name of the control parameter to be assigned an double-precision value. \n\
- \n\
- dval -- the value to be assigned to the control parameter whose name is pointed to by pnam. \n\
- \n\
- ";
-static PyObject *nat_c_nnsetrd(PyObject *self, PyObject *args)
-{
- /* ----------------------- Declarations ------------------------------------*/
-
- /* fields which are passed from Python in the args tuple */
-
- char *pnam; /* the name of the control parameter to be assigned a double value */
- double dval; /* value to be assigned to the control parameter whose name is pointed to by pnam */
-
- /* ----------------------- Start Execution ------------------------------------*/
-
- if(!PyArg_ParseTuple(args, "sd", &pnam, &dval))
- {
- PyErr_SetString(PyExc_TypeError, "Pass to nnsetrd is wrong.\n");
- return NULL;
- }
-
- c_nnsetrd(pnam, dval);
-
- Py_INCREF(Py_None);
- return Py_None;
-}
-
-static char nat_c_nngetrd__doc__[] =
-" \n\
- \n\
- getrd - Retreive an double precision parameter \n\
- \n\
- getrd is called to obtain current values for any of the double-precision control parameters. \n\
- \n\
- Prototype: \n\
- \n\
- extern void c_nngetrd(char pnam, int dval); \n\
- \n\
- Call from Python: \n\
- \n\
- dval = getrd(pnam) \n\
- \n\
- where: \n\
- \n\
- pnam -- the name of the control parameter which is assigned a double precision value. \n\
- \n\
- dval -- the value currently assigned to the control parameter whose name is pointed to by pnam. \n\
- \n\
- ";
-static PyObject *nat_c_nngetrd(PyObject *self, PyObject *args)
-{
- /* ----------------------- Declarations ------------------------------------*/
-
- /* fields which are passed from Python in the args tuple */
-
- char *pnam; /* the name of the control parameter whose value is to be retrieved */
-
- /* fields required by call to c function*/
-
- double dval; /* the value currently assigned to the control parameter whose name is
- pointed to by pnam */
-
- /* ----------------------- Start Execution ------------------------------------*/
-
- if(!PyArg_ParseTuple(args, "s", &pnam))
- {
- PyErr_SetString(PyExc_TypeError, "Pass to nngetrd is wrong.\n");
- return NULL;
- }
-
- c_nngetrd(pnam, &dval);
-
- return Py_BuildValue("d", dval);
-}
-
-static char nat_c_nngetaspectd__doc__[] =
-" \n\
- \n\
- getaspectd - Retreive aspect values, if calculated \n\
- \n\
- getaspectd is called to retrieve an aspect, in double-precision, at a specified coordinate \n\
- value. For further details see the module on computing aspects and slopes. \n\
- \n\
- Prototype: \n\
- \n\
- extern void c_nngetaspectd(int row, int column, double aspect, int ier); \n\
- \n\
- Call from Python: \n\
- \n\
- aspect, ier = getaspectd(row, column) \n\
- \n\
- where: \n\
- \n\
- row -- a subscript indexing the first dimenioned variable in the 2D grid array returned from \n\
- the most recent call to natgridd. \n\
- \n\
- column -- a subscript indexing the second dimenioned variable in the 2D grid array returned \n\
- from the most recent call to natgridd. \n\
- \n\
- aspect -- the aspect at the grid point z[i][j], where z is the output grid in the most recent \n\
- call to natgridd. \n\
- \n\
- ier -- an error return value. If ier is returned as 0, then no errors were detected. If ier \n\
- is non-zero, then refer to the list in the error table for details. \n\
- \n\
- ";
-static PyObject *nat_c_nngetaspectd(PyObject *self, PyObject *args)
-{
- /* ----------------------- Declarations ------------------------------------*/
-
- /* fields which are passed from Python in the args tuple */
-
- int row; /* A subscript indexing the first dimenioned variable in the 2D grid
- array returned from the most recent call to c_natgridd */
- int column; /* A subscript indexing the second dimenioned variable in the 2D grid
- array returned from the most recent call to c_natgridd */
-
- /* fields required by call to c function*/
-
- double aspect; /* the aspect at the grid point z[i][j], where z is the output grid
- in the most recent call to c_natgridd. */
-
- int ier; /* An error return value. If *ier is returned as 0, then no errors were detected.
- If *ier is non-zero, then refer to the list in the error table for details. */
-
- /* ----------------------- Start Execution ------------------------------------*/
-
- if(!PyArg_ParseTuple(args, "ii", &row, &column))
- {
- PyErr_SetString(PyExc_TypeError, "Pass to nngetaspectd is wrong.\n");
- return NULL;
- }
-
- c_nngetaspectd(row, column, &aspect, &ier);
-
- return Py_BuildValue("di", aspect, ier);
-}
-
-static char nat_c_nngetsloped__doc__[] =
-" \n\
- \n\
- getsloped - Retreive slope values, if calculated \n\
- \n\
- getsloped is called to retrieve a slope, in single precision, at a specified coordinate \n\
- value. For further details see the module on computing slopes and slopes. \n\
- \n\
- Prototype: \n\
- \n\
- extern void c_nngetsloped(int row, int column, double slope, int ier); \n\
- \n\
- Call from Python: \n\
- \n\
- slope, ier = getsloped(row, column) \n\
- \n\
- where: \n\
- \n\
- row -- a subscript indexing the first dimenioned variable in the 2D grid array returned from \n\
- the most recent call to natgridd. \n\
- \n\
- column -- a subscript indexing the second dimenioned variable in the 2D grid array returned \n\
- from the most recent call to natgridd. \n\
- \n\
- slope -- the slope at the grid point z[i][j], where z is the output grid in the most recent \n\
- call to natgridd. \n\
- \n\
- ier -- an error return value. If ier is returned as 0, then no errors were detected. If ier \n\
- is non-zero, then refer to the list in the error table for details. \n\
- \n\
- ";
-static PyObject *nat_c_nngetsloped(PyObject *self, PyObject *args)
-{
- /* ----------------------- Declarations ------------------------------------*/
-
- /* fields which are passed from Python in the args tuple */
-
- int row; /* A subscript indexing the first dimenioned variable in the 2D grid
- array returned from the most recent call to c_natgridd */
- int column; /* A subscript indexing the second dimenioned variable in the 2D grid
- array returned from the most recent call to c_natgridd */
-
- /* fields required by call to c function*/
-
- double slope; /* the slope at the grid point z[i][j], where z is the output grid
- in the most recent call to c_natgridd. */
-
- int ier; /* An error return value. If *ier is returned as 0, then no errors were detected.
- If *ier is non-zero, then refer to the list in the error table for details. */
-
- /* ----------------------- Start Execution ------------------------------------*/
-
- if(!PyArg_ParseTuple(args, "ii", &row, &column))
- {
- PyErr_SetString(PyExc_TypeError, "Pass to nngetsloped is wrong.\n");
- return NULL;
- }
-
- c_nngetsloped(row, column, &slope, &ier);
-
- return Py_BuildValue("di", slope, ier);
-}
-
-static char nat_c_nnpntinitd__doc__[] =
-" \n\
- \n\
- pntinitd - Enter single-point mode \n\
- \n\
- This function calculates all naturnal neighbor relationships in an input data array and sets \n\
- some internal parameters so that pnts can be called to interpolate at individual points. \n\
- \n\
- Prototype: \n\
- \n\
- extern void c_nnpntinitd(int row, double x[], double y[], double z[]); \n\
- \n\
- Call from Python: \n\
- \n\
- pntinitd(n, x, y, z) \n\
- \n\
- where: \n\
- \n\
- npnts -- the number of input data points \n\
- \n\
- x -- array of size npnts containing the x coordinates of the input data points \n\
- \n\
- y -- array of size npnts containing the y coordinates of the input data points \n\
- \n\
- z -- array of size npnts containing the functional values of the input data points. That is, \n\
- z[j] is the value of the input function at coordinate (x[j], y[j]), for 0 <= j < npnts. \n\
- \n\
- ";
-static PyObject *nat_c_nnpntinitd(PyObject *self, PyObject *args)
-{
- /* ----------------------- Declarations ------------------------------------*/
-
- /* fields which are passed from Python in the args tuple */
-
- int npnts; /* the number of input data points (npnts > 3)*/
-
- PyArrayObject *object_x; /* object pointer containing the x coordinates of the input data points */
- PyArrayObject *object_y; /* object pointer containing the y coordinates of the input data points */
- PyArrayObject *object_z; /* object pointer containing the functional values at the input data points */
-
- /* declarations for writes to a file */
-
- FILE *fp; /* File used in ascii write */
- char *title[3] = { "x", "y ", "z" }; /* Titles for print to file */
-
- /* ----------------------- Start Execution ------------------------------------*/
-
- if(!PyArg_ParseTuple(args, "iOOO", &npnts, &object_x, &object_y, &object_z))
- {
- PyErr_SetString(PyExc_TypeError, "Pass to nnpntinitd is wrong.\n");
- return NULL;
- }
-
- c_nnpntinitd(npnts, (double *)object_x->data, (double *)object_y->data, (double *)object_z->data);
-
-
- if (PRINTPNTINITS == 1) {
- /* -------- print data to the screen ---------- */
- printf("npnts: %d\n", npnts);
- print_double(npnts, title[0], (double *)object_x->data);
- print_double(npnts, title[1], (double *)object_x->data);
- print_double(npnts, title[2], (double *)object_z->data);
- }
-
- if (WRITEPNTINITS == 1) {
- /* -------- write data to a file ----------- */
- if((fp = fopen("pntinitd.asc", "w")) == NULL) {
- PyErr_SetString(PyExc_IOError, "Can not open file to write checks");
- return NULL;
- }
-
- fprintf(fp, "npnts: %d\n", npnts);
- write_double(npnts, title[0], fp, (double *)object_x->data);
- write_double(npnts, title[1], fp, (double *)object_y->data);
- write_double(npnts, title[2], fp, (double *)object_z->data);
-
- fclose(fp);
- }
-
- Py_INCREF(Py_None);
- return Py_None;
-}
-
-static char nat_c_nnpntd__doc__[] =
-" \n\
- \n\
- pntd - Interpolate at a single point \n\
- \n\
- This function is called to interpolate at a specified point. Before calling this function, \n\
- pntinitd must be called. \n\
- \n\
- Prototype: \n\
- \n\
- extern void c_nnpnts(double x, double y, double z); \n\
- \n\
- Call from Python: \n\
- \n\
- z = pntd(x, y) \n\
- \n\
- where: \n\
- \n\
- x -- x coordinate of the point where interpolation is desired. \n\
- \n\
- y -- y coordinate of the point where interpolation is desired. \n\
- \n\
- z -- the interpolated functional value at (x,y). \n\
- \n\
- ";
-static PyObject *nat_c_nnpntd(PyObject *self, PyObject *args)
-{
- /* ----------------------- Declarations ------------------------------------*/
-
- /* fields which are passed from Python in the args tuple */
-
- double x; /* x coordinate of the point where interpolation is desired */
- double y; /* y coordinate of the point where interpolation is desired */
-
- /* fields required by call to c function*/
-
- double z; /* the interpolated functional value at (x,y) */
-
- /* ----------------------- Start Execution ------------------------------------*/
-
- if(!PyArg_ParseTuple(args, "dd", &x, &y))
- {
- PyErr_SetString(PyExc_TypeError, "Pass to nnpntd is wrong.\n");
- return NULL;
- }
-
- c_nnpntd(x, y, &z);
-
- return Py_BuildValue("d", z);
-}
-
-static char nat_c_nnpntendd__doc__[] =
-" \n\
- \n\
- pntend - Exit single-point mode \n\
- \n\
- This function is called to terminate interpolation at single points. It is called after having \n\
- made previous calls to pntinitd and pntd. \n\
- \n\
- Prototype: \n\
- \n\
- extern void c_nnpntendd(); \n\
- \n\
- Call from Python: \n\
- \n\
- pntendd() \n\
- \n\
- ";
-static PyObject *nat_c_nnpntendd(PyObject *self, PyObject *args)
-{
- /* ----------------------- Start Execution ------------------------------------*/
-
- if(!PyArg_ParseTuple(args, ""))
- {
- PyErr_SetString(PyExc_TypeError, "Pass to nnpntendd is wrong.\n");
- return NULL;
- }
-
- c_nnpntendd();
-
- Py_INCREF(Py_None);
- return Py_None;
-}
-
- /*************************************************************************
- * *
- * METHOD REGISTRATION TABLE: NAME-STRING -> FUNCTION-POINTER
- *
- * *
-\**************************************************************************/
-static struct PyMethodDef nat_methods[] = {
-
- { "natgrids", (PyCFunction)nat_c_natgrids, METH_VARARGS, nat_c_natgrids__doc__ },
- { "seti", (PyCFunction)nat_c_nnseti, METH_VARARGS, nat_c_nnseti__doc__ },
- { "geti", (PyCFunction)nat_c_nngeti, METH_VARARGS, nat_c_nngeti__doc__ },
- { "setr", (PyCFunction)nat_c_nnsetr, METH_VARARGS, nat_c_nnsetr__doc__ },
- { "getr", (PyCFunction)nat_c_nngetr, METH_VARARGS, nat_c_nngetr__doc__ },
- { "setc", (PyCFunction)nat_c_nnsetc, METH_VARARGS, nat_c_nnsetc__doc__ },
- { "getc", (PyCFunction)nat_c_nngetc, METH_VARARGS, nat_c_nngetc__doc__ },
- { "getaspects", (PyCFunction)nat_c_nngetaspects, METH_VARARGS, nat_c_nngetaspects__doc__},
- { "getslopes", (PyCFunction)nat_c_nngetslopes, METH_VARARGS, nat_c_nngetslopes__doc__ },
- { "pntinits", (PyCFunction)nat_c_nnpntinits, METH_VARARGS, nat_c_nnpntinits__doc__ },
- { "pnts", (PyCFunction)nat_c_nnpnts, METH_VARARGS, nat_c_nnpnts__doc__ },
- { "pntend", (PyCFunction)nat_c_nnpntend, METH_VARARGS, nat_c_nnpntend__doc__ },
-
- { "natgridd", (PyCFunction)nat_c_natgridd, METH_VARARGS, nat_c_natgridd__doc__ },
- { "setrd", (PyCFunction)nat_c_nnsetrd, METH_VARARGS, nat_c_nnsetrd__doc__ },
- { "getrd", (PyCFunction)nat_c_nngetrd, METH_VARARGS, nat_c_nngetrd__doc__ },
- { "getaspectd", (PyCFunction)nat_c_nngetaspectd, METH_VARARGS, nat_c_nngetaspectd__doc__},
- { "getsloped", (PyCFunction)nat_c_nngetsloped, METH_VARARGS, nat_c_nngetsloped__doc__ },
- { "pntinitd", (PyCFunction)nat_c_nnpntinitd, METH_VARARGS, nat_c_nnpntinitd__doc__ },
- { "pntd", (PyCFunction)nat_c_nnpntd, METH_VARARGS, nat_c_nnpntd__doc__ },
- { "pntendd", (PyCFunction)nat_c_nnpntendd, METH_VARARGS, nat_c_nnpntendd__doc__ },
- { NULL, NULL, 0, NULL }
-};
-
- /*************************************************************************
- * *
- * INITIALIZATION FUNCTION
- *
- * *
-\**************************************************************************/
-void initnatgridmodule()
-{
- PyObject *m, *d;
-
- /* create this module and add the functions */
- m = Py_InitModule("natgridmodule", nat_methods);
- import_array();
-
- /* add symbolic constants to the module */
- d = PyModule_GetDict(m);
- ErrorObject = Py_BuildValue("s", "natgridmodule.error");
- PyDict_SetItemString(d, "error", ErrorObject);
-
- /* check for errors */
- if(PyErr_Occurred())
- Py_FatalError("can't initialize module natgridmodule");
-}
-
- /*************************************************************************
- * *
- * C FUNCTIONS USED IN THE C-EXTENSIONS
- * *
-\**************************************************************************/
-
-/********************************************************************************
-* Function: write_int.c
-*
-* Procedure: Uses 5d format to write 6 numbers per line
-* Purpose: write ascii data for one horizontal field or one cross section
-*
-* Passed: Data, pointer to start of data
-********************************************************************************/
-void write_int(int size, char *title, FILE *fp, int *data)
-{
-
- int n; /* data counter */
- int line; /* counter to insert a line after each six numbers */
- int *d; /* pointer to increment through data */
-
- d = data;
- line = 0;
-
- fprintf(fp, "\n%s\n", title);
-
- for(n=0; n<size; n++) {
- fprintf(fp, "%5d", *d);
- d++;
- line++;
-
- if(line == 16) { /* add newline after writing 16 numbers */
- fprintf(fp, "\n");
- line = 0;
- }
- }
-}
-
-/********************************************************************************
-* Function: write_float.c
-*
-* Procedure: Uses 10.3e format to write 6 numbers per line
-* Purpose: write ascii data for one horizontal field or one cross section
-*
-* Passed: Data, pointer to start of data
-********************************************************************************/
-void write_float(int size, char *title, FILE *fp, float *data)
-{
-
- int n; /* data counter */
- int line; /* counter to insert a line after each six numbers */
- float *d; /* pointer to increment through data */
-
- d = data;
- line = 0;
-
- fprintf(fp, "\n%s\n", title);
-
- for(n=0; n<size; n++) {
- fprintf(fp, "%10.3e", *d);
- d++;
- line++;
-
- if(line == 8) { /* add newline after writing 8 numbers */
- fprintf(fp, "\n");
- line = 0;
- }
- }
-}
-
-/********************************************************************************
-* Function: print _float.c
-*
-* Procedure: Uses 10.3e format to write 6 numbers per line
-* Purpose: write ascii data for one horizontal field or one cross section
-*
-* Passed: Data, pointer to start of data
-********************************************************************************/
-void print_float(int size, char *title, float *data)
-{
-
- int n; /* data counter */
- int line; /* counter to insert a line after each six numbers */
- float *d; /* pointer to increment through data */
-
- d = data;
- line = 0;
-
- printf("\n%s\n", title);
-
- for(n=0; n<size; n++) {
- printf("%10.3e", *d);
- d++;
- line++;
-
- if(line == 8) { /* add newline after writing 8 numbers */
- printf("\n");
- line = 0;
- }
- }
-}
-
-/********************************************************************************
-* Function: write_double.c
-*
-* Procedure: Uses 21.15lf format to write 4 numbers per line
-* Purpose: write ascii data for one horizontal field or one cross section
-*
-* Passed: data, pointer to start of data
-* size, length of data
-* title, label
-* fp, file pointer
-********************************************************************************/
-void write_double(int size, char *title, FILE *fp, double *data)
-{
-
- int n; /* data counter */
- int line; /* counter to insert a line after each six numbers */
- double *d; /* pointer to increment through data */
-
- d = data;
- line = 0;
-
- fprintf(fp, "\n%s\n", title);
-
- for(n=0; n<size; n++) {
- fprintf(fp, "%21.15lf", *d);
- d++;
- line++;
-
- if(line == 4) { /* add newline after writing 8 numbers */
- fprintf(fp, "\n");
- line = 0;
- }
- }
-}
-
-
-/********************************************************************************
-* Function: print_double.c
-*
-* Procedure: Uses 21.15lf format to write 4 numbers per line
-* Purpose: write ascii data for one horizontal field or one cross section
-*
-* Passed: data, pointer to start of data
-* size, length of data
-* title, label
-* fp, file pointer
-********************************************************************************/
-void print_double(int size, char *title, double *data)
-{
-
- int n; /* data counter */
- int line; /* counter to insert a line after each six numbers */
- double *d; /* pointer to increment through data */
-
- d = data;
- line = 0;
-
- printf("\n%s\n", title);
-
- for(n=0; n<size; n++) {
- printf("%21.15lf", *d);
- d++;
- line++;
-
- if(line == 4) { /* add newline after writing 8 numbers */
- printf("\n");
- line = 0;
- }
- }
-}
-
diff --git a/CEP/PyBDSM/src/natgrid/Src/natgrids.c b/CEP/PyBDSM/src/natgrid/Src/natgrids.c
deleted file mode 100644
index fb6c2eb7a4af912cb49abeceb4ee0f406d8ca870..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/natgrid/Src/natgrids.c
+++ /dev/null
@@ -1,159 +0,0 @@
-#include "nnghead.h"
-#include "nngheads.h"
-#include "nnexver.h"
-
-float *c_natgrids(int n, float x[], float y[], float z[],
- int nxi, int nyi, float xi[], float yi[], int *ier)
-{
- float **data_out=NULL, *rtrn_val=NULL;
-
- *ier = 0;
-
- if (single_point == 0)
- {
- asflag = 1;
- Initialize(n, x, y, nxi, nyi, xi, yi);
-
- if (ReadData(n,x,y,z) != 0)
- {
- *ier = error_status;
- return ( (float *) NULL);
- }
- }
-
- if (adf)
- {
- CircOut();
- if (error_status)
- {
- *ier = error_status;
- return ( (float *) NULL);
- }
- }
- if (igrad)
- {
- Gradient();
- if (error_status)
- {
- *ier = error_status;
- return ( (float *) NULL);
- }
- }
-
- data_out = MakeGrid(nxi, nyi, xi, yi);
- if (error_status)
- {
- if((data_out != NULL)&&(data_out[0] !=NULL)) {
- free(data_out[0]);
- free(data_out);
- }
- *ier = error_status;
- return ( (float *) NULL);
- }
-
- if (single_point == 0)
- {
- Terminate();
- }
-
- horilap = -1.;
- vertlap = -1.;
-
- rtrn_val = data_out[0];
- free(data_out);
- return (rtrn_val);
-}
-void Initialize(int n, float x[], float y[], int nxi, int nyi,
- float xi[], float yi[])
-{
-
- float xil, xir, yib, yit;
-
- error_status = 0;
- datcnt = 0;
- magx_orig = magx;
- magy_orig = magy;
- magz_orig = magz;
- iscale = 0;
- magx_auto = 1.;
- magy_auto = 1.;
- magz_auto = 1.;
-
-/*
- * Find the limits of the output array.
- */
- xstart = armin(nxi, xi);
- xend = armax(nxi, xi);
- ystart = armin(nyi, yi);
- yend = armax(nyi, yi);
-
-/*
- * Find the limits of the input array.
- */
- xil = armin(n, x);
- xir = armax(n, x);
- yib = armin(n, y);
- yit = armax(n, y);
-
-/*
- * As the default (that is, unless horizontal and vertical overlaps
- * have been specifically set by the user) choose the overlap values
- * as the smallest values that will make all input data points included
- * in the overlap region.
- */
- if (horilap EQ -1.) {
- if ( (xstart >= xil) && (xend <= xir) ) {
- horilap = 1.01 * (((xstart-xil) < (xir-xend)) ?
- (xir-xend) : (xstart-xil));
- }
- else if ( (xstart >= xil) && (xend >= xir) ) {
- horilap = 1.01 * (xstart-xil);
- }
- else if ( (xstart <= xil) && (xend <= xir) ) {
- horilap = 1.01 * (xir-xend);
- }
- else if ( (xstart <= xil) && (xir <= xend) ) {
- horilap = 0.;
- }
- }
- if (horilap <= EPSILON) {
- horilap = 0.01 * (xend - xstart);
- }
- if (vertlap EQ -1.) {
- if ( (yib <= ystart) && (yend <= yit) ) {
- vertlap = 1.01 * (((ystart-yib) < (yit-yend)) ?
- (yit-yend) : (ystart-yib));
- }
- else if ( (ystart <= yib) && (yend <= yit) ) {
- vertlap = 1.01 * (yit-yend);
- }
- else if ( (yib <= ystart) && (yit <= yend) ) {
- vertlap = 1.01 * (ystart-yib);
- }
- else if ( (ystart <= yib) && (yit <= yend) ) {
- vertlap = 0.;
- }
- }
- if (vertlap <= EPSILON) {
- vertlap = 0.01 * (yend - ystart);
- }
-}
-
-double armin(int num, float *x)
-{
- int i;
- float amin;
- amin = x[0];
- for (i = 1 ; i < num ; i++)
- if (x[i] < amin) amin = x[i];
- return(amin);
-}
-double armax(int num, float *x)
-{
- int i;
- float amax;
- amax = x[0];
- for (i = 1 ; i < num ; i++)
- if (x[i] > amax) amax = x[i];
- return(amax);
-}
diff --git a/CEP/PyBDSM/src/natgrid/Src/nncrunch.c b/CEP/PyBDSM/src/natgrid/Src/nncrunch.c
deleted file mode 100644
index 97127e2b2d9f072f80e8ce633a8ae3238c8fdb73..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/natgrid/Src/nncrunch.c
+++ /dev/null
@@ -1,934 +0,0 @@
-/*
- * The code in this file is based on code written and
- * copyrighted (C) by Dave Watson. Dr. Watson retains the
- * copyright to his original code. Augmentations and changes
- * to Dr. Watson's code are copyrighted (C) by UCAR, 1997.
- */
-#include <stdlib.h>
-#include "nncheads.h"
-#include "nnchead.h"
-#include "nntypes.h"
-#include "nnexver.h"
-#include "nnuheads.h"
-#include "nnuhead.h"
-
-void Gradient()
-{ int i0, i1, i2, i3;
- double u2, wxd, wyd, wxde, wydn, xc, xe, xn;
- for (i0=0; i0<datcnt; i0++)
- {
- FindNeigh(i0);
- if (error_status) return;
- if (!ext)
- {
- TriNeigh();
- if (error_status) return;
- wxd = points[i0][0];
- wyd = points[i0][1];
- FindProp(wxd,wyd);
- if (error_status) return;
- xc = Surface();
- wxde = wxd + wbit;
- FindProp(wxde,wyd);
- if (error_status) return;
- xe = Surface();
- wydn = wyd + wbit;
- FindProp(wxd,wydn);
- if (error_status) return;
- xn = Surface();
- points[i0][3] = (xc - xe) / wbit;
- points[i0][4] = (xc - xn) / wbit;
- asum /= nn_pi;
- points[i0][5] = 1 - sqrt(asum /
- (asum + SQ(points[i0][2] - xc)));
- }
- else
- {
- points[i0][3] = points[i0][4] = points[i0][5] = xx = 0;
- cursimp = rootsimp;
- for (i1 = 0 ; i1 < numtri ; i1++)
- { cursimp = cursimp->nextsimp;
- for (i2=0; i2<2; i2++)
- for (i3=0; i3<3; i3++)
- work3[i2][i3] =
- points[cursimp->vert[0]][i3] -
- points[cursimp->vert[i2+1]][i3];
- work3[2][0] = work3[0][1] * work3[1][2] -
- work3[1][1] * work3[0][2];
- work3[2][1] = work3[0][2] * work3[1][0] -
- work3[1][2] * work3[0][0];
- work3[2][2] = work3[0][0] * work3[1][1] -
- work3[1][0] * work3[0][1];
- u2 = 1;
- if (work3[2][2]<0) u2 = -1;
- xx += sqrt(SQ(work3[2][0]) +
- SQ(work3[2][1]) + SQ(work3[2][2]));
- for (i2=0; i2<3; i2++) points[i0][i2+3] +=
- work3[2][i2] * u2;
- }
- xx = 1 - sqrt(SQ(points[i0][3]) +
- SQ(points[i0][4]) +
- SQ(points[i0][5])) / xx;
- points[i0][3] /= points[i0][5];
- points[i0][4] /= points[i0][5];
- points[i0][5] = xx;
- }
- }
- for (i0=0; i0<3; i0++)
- { points[datcnt+i0][3] = -bbb;
- points[datcnt+i0][4] = -ccc;
- points[datcnt+i0][5] = 1;
- }
-}
-void FindNeigh(ipt)
-int ipt;
-{ int i0, i1, i2, i3, j1, j2, j3, j4, j5;
- if (rootsimp->nextsimp EQ NULL)
- {
- rootsimp->nextsimp = IMakeSimp();
- if (error_status) return;
- }
- cursimp = rootsimp->nextsimp;
- cursimp->vert[0] = datcnt;
- cursimp->vert[1] = datcnt + 1;
- cursimp->vert[2] = datcnt + 2;
- cursimp->cent[0] = cursimp->cent[1] = 0.5;
- cursimp->cent[2] = BIGNUM;
- numtri = 1;
- lasttemp = roottemp;
- for (i2=0; i2<3; i2++)
- { j1 = 0;
- if (j1 EQ i2) j1++;
- j2 = j1 + 1;
- if (j2 EQ i2) j2++;
- if (lasttemp->nexttemp EQ NULL)
- {
- lasttemp->nexttemp = IMakeTemp();
- if (error_status) return;
- }
- lasttemp = lasttemp->nexttemp;
- lasttemp->end[0] = cursimp->vert[j1];
- lasttemp->end[1] = cursimp->vert[j2];
- }
- curtemp = roottemp;
- for (i1=0; i1<3; i1++)
- { curtemp = curtemp->nexttemp;
- for (i2=0; i2<2; i2++)
- { work3[i2][0] = points[curtemp->end[i2]][0] -
- points[ipt][0];
- work3[i2][1] = points[curtemp->end[i2]][1] -
- points[ipt][1];
- work3[i2][2] = work3[i2][0] *
- (points[curtemp->end[i2]][0] +
- points[ipt][0]) / 2 + work3[i2][1] *
- (points[curtemp->end[i2]][1] +
- points[ipt][1]) / 2;
- }
- xx = work3[0][0] * work3[1][1] -
- work3[1][0] * work3[0][1];
- cursimp->cent[0] = (work3[0][2] * work3[1][1] -
- work3[1][2] * work3[0][1]) / xx;
- cursimp->cent[1] = (work3[0][0] * work3[1][2] -
- work3[1][0] * work3[0][2]) / xx;
- cursimp->cent[2] = SQ(points[ipt][0] -
- cursimp->cent[0]) + SQ(points[ipt][1] -
- cursimp->cent[1]);
- cursimp->vert[0] = curtemp->end[0];
- cursimp->vert[1] = curtemp->end[1];
- cursimp->vert[2] = ipt;
- lastsimp = cursimp;
- if (cursimp->nextsimp EQ NULL)
- {
- cursimp->nextsimp = IMakeSimp();
- if (error_status) return;
- }
- cursimp = cursimp->nextsimp;
- }
- numtri += 2;
- for (i0=0; i0<datcnt; i0++)
- { if (i0 NE ipt)
- { j4 = 0;
- j3 = -1;
- lasttemp = roottemp;
- cursimp = rootsimp;
- for (i1=0; i1<numtri; i1++)
- { prevsimp = cursimp;
- cursimp = cursimp->nextsimp;
- xx = cursimp->cent[2] -
- SQ(points[i0][0] - cursimp->cent[0]);
- if (xx > 0)
- { xx -= SQ(points[i0][1] -
- cursimp->cent[1]);
- if (xx > 0)
- { j4--;
- for (i2=0; i2<3; i2++)
- { j1 = 0;
- if (j1 EQ i2) j1++;
- j2 = j1 + 1;
- if (j2 EQ i2) j2++;
- if (j3>1)
- { j5 = j3;
- curtemp = roottemp;
- for (i3=0; i3<=j5; i3++)
- { prevtemp = curtemp;
- curtemp =
- curtemp->nexttemp;
- if (cursimp->vert[j1] EQ
- curtemp->end[0])
- { if (cursimp->vert[j2] EQ
- curtemp->end[1])
- { if (curtemp EQ lasttemp)
- lasttemp = prevtemp;
- else
- { prevtemp->nexttemp =
- curtemp->nexttemp;
- curtemp->nexttemp =
- lasttemp->nexttemp;
- lasttemp->nexttemp =
- curtemp;
- }
- j3--;
- goto NextOne;
- }
- }
- }
- }
- if (lasttemp->nexttemp EQ NULL)
- {
- lasttemp->nexttemp = IMakeTemp();
- if (error_status) return;
- }
- lasttemp = lasttemp->nexttemp;
- j3++;
- lasttemp->end[0] =
- cursimp->vert[j1];
- lasttemp->end[1] =
- cursimp->vert[j2];
-NextOne:; }
- if (cursimp EQ lastsimp)
- lastsimp = prevsimp;
- else
- { prevsimp->nextsimp =
- cursimp->nextsimp;
- cursimp->nextsimp =
- lastsimp->nextsimp;
- lastsimp->nextsimp = cursimp;
- cursimp = prevsimp;
- }
- }
- }
- }
- if (j3 > -1)
- { curtemp = roottemp;
- cursimp = lastsimp->nextsimp;
- for (i1=0; i1<=j3; i1++)
- { curtemp = curtemp->nexttemp;
- if (curtemp->end[0] EQ ipt OR
- curtemp->end[1] EQ ipt)
- { for (i2=0; i2<2; i2++)
- { work3[i2][0] =
- points[curtemp->end[i2]][0] -
- points[i0][0];
- work3[i2][1] =
- points[curtemp->end[i2]][1] -
- points[i0][1];
- work3[i2][2] = work3[i2][0] *
- (points[curtemp->end[i2]][0] +
- points[i0][0]) / 2 +
- work3[i2][1] *
- (points[curtemp->end[i2]][1] +
- points[i0][1]) / 2;
- }
- xx = work3[0][0] * work3[1][1] -
- work3[1][0] * work3[0][1];
- cursimp->cent[0] = (work3[0][2] *
- work3[1][1] - work3[1][2] *
- work3[0][1]) / xx;
- cursimp->cent[1] = (work3[0][0] *
- work3[1][2] - work3[1][0] *
- work3[0][2]) / xx;
- cursimp->cent[2] =
- SQ(points[i0][0] -
- cursimp->cent[0]) +
- SQ(points[i0][1] -
- cursimp->cent[1]);
- cursimp->vert[0] = curtemp->end[0];
- cursimp->vert[1] = curtemp->end[1];
- cursimp->vert[2] = i0;
- lastsimp = cursimp;
- if (cursimp->nextsimp EQ NULL)
- {
- cursimp->nextsimp = IMakeSimp();
- if (error_status) return;
- }
- cursimp = cursimp->nextsimp;
- j4++;
- }
- }
- numtri += j4;
- }
- }
- }
- for (i0=0; i0<datcnt; i0++) jndx[i0] = 0;
- cursimp = rootsimp;
- for (ext=0, i1=0; i1<numtri; i1++)
- { cursimp = cursimp->nextsimp;
- for (i2=0; i2<3; i2++)
- { if (cursimp->vert[i2] < datcnt)
- { if (cursimp->vert[i2] NE ipt)
- jndx[cursimp->vert[i2]] = 1;
- }
- else ext = 1;
- }
- }
-}
-void TriNeigh()
-{ int i0, i1, i2, i3, j1, j2, j3, j4, j5;
- if (rootsimp->nextsimp EQ NULL)
- {
- rootsimp->nextsimp = IMakeSimp();
- if (error_status) return;
- }
- lastsimp = cursimp = rootsimp->nextsimp;
- cursimp->vert[0] = datcnt;
- cursimp->vert[1] = datcnt + 1;
- cursimp->vert[2] = datcnt + 2;
- cursimp->cent[0] = cursimp->cent[1] = 0.5;
- cursimp->cent[2] = BIGNUM;
- numtri = 1;
- for (i0=0; i0<datcnt; i0++)
- { if (jndx[i0])
- { j3 = -1;
- lasttemp = roottemp;
- cursimp = rootsimp;
- for (i1=0; i1<numtri; i1++)
- { prevsimp = cursimp;
- cursimp = cursimp->nextsimp;
- xx = cursimp->cent[2] -
- SQ(points[i0][0] - cursimp->cent[0]);
- if (xx > 0)
- { xx -= SQ(points[i0][1] -
- cursimp->cent[1]);
- if (xx > 0)
- { for (i2=0; i2<3; i2++)
- { j1 = 0;
- if (j1 EQ i2) j1++;
- j2 = j1 + 1;
- if (j2 EQ i2) j2++;
- if (j3>1)
- { j5 = j3;
- curtemp = roottemp;
- for (i3=0; i3<=j5; i3++)
- { prevtemp = curtemp;
- curtemp =
- curtemp->nexttemp;
- if (cursimp->vert[j1] EQ
- curtemp->end[0])
- { if (cursimp->vert[j2] EQ
- curtemp->end[1])
- { if (curtemp EQ lasttemp)
- lasttemp = prevtemp;
- else
- { prevtemp->nexttemp =
- curtemp->nexttemp;
- curtemp->nexttemp =
- lasttemp->nexttemp;
- lasttemp->nexttemp =
- curtemp;
- }
- j3--;
- goto NextOne;
- }
- }
- }
- }
- if (lasttemp->nexttemp EQ NULL)
- {
- lasttemp->nexttemp = IMakeTemp();
- if (error_status) return;
- }
- lasttemp = lasttemp->nexttemp;
- j3++;
- lasttemp->end[0] =
- cursimp->vert[j1];
- lasttemp->end[1] =
- cursimp->vert[j2];
-NextOne:; }
- if (cursimp EQ lastsimp)
- lastsimp = prevsimp;
- else
- { prevsimp->nextsimp =
- cursimp->nextsimp;
- cursimp->nextsimp =
- lastsimp->nextsimp;
- lastsimp->nextsimp = cursimp;
- cursimp = prevsimp;
- }
- }
- }
- }
- curtemp = roottemp;
- cursimp = lastsimp->nextsimp;
- for (i1=0; i1<=j3; i1++)
- { curtemp = curtemp->nexttemp;
- for (i2=0; i2<2; i2++)
- { work3[i2][0] =
- points[curtemp->end[i2]][0] -
- points[i0][0];
- work3[i2][1] =
- points[curtemp->end[i2]][1] -
- points[i0][1];
- work3[i2][2] = work3[i2][0] *
- (points[curtemp->end[i2]][0] +
- points[i0][0]) / 2 + work3[i2][1] *
- (points[curtemp->end[i2]][1] +
- points[i0][1]) / 2;
- }
- xx = work3[0][0] * work3[1][1] -
- work3[1][0] * work3[0][1];
- cursimp->cent[0] =
- (work3[0][2] * work3[1][1] -
- work3[1][2] * work3[0][1]) / xx;
- cursimp->cent[1] =
- (work3[0][0] * work3[1][2] -
- work3[1][0] * work3[0][2]) / xx;
- cursimp->cent[2] = SQ(points[i0][0] -
- cursimp->cent[0]) + SQ(points[i0][1] -
- cursimp->cent[1]);
- cursimp->vert[0] = curtemp->end[0];
- cursimp->vert[1] = curtemp->end[1];
- cursimp->vert[2] = i0;
- lastsimp = cursimp;
- if (cursimp->nextsimp EQ NULL)
- {
- cursimp->nextsimp = IMakeSimp();
- if (error_status) return;
- }
- cursimp = cursimp->nextsimp;
- }
- numtri += 2;
- }
- }
- cursimp = rootsimp;
- for (asum=0, i0=0; i0<numtri; i0++)
- { cursimp = cursimp->nextsimp;
- for (i1=0; i1<2; i1++)
- { work3[0][i1] = points[cursimp->vert[1]][i1] -
- points[cursimp->vert[0]][i1];
- work3[1][i1] = points[cursimp->vert[2]][i1] -
- points[cursimp->vert[0]][i1];
- }
- xx = work3[0][0] * work3[1][1] -
- work3[0][1] * work3[1][0];
- if (xx < 0)
- { j4 = cursimp->vert[2];
- cursimp->vert[2] = cursimp->vert[1];
- cursimp->vert[1] = j4;
- if (cursimp->vert[0] < datcnt)
- asum -= xx / 2;
- }
- else if (cursimp->vert[0] < datcnt)
- asum += xx / 2;
- }
-}
-void CircOut()
-{
- FILE *filer;
- int ix,i0;
- struct simp *simpaddr;
- if (adf)
- {
- for (i0 = 0; i0 < datcnt; i0++) jndx[i0] = 1;
- TriNeigh();
- if (error_status) return;
-
- if ((filer = fopen(tri_file,"w")) EQ (FILE *) NULL)
- {
- ErrorHnd(3, "CircOut", filee, "\n");
- error_status = 3;
- return;
- }
-
- /*
- * Put out defaults for plot control parameters.
- */
- fprintf(filer,"/*\n");
- fprintf(filer,"/* Integer flags (I5 format).\n");
- fprintf(filer,"/*\n");
- fprintf(filer,"/*..+....1....+....2....+....3....+....4"
- "....+....5....+....6....+....7....+....8\n");
- fprintf(filer," 8 - GKS workstation type "
- "(1=ncgm; 8=X11 window; 20=PostScript).\n");
- fprintf(filer," 1 - flags whether axes should be drawn.\n");
- fprintf(filer," 0 - Halfax/Grid flag (0=halfax and 1=grid)\n");
- fprintf(filer," 1 - Flags whether triangulation should be drawn.\n");
- fprintf(filer," 0 - Flags whether a blue dot should be drawn "
- "at (0.,0.) [0=no; 1=yes]\n");
- fprintf(filer," 0 - Flag to indicate whether the pseudo data "
- "should be included in the plot.\n");
- fprintf(filer," 1 - Flag indicating whether the natural "
- "neighbor circles are drawn.\n");
- fprintf(filer," 1 - Flags whether the centers of the natural "
- "neighborhood circles are drawn.\n");
- fprintf(filer," 1 - Flag indicating if Voronoi polygons should "
- "be drawn [0=no; 1=yes].\n");
- fprintf(filer," 1 - Flag indicating if the original points are "
- "to be marked.\n");
-
- fprintf(filer,"/*\n");
- fprintf(filer,"/* Color information (3F7.3 format) as RGB triples\n");
- fprintf(filer,"/*\n");
- fprintf(filer,"/*..+....1....+....2....+....3....+....4"
- "....+....5....+....6....+....7....+....8\n");
- fprintf(filer," 0.000 0.000 0.000 - background color\n");
- fprintf(filer," 1.000 1.000 1.000 - foreground color "
- "(used for axes)\n");
- fprintf(filer," 1.000 0.000 0.000 - circumcircle color\n");
- fprintf(filer," 0.000 1.000 0.000 - color of circumcircle "
- "centers\n");
- fprintf(filer," 0.000 1.000 1.000 - color for triangulation\n");
- fprintf(filer," 1.000 1.000 0.000 - Voronoi polygon color\n");
- fprintf(filer," 1.000 1.000 0.000 - color of vertex dots\n");
- fprintf(filer," 0.000 0.000 1.000 - color of reference dot\n");
- fprintf(filer," 0.000 0.000 1.000 - color for natural neighbor "
- "points\n");
- fprintf(filer," 1.000 1.000 1.000 - color to mark points where "
- "natural neighbors are desired\n");
-
- fprintf(filer,"/*\n");
- fprintf(filer,"/* Scale factors (F7.3 format)\n");
- fprintf(filer,"/*\n");
- fprintf(filer,"/*..+....1....+....2....+....3....+....4"
- "....+....5....+....6....+....7....+....8\n");
- fprintf(filer," 1.000 - scale factor for dots at vertices\n");
- fprintf(filer," 1.000 - scale factor for circumcircle centers\n");
- fprintf(filer," 2.000 - scale factor for circle lines\n");
- fprintf(filer," 2.000 - scale factor for Voronoi polygon lines\n");
- fprintf(filer," 2.000 - scale factor for tringulation lines\n");
- fprintf(filer," 1.000 - scale factor for axes lines\n");
- fprintf(filer," 1.000 - scale factor for points where natural "
- "neighbors are desired\n");
- fprintf(filer," 1.000 - scale factor for points marking natural "
- "neighbors\n");
-
- fprintf(filer,"/*\n");
- fprintf(filer,"/* User coordinates for SET call (4E15.3 format), "
- "defaults if all zeros\n");
- fprintf(filer,"/*\n");
- fprintf(filer,"/*..+....1....+....2....+....3....+....4"
- "....+....5....+....6....+....7....+....8\n");
- fprintf(filer," 0.000E+00 0.000E+00 0.000E+00 "
- " 0.000E+00\n");
-
- fprintf(filer,"/*\n");
- fprintf(filer,"/* Number of user input data. (I5 format)\n");
- fprintf(filer,"/*\n");
- fprintf(filer,"/*..+....1....+....2....+....3....+....4"
- "....+....5....+....6....+....7....+....8\n");
- fprintf(filer,"%5d\n",datcnt);
-
- fprintf(filer,"/*\n");
- fprintf(filer,"/* User data. The datum number occurs first "
- "(in I5 format) followed\n");
- fprintf(filer,"/* by the x,y,z values (in E15.3 format).\n");
- fprintf(filer,"/*\n");
- fprintf(filer,"/*..+....1....+....2....+....3....+....4"
- "....+....5....+....6....+....7....+....8\n");
- for (ix = 0; ix < datcnt; ix++) {
- fprintf(filer,"%5d%15.3E%15.3E%15.3E\n",
- ix+1,points[ix][0],points[ix][1],points[ix][2]);
- }
-
- fprintf(filer,"/*\n");
- fprintf(filer,"/* Pseudo data.\n");
- fprintf(filer,"/*\n");
- fprintf(filer,"/*..+....1....+....2....+....3....+....4"
- "....+....5....+....6....+....7....+....8\n");
- for (ix = datcnt; ix < datcnt+3; ix++) {
- fprintf(filer,"%5d%15.3E%15.3E%15.3E\n",
- ix+1,points[ix][0],points[ix][1],points[ix][2]);
- }
-
- fprintf(filer,"/*\n");
- fprintf(filer,"/* The number of circumcircles (I5 format).\n");
- fprintf(filer,"/*\n");
- fprintf(filer,"/*..+....1....+....2....+....3....+....4"
- "....+....5....+....6....+....7....+....8\n");
- simpaddr = rootsimp->nextsimp;
- fprintf(filer,"%5d\n",numtri);
-
- fprintf(filer,"/*\n");
- fprintf(filer,"/* Circumcircle data. The first three numbers are "
- "the numbers of the\n");
- fprintf(filer,"/* data (as listed above) lying on the "
- "circumcircle; the next two\n");
- fprintf(filer,"/* numbers give the center position of the "
- "circumcircle; the final\n");
- fprintf(filer,"/* number is the square of the radius of the "
- "circumcircle.\n");
- fprintf(filer,"/*\n");
- fprintf(filer,"/*..+....1....+....2....+....3....+....4"
- "....+....5....+....6....+....7....+....8\n");
- for (ix = 0; ix < numtri; ix++) {
- fprintf(filer,"%5d%5d%5d%15.3E%15.3E%15.3E\n",
- simpaddr->vert[0]+1,simpaddr->vert[1]+1,simpaddr->vert[2]+1,
- simpaddr->cent[0],simpaddr->cent[1],simpaddr->cent[2]);
- simpaddr = simpaddr->nextsimp;
- }
-
- fprintf(filer,"/*\n");
- fprintf(filer,"/* Number of points where natural neighbors are "
- "to be marked and\n");
- fprintf(filer,"/* a flag indicating whether just the points where "
- "first order neighbors\n");
- fprintf(filer,"/* are desired are marked (-1), whether the first "
- " order neighbors \n");
- fprintf(filer,"/* will be marked as well (0), or both first and "
- "second order neighbors\n");
- fprintf(filer,"/* are marked (1). The points will be marked with "
- "Xs, in the\n");
- fprintf(filer,"/* color described above. (2I5 format)\n");
- fprintf(filer,"/*\n");
- fprintf(filer,"/*..+....1....+....2....+....3....+....4"
- "....+....5....+....6....+....7....+....8\n");
- fprintf(filer," 0 0\n");
- fprintf(filer,"/*\n");
- fprintf(filer,"/* The coordinate list of points whose natural "
- "neighbors are to\n");
- fprintf(filer,"/* be displayed (using the color index as described "
- "above), should\n");
- fprintf(filer,"/* be listed here in 2E15.3 format.\n");
- fprintf(filer,"/*\n");
- fprintf(filer,"/*..+....1....+....2....+....3....+....4"
- "....+....5....+....6....+....7....+....8\n");
- fprintf(filer,"/* 0.000E-00 0.000E-00\n");
-
- fclose(filer);
- return;
- }
-}
-
-void FindProp(wxd, wyd)
-double wxd, wyd;
-{ int i2, i3, i4, pos_count, inside;
- double xx, work3[3][3], work4[3][2];
- lastneig = rootneig;
- goodflag = 0;
- numnei = -1;
- cursimp = rootsimp;
- for (i2=0; i2<numtri; i2++)
- { cursimp = cursimp->nextsimp;
- xx = cursimp->cent[2] -
- SQ(wxd - cursimp->cent[0]);
- if (xx > 0)
- { xx -= SQ(wyd - cursimp->cent[1]);
- if (xx > 0)
- { inside = 0;
- if (cursimp->vert[0] < datcnt) inside = 1;
- for (i3=0; i3<3; i3++)
- { for (i4=0; i4<2; i4++)
- { work3[i4][0] =
- points[cursimp->
- vert[scor[i3][i4]]][0] - wxd;
- work3[i4][1] =
- points[cursimp->
- vert[scor[i3][i4]]][1] - wyd;
- work3[i4][2] = work3[i4][0] *
- (points[cursimp->
- vert[scor[i3][i4]]][0] +
- wxd) / 2 + work3[i4][1] *
- (points[cursimp->
- vert[scor[i3][i4]]][1] +
- wyd) / 2;
- }
- xx = work3[0][0] * work3[1][1] -
- work3[1][0] * work3[0][1];
- work4[i3][0] = (work3[0][2] *
- work3[1][1] - work3[1][2] *
- work3[0][1]) / xx;
- work4[i3][1] = (work3[0][0] *
- work3[1][2] - work3[1][0] *
- work3[0][2]) / xx;
- }
- pos_count = 0;
- for (i3=0; i3<3; i3++)
- { work3[2][i3] =
- ((work4[scor[i3][0]][0] -
- cursimp->cent[0]) *
- (work4[scor[i3][1]][1] -
- cursimp->cent[1]) -
- (work4[scor[i3][1]][0] -
- cursimp->cent[0]) *
- (work4[scor[i3][0]][1] -
- cursimp->cent[1])) / 2;
- if (work3[2][i3]>0) pos_count++;
- }
- if (pos_count>2 AND inside) goodflag = 1;
- for (i3=0; i3<3; i3++)
- { if (numnei>1)
- { curneig = rootneig;
- for (i4=0; i4<=numnei; i4++)
- { curneig = curneig->nextneig;
- if (cursimp->vert[i3] EQ
- curneig->neinum)
- { curneig->narea +=
- work3[2][i3];
- goto GOTEM;
- }
- }
- }
- if (lastneig->nextneig EQ NULL)
- {
- lastneig->nextneig = IMakeNeig();
- if (error_status) return;
- }
- lastneig = lastneig->nextneig;
- numnei++;
- lastneig->neinum = cursimp->vert[i3];
- lastneig->narea = work3[2][i3];
-GOTEM:; }
- }
- }
- }
-}
-double Surface()
-{ int i0;
- double xx, asurf;
- curneig = rootneig;
- for (xx=0, i0=0; i0<=numnei; i0++)
- { curneig = curneig->nextneig;
- xx += curneig->narea;
- }
- curneig = rootneig;
- for (asurf=0, i0=0; i0<=numnei; i0++)
- { curneig = curneig->nextneig;
- curneig->narea /= xx;
- asurf += curneig->narea *
- points[curneig->neinum][2];
- }
- return asurf;
-}
-double Meld(double asurf, double wxd, double wyd)
-{ int i0;
- double rS, rT, rB, bD, bB, hP;
- curneig = rootneig;
- for (i0 = 0 ; i0 <= numnei ; i0++)
- {
- curneig = curneig->nextneig;
- curneig->coord = 0;
- if (curneig->narea>0.00001 AND curneig->narea < 2)
- {
- if (fabs(points[curneig->neinum][5]) > 0.00001)
- {
- rS = fabs(points[curneig->neinum][5]) + bI;
- rT = rS * bJ;
- rB = 1 / rT;
- bD = pow(curneig->narea, rT);
- bB = bD * 2;
- if (bD>0.5) bB = (1 - bD) * 2;
- bB = pow(bB, rS) / 2;
- if (bD>0.5) bB = 1 - bB;
- hP = pow(bB, rB);
- curneig->coord =
- ((points[curneig->neinum][3] *
- points[curneig->neinum][0] +
- points[curneig->neinum][4] *
- points[curneig->neinum][1] +
- points[curneig->neinum][2] -
- points[curneig->neinum][3] *
- wxd -
- points[curneig->neinum][4] *
- wyd) - asurf) * hP;
- }
- }
- }
- curneig = rootneig;
- for (i0=0; i0<=numnei; i0++)
- { curneig = curneig->nextneig;
- asurf += curneig->coord;
- }
- return asurf;
-}
-void TooSteep()
-{
- ErrorHnd(4,"TooSteep", filee, "\n");
- igrad = 0;
-}
-void TooShallow()
-{
- ErrorHnd(5,"TooShallow", filee, "\n");
- igrad = 0;
-}
-void TooNarrow()
-{
- ErrorHnd(6, "TooNarrow", filee, "\n");
- igrad = 0;
-}
-int *IntVect(int ncols)
-{
- int *vectptr;
- if ((vectptr = (int *) malloc(ncols * sizeof(int))) EQ (int *) NULL)
- {
- error_status = 7;
- ErrorHnd(error_status, "IntVect", filee, "\n");
- vectptr = (int *) NULL;
- }
- return vectptr;
-}
-void FreeVecti(int *vectptr)
-{
- free(vectptr);
-}
-double *DoubleVect(int ncols)
-{
- double *vectptr;
- if ((vectptr = (double *)
- malloc(ncols * sizeof(double))) EQ (double *) NULL)
- {
- error_status = 8;
- ErrorHnd(error_status, "DoubleVect", filee, "\n");
- return ( (double *) NULL);
- }
- return vectptr;
-}
-void FreeVectd(double *vectptr)
-{
- free(vectptr);
-}
-int **IntMatrix(int nrows, int ncols)
-{ int i0;
- int **matptr;
- if (nrows < 2) nrows = 2;
- if (ncols < 2) ncols = 2;
- if ((matptr = (int **)
- malloc(nrows * sizeof(int *))) EQ (int **) NULL)
- {
- error_status = 9;
- ErrorHnd(error_status, "IntMatrix", filee, "\n");
- return ( (int **) NULL);
- }
- if ((matptr[0] = (int *)
- malloc(nrows * ncols * sizeof(int))) EQ (int *) NULL)
- {
- error_status = 10;
- ErrorHnd(error_status, "IntMatrix", filee, "\n");
- return ( (int **) NULL);
- }
- for (i0=1; i0<nrows; i0++)
- matptr[i0] = matptr[0] + i0 * ncols;
- return matptr;
-}
-void FreeMatrixi(int **matptr)
-{
- free(matptr[0]); /* added 1/1/95 */
- free(matptr);
-}
-float **FloatMatrix(int nrows, int ncols)
-{ int i0;
- float **matptr;
- if (nrows < 2) nrows = 2;
- if (ncols < 2) ncols = 2;
- if ((matptr = (float **)
- malloc(nrows * sizeof(float *))) EQ (float **) NULL)
- {
- error_status = 11;
- ErrorHnd(error_status, "FloatMatrix", filee, "\n");
- return ( (float **) NULL);
- }
- if ((matptr[0] = (float *)
- malloc(nrows * ncols * sizeof(float))) EQ (float *) NULL)
- {
- error_status = 12;
- ErrorHnd(error_status, "FloatMatrix", filee, "\n");
- return ( (float **) NULL);
- }
- for (i0=1; i0<nrows; i0++)
- matptr[i0] = matptr[0] + i0 * ncols;
- return matptr;
-}
-void FreeMatrixf(float **matptr)
-{
- free(matptr[0]); /* added 1/1/95 */
- free(matptr);
-}
-double **DoubleMatrix(int nrows, int ncols)
-{
- int i0;
- double **matptr;
- if (nrows < 2) nrows = 2;
- if (ncols < 2) ncols = 2;
- if ((matptr = (double **)
- malloc(nrows * sizeof(double *))) EQ (double **) NULL)
- {
- error_status = 13;
- ErrorHnd(error_status, "DoubleMatrix", filee, "\n");
- return ( (double **) NULL);
- }
- if ((matptr[0] = (double *)
- malloc(nrows * ncols * sizeof(double))) EQ (double *) NULL)
- {
- error_status = 14;
- ErrorHnd(error_status, "DoubleMatrix", filee, "\n");
- return ( (double **) NULL);
- }
- for (i0 = 1; i0 < nrows; i0++)
- matptr[i0] = matptr[0] + i0 * ncols;
- return matptr;
-}
-void FreeMatrixd(double **matptr)
-{
- free(matptr[0]); /* added 1/1/95 */
- free(matptr);
-}
-struct datum *IMakeDatum()
-{
- struct datum *datptr;
- if ((datptr = (struct datum *)
- malloc(sizeof(struct datum))) EQ (struct datum *) NULL)
- {
- error_status = 15;
- ErrorHnd(error_status, "IMakeDatum", filee, "\n");
- return ((struct datum *) NULL);
- }
- datptr->nextdat = NULL;
- return datptr;
-}
-struct simp *IMakeSimp()
-{
- struct simp *simpptr;
- if ((simpptr = (struct simp *)
- malloc(sizeof(struct simp))) EQ (struct simp *) NULL)
- {
- error_status = 16;
- ErrorHnd(error_status, "IMakeSimp", filee, "\n");
- return ((struct simp *) NULL);
- }
- simpptr->nextsimp = NULL;
- return (simpptr);
-}
-struct temp *IMakeTemp()
-{
- struct temp *tempptr;
- if ((tempptr = (struct temp *)
- malloc(sizeof(struct temp))) EQ (struct temp *) NULL)
- {
- error_status = 17;
- ErrorHnd(error_status, "IMakeTemp", filee, "\n");
- return ((struct temp *) NULL);
- }
- tempptr->nexttemp = NULL;
- return tempptr;
-}
-struct neig *IMakeNeig()
-{
- struct neig *neigptr;
- if ((neigptr = (struct neig *)
- malloc(sizeof(struct neig))) EQ (struct neig *) NULL)
- {
- error_status = 18;
- ErrorHnd(error_status, "IMakeNeig", filee, "\n");
- return ((struct neig *) NULL);
- }
- neigptr->nextneig = NULL;
- return neigptr;
-}
diff --git a/CEP/PyBDSM/src/natgrid/Src/nncrunchd.c b/CEP/PyBDSM/src/natgrid/Src/nncrunchd.c
deleted file mode 100644
index 6b149f1881a817afdf56e8bd64d7efc8ffd987da..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/natgrid/Src/nncrunchd.c
+++ /dev/null
@@ -1,650 +0,0 @@
-#include "nncheadd.h"
-#include "nnchead.h"
-#include "nntypes.h"
-#include "nnexver.h"
-#include "nnuheadd.h"
-#include "nnuhead.h"
-
-int ReadDatad(int numdat, double *xin, double *yin, double *zin)
-{
- double temp[3], minx, maxx, miny, maxy, xtmp, ytmp, ztmp;
- double qtxy, qtyx, qtzx, qtzy;
- int i0, i1, n0;
-
- bigtri[0][0] = bigtri[0][1] = bigtri[1][1] = bigtri[2][0] = -1;
- bigtri[1][0] = bigtri[2][1] = 5;
-
- if (rootdat EQ NULL)
- {
- rootdat = IMakeDatum();
- if (error_status) return (error_status);
-
- rootsimp = IMakeSimp();
- if (error_status) return (error_status);
-
- roottemp = IMakeTemp();
- if (error_status) return (error_status);
-
- rootneig = IMakeNeig();
- if (error_status) return (error_status);
-
- rootdat->values[0] = rootdat->values[1]
- = rootdat->values[2]
- = 0;
- }
- else
- {
- FreeVecti(jndx);
- FreeMatrixd(points);
- FreeMatrixd(joints);
- }
- curdat = rootdat;
- datcnt = 0;
- minx = xstart - horilap; maxx = xend + horilap;
- miny = ystart - vertlap; maxy = yend + vertlap;
-
- for (n0 = 0 ; n0 < numdat ; n0++) {
- temp[0] = xin[n0];
- temp[1] = yin[n0];
- temp[2] = zin[n0];
- if (temp[0] > minx AND temp[0] < maxx AND
- temp[1] > miny AND temp[1] < maxy) {
- if (curdat->nextdat EQ NULL)
- {
- curdat->nextdat = IMakeDatum();
- if (error_status) return (error_status);
- }
- curdat = curdat->nextdat;
- datcnt++;
- for (i1 = 0; i1 < 3; i1++)
- curdat->values[i1] = temp[i1];
- }
- }
-
- if (datcnt > 3)
- {
- datcnt3 = datcnt + 3;
- jndx = IntVect(datcnt3);
- if (error_status) return (error_status);
- sumx = sumy = sumz = sumx2 = sumy2 = sumxy = sumxz = sumyz = 0;
- iscale = 0;
-/*
- * Calculate minimums and maximums of the input data accounting for
- * the scale factors.
- *
- * For the initial calculations, we have:
- *
- * maxxy[0][0] = maximum x input data value
- * maxxy[1][0] = minimum x input data value
- * maxxy[0][1] = maximum y input data value
- * maxxy[1][1] = minimum y input data value
- * maxxy[0][2] = maximum z input data value
- * maxxy[1][2] = minimum z input data value
- *
- */
-
-data_limits:
-
- maxxy[0][0] = maxxy[0][1] = maxxy[0][2] =
- -(maxxy[1][0] = maxxy[1][1] = maxxy[1][2] = BIGNUM);
- curdat = rootdat->nextdat;
- for (i0 = 0; i0 < datcnt; i0++)
- {
- xtmp = curdat->values[0] * magx;
- if (maxxy[0][0] < xtmp)
- maxxy[0][0] = xtmp;
- if (maxxy[1][0] > xtmp)
- maxxy[1][0] = xtmp;
- ytmp = curdat->values[1] * magy;
- if (maxxy[0][1] < ytmp)
- maxxy[0][1] = ytmp;
- if (maxxy[1][1] > ytmp)
- maxxy[1][1] = ytmp;
- ztmp = curdat->values[2] * magz;
- if (maxxy[0][2] < ztmp)
- maxxy[0][2] = ztmp;
- if (maxxy[1][2] > ztmp)
- maxxy[1][2] = ztmp;
- curdat = curdat->nextdat;
- }
-/*
- * Modify the mins and maxs based on the scale factors and overlap regions.
- * to get the actual minimums and maximums of the data under consideration.
- */
- if (maxxy[0][0] < maxx * magx)
- maxxy[0][0] = maxx * magx;
- if (maxxy[1][0] > minx * magx)
- maxxy[1][0] = minx * magx;
- if (maxxy[0][1] < maxy * magy)
- maxxy[0][1] = maxy * magy;
- if (maxxy[1][1] > miny * magy)
- maxxy[1][1] = miny * magy;
-/*
- * Calculate the extents in x, y, and z.
- *
- * maxxy[0][0] = maximum x extent, including overlap regions.
- * maxxy[0][1] = maximum y extent, including overlap regions.
- * maxxy[0][2] = maximum z extent.
- */
- for (i0 = 0 ; i0 < 3 ; i0++)
- {
- maxxy[0][i0] -= maxxy[1][i0];
- }
- maxhoriz = maxxy[0][0];
- if (maxhoriz < maxxy[0][1])
- maxhoriz = maxxy[0][1];
- wbit = maxhoriz * EPSILON;
-/*
- * Calculate the ratio of the x extent by the y extent (qtxy) and
- * the y extent by the x extent (qtyx) .
- */
- qtxy = maxxy[0][0] / maxxy[0][1];
- qtyx = 1./qtxy;
- if ( (qtxy > (2.+EPSILON)) OR (qtyx > (2.+EPSILON)) )
- {
- if (auto_scale)
- {
-/*
- * Readjust the scaling and recompute the data limits.
- */
- iscale = 1;
- if (qtxy > (2+EPSILON) )
- {
- magy *= qtxy;
- }
- else
- {
- magx *= qtyx;
- }
- magx_auto = magx;
- magy_auto = magy;
- magz_auto = magz;
- goto data_limits;
- }
- else
- {
-/*
- * Issue a warning and turn off gradient estimation.
- */
- TooNarrow();
- }
- }
-
- if (igrad)
- {
- qtzx = maxxy[0][2] / maxxy[0][0];
- qtzy = maxxy[0][2] / maxxy[0][1];
- if ( (qtzx > 60) OR (qtzy > 60) )
- {
- if (auto_scale)
- {
-/*
- * Readjust the scaling and recompute the data limits. The X and Y
- * scales have been appropriately adjusted by the time you get here,
- * so dividing magz by either qtzx or qtzy will bring it in line.
- */
- iscale = 1;
- magz *= 1./qtzx;
- magx_auto = magx;
- magy_auto = magy;
- magz_auto = magz;
- goto data_limits;
- }
- else
- {
-/*
- * Issue a warning and turn off gradient estimation.
- */
- TooSteep();
- }
- }
- if ( (qtzx < .017) OR (qtzy < .017) )
- {
- if (auto_scale)
- {
-/*
- * Readjust the scaling and recompute the data limits. The X and Y
- * scales have been appropriately adjusted by the time you get here,
- * so dividing magz by either qtzx or qtzy will bring it in line.
- */
- iscale = 1;
- magz *= 1./qtzx;
- magx_auto = magx;
- magy_auto = magy;
- magz_auto = magz;
- goto data_limits;
- }
- else
- {
-/*
- * Issue a warning and turn off gradient estimation.
- */
- TooShallow();
- }
- }
- }
-
- if (igrad)
- {
- points = DoubleMatrix(datcnt+4, 6);
- if (error_status) return (error_status);
- }
- else
- {
- points = DoubleMatrix(datcnt+4, 3);
- if (error_status) return (error_status);
- }
- joints = DoubleMatrix(datcnt3, 2);
- if (error_status) return (error_status);
- curdat = rootdat->nextdat;
- rootdat->nextdat = NULL;
- for (i0 = 0; i0 < datcnt; i0++)
- { sumx += points[i0][0] =
- curdat->values[0] * magx;
- sumx2 += SQ(points[i0][0]);
- sumy += points[i0][1] =
- curdat->values[1] * magy;
- sumy2 += SQ(points[i0][1]);
- sumxy += points[i0][0] * points[i0][1];
- if (densi) points[i0][2] = 1;
- else
- { sumz += points[i0][2] =
- curdat->values[2] * magz;
- sumxz += points[i0][0] * points[i0][2];
- sumyz += points[i0][1] * points[i0][2];
- }
- holddat = curdat;
- curdat = curdat->nextdat;
- free(holddat);
- }
- det = (datcnt * (sumx2 * sumy2 - sumxy * sumxy))
- - (sumx * (sumx * sumy2 - sumy * sumxy))
- + (sumy * (sumx * sumxy - sumy * sumx2));
- aaa = ((sumz * (sumx2 * sumy2 - sumxy * sumxy))
- - (sumxz * (sumx * sumy2 - sumy * sumxy))
- + (sumyz * (sumx * sumxy - sumy * sumx2))) /
- det;
- bbb =
- ((datcnt * (sumxz * sumy2 - sumyz * sumxy))
- - (sumz * (sumx * sumy2 - sumy * sumxy))
- + (sumy * (sumx * sumyz - sumy * sumxz))) /
- det;
- ccc =
- ((datcnt * (sumx2 * sumyz - sumxy * sumxz))
- - (sumx * (sumx * sumyz - sumy * sumxz))
- + (sumz * (sumx * sumxy - sumy * sumx2))) /
- det;
-
-
- for (i0 = 0 ; i0 < 3 ; i0++)
- { points[datcnt+i0][0] = maxxy[1][0] +
- bigtri[i0][0] * maxxy[0][0] * RANGE;
- points[datcnt+i0][1] = maxxy[1][1] +
- bigtri[i0][1] * maxxy[0][1] * RANGE;
- if (densi)
- points[datcnt+i0][2] = 1;
- else
- points[datcnt+i0][2] =
- aaa + bbb * points[datcnt+i0][0] +
- ccc * points[datcnt+i0][1];
- }
- rootdat = NULL;
- }
- else
- {
- ErrorHnd(1, "ReadData", filee, "\n");
- error_status = 1;
- return (error_status);
- }
-
-/*
- * Determine if any input data coordinates are duplicated.
- */
- if (nndup == 1) {
- for (i0 = 0 ; i0 < datcnt ; i0++) {
- for (i1 = i0+1 ; i1 < datcnt ; i1++) {
- if ( (points[i0][0] == points[i1][0]) &&
- (points[i0][1] == points[i1][1]) )
- {
- sprintf(emsg,"\n Coordinates %d and %d are identical.\n",i0,i1);
- ErrorHnd(2, "ReadData", filee, emsg);
- error_status = 2;
- return (error_status);
- }
- }
- }
- }
-
-/*
- * Introduce a small random perturbation into the coordinate values.
- */
- srand(367);
- for (i0 = 0 ; i0 < datcnt ; i0++)
- {
- for (i1 = 0 ; i1 < 2 ; i1++)
- {
- points[i0][i1] += wbit * (0.5 - (double)rand() / RAND_MAX);
- }
- }
- if (sdip OR igrad)
- {
- piby2 = 2 * atan(1.0);
- nn_pi = piby2 * 2;
- piby32 = 3 * piby2;
- rad2deg = 90 / piby2;
- }
- return (0);
-}
-
-double **MakeGridd(int nxi, int nyi, double *xi, double *yi)
-{
- double wxd, wyd, wxde, wydn, surf, surfe, surfn, aspect, slope;
- int i0, j7, j8;
- static int first_c = 1, first_as = 1;
- static double **data_out;
-
- if (optim) {
- for (i0 = 0 ; i0 < datcnt ; i0++) jndx[i0] = 1;
-
- if ( (single_point == 0) || (igrad > 0) ) {
- TriNeigh();
- }
- else {
- if (first_single == 1) {
- TriNeigh();
- first_single = 0;
- }
- }
-
- if (error_status) return ( (double **) NULL);
- }
-
- data_out = DoubleMatrix(nxi,nyi);
- if (error_status) return ( (double **) NULL);
-
- if (sdip) {
- if (first_as)
- first_as = 0;
- else {
- FreeMatrixd(curasd.aspect_outd);
- FreeMatrixd(curasd.slope_outd);
- }
- curasd.crows = 0;
- curasd.ccols = 0;
- curasd.aspect_outd = DoubleMatrix(nxi,nyi);
- curasd.slope_outd = DoubleMatrix(nxi,nyi);
- }
-
- for (j8 = 0 ; j8 < nyi ; j8++) {
- if (updir > 0)
- wyd = yi[j8]*magy;
- else
- wyd = yi[nyi-j8-1]*magy;
-
- points[datcnt3][1] = wyd;
-
- for (j7 = 0 ; j7 < nxi ; j7++) {
- wxd = xi[j7]*magx;
- points[datcnt3][0] = wxd;
-
- if (!optim) {
- FindNeigh(datcnt3);
- if (error_status) return ( (double **) NULL);
- TriNeigh();
- if (error_status) return ( (double **) NULL);
- }
- FindProp(wxd,wyd);
- if (error_status) return ( (double **) NULL);
- if (!extrap AND !goodflag)
- surf = nuldat;
- else {
- surf = Surface();
- if (igrad>0) surf = Meld(surf,wxd,wyd);
- if (non_neg) if (surf < 0) surf = 0;
- }
- if (sdip) {
- wxde = wxd + wbit;
- FindProp(wxde,wyd);
- if (error_status) return ( (double **) NULL);
- surfe = Surface();
- if (igrad > 0)
- surfe = Meld(surfe,wxde,wyd);
- if (non_neg) if (surfe < 0) surfe = 0;
- wydn = wyd + wbit;
- FindProp(wxd,wydn);
- if (error_status) return ( (double **) NULL);
- surfn = Surface();
- if (igrad > 0)
- surfn = Meld(surfn,wxd,wydn);
- if (non_neg) if (surfn < 0) surfn = 0;
- surfe = (surf - surfe) / wbit;
- surfn = (surf - surfn) / wbit;
- if (surfe > 0) {
- if (surfn > 0)
- aspect = piby2 - atan(surfn / surfe);
- else
- aspect = piby2 + atan(surfn / surfe) * -1;
- }
- else {
- if (surfe < 0) {
- if (surfn > 0)
- aspect = piby32 + atan(surfn / surfe) * -1;
- else aspect =
- piby32 - atan(surfn / surfe);
- }
- else {
- if (surfn > 0)
- aspect = 0;
- else
- aspect = nn_pi;
- }
- }
- slope = atan(sqrt(SQ(surfe) + SQ(surfn)));
- if (!rads) {
- aspect *= rad2deg;
- slope *= rad2deg;
- }
- (curasd.aspect_outd)[j7][j8] = aspect;
- (curasd.slope_outd)[j7][j8] = slope;
- curasd.crows = nxi;
- curasd.ccols = nyi;
- if (magz EQ 1.)
- data_out[j7][j8] = surf;
- else
- data_out[j7][j8] = surf/magz;
- }
- else {
- if (magz EQ 1.)
- data_out[j7][j8] = surf;
- else
- data_out[j7][j8] = surf/magz;
- }
- }
- }
- return (data_out);
-}
-
-void c_nngetsloped(int row, int col, double *slope, int *ier)
-{
- if (asflag == 0) {
- error_status = 28;
- ErrorHnd(error_status, "c_nngetsloped", filee, "\n");
- *ier = 28;
- *slope = -999.;
- return;
- }
- if (iscale == 1)
- {
- sprintf(emsg,"\n\n Current automatically computed scaling "
- "values:\n"
- " magx = %f\n magy = %f\n"
- " magz = %f\n\n",
- magx_auto, magy_auto, magz_auto);
- ErrorHnd(26, "c_nngetsloped", filee, emsg);
- *ier = 26;
- *slope = -999.;
- return;
- }
- if (curasd.crows == 0)
- {
- ErrorHnd(19, "c_nngetsloped", filee, "\n");
- *ier = 19;
- *slope = -999.;
- return;
- }
- if (row >= curasd.crows || row < 0)
- {
- sprintf(emsg,"\n Requested row = %d (indices starting with one)\n",row+1);
- ErrorHnd(20, "c_nngetsloped", filee, emsg);
- *ier = 20;
- *slope = -999.;
- return;
- }
- if (col >= curasd.ccols || col < 0)
- {
- sprintf(emsg,"\n Requested column = %d (indices starting with one)\n",
- col+1);
- ErrorHnd(21, "c_nngetsloped", filee, emsg);
- *ier = 21;
- *slope = -999.;
- return;
- }
- *ier = 0;
- *slope = (curasd.slope_outd)[row][col];
-}
-void c_nngetaspectd(int row, int col, double *aspect, int *ier)
-{
- if (asflag == 0) {
- error_status = 28;
- ErrorHnd(error_status, "c_nngetaspectd", filee, "\n");
- *ier = 28;
- *aspect = -999.;
- return;
- }
- if (iscale == 1)
- {
- sprintf(emsg,"\n\n Current automatically computed scaling "
- "values:\n"
- " magx = %f\n magy = %f\n"
- " magz = %f\n\n",
- magx_auto, magy_auto, magz_auto);
- ErrorHnd(25, "c_nngetaspectd", filee, emsg);
- *ier = 25;
- *aspect = -999.;
- return;
- }
- if (curasd.crows == 0)
- {
- ErrorHnd(22, "c_nngetaspectd", filee, "\n");
- *ier = 22;
- *aspect = -999.;
- return;
- }
- if (row >= curasd.crows || row < 0)
- {
- sprintf(emsg,"\n Requested row = %d (indices starting with one)\n",row+1);
- ErrorHnd(20, "c_nngetaspectd", filee, emsg);
- *ier = 20;
- *aspect = -999.;
- return;
- }
- if (col >= curasd.ccols || col < 0)
- {
- sprintf(emsg,"\n Requested column = %d (indices starting with one)\n",
- col);
- ErrorHnd(21, "c_nngetaspectd", filee, emsg);
- *ier = 21;
- *aspect = -999.;
- return;
- }
- *ier = 0;
- *aspect = (curasd.aspect_outd)[row][col];
-}
-
-/*
- * Initialize single point interpolation mode. This just
- * does the regridding initialization and initial data analysis.
- */
-void c_nnpntinitd(int n, double x[], double y[], double z[])
-{
-#define NXI 2
-#define NYI 2
-
- double xi[NXI], yi[NYI], wtmp;
-
- single_point = 1;
- first_single = 1;
- asflag = 0;
- horilap_save = horilap;
- vertlap_save = vertlap;
- horilap = -1.;
- vertlap = -1.;
-
-/*
- * Establish the gridded region to contain all of the input
- * data points plus an extra 10% space around the border.
- */
- xi[0] = armind(n, x);
- xi[1] = armaxd(n, x);
- wtmp = xi[1] - xi[0];
- xi[0] -= 0.1*wtmp;
- xi[1] += 0.1*wtmp;
-
- yi[0] = armind(n, y);
- yi[1] = armaxd(n, y);
- wtmp = yi[1] - yi[0];
- yi[0] -= 0.1*wtmp;
- yi[1] += 0.1*wtmp;
-
- Initialized(n, x, y, NXI, NYI, xi, yi);
-
- if (ReadDatad(n,x,y,z) != 0)
- {
- ErrorHnd(error_status, "c_nnpntinitd", filee, "\n");
- }
-}
-void c_nnpntd(double x, double y, double *point)
-{
- int idum, nxi=3, nyi=3, ierr;
- double xdum[1], ydum[1], zdum[1], xi[3], yi[3], *out;
-
-/*
- * Check to see if the input point is within the gridded region
- * set up in the initialization.
- */
- if ( (x < xstart) || (x > xend) || (y < ystart) || (y > yend) )
- {
- sprintf(emsg,"\n Coordinate = (%f, %f)\n", x, y);
- ErrorHnd(27, "c_nnpntd", filee, emsg);
- return;
- }
-
-/*
- * Set up a 3 x 3 gridded region with the desired coordinate in
- * the middle.
- */
- xi[0] = x-0.05*(xend-xstart);
- xi[1] = x;
- xi[2] = x+0.05*(xend-xstart);
- yi[0] = y-0.05*(yend-ystart);
- yi[1] = y;
- yi[2] = y+0.05*(yend-ystart);
-
- out = c_natgridd(idum, xdum, ydum, zdum, nxi, nyi, xi, yi, &ierr);
- if (ierr != 0)
- {
- ErrorHnd(28, "c_nnpntd", filee, "\n");
- error_status = ierr;
- *point = -999.;
- }
-
- *point = out[3*1 +1];
-}
-void c_nnpntendd()
-{
- single_point = 0;
- first_single = 0;
- horilap = horilap_save;
- vertlap = vertlap_save;
- Terminate();
-}
diff --git a/CEP/PyBDSM/src/natgrid/Src/nncrunchs.c b/CEP/PyBDSM/src/natgrid/Src/nncrunchs.c
deleted file mode 100644
index 8b24e317f0238d24d6a1af0662276fe0274e20a6..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/natgrid/Src/nncrunchs.c
+++ /dev/null
@@ -1,651 +0,0 @@
-#include "nncheads.h"
-#include "nnchead.h"
-#include "nntypes.h"
-#include "nnexver.h"
-#include "nnuheads.h"
-#include "nnuhead.h"
-
-int ReadData(int numdat, float *xin, float *yin, float *zin)
-{
- double temp[3], minx, maxx, miny, maxy, xtmp, ytmp, ztmp;
- double qtxy, qtyx, qtzx, qtzy;
- int i0, i1, n0;
-
- bigtri[0][0] = bigtri[0][1] = bigtri[1][1] = bigtri[2][0] = -1;
- bigtri[1][0] = bigtri[2][1] = 5;
-
- if (rootdat EQ NULL)
- {
- rootdat = IMakeDatum();
- if (error_status) return (error_status);
-
- rootsimp = IMakeSimp();
- if (error_status) return (error_status);
-
- roottemp = IMakeTemp();
- if (error_status) return (error_status);
-
- rootneig = IMakeNeig();
- if (error_status) return (error_status);
-
- rootdat->values[0] = rootdat->values[1]
- = rootdat->values[2]
- = 0;
- }
- else
- {
- FreeVecti(jndx);
- FreeMatrixd(points);
- FreeMatrixd(joints);
- }
- curdat = rootdat;
- datcnt = 0;
- minx = xstart - horilap; maxx = xend + horilap;
- miny = ystart - vertlap; maxy = yend + vertlap;
-
- for (n0 = 0 ; n0 < numdat ; n0++) {
- temp[0] = xin[n0];
- temp[1] = yin[n0];
- temp[2] = zin[n0];
- if (temp[0] > minx AND temp[0] < maxx AND
- temp[1] > miny AND temp[1] < maxy) {
- if (curdat->nextdat EQ NULL)
- {
- curdat->nextdat = IMakeDatum();
- if (error_status) return (error_status);
- }
- curdat = curdat->nextdat;
- datcnt++;
- for (i1 = 0; i1 < 3; i1++)
- curdat->values[i1] = temp[i1];
- }
- }
-
- if (datcnt > 3)
- {
- datcnt3 = datcnt + 3;
- jndx = IntVect(datcnt3);
- if (error_status) return (error_status);
- sumx = sumy = sumz = sumx2 = sumy2 = sumxy = sumxz = sumyz = 0;
- iscale = 0;
-/*
- * Calculate minimums and maximums of the input data accounting for
- * the scale factors.
- *
- * For the initial calculations, we have:
- *
- * maxxy[0][0] = maximum x input data value
- * maxxy[1][0] = minimum x input data value
- * maxxy[0][1] = maximum y input data value
- * maxxy[1][1] = minimum y input data value
- * maxxy[0][2] = maximum z input data value
- * maxxy[1][2] = minimum z input data value
- *
- */
-
-data_limits:
-
- maxxy[0][0] = maxxy[0][1] = maxxy[0][2] =
- -(maxxy[1][0] = maxxy[1][1] = maxxy[1][2] = BIGNUM);
- curdat = rootdat->nextdat;
- for (i0 = 0; i0 < datcnt; i0++)
- {
- xtmp = curdat->values[0] * magx;
- if (maxxy[0][0] < xtmp)
- maxxy[0][0] = xtmp;
- if (maxxy[1][0] > xtmp)
- maxxy[1][0] = xtmp;
- ytmp = curdat->values[1] * magy;
- if (maxxy[0][1] < ytmp)
- maxxy[0][1] = ytmp;
- if (maxxy[1][1] > ytmp)
- maxxy[1][1] = ytmp;
- ztmp = curdat->values[2] * magz;
- if (maxxy[0][2] < ztmp)
- maxxy[0][2] = ztmp;
- if (maxxy[1][2] > ztmp)
- maxxy[1][2] = ztmp;
- curdat = curdat->nextdat;
- }
-/*
- * Modify the mins and maxs based on the scale factors and overlap regions.
- * to get the actual minimums and maximums of the data under consideration.
- */
- if (maxxy[0][0] < maxx * magx)
- maxxy[0][0] = maxx * magx;
- if (maxxy[1][0] > minx * magx)
- maxxy[1][0] = minx * magx;
- if (maxxy[0][1] < maxy * magy)
- maxxy[0][1] = maxy * magy;
- if (maxxy[1][1] > miny * magy)
- maxxy[1][1] = miny * magy;
-/*
- * Calculate the extents in x, y, and z.
- *
- * maxxy[0][0] = maximum x extent, including overlap regions.
- * maxxy[0][1] = maximum y extent, including overlap regions.
- * maxxy[0][2] = maximum z extent.
- */
- for (i0 = 0 ; i0 < 3 ; i0++)
- {
- maxxy[0][i0] -= maxxy[1][i0];
- }
- maxhoriz = maxxy[0][0];
- if (maxhoriz < maxxy[0][1])
- maxhoriz = maxxy[0][1];
- wbit = maxhoriz * EPSILON;
-/*
- * Calculate the ratio of the x extent by the y extent (qtxy) and
- * the y extent by the x extent (qtyx) .
- */
- qtxy = maxxy[0][0] / maxxy[0][1];
- qtyx = 1./qtxy;
- if ( (qtxy > (2.+EPSILON)) OR (qtyx > (2.+EPSILON)) )
- {
- if (auto_scale)
- {
-/*
- * Readjust the scaling and recompute the data limits.
- */
- iscale = 1;
- if (qtxy > (2+EPSILON) )
- {
- magy *= qtxy;
- }
- else
- {
- magx *= qtyx;
- }
- magx_auto = magx;
- magy_auto = magy;
- magz_auto = magz;
- goto data_limits;
- }
- else
- {
-/*
- * Issue a warning and turn off gradient estimation.
- */
- TooNarrow();
- }
- }
-
- if (igrad)
- {
- qtzx = maxxy[0][2] / maxxy[0][0];
- qtzy = maxxy[0][2] / maxxy[0][1];
- if ( (qtzx > 60) OR (qtzy > 60) )
- {
- if (auto_scale)
- {
-/*
- * Readjust the scaling and recompute the data limits. The X and Y
- * scales have been appropriately adjusted by the time you get here,
- * so dividing magz by either qtzx or qtzy will bring it in line.
- */
- iscale = 1;
- magz *= 1./qtzx;
- magx_auto = magx;
- magy_auto = magy;
- magz_auto = magz;
- goto data_limits;
- }
- else
- {
-/*
- * Issue a warning and turn off gradient estimation.
- */
- TooSteep();
- }
- }
- if ( (qtzx < .017) OR (qtzy < .017) )
- {
- if (auto_scale)
- {
-/*
- * Readjust the scaling and recompute the data limits. The X and Y
- * scales have been appropriately adjusted by the time you get here,
- * so dividing magz by either qtzx or qtzy will bring it in line.
- */
- iscale = 1;
- magz *= 1./qtzx;
- magx_auto = magx;
- magy_auto = magy;
- magz_auto = magz;
- goto data_limits;
- }
- else
- {
-/*
- * Issue a warning and turn off gradient estimation.
- */
- TooShallow();
- }
- }
- }
-
- if (igrad)
- {
- points = DoubleMatrix(datcnt+4, 6);
- if (error_status) return (error_status);
- }
- else
- {
- points = DoubleMatrix(datcnt+4, 3);
- if (error_status) return (error_status);
- }
- joints = DoubleMatrix(datcnt3, 2);
- if (error_status) return (error_status);
- curdat = rootdat->nextdat;
- rootdat->nextdat = NULL;
- free(rootdat);
- for (i0 = 0; i0 < datcnt; i0++)
- { sumx += points[i0][0] =
- curdat->values[0] * magx;
- sumx2 += SQ(points[i0][0]);
- sumy += points[i0][1] =
- curdat->values[1] * magy;
- sumy2 += SQ(points[i0][1]);
- sumxy += points[i0][0] * points[i0][1];
- if (densi) points[i0][2] = 1;
- else
- { sumz += points[i0][2] =
- curdat->values[2] * magz;
- sumxz += points[i0][0] * points[i0][2];
- sumyz += points[i0][1] * points[i0][2];
- }
- holddat = curdat;
- curdat = curdat->nextdat;
- free(holddat);
- }
- det = (datcnt * (sumx2 * sumy2 - sumxy * sumxy))
- - (sumx * (sumx * sumy2 - sumy * sumxy))
- + (sumy * (sumx * sumxy - sumy * sumx2));
- aaa = ((sumz * (sumx2 * sumy2 - sumxy * sumxy))
- - (sumxz * (sumx * sumy2 - sumy * sumxy))
- + (sumyz * (sumx * sumxy - sumy * sumx2))) /
- det;
- bbb =
- ((datcnt * (sumxz * sumy2 - sumyz * sumxy))
- - (sumz * (sumx * sumy2 - sumy * sumxy))
- + (sumy * (sumx * sumyz - sumy * sumxz))) /
- det;
- ccc =
- ((datcnt * (sumx2 * sumyz - sumxy * sumxz))
- - (sumx * (sumx * sumyz - sumy * sumxz))
- + (sumz * (sumx * sumxy - sumy * sumx2))) /
- det;
-
-
- for (i0 = 0 ; i0 < 3 ; i0++)
- { points[datcnt+i0][0] = maxxy[1][0] +
- bigtri[i0][0] * maxxy[0][0] * RANGE;
- points[datcnt+i0][1] = maxxy[1][1] +
- bigtri[i0][1] * maxxy[0][1] * RANGE;
- if (densi)
- points[datcnt+i0][2] = 1;
- else
- points[datcnt+i0][2] =
- aaa + bbb * points[datcnt+i0][0] +
- ccc * points[datcnt+i0][1];
- }
- rootdat = NULL;
- }
- else
- {
- ErrorHnd(1, "ReadData", filee, "\n");
- error_status = 1;
- return (error_status);
- }
-
-/*
- * Determine if any input data coordinates are duplicated.
- */
- if (nndup == 1) {
- for (i0 = 0 ; i0 < datcnt ; i0++) {
- for (i1 = i0+1 ; i1 < datcnt ; i1++) {
- if ( (points[i0][0] == points[i1][0]) &&
- (points[i0][1] == points[i1][1]) )
- {
- sprintf(emsg,"\n Coordinates %d and %d are identical.\n",i0,i1);
- ErrorHnd(2, "ReadData", filee, emsg);
- error_status = 2;
- return (error_status);
- }
- }
- }
- }
-
-/*
- * Introduce a small random perturbation into the coordinate values.
- */
- srand(367);
- for (i0 = 0 ; i0 < datcnt ; i0++)
- {
- for (i1 = 0 ; i1 < 2 ; i1++)
- {
- points[i0][i1] += wbit * (0.5 - (double)rand() / RAND_MAX);
- }
- }
- if (sdip OR igrad)
- {
- piby2 = 2 * atan(1.0);
- nn_pi = piby2 * 2;
- piby32 = 3 * piby2;
- rad2deg = 90 / piby2;
- }
- return (0);
-}
-
-float **MakeGrid(int nxi, int nyi, float *xi, float *yi)
-{
- double wxd, wyd, wxde, wydn, surf, surfe, surfn, aspect, slope;
- int i0, j7, j8;
- static int first_c = 1, first_as = 1;
- static float **data_out;
-
- if (optim) {
- for (i0 = 0 ; i0 < datcnt ; i0++) jndx[i0] = 1;
-
- if ( (single_point == 0) || (igrad > 0) ) {
- TriNeigh();
- }
- else {
- if (first_single == 1) {
- TriNeigh();
- first_single = 0;
- }
- }
-
- if (error_status) return ( (float **) NULL);
- }
-
- data_out = FloatMatrix(nxi,nyi);
- if (error_status) return ( (float **) NULL);
-
- if (sdip) {
- if (first_as)
- first_as = 0;
- else {
- FreeMatrixf(curas.aspect_out);
- FreeMatrixf(curas.slope_out);
- }
- curas.crows = 0;
- curas.ccols = 0;
- curas.aspect_out = FloatMatrix(nxi,nyi);
- curas.slope_out = FloatMatrix(nxi,nyi);
- }
-
- for (j8 = 0 ; j8 < nyi ; j8++) {
- if (updir > 0)
- wyd = yi[j8]*magy;
- else
- wyd = yi[nyi-j8-1]*magy;
-
- points[datcnt3][1] = wyd;
-
- for (j7 = 0 ; j7 < nxi ; j7++) {
- wxd = xi[j7]*magx;
- points[datcnt3][0] = wxd;
-
- if (!optim) {
- FindNeigh(datcnt3);
- if (error_status) return ( (float **) NULL);
- TriNeigh();
- if (error_status) return ( (float **) NULL);
- }
- FindProp(wxd,wyd);
- if (error_status) return ( (float **) NULL);
- if (!extrap AND !goodflag)
- surf = nuldat;
- else {
- surf = Surface();
- if (igrad>0) surf = Meld(surf,wxd,wyd);
- if (non_neg) if (surf < 0) surf = 0;
- }
- if (sdip) {
- wxde = wxd + wbit;
- FindProp(wxde,wyd);
- if (error_status) return ( (float **) NULL);
- surfe = Surface();
- if (igrad > 0)
- surfe = Meld(surfe,wxde,wyd);
- if (non_neg) if (surfe < 0) surfe = 0;
- wydn = wyd + wbit;
- FindProp(wxd,wydn);
- if (error_status) return ( (float **) NULL);
- surfn = Surface();
- if (igrad > 0)
- surfn = Meld(surfn,wxd,wydn);
- if (non_neg) if (surfn < 0) surfn = 0;
- surfe = (surf - surfe) / wbit;
- surfn = (surf - surfn) / wbit;
- if (surfe > 0) {
- if (surfn > 0)
- aspect = piby2 - atan(surfn / surfe);
- else
- aspect = piby2 + atan(surfn / surfe) * -1;
- }
- else {
- if (surfe < 0) {
- if (surfn > 0)
- aspect = piby32 + atan(surfn / surfe) * -1;
- else aspect =
- piby32 - atan(surfn / surfe);
- }
- else {
- if (surfn > 0)
- aspect = 0;
- else
- aspect = nn_pi;
- }
- }
- slope = atan(sqrt(SQ(surfe) + SQ(surfn)));
- if (!rads) {
- aspect *= rad2deg;
- slope *= rad2deg;
- }
- (curas.aspect_out)[j7][j8] = aspect;
- (curas.slope_out)[j7][j8] = slope;
- curas.crows = nxi;
- curas.ccols = nyi;
- if (magz EQ 1.)
- data_out[j7][j8] = surf;
- else
- data_out[j7][j8] = surf/magz;
- }
- else {
- if (magz EQ 1.)
- data_out[j7][j8] = surf;
- else
- data_out[j7][j8] = surf/magz;
- }
- }
- }
- return (data_out);
-}
-
-void c_nngetslopes(int row, int col, float *slope, int *ier)
-{
- if (asflag == 0) {
- error_status = 28;
- ErrorHnd(error_status, "c_nngetslopes", filee, "\n");
- *ier = 28;
- *slope = -999.;
- return;
- }
- if (iscale == 1)
- {
- sprintf(emsg,"\n\n Current automatically computed scaling "
- "values:\n"
- " magx = %f\n magy = %f\n"
- " magz = %f\n\n",
- magx_auto, magy_auto, magz_auto);
- ErrorHnd(26, "c_nngetslopes", filee, emsg);
- *ier = 26;
- *slope = -999.;
- return;
- }
- if (curas.crows == 0)
- {
- ErrorHnd(19, "c_nngetslopes", filee, "\n");
- *ier = 19;
- *slope = -999.;
- return;
- }
- if (row >= curas.crows || row < 0)
- {
- sprintf(emsg,"\n Requested row = %d (indices starting with one)\n",row+1);
- ErrorHnd(20, "c_nngetslopes", filee, emsg);
- *ier = 20;
- *slope = -999.;
- return;
- }
- if (col >= curas.ccols || col < 0)
- {
- sprintf(emsg,"\n Requested column = %d (indices starting with one)\n",
- col+1);
- ErrorHnd(21, "c_nngetslopes", filee, emsg);
- *ier = 21;
- *slope = -999.;
- return;
- }
- *ier = 0;
- *slope = (curas.slope_out)[row][col];
-}
-void c_nngetaspects(int row, int col, float *aspect, int *ier)
-{
- if (asflag == 0) {
- error_status = 28;
- ErrorHnd(error_status, "c_nngetaspects", filee, "\n");
- *ier = 28;
- *aspect = -999.;
- return;
- }
- if (iscale == 1)
- {
- sprintf(emsg,"\n\n Current automatically computed scaling "
- "values:\n"
- " magx = %f\n magy = %f\n"
- " magz = %f\n\n",
- magx_auto, magy_auto, magz_auto);
- ErrorHnd(25, "c_nngetaspects", filee, emsg);
- *ier = 25;
- *aspect = -999.;
- return;
- }
- if (curas.crows == 0)
- {
- ErrorHnd(22, "c_nngetaspects", filee, "\n");
- *ier = 22;
- *aspect = -999.;
- return;
- }
- if (row >= curas.crows || row < 0)
- {
- sprintf(emsg,"\n Requested row = %d (indices starting with one)\n",row+1);
- ErrorHnd(20, "c_nngetaspects", filee, emsg);
- *ier = 20;
- *aspect = -999.;
- return;
- }
- if (col >= curas.ccols || col < 0)
- {
- sprintf(emsg,"\n Requested column = %d (indices starting with one)\n",
- col);
- ErrorHnd(21, "c_nngetaspects", filee, emsg);
- *ier = 21;
- *aspect = -999.;
- return;
- }
- *ier = 0;
- *aspect = (curas.aspect_out)[row][col];
-}
-
-/*
- * Initialize single point interpolation mode. This just
- * does the regridding initialization and initial data analysis.
- */
-void c_nnpntinits(int n, float x[], float y[], float z[])
-{
-#define NXI 2
-#define NYI 2
-
- float xi[NXI], yi[NYI], wtmp;
-
- single_point = 1;
- first_single = 1;
- asflag = 0;
- horilap_save = horilap;
- vertlap_save = vertlap;
- horilap = -1.;
- vertlap = -1.;
-
-/*
- * Establish the gridded region to contain all of the input
- * data points plus an extra 10% space around the border.
- */
- xi[0] = (float) armin(n, x);
- xi[1] = (float) armax(n, x);
- wtmp = xi[1] - xi[0];
- xi[0] -= 0.1*wtmp;
- xi[1] += 0.1*wtmp;
-
- yi[0] = (float) armin(n, y);
- yi[1] = (float) armax(n, y);
- wtmp = yi[1] - yi[0];
- yi[0] -= 0.1*wtmp;
- yi[1] += 0.1*wtmp;
-
- Initialize(n, x, y, NXI, NYI, xi, yi);
-
- if (ReadData(n,x,y,z) != 0)
- {
- ErrorHnd(error_status, "c_nnpntinits", filee, "\n");
- }
-}
-void c_nnpnts(float x, float y, float *point)
-{
- int idum, nxi=3, nyi=3, ierr;
- float xdum[1], ydum[1], zdum[1], xi[3], yi[3], *out;
-
-/*
- * Check to see if the input point is within the gridded region
- * set up in the initialization.
- */
- if ( (x < xstart) || (x > xend) || (y < ystart) || (y > yend) )
- {
- sprintf(emsg,"\n Coordinate = (%f, %f)\n", x, y);
- ErrorHnd(27, "c_nnpnts", filee, emsg);
- return;
- }
-
-/*
- * Set up a 3 x 3 gridded region with the desired coordinate in
- * the middle.
- */
- xi[0] = x-0.05*(xend-xstart);
- xi[1] = x;
- xi[2] = x+0.05*(xend-xstart);
- yi[0] = y-0.05*(yend-ystart);
- yi[1] = y;
- yi[2] = y+0.05*(yend-ystart);
-
- out = c_natgrids(idum, xdum, ydum, zdum, nxi, nyi, xi, yi, &ierr);
- if (ierr != 0)
- {
- ErrorHnd(28, "c_nnpnts", filee, "\n");
- error_status = ierr;
- *point = -999.;
- }
-
- *point = out[3*1 + 1];
-}
-void c_nnpntend()
-{
- single_point = 0;
- first_single = 0;
- horilap = horilap_save;
- vertlap = vertlap_save;
- Terminate();
-}
diff --git a/CEP/PyBDSM/src/natgrid/Src/nnerror.c b/CEP/PyBDSM/src/natgrid/Src/nnerror.c
deleted file mode 100644
index 756e5dab179059578afa44c1979e1f36d446f8f6..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/natgrid/Src/nnerror.c
+++ /dev/null
@@ -1,141 +0,0 @@
-#include <stdio.h>
-#include <stdlib.h>
-
-#define MAX_ERROR 30
-
-void ErrorLog(int, char *, FILE *, char *);
-char *ErrMsg(int);
-
-extern int error_status;
-
-void ErrorHnd(int error, char *func, FILE *efile, char *smsg)
-{
- ErrorLog(error, func, efile, smsg);
-}
-
-void ErrorLog(int error, char *func, FILE *efile, char *smsg)
-{
- if ( (error == 4) || (error == 5) || (error == 6 || error == 28) )
- {
- fprintf(efile, "natgrid - warning number %d from %s:\n %s",
- error, func, ErrMsg(error));
- error_status = 0;
- }
- else
- {
- fprintf(efile, "natgrid - error number %d from %s:\n %s",
- error, func, ErrMsg(error));
- error_status = error;
- }
- fprintf(efile,"%s",smsg);
-}
-
-char *ErrMsg(int i)
-{
- char *rlist;
- const char *err_list[MAX_ERROR] = {
-
-/* #001 */
- "Insufficient data in gridded region to triangulate.",
-
-/* #002 */
- "Duplicate input data coordinates are not allowed.",
-
-/* #003 */
- "Unable to open file for writing algorithmic data.",
-
-/* #004 */
- "WARNING: The ratio of vertical to horizontal scales is too large for \n meaningful gradient estimation. Rescale the data if gradients are required.",
-
-/* #005 */
- "WARNING: The ratio of vertical to horizontal scales is too small for\n meaningful gradient estimation. Rescale the data if gradients are required.",
-
-/* #006 */
- "WARNING: The ratio of x-axis breadth to y-axis breadth of this gridded \n region may be too extreme for good interpolation. Changing the block \n proportions, or rescaling the x or y coordinate may be indicated.\n Gradient calculations have been disabled.",
-
-/* #007 */
- "Unable to allocate storage for ivector.",
-
-/* #008 */
- "Unable to allocate storage for dvector.",
-
-/* #009 */
- "Unable to allocate storage for **imatrix.",
-
-/* #010 */
- "Unable to allocate storage for imatrix[].",
-
-/* #011 */
- "Unable to allocate storage for **fmatrix.",
-
-/* #012 */
- "Unable to allocate storage for fmatrix[].",
-
-/* #013 */
- "Unable to allocate storage for **dmatrix.",
-
-/* #014 */
- "Unable to allocate storage for dmatrix[].",
-
-/* #015 */
- "Unable to allocate storage for raw data.",
-
-/* #016 */
- "Unable to allocate storage for a simplex.",
-
-/* #017 */
- "Unable to allocate storage for temp.",
-
-/* #018 */
- "Unable to allocate storage for neig.",
-
-/* #019 */
- "Slopes have not been computed, set sdi.",
-
-/* #020 */
- "Row argument out of range.",
-
-/* #021 */
- "Column argument out of range.",
-
-/* #022 */
- "Aspects have not been computed, set sdi.",
-
-/* #023 */
- "Parameter name not known.",
-
-/* #024 */
- "Cannot open error file.",
-
-/* #025 */
- "Automatic scaling has been done - aspects will be distorted and \n consequently are not returned. Rescale your data manually, or \n by setting magx, magy, and magz appropriately.",
-
-/* #026 */
- "Automatic scaling has been done - slopes will be distorted and \n consequently are not returned. Rescale your data manually, or \n by setting magx, magy, and magz appropriately.",
-
-/* #027 */
- "Coordinate is outside of the gridded region for a single point interpolation.",
-
-/* #028 */
- "Cannot compute aspects and slopes in conjunction with single point \n interpolation mode.",
-
-/* #029 */
- "Fortran DOUBLE PRECISION entries are not supported on UNICOS.",
-
-/* #030 */
- "Error number out of range."
- };
-
- if (i >= MAX_ERROR) {
- rlist = (char *) err_list[29];
- }
- else {
- rlist = (char *) err_list[i-1];
- }
- return (rlist);
-}
-
-int ErrMax()
-{
- return(MAX_ERROR);
-}
diff --git a/CEP/PyBDSM/src/natgrid/Src/nnuser.c b/CEP/PyBDSM/src/natgrid/Src/nnuser.c
deleted file mode 100644
index 720a254865f9d40e73e5ed602709ad9ed77b4e60..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/natgrid/Src/nnuser.c
+++ /dev/null
@@ -1,186 +0,0 @@
-#include "nnuheads.h"
-#include "nnuhead.h"
-
-/*
- * Get values for character parameters.
- */
-void c_nngetc(char *pnam, char *vnam)
-{
- char *s;
- if (!strncmp(pnam,"alg",3) OR !strncmp(pnam,"ALG",3)) {
- s = tri_file;
- }
- else if (!strncmp(pnam,"erf",3) OR !strncmp(pnam,"ERF",3)) {
- s = error_file;
- }
- else {
- sprintf(emsg,"\n Parameter name supplied is: %s\n",pnam);
- ErrorHnd(23, "c_nngetc", filee, emsg);
- return;
- }
- for ( ; *s != '\0'; ++s, ++vnam) {
- *vnam = *s;
- }
- *vnam = '\0';
-}
-
-/*
- * Get values for integer parameters.
- */
-void c_nngeti(char *pnam, int *ival)
-{
- if (!strncmp(pnam,"asc",3) OR !strncmp(pnam,"ASC",3)) {
- *ival = auto_scale;
- }
- else if (!strncmp(pnam,"igr",3) OR !strncmp(pnam,"IGR",3)) {
- *ival = igrad;
- }
- else if (!strncmp(pnam,"upd",3) OR !strncmp(pnam,"UPD",3)) {
- *ival = updir;
- }
- else if (!strncmp(pnam,"non",3) OR !strncmp(pnam,"NON",3)) {
- *ival = non_neg;
- }
- else if (!strncmp(pnam,"sdi",3) OR !strncmp(pnam,"SDI",3)) {
- *ival = sdip;
- }
- else if (!strncmp(pnam,"rad",3) OR !strncmp(pnam,"RAD",3)) {
- *ival = rads;
- }
- else if (!strncmp(pnam,"opt",3) OR !strncmp(pnam,"OPT",3)) {
- *ival = optim;
- }
- else if (!strncmp(pnam,"ext",3) OR !strncmp(pnam,"EXT",3)) {
- *ival = extrap;
- }
- else if (!strncmp(pnam,"adf",3) OR !strncmp(pnam,"ADF",3)) {
- *ival = adf;
- }
- else if (!strncmp(pnam,"dup",3) OR !strncmp(pnam,"DUP",3)) {
- *ival = nndup;
- }
- else {
- sprintf(emsg,"\n Parameter name supplied is: %s\n",pnam);
- ErrorHnd(23, "c_nngeti", filee, emsg);
- }
-}
-
-
-/*
- * Set values for character parameters.
- */
-void c_nnsetc(char *pnam, char *vnam)
-{
- int i;
- char *s;
- if (!strncmp(pnam,"alg",3) OR !strncmp(pnam,"ALG",3)) {
- s = tri_file;
- for ( ; *vnam != '\0'; ++s, ++vnam) {
- *s = *vnam;
- }
- *s = '\0';
- }
- else if (!strncmp(pnam,"erf",3) OR !strncmp(pnam,"ERF",3)) {
- if (!strncmp(vnam,"stderr",6)) {
- filee = stderr;
- strcpy(error_file,"stderr");
- }
- else if (!strncmp(vnam,"stdout",6)) {
- filee = stdout;
- strcpy(error_file,"stdout");
- }
- else {
- if ((filee = fopen(vnam,"w")) EQ (FILE *) NULL)
- {
- ErrorHnd(24, "c_nnsetc", stderr, "\n");
- return;
- }
- strcpy(error_file,vnam);
- }
- }
- else {
- sprintf(emsg,"\n Parameter name supplied is: %s\n",pnam);
- ErrorHnd(23, "c_nnsetc", filee, emsg);
- }
-}
-
-/*
- * Set values for integer parameters.
- */
-void c_nnseti(char *pnam, int ival)
-{
- if (!strncmp(pnam,"asc",3) OR !strncmp(pnam,"ASC",3)) {
- auto_scale = ival;
- }
- else if (!strncmp(pnam,"igr",3) OR !strncmp(pnam,"IGR",3)) {
- igrad = ival;
- }
- else if (!strncmp(pnam,"upd",3) OR !strncmp(pnam,"UPD",3)) {
- updir = ival;
- }
- else if (!strncmp(pnam,"non",3) OR !strncmp(pnam,"NON",3)) {
- non_neg = ival;
- }
- else if (!strncmp(pnam,"sdi",3) OR !strncmp(pnam,"SDI",3)) {
- sdip = ival;
- }
- else if (!strncmp(pnam,"rad",3) OR !strncmp(pnam,"RAD",3)) {
- rads = ival;
- }
- else if (!strncmp(pnam,"opt",3) OR !strncmp(pnam,"OPT",3)) {
- optim = ival;
- }
- else if (!strncmp(pnam,"ext",3) OR !strncmp(pnam,"EXT",3)) {
- extrap = ival;
- }
- else if (!strncmp(pnam,"adf",3) OR !strncmp(pnam,"ADF",3)) {
- adf = ival;
- }
- else if (!strncmp(pnam,"dup",3) OR !strncmp(pnam,"DUP",3)) {
- nndup = ival;
- }
- else {
- sprintf(emsg,"\n Parameter name supplied is: %s\n",pnam);
- ErrorHnd(23, "c_nnseti", filee, emsg);
- }
-}
-
-void NGCALLF(nnseti,NNSETI) (char *pnam, int *ival)
-{
- c_nnseti(pnam, *ival);
-}
-void NGCALLF(nngeti,NNGETI) (char *pnam, int *ival)
-{
- c_nngeti(pnam, ival);
-}
-
-void NGCALLF(fnnsetc,FNNSETC) (char *pnam, char *cval, int *clen)
-{
- char cdum[256];
- int i;
-
- for (i = 0 ; i < *clen ; i++) {
- cdum[i] = cval[i];
- }
- i = *clen;
- cdum[i] = '\0';
- c_nnsetc(pnam, cdum);
-}
-void NGCALLF(fnngetc,FNNGETC) (char *pnam, char *cval, int *clen)
-{
- char cdum[256] = {" "};
- int i,jf;
-
- c_nngetc(pnam, cdum);
- jf = 0;
- for (i = 0 ; i < *clen ; i++) {
- if ((cdum[i] != '\0') && (jf == 0)) {
- cval[i] = cdum[i];
- }
- else
- {
- jf = 1;
- cval[i] = ' ';
- }
- }
-}
diff --git a/CEP/PyBDSM/src/natgrid/Src/nnuserd.c b/CEP/PyBDSM/src/natgrid/Src/nnuserd.c
deleted file mode 100644
index 7fc8f61ecd6661c41950bc968fc9378b111e72b0..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/natgrid/Src/nnuserd.c
+++ /dev/null
@@ -1,230 +0,0 @@
-#include "nnuheadd.h"
-#include "nnuhead.h"
-#include <stdlib.h>
-
-extern int error_status;
-
-/*
- * Get values for double parameters.
- */
-void c_nngetrd(char *pnam, double *dval)
-{
- if (!strncmp(pnam,"bi",2) OR !strncmp(pnam,"BI",2) OR
- !strncmp(pnam,"bI",2) OR !strncmp(pnam,"Bi",2)) {
- *dval = bI;
- }
- else if (!strncmp(pnam,"bj",2) OR !strncmp(pnam,"BJ",2) OR
- !strncmp(pnam,"bJ",2) OR !strncmp(pnam,"Bj",2)) {
- *dval = bJ;
- }
- else if (!strncmp(pnam,"magx",4) OR !strncmp(pnam,"MAGX",4)) {
- *dval = magx;
- }
- else if (!strncmp(pnam,"magy",4) OR !strncmp(pnam,"MAGY",4)) {
- *dval = magy;
- }
- else if (!strncmp(pnam,"magz",4) OR !strncmp(pnam,"MAGZ",4)) {
- *dval = magz;
- }
- else if (!strncmp(pnam,"hor",3) OR !strncmp(pnam,"HOR",3)) {
- *dval = horilap;
- }
- else if (!strncmp(pnam,"ver",3) OR !strncmp(pnam,"VER",3)) {
- *dval = vertlap;
- }
- else if (!strncmp(pnam,"nul",3) OR !strncmp(pnam,"NUL",3)) {
- *dval = nuldat;
- }
- else if (!strncmp(pnam,"xas",3) OR !strncmp(pnam,"XAS",3)) {
- *dval = magx_auto;
- }
- else if (!strncmp(pnam,"yas",3) OR !strncmp(pnam,"YAS",3)) {
- *dval = magy_auto;
- }
- else if (!strncmp(pnam,"zas",3) OR !strncmp(pnam,"ZAS",3)) {
- *dval = magz_auto;
- }
- else {
- sprintf(emsg,"\n Parameter name supplied is: %s\n",pnam);
- ErrorHnd(23, "c_nngetrd", filee, emsg);
- }
-}
-
-/*
- * Set values for double parameters.
- */
-void c_nnsetrd(char *pnam, double dval)
-{
- if (!strncmp(pnam,"bi",2) OR !strncmp(pnam,"BI",2) OR
- !strncmp(pnam,"bI",2) OR !strncmp(pnam,"Bi",2)) {
- if (dval < 1.) {
- bI = 1.;
- }
- else if (dval > 3.) {
- bI = 3.;
- }
- else {
- bI = dval;
- }
- }
- else if (!strncmp(pnam,"bj",2) OR !strncmp(pnam,"BJ",2) OR
- !strncmp(pnam,"bJ",2) OR !strncmp(pnam,"Bj",2)) {
- if (dval < 3.) {
- bJ = 3.;
- }
- else if (dval > 9.) {
- bJ = 9.;
- }
- else {
- bJ = dval;
- }
- }
- else if (!strncmp(pnam,"magx",4) OR !strncmp(pnam,"MAGX",4)) {
- magx = dval;
- }
- else if (!strncmp(pnam,"magy",4) OR !strncmp(pnam,"MAGY",4)) {
- magy = dval;
- }
- else if (!strncmp(pnam,"magz",4) OR !strncmp(pnam,"MAGZ",4)) {
- magz = dval;
- }
- else if (!strncmp(pnam,"hor",3) OR !strncmp(pnam,"HOR",3)) {
- horilap = dval;
- }
- else if (!strncmp(pnam,"ver",3) OR !strncmp(pnam,"VER",3)) {
- vertlap = dval;
- }
- else if (!strncmp(pnam,"nul",3) OR !strncmp(pnam,"NUL",3)) {
- nuldat = dval;
- }
- else {
- sprintf(emsg,"\n Parameter name supplied is: %s\n",pnam);
- ErrorHnd(23, "c_nnsetrd", filee, emsg);
- }
-}
-
-/*
- * C entries in support of the Fortran interface.
- */
-
-#ifdef UNICOS
-void NGCALLF(natgridd,NATGRIDD) (int *n, double *x, double *y, double *z,
- int *nxg, int *nyg, double *xg, double *yg, double *zg,
- int *ier)
-{
- ErrorHnd(29, "natgridd", filee, "\n");
- *ier = error_status;
- return;
-}
-#else
-void NGCALLF(natgridd,NATGRIDD) (int *n, double *x, double *y, double *z,
- int *nxg, int *nyg, double *xg, double *yg, double *zg,
- int *ier)
-{
- double *zar;
- int nn, mm;
-
- zar = c_natgridd(*n, x, y, z, *nxg, *nyg, xg, yg, ier);
-
- if (*ier) return;
-
- for (mm = 0 ; mm < *nxg ; mm++) {
- for (nn = 0 ; nn < *nyg ; nn++) {
- *(zg + nn * (*nxg) + mm) = zar[mm*(*nyg)+nn];
- }
- }
- free(zar);
-
- return;
-}
-#endif
-
-#ifdef UNICOS
-void NGCALLF(nnsetrd,NNSETRD) (char *pnam, double *rval)
-{
- ErrorHnd(29, "nnsetrd", filee, "\n");
-}
-#else
-void NGCALLF(nnsetrd,NNSETRD) (char *pnam, double *rval)
-{
- c_nnsetrd(pnam, *rval);
-}
-#endif
-
-#ifdef UNICOS
-void NGCALLF(nngetrd,NNGETRD) (char *pnam, double *rval)
-{
- ErrorHnd(29, "nngetrd", filee, "\n");
-}
-#else
-void NGCALLF(nngetrd,NNGETRD) (char *pnam, double *rval)
-{
- c_nngetrd(pnam, rval);
-}
-#endif
-
-#ifdef UNICOS
-void NGCALLF(nngetsloped,NNGETSLOPED) (int *row, int *col,
- double *slope, int *ier)
-{
- ErrorHnd(29, "nngetsloped", filee, "\n");
- *ier = error_status;
-}
-#else
-void NGCALLF(nngetsloped,NNGETSLOPED) (int *row, int *col,
- double *slope, int *ier)
-{
- c_nngetsloped(*row-1, *col-1, slope, ier);
-}
-#endif
-
-#ifdef UNICOS
-void NGCALLF(nngetaspectd,NNGETASPECTD) (int *row, int *col,
- double *aspect, int *ier)
-{
- ErrorHnd(29, "nngetaspectd", filee, "\n");
- *ier = error_status;
-}
-#else
-void NGCALLF(nngetaspectd,NNGETASPECTD) (int *row, int *col,
- double *aspect, int *ier)
-{
- c_nngetaspectd(*row-1, *col-1, aspect, ier);
-}
-#endif
-
-#ifdef UNICOS
-void NGCALLF(nnpntinitd,NNPNTINITD) (int *n, double *x, double *y, double *z)
-{
- ErrorHnd(29, "nnpntinitd", filee, "\n");
-}
-#else
-void NGCALLF(nnpntinitd,NNPNTINITD) (int *n, double *x, double *y, double *z)
-{
- c_nnpntinitd (*n, x, y, z);
-}
-#endif
-
-#ifdef UNICOS
-void NGCALLF(nnpntd,NNPNTD) (double *x, double *y, double *point)
-{
- ErrorHnd(29, "nnpntd", filee, "\n");
-}
-#else
-void NGCALLF(nnpntd,NNPNTD) (double *x, double *y, double *point)
-{
- c_nnpntd (*x, *y, point);
-}
-#endif
-
-#ifdef UNICOS
-void NGCALLF(nnpntendd,NNPNTENDD) ()
-{
- ErrorHnd(29, "nnpntendd", filee, "\n");
-}
-#else
-void NGCALLF(nnpntendd,NNPNTENDD) ()
-{
- c_nnpntendd ();
-}
-#endif
diff --git a/CEP/PyBDSM/src/natgrid/Src/nnusers.c b/CEP/PyBDSM/src/natgrid/Src/nnusers.c
deleted file mode 100644
index b2d90d09bf915bf8e4bdce56990d9b30359a958c..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/natgrid/Src/nnusers.c
+++ /dev/null
@@ -1,157 +0,0 @@
-#include "nnuheads.h"
-#include "nnuhead.h"
-#include <stdlib.h>
-
-/*
- * Get values for float parameters.
- */
-void c_nngetr(char *pnam, float *dval)
-{
- if (!strncmp(pnam,"bi",2) OR !strncmp(pnam,"BI",2) OR
- !strncmp(pnam,"bI",2) OR !strncmp(pnam,"Bi",2)) {
- *dval = bI;
- }
- else if (!strncmp(pnam,"bj",2) OR !strncmp(pnam,"BJ",2) OR
- !strncmp(pnam,"bJ",2) OR !strncmp(pnam,"Bj",2)) {
- *dval = bJ;
- }
- else if (!strncmp(pnam,"magx",4) OR !strncmp(pnam,"MAGX",4)) {
- *dval = magx;
- }
- else if (!strncmp(pnam,"magy",4) OR !strncmp(pnam,"MAGY",4)) {
- *dval = magy;
- }
- else if (!strncmp(pnam,"magz",4) OR !strncmp(pnam,"MAGZ",4)) {
- *dval = magz;
- }
- else if (!strncmp(pnam,"hor",3) OR !strncmp(pnam,"HOR",3)) {
- *dval = horilap;
- }
- else if (!strncmp(pnam,"ver",3) OR !strncmp(pnam,"VER",3)) {
- *dval = vertlap;
- }
- else if (!strncmp(pnam,"nul",3) OR !strncmp(pnam,"NUL",3)) {
- *dval = nuldat;
- }
- else if (!strncmp(pnam,"xas",3) OR !strncmp(pnam,"XAS",3)) {
- *dval = magx_auto;
- }
- else if (!strncmp(pnam,"yas",3) OR !strncmp(pnam,"YAS",3)) {
- *dval = magy_auto;
- }
- else if (!strncmp(pnam,"zas",3) OR !strncmp(pnam,"ZAS",3)) {
- *dval = magz_auto;
- }
- else {
- sprintf(emsg,"\n Parameter name supplied is: %s\n",pnam);
- ErrorHnd(23, "c_nngetr", filee, emsg);
- }
-}
-
-/*
- * Set values for float parameters.
- */
-void c_nnsetr(char *pnam, float dval)
-{
- if (!strncmp(pnam,"bi",2) OR !strncmp(pnam,"BI",2) OR
- !strncmp(pnam,"bI",2) OR !strncmp(pnam,"Bi",2)) {
- if (dval < 1.) {
- bI = 1.;
- }
- else if (dval > 3.) {
- bI = 3.;
- }
- else {
- bI = dval;
- }
- }
- else if (!strncmp(pnam,"bj",2) OR !strncmp(pnam,"BJ",2) OR
- !strncmp(pnam,"bJ",2) OR !strncmp(pnam,"Bj",2)) {
- if (dval < 3.) {
- bJ = 3.;
- }
- else if (dval > 9.) {
- bJ = 9.;
- }
- else {
- bJ = dval;
- }
- }
- else if (!strncmp(pnam,"magx",4) OR !strncmp(pnam,"MAGX",4)) {
- magx = dval;
- }
- else if (!strncmp(pnam,"magy",4) OR !strncmp(pnam,"MAGY",4)) {
- magy = dval;
- }
- else if (!strncmp(pnam,"magz",4) OR !strncmp(pnam,"MAGZ",4)) {
- magz = dval;
- }
- else if (!strncmp(pnam,"hor",3) OR !strncmp(pnam,"HOR",3)) {
- horilap = dval;
- }
- else if (!strncmp(pnam,"ver",3) OR !strncmp(pnam,"VER",3)) {
- vertlap = dval;
- }
- else if (!strncmp(pnam,"nul",3) OR !strncmp(pnam,"NUL",3)) {
- nuldat = dval;
- }
- else {
- sprintf(emsg,"\n Parameter name supplied is: %s\n",pnam);
- ErrorHnd(23, "c_nngetc", filee, emsg);
- }
-}
-
-/*
- * C entries in support of the Fortran interface.
- */
-void NGCALLF(natgrids,NATGRIDS) (int *n, float *x, float *y, float *z,
- int *nxg, int *nyg, float *xg, float *yg,
- float *zg, int *ier)
-{
- float *zar;
- int nn, mm;
-
- zar = c_natgrids(*n, x, y, z, *nxg, *nyg, xg, yg, ier);
-
- if (*ier) return;
-
- for (mm = 0 ; mm < *nxg ; mm++) {
- for (nn = 0 ; nn < *nyg ; nn++) {
- *(zg + nn * (*nxg) + mm) = zar[mm*(*nyg)+nn];
- }
- }
- free(zar);
-
- return;
-}
-void NGCALLF(nnsetr,NNSETR) (char *pnam, float *rval)
-{
- c_nnsetr(pnam, *rval);
-}
-void NGCALLF(nngetr,NNGETR) (char *pnam, float *rval)
-{
- c_nngetr(pnam, rval);
-}
-
-void NGCALLF(nngetslopes,NNGETSLOPES) (int *row, int *col,
- float *slope, int *ier)
-{
- c_nngetslopes(*row-1, *col-1, slope, ier);
-}
-void NGCALLF(nngetaspects,NNGETASPECTS) (int *row, int *col,
- float *aspect, int *ier)
-{
- c_nngetaspects(*row-1, *col-1, aspect, ier);
-}
-void NGCALLF(nnpntinits,NNPNTINITS) (int *n, float *x, float *y, float *z)
-{
- c_nnpntinits (*n, x, y, z);
-}
-void NGCALLF(nnpnts,NNPNTS) (float *x, float *y, float *point)
-{
- c_nnpnts (*x, *y, point);
-}
-void NGCALLF(nnpntend,NNPNTEND) ()
-{
- c_nnpntend ();
-}
diff --git a/CEP/PyBDSM/src/natgrid/Test/test_natgrid.py b/CEP/PyBDSM/src/natgrid/Test/test_natgrid.py
deleted file mode 100755
index 3f7b6f87401f59777200e1fce390efefbbea22b9..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/natgrid/Test/test_natgrid.py
+++ /dev/null
@@ -1,1109 +0,0 @@
-# Adapted for numpy/ma/cdms2 by convertcdms.py
-
-"""Documentation for module natgridtest: an automatic test for natgrid, an interface to the ngmath NATGRID
-
- TESTING
-
- Typing
-
- cdat natgridtest.py
-
- generates some testing of the natgridmodule using analytical functions as fields. It also writes a
- hard copy of the documentation to the file natgridmodule.doc and a copy of the information describing
- the nature of the tests to test.asc. For the single and the double precision interpolations from
- randomly spaced data to a rectangular grid on a sphere, the numerical results are written to netCDF files
- if there is access to the module cdms.
-
- DOCUMENTATION
-
- Without conducting the tests, documentation written to the file natgridmodule.doc can be produced after
- importing the natgridtest module by typing
-
- natgridtest.document()
-
-"""
-import sys, numpy, math, random, nat, natgridmodule
-
-writeTestcase = 'yes'
-try:
- import cdms2
-except ImportError:
- print 'Can not write test case results to netCDF files without module cdms2'
- writeTestcase = 'no'
-
-def document():
- #-------------------------------------------------------------------------------
- #
- # purpose: 'document' writes documentation for the user to a file
- #
- # usage: import natgridtest
- # natgridtest.document()
- #
- # passed : nothing
- #
- # returned: nothing
- #
- #-------------------------------------------------------------------------------
- import nat
-
- std = sys.stdout # save sys.stout to allow reassigning later
- sys.stdout = open( 'natgridmodule.doc', 'w')
-
- print '**********************************************************************************************\n'
- print '*************************** Overview of the CDAT interface to natgrid ************************\n'
- print '**********************************************************************************************\n'
- print nat.__doc__
- print
- print
- print ' HELP PACKAGE EXAMPLE \n'
- print ' ************************ Default Parameter Table **********************\n'
- print ' -----------------------------------------------------------------------------------------------------'
- nat.help('table')
- print
-
- sys.stdout = std
-
- return None
-
-def sendOutput(msg, value = None, screen = 'no'):
- #------------------------------------------------------------------------------
- #
- # purpose: send a message and optionally a value a file and if screen is not 'no'
- # send the same thing to the screen
- #
- # usage: sendOutput(msg, value = number, screen = 'yes')
- #
- # passed : msg - the string to write to the output media
- # value - a number
- # screen - a string set to something different from 'no' if the output also
- # goes to the screen
- #
- # returned: None
- #
- #------------------------------------------------------------------------------
- if value is None:
- if screen != 'no':
- print msg
- output.write(msg + '\n')
- else:
- if screen != 'no':
- print msg, `value`
- output.write(msg + ' %15.11e\n' % (value,))
-
- return None
-
-# ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
-# ++++++++++++++++++++++++++++++++++ Autotest Calls ++++++++++++++++++++++++++++++++++
-# ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
-
-def runtests():
- #-----------------------------------------------------------------------------
- #
- # purpose: call test cases
- #
- #-----------------------------------------------------------------------------
- sendOutput('############################################################################################')
- sendOutput('################## Here are the results of running analytical test cases #####################')
- sendOutput('############################################################################################')
-
- testError = 0
- for n in range(1,8):
- err = choose(n)
- if err != 0:
- #print 'test number with error :',n,err
- testError = testError + 1
- return testError
-
-def choose(case):
- #-------------------------------------------------------------------------------
- #
- # purpose: check out natgrid
- #
- # case 1: a simple 2D interpolation using y32 -- single precision
- #---------------------------------------------------------------------------------
- err = 0
-
- if case == 1:
- sendOutput('\n******* natural neighbor linear interpolation -- single precision *****\n')
-
- # array dimensions
- ni = 6 # size of xi, yi, and dataIn
- nxo = 21
- nyo = 21
-
- # input arrays and data
-
- xiList = [0.00, 1.00, 0.00, 1.00, 0.40, 0.75]
- yiList = [0.00, 0.00, 1.00, 1.00, 0.20, 0.65]
- dataInList = [0.00, 0.00, 0.00, 0.00, 1.25, 0.80]
-
- xi = numpy.array(xiList, numpy.float32)
- yi = numpy.array(yiList, numpy.float32)
- dataIn = numpy.array(dataInList, numpy.float32)
-
- # output array
-
- xo = uniformGrid(nxo, 1.0, 0.0)
- yo = uniformGrid(nyo, 1.0, 0.0)
-
- r = nat.Natgrid(xi, yi, xo, yo)
-
- dataOut = r.rgrd(dataIn)
-
- sendOutput('*** writing single precision linear interpolation test case to the netCDF file SingleLinearRegrid.nc')
- write1D_4DField('SingleLinearRegrid', dataOut, xo, yo)
-
- dataCheck = storedAnswers('linearRegrid')
- dataCheck = numpy.reshape(dataCheck, (nxo,nyo))
-
- error = rmserror(dataOut, dataCheck) # find the rms error
- sendOutput('\n******* compare results\n')
- sendOutput('*** the linear interpolation test case rms error is usually less than 1.e-05')
- sendOutput('*** the linear interpolation test case rms error = ', error)
-
- if error > .0001:
- err = 1
-
- return err
-
- elif case == 2:
- sendOutput('\n******* natural neighbor linear interpolation -- double precision *****\n')
-
- # array dimensions
- ni = 6 # size 0f xi, yi, and dataIn
- nxo = 21
- nyo = 21
-
- # input arrays and data
-
- xiList = [0.00, 1.00, 0.00, 1.00, 0.40, 0.75]
- yiList = [0.00, 0.00, 1.00, 1.00, 0.20, 0.65]
- dataInList = [0.00, 0.00, 0.00, 0.00, 1.25, 0.80]
-
- xi = numpy.array(xiList, numpy.float64)
- yi = numpy.array(yiList, numpy.float64)
- dataIn = numpy.array(dataInList, numpy.float64)
-
- # output array
-
- xo = uniformGrid(nxo, 1.0, 0.0)
- yo = uniformGrid(nyo, 1.0, 0.0)
-
- xo = xo.astype(numpy.float64)
- yo = yo.astype(numpy.float64)
-
- r = nat.Natgrid(xi, yi, xo, yo)
-
- dataOut = r.rgrd(dataIn)
-
- xo = xo.astype(numpy.float32) # convert back to single precision
- yo = yo.astype(numpy.float32)
- dataOut = dataOut.astype(numpy.float32)
-
- sendOutput('*** writing double precision linear interpolation test case to the netCDF file DoubleLinearRegrid.nc')
- write1D_4DField('DoubleLinearRegrid', dataOut, xo, yo)
-
- dataCheck = storedAnswers('linearRegrid')
- dataCheck = numpy.reshape(dataCheck, (nxo,nyo))
-
- error = rmserror(dataOut, dataCheck) # find the rms error
- sendOutput('\n******* compare results\n')
- sendOutput('*** the linear interpolation test case rms error is usually less than 1.e-05')
- sendOutput('*** the linear interpolation test case rms error = ', error)
-
- if error > .0001:
- err = 1
-
- return err
-
- elif case == 3:
- sendOutput('\n******* natural neighbor nonlinear interpolation -- single precision *****\n')
-
- # array dimensions
- ni = 6 # size of xi, yi, and dataIn
- nxo = 21
- nyo = 21
-
- # input arrays and data
-
- xiList = [0.00, 1.00, 0.00, 1.00, 0.40, 0.75]
- yiList = [0.00, 0.00, 1.00, 1.00, 0.20, 0.65]
- dataInList = [0.00, 0.00, 0.00, 0.00, 1.25, 0.80]
-
- xi = numpy.array(xiList, numpy.float32)
- yi = numpy.array(yiList, numpy.float32)
- dataIn = numpy.array(dataInList, numpy.float32)
-
- # output array
-
- xo = uniformGrid(nxo, 1.0, 0.0)
- yo = uniformGrid(nyo, 1.0, 0.0)
-
- r = nat.Natgrid(xi, yi, xo, yo)
- r.igr = 1 # choose nonlinear interpolation
-
- dataOut = r.rgrd(dataIn)
-
- sendOutput('*** writing single precision nonlinear interpolation test case to the netCDF file SingleNonlinearRegrid.nc')
- write1D_4DField('SingleNonlinearRegrid', dataOut, xo, yo)
-
- dataCheck = storedAnswers('nonlinearRegrid')
- dataCheck = numpy.reshape(dataCheck, (nxo,nyo))
-
- error = rmserror(dataOut, dataCheck) # find the rms error
- sendOutput('\n******* compare results\n')
- sendOutput('*** the nonlinear interpolation test case rms error is usually less than 1.e-05')
- sendOutput('*** the nonlinear interpolation test case rms error = ', error)
-
- if error > .0001:
- err = 1
-
- return err
-
- elif case == 4:
- sendOutput('\n******* natural neighbor nonlinear interpolation -- double precision *****\n')
-
- # array dimensions
- ni = 6 # size 0f xi, yi, and dataIn
- nxo = 21
- nyo = 21
-
- # input arrays and data
-
- xiList = [0.00, 1.00, 0.00, 1.00, 0.40, 0.75]
- yiList = [0.00, 0.00, 1.00, 1.00, 0.20, 0.65]
- dataInList = [0.00, 0.00, 0.00, 0.00, 1.25, 0.80]
-
- xi = numpy.array(xiList, numpy.float64)
- yi = numpy.array(yiList, numpy.float64)
- dataIn = numpy.array(dataInList, numpy.float64)
-
- # output array
-
- xo = uniformGrid(nxo, 1.0, 0.0)
- yo = uniformGrid(nyo, 1.0, 0.0)
-
- xo = xo.astype(numpy.float64)
- yo = yo.astype(numpy.float64)
-
- r = nat.Natgrid(xi, yi, xo, yo)
- r.igr = 1 # choose nonlinear interpolation
-
- dataOut = r.rgrd(dataIn)
-
- xo = xo.astype(numpy.float32) # convert back to single precision
- yo = yo.astype(numpy.float32)
- dataOut = dataOut.astype(numpy.float32)
-
- sendOutput('*** writing double precision nonlinear interpolation test case to the netCDF file DoubleNonlinearRegrid.nc')
- write1D_4DField('DoubleNonlinearRegrid', dataOut, xo, yo)
-
- dataCheck = storedAnswers('nonlinearRegrid')
- dataCheck = numpy.reshape(dataCheck, (nxo,nyo))
-
- error = rmserror(dataOut, dataCheck) # find the rms error
- sendOutput('\n******* compare results\n')
- sendOutput('*** the nonlinear interpolation test case rms error is usually less than 1.e-05')
- sendOutput('*** the nonlinear interpolation test case rms error = ', error)
-
- if error > .0001:
- err = 1
-
- return err
-
-
- elif case == 5:
- sendOutput('\n******* interpolation and computation of aspects and slopes -- single precision *******\n')
-
- # array dimensions
- ni = 800 # size of xi, yi, and dataIn
- nxo = 21
- nyo = 21
-
- # input array and data
-
- xisort, xi = randomGrid(ni, 1.2, -0.2) # xisort has random numbers monotonically increasing
- yisort, yi = randomGrid(ni, 1.2, -0.2)
-
- dataIn = numpy.zeros((ni,), numpy.float32)
- for i in range(ni):
- dataIn[i] = (xi[i] - 0.25)*(xi[i] - 0.25) + (yi[i] - 0.50)*(yi[i] - 0.50)
-
- # output array
-
- xo = uniformGrid(nxo, 1.0, 0.0)
- yo = uniformGrid(nyo, 1.0, 0.0)
-
- r = nat.Natgrid(xi, yi, xo, yo)
-
- dataOut, aspect, slope = r.rgrd(dataIn, aspectSlope = 'yes')
-
-
- sendOutput('*** writing single precision linear interpolation test case to the netCDF file AspectSlopeRegrid.nc')
- write1D_4DField('AspectSlopeRegrid', dataOut, xo, yo)
-
- # Calculate the exact answer
- dataCheck = numpy.zeros((nxo, nyo), numpy.float32)
- for i in range(nxo):
- for j in range(nyo):
- dataCheck[i,j] = (xo[i] - 0.25)*(xo[i] - 0.25) + (yo[j] - 0.50)*(yo[j] - 0.50)
-
- sendOutput('*** writing exact answer to single precision interpolation test case to the netCDF file AspectSlopeExact.nc')
- write1D_4DField('AspectSlopeExact', dataOut, xo, yo)
-
- error = rmserror(dataOut, dataCheck) # find the rms error
- sendOutput('\n******* compare results\n')
- sendOutput('*** the linear interpolation test case rms error is usually about 1.e-03')
- sendOutput('*** the linear interpolation test case rms error = ', error)
-
- # Calculate the x and y aspects
-
- u = numpy.zeros((nxo, nyo), numpy.float32)
- v = numpy.zeros((nxo, nyo), numpy.float32)
- for i in range(nxo):
- for j in range(nyo):
- uvtemp = (math.pi/180.)*aspect[i,j]
- u[i,j] = math.cos(uvtemp)
- v[i,j] = math.sin(uvtemp)
-
- sendOutput('*** writing the cosine of the aspect to xaspect.nc')
- sendOutput('*** writing the sine of the aspect to yaspect.nc')
- write1D_4DField('xaspect', u, xo, yo)
- write1D_4DField('yaspect', v, xo, yo)
-
- if error > .01:
- err = 1
-
- return err
-
- elif case == 6:
- sendOutput('\n******* single point mode -- single precision *****\n')
-
- # array dimensions
- ni = 171 # size of xi, yi, and dataIn
- nxo = 21
- nyo = 21
-
- # input arrays and data
-
- xisort, xi = randomGrid(ni, 1.2, -0.2) # xisort has random numbers monotonically increasing
- yisort, yi = randomGrid(ni, 1.2, -0.2)
-
- dataIn = numpy.zeros((ni,), numpy.float32)
- for i in range(ni):
- dataIn[i] = (xi[i] - 0.25)*(xi[i] - 0.25) + (yi[i] - 0.50)*(yi[i] - 0.50)
-
- # output array
- xo = uniformGrid(nxo, 1.0, 0.0)
- yo = uniformGrid(nyo, 1.0, 0.0)
- xn, yn = grid2Dto1D(xo, yo)
-
- r = nat.Natgrid(xi, yi, xn, yn, listOutput = 'yes')
- r.igr = 1 # choose nonlinear interpolation
-
- zn = r.rgrd(dataIn)
- xo, yo, dataOut = c1Dto2D(nxo, nyo, xn, yn, zn)
-
- sendOutput('*** writing single precision single point mode test case to the netCDF file SinglePointMode.nc')
- write1D_4DField('SinglePointMode', dataOut, xo, yo)
-
- dataCheck = numpy.zeros((nxo,nyo), numpy.float32)
- for i in range(nxo):
- for j in range(nyo):
- dataCheck[i,j] = (xo[i] - 0.25)*(xo[i] - 0.25) + (yo[j] - 0.50)*(yo[j] - 0.50)
-
- sendOutput('*** writing exact answer to single precision single point mode test case to the netCDF file SinglePointExact.nc')
- write1D_4DField('SinglePointExact', dataOut, xo, yo)
-
- error = rmserror(dataOut, dataCheck) # find the rms error
- sendOutput('\n******* compare results\n')
- sendOutput('*** the nonlinear single point mode test case rms error is usually less than 1.e-02')
- sendOutput('*** the nonlinear single point test case rms error = ', error)
-
- if error > .01:
- err = 1
-
- return err
-
-
- elif case == 7:
- sendOutput('\n******* nonlinear interpolation of y32 with a wrap -- single precision *****\n')
-
- # input arrays and data
-
- lati,latiSort,loni,loniSort = storedGrids()
-
- y32 = YData(loni, lati) # y32(lati[i], loni[j]) format
-
- newOrder = (1,0)
- y32 = numpy.transpose(y32, newOrder)
- lonLinear, latLinear, y32Linear = c2Dto1D(loni, lati, y32) # change to the linear list format
-
-
- # output array
-
- nlato = 71
- nlono = 144
- lato = uniformGrid(nlato, 87.5, -87.5) # start at - 87.5
- lono = uniformGrid(nlono, 357.5, 0.0) # start at 0.
-
-
- r = nat.Natgrid(latLinear, lonLinear, lato, lono)
- #r.igr = 1 # choose nonlinear interpolation
-
- dataOut = r.rgrd(y32Linear, wrap = 'yes')
-
- dataCheck = YData(lono, lato) # longitude varies the fastest
- sendOutput('*** writing exact answer to single precision y32 interpolatiion test case to the netCDF file y32Exact.nc')
- write1D_4DField('y32Exact', dataCheck, lato, lono) # lono varies the fastest. Shape is(nlati, nloni)
-
- sendOutput('*** writing single precision y32 interpolation test case to the netCDF file y32Regrid.nc')
- write1D_4DField('y32Regrid', dataOut, lato, lono)
-
- error = rmserror(dataOut, dataCheck) # find the rms error
- sendOutput('\n******* compare results\n')
- sendOutput('*** the nonlinear interpolation test case rms error is usually less than 1.e-02')
- sendOutput('*** the nonlinear interpolation test case rms error = ', error)
-
- if error > .01:
- err = 1
-
- return err
-
-
-
- dataCheck = YData(lono, lato) # longitude varies the fastest
- write1D_4DField('data_Check', dataCheck, lato, lono) # lono varies the fastest. Shape is(nlati, nloni)
-
- # ------------------------------------------------------------------------------
- # Call the interpolator
-
- print 'making instance for case 8'
-
- r = nat.Natgrid(latLinear, lonLinear, lato, lono)
-
- print 'call rgrd method for case 8'
-
- dataOut = r.rgrd(y32Linear, wrap = 'yes')
-
- print 'returning from call rgrd method for case 8'
-
- write1D_4DField('wrapdata_Out', dataOut, lato, lono) # loni varies the fastest. Shape is(nlati, nloni)
-
- print 'dataOut and dataCheck shapes before call to rmserror', dataOut.shape, dataCheck.shape
- error = rmserror(dataOut, dataCheck) # find the rms error
- print 'case 1 rms error = ', error
-
- return None
-
-# ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
-# ++++++++++++++++++++++++++++++++ Autotest Utilities +++++++++++++++++++++++++++++++++
-# ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
-
-def randomGrid(number, vmax, vmin):
- #----------------------------------------------------------------------------------------
- #
- # purpose: to construct a grid coordinate which is random but monotonically increasing
- #
- # usage: vsort, vraw = randomGrid(number, vmax, vmin)
- #
- # passed: number - the size of the array
- # vmax - the largest possible value
- # vmin - the smallest possible value
- #
- # returned: vsort - a numpy array sorted to be monotonically increasing
- # vraw - the same array as vsort without the sort into a monotonically
- # increasing values
- #
- #-----------------------------------------------------------------------------------------
- listNumbers = [] # generate random numbers
- vrange = vmax - vmin
- for i in range(number):
- listNumbers.append(vmin + vrange*random.random() )
-
- vraw = numpy.array(listNumbers, numpy.float32) # make array of raw list of random numbers
-
- listNumbers.sort() # make array of sorted list of random numbers
- listNumbers.reverse() # make array of sorted list of random numbers
- vsort = numpy.array(listNumbers, numpy.float32)
-
- return vsort, vraw
-
-def storedAnswers(choice):
- #----------------------------------------------------------------------------------------
- #
- # purpose: to store the answers to selected test cases
- #
- # usage: data = storedAnswers(choice)
- #
- # passed : choice -- a string idetifying the desired data
- #
- # returned: data
- #
- #----------------------------------------------------------------------------------------
-
- if choice == 'linearRegrid':
- linearRegridList = [
- 8.4993E-07, 3.7050E-03, 6.9907E-03, 9.8621E-03, 1.2324E-02, 1.4383E-02, 1.6037E-02, 1.7102E-02,
- 1.7583E-02, 1.7586E-02, 1.7189E-02, 1.6454E-02, 1.5428E-02, 1.4147E-02, 1.2642E-02, 1.0937E-02,
- 9.0519E-03, 7.0031E-03, 4.8043E-03, 2.4671E-03, 4.3879E-06, 7.2811E-03, 1.5625E-01, 1.5625E-01,
- 1.5625E-01, 1.5625E-01, 1.5625E-01, 1.5476E-01, 1.5088E-01, 1.4598E-01, 1.4069E-01, 1.3534E-01,
- 1.3005E-01, 1.2487E-01, 1.1980E-01, 1.1476E-01, 1.0963E-01, 1.0414E-01, 9.7756E-02, 8.8053E-02,
- 6.6249E-02, 8.4452E-04, 1.3750E-02, 2.6209E-01, 3.1250E-01, 3.1250E-01, 3.1250E-01, 3.1158E-01,
- 3.0454E-01, 2.9412E-01, 2.8246E-01, 2.7050E-01, 2.5865E-01, 2.4703E-01, 2.3563E-01, 2.2431E-01,
- 2.1283E-01, 2.0076E-01, 1.8705E-01, 1.6770E-01, 1.3780E-01, 8.7170E-02, 1.6137E-03, 1.9411E-02,
- 2.9894E-01, 4.5966E-01, 4.6875E-01, 4.6875E-01, 4.6336E-01, 4.4829E-01, 4.2966E-01, 4.1005E-01,
- 3.9052E-01, 3.7142E-01, 3.5281E-01, 3.3451E-01, 3.1623E-01, 2.9748E-01, 2.7694E-01, 2.5040E-01,
- 2.1500E-01, 1.6605E-01, 9.5877E-02, 2.3095E-03, 2.4271E-02, 3.1159E-01, 5.5232E-01, 6.2500E-01,
- 6.2490E-01, 6.1118E-01, 5.8621E-01, 5.5806E-01, 5.2959E-01, 5.0180E-01, 4.7493E-01, 4.4884E-01,
- 4.2320E-01, 3.9749E-01, 3.7065E-01, 3.3827E-01, 2.9815E-01, 2.4785E-01, 1.8341E-01, 1.0017E-01,
- 2.9305E-03, 2.8341E-02, 3.1249E-01, 6.0503E-01, 7.7272E-01, 7.8001E-01, 7.5547E-01, 7.1872E-01,
- 6.7979E-01, 6.4164E-01, 6.0504E-01, 5.6997E-01, 5.3607E-01, 5.0277E-01, 4.6931E-01, 4.3199E-01,
- 3.8746E-01, 3.3460E-01, 2.7123E-01, 1.9442E-01, 1.0243E-01, 3.4747E-03, 3.1627E-02, 3.1249E-01,
- 6.2499E-01, 8.7816E-01, 9.3479E-01, 8.9655E-01, 8.4565E-01, 7.9466E-01, 7.4613E-01, 7.0030E-01,
- 6.5677E-01, 6.1484E-01, 5.7368E-01, 5.3151E-01, 4.8291E-01, 4.2690E-01, 3.6244E-01, 2.8776E-01,
- 2.0100E-01, 1.0437E-01, 3.9397E-03, 3.4140E-02, 3.1249E-01, 6.2500E-01, 9.3601E-01, 1.0908E+00,
- 1.0330E+00, 9.6510E-01, 9.0112E-01, 8.4192E-01, 7.8681E-01, 7.3480E-01, 6.8485E-01, 6.3583E-01,
- 5.8391E-01, 5.2465E-01, 4.5798E-01, 3.8304E-01, 2.9858E-01, 2.0549E-01, 1.0620E-01, 4.3220E-03,
- 3.5887E-02, 3.1250E-01, 6.2500E-01, 9.3750E-01, 1.2500E+00, 1.1529E+00, 1.0692E+00, 9.9449E-01,
- 9.2588E-01, 8.6236E-01, 8.0251E-01, 7.4497E-01, 6.8836E-01, 6.2670E-01, 5.5756E-01, 4.8112E-01,
- 3.9679E-01, 3.0586E-01, 2.0979E-01, 1.0798E-01, 4.6174E-03, 3.6877E-02, 3.1250E-01, 6.2396E-01,
- 9.1734E-01, 1.1479E+00, 1.1546E+00, 1.1088E+00, 1.0471E+00, 9.8424E-01, 9.2126E-01, 8.5666E-01,
- 7.9286E-01, 7.2938E-01, 6.5911E-01, 5.8108E-01, 4.9636E-01, 4.0694E-01, 3.1293E-01, 2.1400E-01,
- 1.0972E-01, 4.8200E-03, 3.7117E-02, 3.1097E-01, 6.0588E-01, 8.6639E-01, 1.0526E+00, 1.0806E+00,
- 1.0693E+00, 1.0360E+00, 9.9296E-01, 9.4356E-01, 8.8783E-01, 8.2419E-01, 7.5644E-01, 6.8069E-01,
- 5.9785E-01, 5.0976E-01, 4.1712E-01, 3.1998E-01, 2.1814E-01, 1.1139E-01, 4.9216E-03, 3.6509E-02,
- 3.0353E-01, 5.7902E-01, 8.1072E-01, 9.6003E-01, 9.8676E-01, 1.0031E+00, 9.9376E-01, 9.6959E-01,
- 9.3602E-01, 8.9422E-01, 8.4272E-01, 7.7847E-01, 7.0090E-01, 6.1499E-01, 5.2351E-01, 4.2744E-01,
- 3.2700E-01, 2.2214E-01, 1.1290E-01, 4.9105E-03, 3.4793E-02, 2.9338E-01, 5.4929E-01, 7.5334E-01,
- 8.6617E-01, 8.9081E-01, 9.1544E-01, 9.3057E-01, 9.2741E-01, 9.1235E-01, 8.8750E-01, 8.5160E-01,
- 8.0010E-01, 7.2228E-01, 6.3305E-01, 5.3775E-01, 4.3786E-01, 3.3380E-01, 2.2572E-01, 1.1400E-01,
- 4.7721E-03, 3.2230E-02, 2.8206E-01, 5.1778E-01, 6.9308E-01, 7.7022E-01, 7.9485E-01, 8.1948E-01,
- 8.4411E-01, 8.6324E-01, 8.6898E-01, 8.6426E-01, 8.4838E-01, 8.1552E-01, 7.4542E-01, 6.5225E-01,
- 5.5230E-01, 4.4790E-01, 3.3973E-01, 2.2820E-01, 1.1429E-01, 4.5258E-03, 2.9007E-02, 2.6994E-01,
- 4.8377E-01, 6.2700E-01, 6.7426E-01, 6.9889E-01, 7.2353E-01, 7.4816E-01, 7.7279E-01, 7.9709E-01,
- 8.1464E-01, 8.2358E-01, 8.1914E-01, 7.7103E-01, 6.7221E-01, 5.6584E-01, 4.5576E-01, 3.4286E-01,
- 2.2858E-01, 1.1429E-01, 4.1797E-03, 2.5235E-02, 2.5676E-01, 4.4512E-01, 5.5023E-01, 5.7831E-01,
- 6.0294E-01, 6.2757E-01, 6.5220E-01, 6.7608E-01, 6.9914E-01, 7.2227E-01, 7.4625E-01, 7.7187E-01,
- 7.9999E-01, 6.8572E-01, 5.7143E-01, 4.5715E-01, 3.4286E-01, 2.2858E-01, 1.1429E-01, 3.7338E-03,
- 2.0987E-02, 2.4149E-01, 3.9756E-01, 4.5772E-01, 4.8235E-01, 5.0624E-01, 5.2689E-01, 5.4531E-01,
- 5.6257E-01, 5.7940E-01, 5.9628E-01, 6.1336E-01, 6.2992E-01, 6.3999E-01, 6.3186E-01, 5.6427E-01,
- 4.5715E-01, 3.4286E-01, 2.2858E-01, 1.1429E-01, 3.1880E-03, 1.6310E-02, 2.2155E-01, 3.3264E-01,
- 3.6166E-01, 3.8203E-01, 3.9797E-01, 4.1139E-01, 4.2346E-01, 4.3486E-01, 4.4598E-01, 4.5695E-01,
- 4.6754E-01, 4.7658E-01, 4.7999E-01, 4.7999E-01, 4.7245E-01, 4.2657E-01, 3.4218E-01, 2.2858E-01,
- 1.1429E-01, 2.5420E-03, 1.1239E-02, 1.8956E-01, 2.4052E-01, 2.5713E-01, 2.6835E-01, 2.7702E-01,
- 2.8442E-01, 2.9121E-01, 2.9769E-01, 3.0399E-01, 3.1006E-01, 3.1554E-01, 3.1941E-01, 3.1999E-01,
- 3.1999E-01, 3.1999E-01, 3.1737E-01, 2.9044E-01, 2.2479E-01, 1.1429E-01, 1.7957E-03, 5.7978E-03,
- 1.1982E-01, 1.3170E-01, 1.3741E-01, 1.4126E-01, 1.4439E-01, 1.4721E-01, 1.4990E-01, 1.5251E-01,
- 1.5503E-01, 1.5735E-01, 1.5920E-01, 1.6000E-01, 1.6000E-01, 1.6000E-01, 1.6000E-01, 1.6000E-01,
- 1.6000E-01, 1.5335E-01, 1.1016E-01, 9.4906E-04, 7.6115E-08, 1.3378E-03, 2.5593E-03, 3.6624E-03,
- 4.6450E-03, 5.5041E-03, 6.2360E-03, 6.8355E-03, 7.2956E-03, 7.6065E-03, 7.7542E-03, 7.7177E-03,
- 7.4883E-03, 7.1010E-03, 6.5572E-03, 5.8568E-03, 4.9997E-03, 3.9857E-03, 2.8145E-03, 1.4861E-03,
- 9.4486E-07]
-
- return numpy.array((linearRegridList), numpy.float32)
-
- elif choice == 'nonlinearRegrid':
- nonlinearRegridList = [
- 1.4061E-07, 5.9856E-04, 3.3025E-03, 7.1219E-03, 1.1544E-02, 1.6204E-02, 2.0812E-02, 2.5066E-02,
- 2.8761E-02, 3.1773E-02, 3.4004E-02, 3.5371E-02, 3.5807E-02, 3.5254E-02, 3.3662E-02, 3.0987E-02,
- 2.7190E-02, 2.2235E-02, 1.6086E-02, 8.6904E-03, 9.3576E-07, -1.6475E-03, 4.0636E-02, 5.1891E-02,
- 6.2648E-02, 7.2691E-02, 8.1856E-02, 8.8773E-02, 9.2560E-02, 9.4276E-02, 9.4444E-02, 9.3304E-02,
- 9.0947E-02, 8.7384E-02, 8.2576E-02, 7.6457E-02, 6.8940E-02, 5.9917E-02, 4.9275E-02, 3.6498E-02,
- 2.0278E-02, 1.0188E-04, -2.3704E-03, 1.1213E-01, 1.6880E-01, 1.8774E-01, 2.0453E-01, 2.1804E-01,
- 2.2176E-01, 2.1920E-01, 2.1323E-01, 2.0517E-01, 1.9562E-01, 1.8480E-01, 1.7278E-01, 1.5950E-01,
- 1.4489E-01, 1.2884E-01, 1.1104E-01, 8.9636E-02, 6.3626E-02, 3.2008E-02, -8.7618E-05, -2.3976E-03,
- 1.5408E-01, 3.2600E-01, 3.6266E-01, 3.8633E-01, 3.9820E-01, 3.9203E-01, 3.7764E-01, 3.5940E-01,
- 3.3920E-01, 3.1785E-01, 2.9562E-01, 2.7254E-01, 2.4856E-01, 2.2356E-01, 1.9698E-01, 1.6591E-01,
- 1.2967E-01, 8.7819E-02, 4.0778E-02, -4.2476E-04, -1.9720E-03, 1.7771E-01, 4.5068E-01, 5.6699E-01,
- 5.9747E-01, 6.0036E-01, 5.8014E-01, 5.5077E-01, 5.1774E-01, 4.8328E-01, 4.4829E-01, 4.1306E-01,
- 3.7759E-01, 3.4182E-01, 3.0540E-01, 2.6448E-01, 2.1798E-01, 1.6583E-01, 1.0820E-01, 4.7477E-02,
- -8.5668E-04, -1.2987E-03, 1.8918E-01, 5.3532E-01, 7.6919E-01, 8.1425E-01, 8.0561E-01, 7.7032E-01,
- 7.2542E-01, 6.7709E-01, 6.2785E-01, 5.7870E-01, 5.2997E-01, 4.8176E-01, 4.3409E-01, 3.8373E-01,
- 3.2738E-01, 2.6522E-01, 1.9749E-01, 1.2515E-01, 5.2692E-02, -1.3503E-03, -5.4612E-04, 1.9741E-01,
- 5.7911E-01, 9.1567E-01, 1.0141E+00, 9.9646E-01, 9.4885E-01, 8.9058E-01, 8.2845E-01, 7.6536E-01,
- 7.0264E-01, 6.4088E-01, 5.8039E-01, 5.2051E-01, 4.5538E-01, 3.8409E-01, 3.0698E-01, 2.2467E-01,
- 1.3902E-01, 5.7014E-02, -1.8810E-03, 1.5272E-04, 2.0341E-01, 5.9346E-01, 9.9962E-01, 1.1721E+00,
- 1.1542E+00, 1.1021E+00, 1.0360E+00, 9.6363E-01, 8.8911E-01, 8.1453E-01, 7.4107E-01, 6.6956E-01,
- 5.9736E-01, 5.1877E-01, 4.3381E-01, 3.4303E-01, 2.4748E-01, 1.5066E-01, 6.0634E-02, -2.4281E-03,
- 6.9861E-04, 2.0731E-01, 6.0225E-01, 1.0160E+00, 1.2500E+00, 1.2555E+00, 1.2148E+00, 1.1508E+00,
- 1.0743E+00, 9.9241E-01, 9.0888E-01, 8.2606E-01, 7.4565E-01, 6.6273E-01, 5.7280E-01, 4.7605E-01,
- 3.7323E-01, 2.6681E-01, 1.6090E-01, 6.3627E-02, -2.9730E-03, 1.0247E-03, 2.0918E-01, 6.0431E-01,
- 9.9699E-01, 1.2241E+00, 1.2631E+00, 1.2530E+00, 1.2085E+00, 1.1440E+00, 1.0666E+00, 9.7985E-01,
- 8.9131E-01, 8.0517E-01, 7.1501E-01, 6.1671E-01, 5.1081E-01, 3.9933E-01, 2.8423E-01, 1.6982E-01,
- 6.6003E-02, -3.4978E-03, 1.0951E-03, 2.0736E-01, 5.7738E-01, 9.3136E-01, 1.1486E+00, 1.2035E+00,
- 1.2158E+00, 1.1947E+00, 1.1512E+00, 1.0908E+00, 1.0171E+00, 9.3223E-01, 8.4588E-01, 7.5422E-01,
- 6.5262E-01, 5.4169E-01, 4.2310E-01, 2.9972E-01, 1.7733E-01, 6.7690E-02, -3.9847E-03, 8.6025E-04,
- 1.9721E-01, 5.3426E-01, 8.4983E-01, 1.0425E+00, 1.0970E+00, 1.1360E+00, 1.1387E+00, 1.1160E+00,
- 1.0752E+00, 1.0199E+00, 9.5238E-01, 8.7484E-01, 7.8660E-01, 6.8440E-01, 5.6941E-01, 4.4420E-01,
- 3.1296E-01, 1.8312E-01, 6.8501E-02, -4.4155E-03, 2.4226E-04, 1.8267E-01, 4.8442E-01, 7.5872E-01,
- 9.1395E-01, 9.6583E-01, 1.0156E+00, 1.0482E+00, 1.0516E+00, 1.0343E+00, 1.0007E+00, 9.5303E-01,
- 8.9252E-01, 8.1160E-01, 7.1103E-01, 5.9312E-01, 4.6183E-01, 3.2305E-01, 1.8641E-01, 6.8047E-02,
- -4.7698E-03, -5.8461E-04, 1.6578E-01, 4.3042E-01, 6.5949E-01, 7.7110E-01, 8.2280E-01, 8.7431E-01,
- 9.2200E-01, 9.5600E-01, 9.6629E-01, 9.5780E-01, 9.3276E-01, 8.9167E-01, 8.2627E-01, 7.3058E-01,
- 6.1102E-01, 4.7395E-01, 3.2792E-01, 1.8550E-01, 6.5685E-02, -5.0087E-03, -1.4594E-03, 1.4726E-01,
- 3.7257E-01, 5.5181E-01, 6.2548E-01, 6.7771E-01, 7.3133E-01, 7.8294E-01, 8.2931E-01, 8.6682E-01,
- 8.8664E-01, 8.8759E-01, 8.6922E-01, 8.2572E-01, 7.3918E-01, 6.1846E-01, 4.7522E-01, 3.2240E-01,
- 1.7822E-01, 6.2363E-02, -5.0958E-03, -2.2396E-03, 1.2721E-01, 3.1004E-01, 4.3490E-01, 4.8592E-01,
- 5.3958E-01, 5.9600E-01, 6.5193E-01, 7.0330E-01, 7.4713E-01, 7.8192E-01, 8.0552E-01, 8.1423E-01,
- 8.0000E-01, 7.2297E-01, 5.9985E-01, 4.5521E-01, 3.0629E-01, 1.6880E-01, 5.8577E-02, -4.9947E-03,
- -2.7897E-03, 1.0526E-01, 2.4121E-01, 3.1212E-01, 3.6074E-01, 4.1573E-01, 4.6891E-01, 5.1792E-01,
- 5.6226E-01, 6.0169E-01, 6.3568E-01, 6.6300E-01, 6.8064E-01, 6.7757E-01, 6.4324E-01, 5.5705E-01,
- 4.2785E-01, 2.8778E-01, 1.5805E-01, 5.4318E-02, -4.6651E-03, -2.9748E-03, 8.0481E-02, 1.6467E-01,
- 2.0663E-01, 2.5106E-01, 2.9319E-01, 3.3190E-01, 3.6737E-01, 3.9985E-01, 4.2931E-01, 4.5529E-01,
- 4.7648E-01, 4.8955E-01, 4.8514E-01, 4.6828E-01, 4.3856E-01, 3.6952E-01, 2.6597E-01, 1.4587E-01,
- 4.9559E-02, -4.0612E-03, -2.6588E-03, 5.0914E-02, 8.7792E-02, 1.1716E-01, 1.4398E-01, 1.6823E-01,
- 1.9056E-01, 2.1134E-01, 2.3069E-01, 2.4842E-01, 2.6399E-01, 2.7621E-01, 2.8241E-01, 2.7877E-01,
- 2.7097E-01, 2.5980E-01, 2.4222E-01, 2.0011E-01, 1.2931E-01, 4.4238E-02, -3.1307E-03, -1.6950E-03,
- 1.5529E-02, 2.6578E-02, 3.5795E-02, 4.4418E-02, 5.2999E-02, 6.1652E-02, 7.0306E-02, 7.8788E-02,
- 8.6822E-02, 9.3985E-02, 9.9597E-02, 1.0247E-01, 1.0283E-01, 1.0170E-01, 9.8775E-02, 9.3695E-02,
- 8.5980E-02, 7.1050E-02, 3.6490E-02, -1.8052E-03, -9.6657E-07, -8.0903E-03, -1.3190E-02, -1.6109E-02,
- -1.7301E-02, -1.7095E-02, -1.5765E-02, -1.3557E-02, -1.0694E-02, -7.3887E-03, -3.8441E-03, -2.5851E-04,
- 3.1767E-03, 6.2818E-03, 8.8673E-03, 1.0736E-02, 1.1677E-02, 1.1452E-02, 9.7757E-03, 6.2375E-03,
- 4.3809E-07]
-
- return numpy.array((nonlinearRegridList), numpy.float32)
- else:
- print 'unknown option in call for data in storedAnswers'
- return None
-
-def uniformGrid(number, vend, vstart):
- #----------------------------------------------------------------------------
- #
- # purpose: to construct a grid coordinate which is uniform
- #
- # usage: v = uniformGrid(number, vend, vstart)
- #
- # passed: number - the size of the array
- # vend - the last value
- # vstart - the first value
- #
- # returned: v - a float32 numpy array with values from vstart to v end
- #
- #-----------------------------------------------------------------------------
- v = numpy.zeros((number,), numpy.float32)
-
- vinc = (vend - vstart)/(number - 1)
- for n in range(number):
- v[n] = vstart + n*vinc
- return v
-
-def storedGrids():
- """ #-------------------------------------------------------------------
- #
- # purpose: to construct a grid coordinate which is random
- #
- # passed : nothing
- #
- # returned: lati -- a 60 element latitude grid from -90. to +90. degrees
- # latiSort -- lati sorted to be montonically decreasing
- # loni -- a 120 element longitude grid from 0. to 360. degrees
- # loniSort -- loni sorted to be montonically increasing
- #
- #------------------------------------------------------------------------"""
- latiList = [
- 1.3092E+01, 7.1081E+01, 3.2199E+01, 2.6314E+01, -7.5665E+01, -7.2182E+00, -2.1963E+01, -8.3351E+01,
- 4.8161E+01, 8.6379E+01, -5.6722E+01, -3.3604E+01, 3.4670E-01, -5.9393E+00, -1.7894E+01, 1.7068E+01,
- -1.0846E+01, -6.0505E+00, -4.9974E+01, 7.1796E+01, 3.3333E+01, 8.0870E+01, 2.7362E+00, 2.6315E+00,
- -3.9012E+01, 5.2667E+00, -8.1956E+01, 8.8042E+01, 8.0710E+00, -5.3203E+01, -6.5512E+00, 5.0851E+01,
- 2.2580E+00, -2.2110E+01, 5.3739E+01, -8.7512E+01, 6.7964E+01, 3.9599E+01, 1.2495E+01, -1.1603E+01,
- -1.3217E+01, 3.0072E+01, -6.2477E+01, 8.9158E+01, 6.1896E+01, 3.5624E+01, -3.5438E+01, 6.2368E+01,
- -3.2040E+01, 7.2130E+01, -7.9999E+01, 6.4780E+01, 5.3882E+01, 6.9012E+01, 7.9715E+01, -7.2460E+01,
- 7.5047E+00, -1.5061E+01, 2.5178E+01, 6.9948E+00]
-
- latiSortList = [
- -8.7512E+01, -8.3351E+01, -8.1956E+01, -7.9999E+01, -7.5665E+01, -7.2460E+01, -6.2477E+01, -5.6722E+01,
- -5.3203E+01, -4.9974E+01, -3.9012E+01, -3.5438E+01, -3.3604E+01, -3.2040E+01, -2.2110E+01, -2.1963E+01,
- -1.7894E+01, -1.5061E+01, -1.3217E+01, -1.1603E+01, -1.0846E+01, -7.2182E+00, -6.5512E+00, -6.0505E+00,
- -5.9393E+00, 3.4670E-01, 2.2580E+00, 2.6315E+00, 2.7362E+00, 5.2667E+00, 6.9948E+00, 7.5047E+00,
- 8.0710E+00, 1.2495E+01, 1.3092E+01, 1.7068E+01, 2.5178E+01, 2.6314E+01, 3.0072E+01, 3.2199E+01,
- 3.3333E+01, 3.5624E+01, 3.9599E+01, 4.8161E+01, 5.0851E+01, 5.3739E+01, 5.3882E+01, 6.1896E+01,
- 6.2368E+01, 6.4780E+01, 6.7964E+01, 6.9012E+01, 7.1081E+01, 7.1796E+01, 7.2130E+01, 7.9715E+01,
- 8.0870E+01, 8.6379E+01, 8.8042E+01, 8.9158E+01]
- latiSortList.reverse()
-
- loniList = [
- 1.0950E+02, 3.1987E+02, 1.6087E+02, 2.2737E+02, 1.4790E+02, 6.2704E+01, 6.2566E+01, 2.4556E+02,
- 2.4902E+01, 9.1912E+01, 1.2039E+02, 1.6807E+02, 1.8303E+02, 2.4495E+02, 1.1643E+01, 9.5821E+01,
- 1.6826E+02, 2.3723E+02, 1.4022E+01, 2.6537E+02, 3.4034E+01, 1.0511E+02, 2.4025E+02, 1.0651E+02,
- 8.4892E+01, 3.4940E+02, 1.6315E+02, 1.1100E+02, 1.4735E+02, 1.7356E+02, 7.5067E+01, 2.9491E+02,
- 1.3526E+02, 3.4038E+02, 3.1191E+02, 2.4636E+02, 1.0361E+02, 3.1934E+02, 2.5720E+02, 3.5403E+02,
- 1.8194E+02, 2.8795E+02, 9.0098E+01, 2.7536E+02, 4.1070E+01, 3.7064E+01, 1.5244E+02, 8.5413E+01,
- 1.3328E+02, 3.2401E+02, 2.7889E+01, 1.3045E+02, 2.3126E+01, 2.2804E+02, 1.2270E+02, 1.5981E+02,
- 2.1705E+02, 2.2611E+02, 2.9517E+02, 3.5181E+02, 3.0866E+02, 1.0522E+01, 2.2290E+01, 1.2809E+02,
- 3.1070E+01, 2.3676E+02, 1.6915E+01, 3.2640E+02, 7.1367E+01, 1.9983E+02, 1.0566E+02, 2.7452E+02,
- 1.3069E+02, 2.5578E+02, 2.2619E+02, 3.5151E+02, 3.3032E+01, 1.2169E+02, 1.4333E+02, 8.3669E+01,
- 3.3945E-01, 2.8520E+02, 9.7079E+01, 3.1794E+02, 1.7400E+02, 3.1042E+02, 1.2403E+02, 2.8891E+02,
- 2.5776E+02, 1.5096E+02, 4.0489E+01, 2.1803E+02, 2.6891E+02, 2.5970E+02, 2.3404E+02, 3.2476E+01,
- 6.4254E+01, 2.9157E+02, 4.8417E+00, 2.7701E+02, 7.5394E+01, 1.5646E+02, 4.3079E+01, 1.6228E+02,
- 3.3645E+02, 2.8462E+02, 3.4708E+02, 1.8942E+02, 1.4303E+02, 1.8721E+00, 1.3013E+02, 1.9077E+02,
- 1.8328E+02, 3.5694E+02, 3.5559E+02, 1.4661E+01, 8.7624E+01, 2.0111E+02, 1.5145E+02, 1.8391E+02]
-
- loniSortList = [
- 3.3945E-01, 1.8721E+00, 4.8417E+00, 1.0522E+01, 1.1643E+01, 1.4022E+01, 1.4661E+01, 1.6915E+01,
- 2.2290E+01, 2.3126E+01, 2.4902E+01, 2.7889E+01, 3.1070E+01, 3.2476E+01, 3.3032E+01, 3.4034E+01,
- 3.7064E+01, 4.0489E+01, 4.1070E+01, 4.3079E+01, 6.2566E+01, 6.2704E+01, 6.4254E+01, 7.1367E+01,
- 7.5067E+01, 7.5394E+01, 8.3669E+01, 8.4892E+01, 8.5413E+01, 8.7624E+01, 9.0098E+01, 9.1912E+01,
- 9.5821E+01, 9.7079E+01, 1.0361E+02, 1.0511E+02, 1.0566E+02, 1.0651E+02, 1.0950E+02, 1.1100E+02,
- 1.2039E+02, 1.2169E+02, 1.2270E+02, 1.2403E+02, 1.2809E+02, 1.3013E+02, 1.3045E+02, 1.3069E+02,
- 1.3328E+02, 1.3526E+02, 1.4303E+02, 1.4333E+02, 1.4735E+02, 1.4790E+02, 1.5096E+02, 1.5145E+02,
- 1.5244E+02, 1.5646E+02, 1.5981E+02, 1.6087E+02, 1.6228E+02, 1.6315E+02, 1.6807E+02, 1.6826E+02,
- 1.7356E+02, 1.7400E+02, 1.8194E+02, 1.8303E+02, 1.8328E+02, 1.8391E+02, 1.8942E+02, 1.9077E+02,
- 1.9983E+02, 2.0111E+02, 2.1705E+02, 2.1803E+02, 2.2611E+02, 2.2619E+02, 2.2737E+02, 2.2804E+02,
- 2.3404E+02, 2.3676E+02, 2.3723E+02, 2.4025E+02, 2.4495E+02, 2.4556E+02, 2.4636E+02, 2.5578E+02,
- 2.5720E+02, 2.5776E+02, 2.5970E+02, 2.6537E+02, 2.6891E+02, 2.7452E+02, 2.7536E+02, 2.7701E+02,
- 2.8462E+02, 2.8520E+02, 2.8795E+02, 2.8891E+02, 2.9157E+02, 2.9491E+02, 2.9517E+02, 3.0866E+02,
- 3.1042E+02, 3.1191E+02, 3.1794E+02, 3.1934E+02, 3.1987E+02, 3.2401E+02, 3.2640E+02, 3.3645E+02,
- 3.4038E+02, 3.4708E+02, 3.4940E+02, 3.5151E+02, 3.5181E+02, 3.5403E+02, 3.5559E+02, 3.5694E+02]
-
- lati = numpy.array((latiList), numpy.float32)
- latiSort = numpy.array((latiSortList), numpy.float32)
- loni = numpy.array((loniList), numpy.float32)
- loniSort = numpy.array((loniSortList), numpy.float32)
-
- return lati, latiSort, loni, loniSort
-
-def grid2Dto1D(x, y):
- """ #-------------------------------------------------------------------
- #
- # purpose: to construct a linear grid from a rectangular one
- #
- # passed : x[i] and y[j]
- #
- # returned: xn[n], yn[n]
- #
- #------------------------------------------------------------------------"""
-
- numberx = len(x)
- numbery = len(y)
- size =numberx*numbery
- xn = numpy.zeros(size, numpy.float32)
- yn = numpy.zeros(size, numpy.float32)
-
- for i in range(numberx):
- for j in range(numbery):
- n = j + i*numbery
- xn[n] = x[i]
- yn[n] = y[j]
-
- return (xn, yn)
-
-def c1Dto2D(numberx, numbery, xn, yn, zn):
- """ #-------------------------------------------------------------------
- #
- # purpose: to construct 2D z[i,j] 1D zn[n] format
- #
- # passed: xn[n], yn[n], zn[n]
- #
- # returned : x[i], y[j] and z[i,j]
- #
- #------------------------------------------------------------------------"""
-
- x = numpy.zeros(numberx, numpy.float32)
- y = numpy.zeros(numbery, numpy.float32)
-
- for i in range(numberx):
- x[i] = xn[i*numbery]
-
- for j in range(numbery):
- y[j] = yn[j]
-
- z = numpy.reshape(zn, (numberx, numbery))
-
- return (x, y, z)
-def c2Dto1D(x, y, z):
- #---------------------------------------------------------------------------------------------------
- #
- # purpose: to construct 1D zn[n] from 2D z[i,j] format
- #
- # usage: xn, yn, zn = c2Dto1D(x, y, z)
- #
- # passed: x - the array which describes the rectangular grid associated with the first z index
- # y - the array which describes the rectangular grid associated with the second z index
- # z - the 2D data associated with the x, y grid
- #
- # returned: xn - a list form of the x array
- # yn - a list form of the y array
- # zn - a list form of the data array (this array has the same length as xn and yn
- #
- #---------------------------------------------------------------------------------------------------
-
- numberx = len(x)
- numbery = len(y)
- size =numberx*numbery
- xn = numpy.zeros(size, numpy.float32)
- yn = numpy.zeros(size, numpy.float32)
-
- for i in range(numberx):
- for j in range(numbery):
- n = j + i*numbery
- xn[n] = x[i]
- yn[n] = y[j]
-
- zn = numpy.ravel(z)
-
- return (xn, yn, zn)
-
-def write1D_4DField(varname, dataField, x, y = None, z = None, t = None):
-
- #------------------------------------------------------------------------------
- #
- # purpose: write an output field which may be 1D, 2D, 3D or 4D to a NetCDF file
- #
- # usage: write1D_4DField(varname, dataField, x, y, z = None, t = None) for a 2D write
- #
- # passed : varname - name of the variable and the file id
- # x,y,z,t - dimension vectors
- # dataField - the data
- #
- # returned: None
- #
- #-------------------------------------------------------------------------------
- import cdms2
-
- fileObj = cdms2.createDataset(varname + '.nc')
-
- # construct the axis tuple
-
- x = x.astype(numpy.float64)
- x_axis = fileObj.createAxis('x', x)
- axisList = [x_axis]
-
- if y is not None:
- y = y.astype(numpy.float64)
- y_axis = fileObj.createAxis('y', y)
- axisList.append(y_axis)
-
- if z is not None:
- z = z.astype(numpy.float64)
- z_axis = fileObj.createAxis('z', z)
- axisList.append(z_axis)
-
- if t is not None:
- t = t.astype(numpy.float64)
- t_axis = fileObj.createAxis('t', t)
- axisList.append(t_axis)
-
- if len(axisList) == 1:
- axisTuple = (x_axis,)
- else:
- axisTuple = tuple(axisList)
-
- # write the data to the file
-
- var = fileObj.createVariable(varname, numpy.float32, axisTuple) # variable without data
-
- var[:] = dataField # copy in the data
-
- fileObj.close()
-
- return None
-
-#-----------------------------------------------------------------
-
-def YData(lonvals, latvals, data_name = 'Y32'):
- #----------------------------------------------------------------------------
- #
- # purpose: construct Y33, Y32, Y31 or Y30 data
- #
- # usage: data = YData(lonvals, latvals, data_name = 'Y32'):
- #
- # passed : lonvals -- longitude vactor
- # latvals -- latitude vactor
- #
- # returned: data
- #-----------------------------------------------------------------------------
-
- if data_name[:3] == 'Y33':
- data = Y33(lonvals, latvals)
- elif data_name[:3] == 'Y32':
- data = Y32(lonvals, latvals)
- elif data_name[:3] == 'Y31':
- data = Y31(lonvals, latvals)
- elif data_name[:3] == 'Y30':
- data = Y30(lonvals, latvals)
- else:
- msg = 'Must choose Y33, Y32, Y31 or Y30'
- raise ValueError, msg
- return
-
- return data
-
-def Y33(lonvals, latvals):
- #------------------------------------------------------------------------------
- #
- # purpose: construct Y33 data
- #
- # usage: y33 = Y33(lonvals, latvals)
- #
- # passed : lonvals -- longitude vactor
- # latvals -- latitude vactor
- #
- # returned: data
- #------------------------------------------------------------------------------
-
- nlon = len(lonvals)
- nlat = len(latvals)
- phi = (math.pi/180.)*lonvals
- theta = (math.pi/180.)*latvals
-
- y33 = numpy.zeros( (nlat,nlon), numpy.float32) # memory
-
- fac = -(1./4.)*math.sqrt( (35./(4.*math.pi)) )
- fac = 1.0
-
- for i in range(nlon):
- for j in range(nlat):
- y33[j,i] = fac*(math.sin(theta[j])**3)*math.cos(3.*phi[i])
-
- return y33
-
-
-def Y32(lonvals, latvals):
- #-------------------------------------------------------------------------------
- #
- # purpose: construct Y32 data
- #
- # usage: y32 = Y32(lonvals, latvals)
- #
- # passed : lonvals -- longitude vactor
- # latvals -- latitude vactor
- #
- # returned: data
- #-------------------------------------------------------------------------------
-
- nlon = len(lonvals)
- nlat = len(latvals)
- phi = (math.pi/180.)*lonvals
- theta = (math.pi/180.)*latvals
-
- y32 = numpy.zeros( (nlat,nlon), numpy.float32) # memory
-
- fac = (1./4.)*math.sqrt( (105./(4.*math.pi)) )
- fac = 1.0
-
- for i in range(nlon):
- for j in range(nlat):
- y32[j,i] = fac*(math.sin(theta[j])**2)*math.cos(theta[j])*math.cos(2.*phi[i])
-
- return y32
-
-
-def Y31(lonvals, latvals):
- #--------------------------------------------------------------------------------
- #
- # purpose: construct Y31 data
- #
- # usage: y31 = Y31(lonvals, latvals)
- #
- # passed : lonvals -- longitude vactor
- # latvals -- latitude vactor
- #
- # returned: data
- #--------------------------------------------------------------------------------
-
- nlon = len(lonvals)
- nlat = len(latvals)
- phi = (math.pi/180.)*lonvals
- theta = (math.pi/180.)*latvals
-
- y31 = numpy.zeros( (nlat,nlon), numpy.float32) # memory
-
- fac = -(1./4.)*math.sqrt( (21./(4.*math.pi)) )
- fac = 1.0
-
- for i in range(nlon):
- for j in range(nlat):
- y31[j,i] = fac*math.sin(theta[j])*(5.*math.cos(theta[j])**2 - 1.)*math.cos(phi[i])
-
- return y31
-
-
-def Y30(lonvals, latvals):
- #----------------------------------------------------------------------------------
- #
- # purpose: construct Y30 data
- #
- # usage: y30 = Y30(lonvals, latvals)
- #
- # passed : lonvals -- longitude vactor
- # latvals -- latitude vactor
- #
- # returned: data
- #-----------------------------------------------------------------------------------
-
- nlon = len(lonvals)
- nlat = len(latvals)
- phi = (math.pi/180.)*lonvals
- theta = (math.pi/180.)*latvals
-
- lonvals = makelon(nlon)
- phi = lonvals
- phi = (math.pi/180.)*lonvals
-
- latvals, colatvals = makelat(nlat, grid_type)
- latvals, colatvals = makelat(nlat)
- theta = (math.pi/180.)*colatvals
-
- y30 = numpy.zeros( (nlat,nlon), numpy.float32) # memory
-
- fac = math.sqrt( (7./(4.*math.pi)) )
- fac = 1.0
-
- for i in range(nlon):
- for j in range(nlat):
- y30[j,i] = fac*( (5./2.)*math.cos(theta[j])**3 - (3./2.)*math.cos(theta[j]) )
-
- return y30
-
-#-----------------------------------------------------------------
-
-def rmserror(data1, data2):
- #---------------------------------------------------------------------------------
- #
- # purpose: compute the rms error for two data sets having the same shape
- #
- # passed : the two data sets
- #
- # returned: rms error
- #
- #---------------------------------------------------------------------------------
-
- if data1.shape != data2.shape:
- print 'Error in shape in rmserror'
- print 'data1 shape = ', data1.shape
- print 'data2 shape = ', data2.shape
- raise ValueError
-
- d1 = numpy.ravel(data1)
- d2 = numpy.ravel(data2)
-
- sq = (d1 - d2)*(d1 - d2)
- error = numpy.sum(sq)/len(d1)
- rmserror = numpy.sqrt(error)
-
- return rmserror
-
-
-if __name__ == "__main__":
- output = open('test.asc', 'w') # global file name
-
- print 'Running the test computations'
- testError = runtests()
- write = document()
-
- sendOutput(' ')
- sendOutput('*********')
- sendOutput('General information on the use of NATGRID has been written to the file natgridmodule.doc.')
- sendOutput('*********')
- sendOutput(' ')
-
- if testError == 0:
- print 'Testing Completed Successfully'
- else:
- print 'Testing completed but it may have problems. Look at test.asc for an explanation'
-
- print 'Some details on the testing have been written to the file test.asc.'
- print 'General information on the use of NATGRID has been written to the file natgridmodule.doc.'
-
- output.close()
diff --git a/CEP/PyBDSM/src/natgrid/natgridmodule.doc b/CEP/PyBDSM/src/natgrid/natgridmodule.doc
deleted file mode 100644
index 8d9505a1cb250c3bcf04bc1cd4fd656c57dfaf4d..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/natgrid/natgridmodule.doc
+++ /dev/null
@@ -1,396 +0,0 @@
-**********************************************************************************************
-
-*************************** Overview of the CDAT interface to natgrid ************************
-
-**********************************************************************************************
-
----------------------------------------------------------------------------------------------
-
- INTRODUCTION TO NGMATH
-
- The ngmath library is a collection of interpolators and approximators for one-dimensional, two-dimensional
- and three-dimensional data. The packages, which were obtained from NCAR, are:
-
- natgrid -- a two-dimensional random data interpolation package based on Dave Watson's nngridr.
-
- dsgrid -- a three-dimensional random data interpolator based on a simple inverse distance weighting
- algorithm.
-
- fitgrid -- an interpolation package for one-dimensional and two-dimensional gridded data based on
- Alan Cline's Fitpack. Fitpack uses splines under tension to interpolate in one and two
- dimensions.
-
- csagrid -- an approximation package for one-dimensional, two-dimensional and three-dimensional random
- data based on David Fulker's Splpack. csagrid uses cubic splines to calculate its
- approximation function.
-
- cssgrid -- an interpolation package for random data on the surface of a sphere based on the work of
- Robert Renka. cssgrid uses cubic splines to calculate its interpolation function.
-
- shgrid -- an interpolation package for random data in 3-space based on the work of Robert Renka.
- shgrid uses a modified Shepard's algorithm to calculate its interpolation function.
-
- COMPARISION OF NGMATH PACKAGES
-
- Three-dimensional packages -- shgrid, csagrid and dsgrid.
-
- shgrid is probably the package of choice for interpolation. It uses a least squares fit of biquadratics
- to construct its interpolation function. The interpolation function will pass through the original data
- points.
-
- csagrid uses a least squares fit of cubic splines to calculate its approximation function: the calculated
- surface will not necesarily pass through the original data points. The algorithm can become unstable in data
- sparse regions.
-
- dsgrid uses a weighted average algorithm and is stable in all cases, but the resultant interpolation is
- not usually smooth and execution time is very slow. dsgrid is probably best used when csagrid and shgrid
- fail or for comparative purposes.
-
- Two-dimensional packages -- natgrid, fitgrid, csagrid and dsgrid.
-
- natgrid is the package of choice in most cases. It implements a very stable algorithm and has parameters
- for adjusting the smoothness of the output surface.
-
- fitgrid offers user-settable parameters for specifiying derivatives along the boundary of the output grid
- which are not available in natgrid.
-
- csagrid produces an approximate two-dimensional surface which may be smoother than that produced by fitgrid
- and natgrid.
-
- dsgrid is not recommended for two-dimensional surfaces. natgrid is superior in all respects.
-
- One-dimensional packages -- fitgrid and csagrid.
-
- fitgrid is definitely the package of choice. It has many features not available in csagrid, such as
- interpolating parametric curves, finding integrals, handling periodic functions, allowing smoothing that
- varies from linear to a full cubic spline interpolation and specifying slopes at the end points.
-
- Interpolation on a sphere -- cssgrid.
-
- cssgrid is designed specifically for interpolating on a sphere. It uses cubic splines to calculate an
- interpolation function.
-
- NATGRID PACKAGE
-
- natgrid implements a natural neighbor interpolation method. The input for the interpolation is a set
- of randomly spaced two-dimensional coordinates with functional values at those coordinates; the output is a
- set of interpolated values at coordinates in a user specified rectangular grid. The coordinates in the output
- grid must be monotonic in each coordinate direction, but need not be evenly spaced. It is also possible to
- interpolate at a single point.
-
- natgrid uses a weighted average method that is much more sophisticated than the inverse distance weighted
- average used by dsgrid. One distinguishing quality of natural neighbor interpolation is the way in which
- a set of neighboring points (the natural neighbor) is selected to use for interpolating at a point. The
- natural neighbor selection process avoids the problems common to methods based on choosing a fixed number
- of neighboring points, or all points within a fixed distance. Another distinguishing quality of natural
- neighbor interpolation is the way that the weights are calculated for the functional values at the natural
- neighbor coordinates. These weights are based on proportionate area, rather than distances.
-
- The method of finding the natural neighbors and calculating area-based weights to produce interpolated
- values is called natural neighbor linear interpolation. This produces an interpolation surface that has a
- continous slope at all points, except at the original input points. The result of natural neighbor linear
- interpolation can be visualized as producing a snugly fit sheet stretched over all of the input points.
-
- The interpolation method in natgrid also allows for natural neighbor linear interpolation augmented by
- blending in gradient estimates. This is called natural neighbor nonlinear interpolation. It produces an
- interpolation surface that has a continuous slope at all locations; two tautness parameters can be set by
- the user to control the apparent smoothness of the output surface.
-
- NATGRID CONTENTS
-
- Access through Python to the natgrid package from NCAR's ngmath distribution is provided directly through the module
- natgridmodule.so which was generated as a Python C language extension in order to export the natgrid functions
- from the original C language library to Python.
-
- REQUIRED FILE
-
- natgridmodule.so -- the Python interface to the ngmath natgrid package.
-
- USEFUL FILES
-
- nat.py -- the object oriented interface including a general help package.
- natgridtest.py -- the code to test nat.py and to write documentation.
-
- USAGE
-
- This module is designed to use in two ways. One is through the use of the object oriented interface to the underlying
- functions. This approach is recommended for users not already familiar with the original natgrid distribtution because
- it simplifies the calls to the routines. The other method uses the original functions calling them directly from Python.
-
- ------------------- OBJECT ORIENTED APPROACH ----------------
-
- The nat module contains the Natgrid class and its single method, rgrd, which provides access to all the natgrid
- functions. The object oriented approach has been organized as a two step process.
-
- STEP 1.
-
- To make an instance, r, type:
-
- import nat
-
- r = nat.Natgrid(xi, yi, xo, yo)
- or
- r = nat.Natgrid(xi, yi, xo, yo, listOutput = 'yes')
-
- where xi, yi and xo, yo are the input and output grid coordinate arrays. The optional listOutput must
- set to anything except 'no' if xo, yo are in list format as explained below. It is the responsibility
- of the user to set listOutput if the output is in the list form.
-
- The input grid must be organized in a list format always. The size of the xi array and the yi array are
- necessarily equal. For example, if there are n randomly spaced input data points, there
- are n values in xi and n values in yi.
-
- There are two possible formats for the output grid. The output grid coordinate arrays may be a list like
- the input array or it may be a rectangular grid. The choice between the two posibilities is made according
- to requirements in subseqent calls to the method function. The first choice is required if the subsequent
- call is to the single point mode interpolation. The list can have one or more points. Of course, the list
- could describe a rectangular grid. For example, a rectangular grid with 10 x values and 20 y values can be
- rewrtten in list form with 200 x value and 200 y values. However, this form requires calling the slower
- single point interpolator. The second choice is most efficient for the basic interpolation to a rectangular
- output grid. The output grid must be monotonic but need not be equally spced.
-
- The grid coordinate arrays can be single precision (numpy.float32) or double precision (numpy.float64). The
- decision on whether to call for a single or a double precision computation subsequently is made by looking at
- the type of these arrays.
-
- To look at the default settings for the control parameters and a brief description of thier properties, type
-
- r.printDefaultParameterTable()
-
- To change a setting type the new value. For example, to set igr to 1, type
-
- r.igr = 1
-
- To find a value without printing the table, type the name. For example, to exam the value of hor, type
-
- r.hor
-
- To check the settings type
-
- r.printInstanceParameterTable() -- prints in tabular form the parameters used in subsequent calls to the method
- function rgrd.
- or
-
- printStoredParameters() -- prints the parameters in memory which may differ from the above if the user
- has made more than one instance of the Natgrid class.
-
- STEP 2.
-
- natgrid is restricted to two dimensions . Consequently, it is the user's responsibility to reduce the processing of
- higher dimensional data to a sequence of calls using only two dimensional data.
-
- The computations are divided into two groups depending on whether the output arrays are in list form or in rectilinear
- grid form. If they are in list format the single point mode is called to interpolate to those individual points. This is
- the only process possible. On the other hand, if the output goes to a rectangular grid there are more choices. In
- addition to carrying out linear and nonlinear interpolations, it is possible to request aspects and slopes. The aspect
- at a point on the interpolated surface is the direction of steepest descend. The slope is the value of the partial
- derivative taken in the direction of the aspect. The slope is measured as an angle that is zero in a horizonal surface
- and positive below the horizontal.
-
- The following examples cover the basic computations. They start with a indication of the appropriate STEP 1.
-
- Example 1: the basic natural neighbor linear interpolation
-
- As STEP 1 make an instance, r, with:
-
- import nat
-
- r = nat.Natgrid(xi, yi, xo, yo)
-
- where the xo, yo grid is rectilinear as explained above in STEP 1.
-
- Then call the primary interpolation computation to regrid the input data, dataIn, on the grid (xi, yi) to
- the output data, dataOut, on the grid (xo, yo), with
-
- dataOut = r.rgrd( dataIn )
-
- The computation is either single or double precision as determined by the precision submitted in the grid
- description in STEP 1.
-
- It is also possible to request a wrap in the input grid and the input data in the longitude direction, assumed
- to be the yi grid coordinate, by adding a keyword as
-
- dataOut = r.rgrd( dataIn, wrap = 'yes' )
-
-
- Example 2: natural neighbor linear interpolation returning the aspect and the slope.
-
- As STEP 1 make an instance, r, with:
-
- import nat
-
- r = nat.Natgrid(xi, yi, xo, yo)
-
- where the xo, yo grid is rectilinear as explained above in STEP 1.
-
- Then call the primary interpolation computation to regrid the input data, dataIn, on the grid (xi, yi) to
- the output data, dataOut, on the grid (xo, yo), while asking for the aspect and the slope on this output grid, with
-
- dataOut, a, s = r.rgrd( dataIn, aspectSlope = 'yes' )
-
- where a is the aspect, the direction of the steepest descent in degrees measured from 'north' and s is the
- slope in degrees measured from the horizontal. Necessarily, these are arrays aligned with the rectilinear
- output grid, xo, yo.
-
- The computation is either single or double precision as determined by the precision submitted in the grid
- description in STEP 1.
-
- It is also possible to request a wrap in the input grid and the input data in the longitude direction, assumed
- to be the yi grid coordinate, by adding a keyword as
-
- dataOut, a, s = r.rgrd( dataIn, aspectSlope = 'yes', wrap = 'yes' )
-
-
- Example 3: the basic natural neighbor nonlinear interpolation
-
- The procedure for the nonlinear interpolation differs from the linear case in the need to set the control
- parameter igr. Follow Example 1 and insert the following statament after making the instance, r.
-
- r.igr = 1
-
- Example 4: natural neighbor nonlinear interpolation returning the aspect and the slope.
-
- The procedure for the nonlinear interpolation differs from the linear case in the need to set the control
- parameter igr. Follow Example 2 and insert the following statament after making the instance, r.
-
- r.igr = 1
-
- Example 5: single point mode natural neighbor linear interpolation
-
- As STEP 1 make an instance, r, with:
-
- import nat
-
- r = nat.Natgrid(xi, yi, xo, yo, listOutput = 'yes')
-
- where the xo, yo output grid is in the list form (not a rectangular output grid) as explained above in
- STEP 1.
-
- To call the single point mode interpolation computation to regrid the input data, dataIn, on the grid (xi, yi)
- to the output data, dataOut, on the grid (xo, yo), type
-
- dataOut = r.rgrd( dataIn )
-
- The computation is either single or double precision as determined by the precision submitted in the grid
- description in STEP 1. In the single point mode it is not possible to request the aspect and the slope.
-
-
- Example 6: single point mode natural neighbor nonlinear interpolation
-
- The procedure for the nonlinear interpolation differs from the linear case in the need to set the control
- parameter igr. Follow Example 5 and insert the following statament after making the instance, r.
-
- r.igr = 1
-
- ------------------- ORIGINAL FUNCTION APPROACH -----------------
-
- The module natgridmodule.so exports the following functions to Python from the original ngmath C library:
-
- Single precision procedures:
-
- natgrids - primary function for gridding.
- seti - set int parameter values.
- geti - retrieve values for int parameters.
- setr - set float parameter values.
- getr - retrieve values for float parameters
- setc - set char parameter values.
- getc - retrieve values for char parameters.
- getaspects - get aspect values, if calculated by setting sdi = 1.
- getslopes - get slope values, if calculated by setting sdi = 1.
- pntinits - initiate single point mode.
- pnts - interpolate at a single point.
- pntend - terminate single point mode.
-
-
- Double precision procedures:
-
- natgridd - primary function for gridding.
- setrd - set float parameter values.
- getrd - retrieve values for float parameters
- getaspectd - get aspect values, if calculated by setting sdi = 1.
- getsloped - get slope values, if calculated by setting sdi = 1.
- pntinitd - initiate single point mode.
- pntd - interpolate at a single point.
- pntendd - terminate single point mode.
-
-
-
-
- Information on the use of the routines is available by importing natgridmodule and printing the docstring
- of interest. For example, documentation for the routine natgrids is obtained by typing
-
- import natgridmodule
- print natgridmodule.natgrids.__doc__
-
- This same information is available in the help package.
-
- A description of the control parameters is not in the natgridmodule documentation. It can be found by typing
-
- import nat
- nat.printParameterTable()
-
-
- The documentation associated with the natgridmodule.so, such as the doctrings, describe the C code.
-
- DOCUMENTATION
-
- Documentation is provided through Python's docstrings, essentially Python style program
- comments. A help package provides instructions on the use of the natgrid module. A table of contents
- is printed to the screen by typing
-
- nat.help()
-
- after importing nat.
-
- A hard copy of all the pertinent 'docstring' documentation written to the file natgridmodule.doc can
- be produced by typing
-
- nat.document()
-
-
- As an alternate to using the help package, online documentation for the natgrids function, for example,
- is available directly from the natgrids doctring by typing
-
- import natgridmodule
-
- print natgridmodule.natgrids.__doc__
-
-
- TESTING
-
- To run a test of the natgrid computations and to get a copy of this documentation, type
-
- cdat natgridtest.py
-
---------------------------------------------------------------------------------------------------------------
-
-
- HELP PACKAGE EXAMPLE
-
- ************************ Default Parameter Table **********************
-
- -----------------------------------------------------------------------------------------------------
-name type legal value default value description
----- ----- ------------ --------------- ------------------------------------------------------------
-adf int 0 = no or 1 0 produce data file of algoritmic info for display? (see alg)
-alg char any file nam "nnalg.dat" file name for algoritmic display tool (see adf)
-asc int 0 = no or 1 1 is automatic scaling is allowed?
-bI float >= 1. 1.5 tautness increasing effect of the gradients by increasing bI
-bJ float >= 1. 7.0 tautness decreasing breadth of region affected by gradients
-dup int 0 = yes or 1 1 are duplicate input coordinates are allowed?
-ext int 0 = no or 1 1 is extrapolation allowed outside the convex hull?
-hor float >= 0. -1.0 amount of horizontal overlap from outside current region
-igr int 0 = no or 1 0 are gradients are to be computed?
-magx float > 0. 1.0 scale factor for x coordinate values
-magy float > 0. 1.0 scale factor for y coordinate values
-magz float > 0. 1.0 scale factor for z coordinate values
-non int 0 = yes or 1 0 are interpolated values are allowed to be negative?
-nul float any float 0.0 value for points outside the convex hull if no extrapolation
-rad int 0 = rad or 1 0 are slopes and aspects are returned in radians or degrees?
-sdi int 0 = no or 1 0 are slopes and aspects to be computed?
-upd int 0=N to S or 1 does output array from giving N to S or S to N?
-ver float >= 0. -1.0 amount of vertical overlap from outside current region
-xas float > 0. 0.0 scale used by automatic scaling of x in last interpolation
-yas float > 0. 0.0 scale used by automatic scaling of y in last interpolation
-zas float > 0. 0.0 scale used by automatic scaling of z in last interpolation
-
diff --git a/CEP/PyBDSM/src/natgrid/setup.py b/CEP/PyBDSM/src/natgrid/setup.py
deleted file mode 100644
index d282c77f1a6be952c36c0cf5ee06b1da83cb4039..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/natgrid/setup.py
+++ /dev/null
@@ -1,16 +0,0 @@
-#!/usr/bin/env python
-from numpy.distutils.core import setup, Extension
-import glob,sys
-
-sources=glob.glob('Src/*.c')
-
-setup (name = "natgrid",
- version='1.0',
- description = "natgrid",
- url = "http://cdat.sf.net",
- packages = [''],
- package_dir = {'': 'Lib'},
- include_dirs = ['Include',],
- ext_modules = [Extension('natgridmodule', sources),
- ]
- )
diff --git a/CEP/PyBDSM/src/port3/CHANGES b/CEP/PyBDSM/src/port3/CHANGES
deleted file mode 100644
index a688ea8294049fde6c9e25d8512ba1c8a1b57613..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/CHANGES
+++ /dev/null
@@ -1,437 +0,0 @@
-====== corrections to PORT ======
-
-The PORT3 subroutine library has two parts, one with publicly
-available code (freely available from netlib), the other proprietary
-(available for a fee: contact AT&T Technology Licensing, (800) 462-8146;
-10 Independence Blvd, Warren, NJ 07060-0911.) This file describes
-changes to both parts. Descriptions of corrections to the proprietary
-part are flagged with ($$); the corrected proprietary routines are
-available "from portfix".
-
-For AT&T people (accessing netlib from a machine known to Network
-Action Central as an AT&T machine "inside the firewall"), all of
-PORT3 is available from netlib.
-
-====== errata ======
-
-N2F (and N2G): the last word in the ``Purpose'' section should be ``N2G''
-rather than ``N2F''.
-
-MNSX and SMNSX ($$): Usage sections should show these as functions
-rather than subroutines. See the SMNSX example.
-
-N2FB (and N2GB): Note 3 should mention ``NSFB or NSGB''
-rather than ``PSNBN, PSNLB, SNLLB, or SNLBN''.
-
-POST ($$): LPLMI calling sequence is WRONG - should be LPLMI(NV,V,X,NX,XI).
-
-*********** (The above errors have been corrected in Port documenttion source.)
-
-From nls Wed Dec 12 10:06 EST 1984
-l2sff calls gq1 (not gqm11) which calls ... which calls "gamma", disagrees with
-cross-reference index of port 3. should check them all.
-
-From dmg Wed Apr 3 8:50 EST 1985
-The examples for MFTCR (label MFTG) and MFTRC (label MFTF) have
-two statements misplaced in the loops that conjugate the output
-from MFTRC: the statement "N2MK = N-1" should be one line
-higher (just before the outer DO statement) and the statement
-"N2MK = N2MK - 2" should be one lower (just after the
-CONTINUE closing the inner DO statement). This has no effect
-on the output of the examples (unless you turn subscript
-checking on), but it does make them confusing.
-
-
-====== Bug fixes ======
-
-From dmg Thu Apr 4 06:25 EST 1985
-Adjust FFT routines ($$) MFTCC, MFTCR, and MFTRC to work correctly when
-N is the product of an odd number of primes. (Source tapes distributed
-after March of 1985 should have these bugs fixed.)
-
-From dmg Sun Apr 7 14:24 EST 1985
-The scratch storage (from the Port stack) required by MFTCR ($$)
-and MFTRC is (N+2)*NNS rather than N*NNS.
-
-From dmg Tue Sep 24 08:00 EST 1985
-Corrections to Port 3 source:
- A9RNT[CDILR] (in p3src.frame) and APRNT[CDILR] (in Utilities):
-delete the line "MCOL = MIN0(MCOL, 160)" and later (in the one line
-where MCOL is used) change "MCOL" to "MIN0(MCOL,160)". [This stops
-these routines from possibly modifying the input-only parameter MCOL.]
- BPLD, CBPLD, DBPLD (in p3src.lin): insert "CALL ERROFF"
-at label 70 (just before the call on SETERR originally labeled 70).
-[In the unlikely event that SETERR has been called with the message
-"SINGULAR MATRIX", this eliminates the Port error of calling
-SETERR while an error is outstanding.]
- CBANM and CBPNM (in p3src.lin ($$)): omit the declaration of CABS.
- QP2NT and DQP2NT (in p3src.linopt ($$)): change "WRITE(6" to
-"WRITE(PU" (twice).
- LGEA (in p3tests): change "IWRITE = 6" to "IWRITE = I1MACH(2)"
-(on line 7).
- PRSA (in p3tests): change "WRITE(6" to "WRITE(IWRITE"
-(11 times).
- M66FT, MFTCC, MFTCR, MFTRC, DM66FT, DMFTCC, DMFTCR, DMFTRC
-(in p3src.fft ($$)): change "INTEGER IFX(1)" to the following 5 lines:
-C/6S
- INTEGER IFX(1)
-C/7S
-C INTEGER IFX(*)
-C/
-[This prevents a compile-time diagnostic of subscript out of range
-on some Fortran 77 compilers when these routines reference IFX(2)
-or IFX(3).]
- [IRD]1MACH (in p3src.frame): constants for Sequent Balance
-8000 and AT&T 7300 (UNIX PC) added.
-
-From dmg Tue Sep 24 19:32 EST 1985
- SVAD (in p3tests) should declare UNI to be REAL rather than
-DOUBLE PRECISION and should reference DBLE(UNI(0)) rather than just
-UNI(0).
-
-From dmg Wed Sep 25 13:22 EST 1985
- DT1UED, DT1UEV, DT2UEV, DT3UEV, DVDSS1 (in p3src.app2 ($$))
-should reference DBLE(FLOAT(...)) rather than DFLOAT(...)
-(or should declare DFLOAT to be DOUBLE PRECISION). The same applies
-to LYAD, VDAD, VDBD, and VDED in p3tests.
-
-From dmg Wed Oct 16 15:25 EST 1985
- Linear programming modules changed by Linda Kaufman ($$):
-A4PPG A4PPS C4NST C4ONS D4CLM DA4PPG DA4PPS DC4NST DC4ONS DD4CLM
-DG4ETC DL4P2 DL4PH1 G4ETC L4P2 L4PH1
-
-From dmg Wed Oct 16 15:28 EST 1985
-LRAD and LRPA in p3tests have four FORMAT statements each with
-extra commas in them (before and after a / ).
-
-From ehg Fri Oct 25 18:04 EDT 1985
-In VDSS1 and DVDSS1 ($$), the assignment to L1 should
-involve FLOAT(N-1) rather than FLOAT(N).
-
-From dmg Fri Feb 14 10:57 EST 1986
-In Z1ONE ($$), the lines
- IF (JCALL .GT. 1 .AND. G2 .GT. 0.0E0) DXTRY = AMIN1(DXTRY, G2)
- JUSED = 0
-should be changed to
-C *** G2 IS NOT DEFINED WHEN JCALL .LE. 1 ***
- IF (JCALL .LE. 1) GO TO 61
- IF (G2 .GT. 0.0E0) DXTRY = AMIN1(DXTRY, G2)
- 61 JUSED = 0
-Similarly, in DZ1ONE, the lines
- IF (JCALL .GT. 1 .AND. G2 .GT. 0.0D0) DXTRY = DMIN1(DXTRY, G2)
- JUSED = 0
-should be changed to
-C *** G2 IS NOT DEFINED WHEN JCALL .LE. 1 ***
- IF (JCALL .LE. 1) GO TO 61
- IF (G2 .GT. 0.0D0) DXTRY = DMIN1(DXTRY, G2)
- 61 JUSED = 0
-
-From dmg Tue Apr 15 23:30 EST 1986
-Linda Kaufman has changed LINPA, LINPR, DLINPA, DLINPR,
-and many of the modules they call ($$).
-
-From dmg Fri Jun 6 17:00 EST 1986
-In RQUAD ($$), the line
- IF (KWARN .GT. 0) GO TO 200
-should be added before line 40, i.e., just before
- EPS = EPSA + EPSR * ABS(ANS)
-
-In DRQUAD ($$), lines 41-43 should be changed from
- EPS = EPSA + EPSR * DABS(ANS)
- EPS = EPSA + EPSR * DMAX1(0.5D0*DABS(ANS), DABS(ANS)-ERREST)
- IF (KWARN .GT. 0) GO TO 200
-to
- IF (KWARN .GT. 0) GO TO 200
- EPS = EPSA + EPSR * DABS(ANS)
- IF (ERREST .LE. EPS) RETURN
- EPS = EPSA + EPSR * DMAX1(0.5D0*DABS(ANS), DABS(ANS)-ERREST)
-That is, "IF (KWARN..." should go up two lines, and
-"IF (ERREST .LE. EPS) RETURN" should be added after the first
-assignment ot EPS.
-
-From dmg Thu Aug 7 14:54 EDT 1986
-The documentation for NSF1 ($$) should list X as an output (rather than
-input) variable and should define f(x) as
-1/2 sum from i=1 to n ( sum from j=1 to L A sub i,j (x) c sub j y(x) sub i ) sup 2
-(i.e., there should be a left paren between the sumation signs rather
-than before A).
-
-From dmg Tue Sep 30 12:45 EDT 1986
-In subroutines V7DFL and DV7DFL, the statement
- V(DELTA0) = SQTEPS
-should be moved from line 58 to line 86, i.e., to follow
- V(DINIT) = 0.D+0
-(This only matters if you provide [D]MN[FG] with an initial
-Hessian approximation.)
-
-From dmg Thu Feb 12 14:38 EST 1987
-DM[135]FT DMFT[CR]I: COMMON /M55FT/ changed to /DM55FT/
-
-From dmg Thu Feb 26 11:02 EST 1987
-[D]MFTC[RC], [D]MFTRC ($$): size of DSTAK made consistent with
-the rest of Port.
-
-From dmg Fri Feb 27 23:32 EST 1987
-[D]LTSQ ($$): calls on [D]G1SVD and [D]C2LSQ should pass DSTAK(IV)
-or RSTAK(IV) rather than A. [bug fix by lck]
-
-From dmg Fri Feb 27 23:38 EST 1987
-Sundry Optimization Chapter modules adjusted so they only
-declare EXTERNAL routines actually used, and so EXTERNAL
-statements come after rather than before relevant type statements.
-
-From dmg Fri Apr 17 7:18:00 EDT 1987
-[D]SVDLS ($$): last two calls on [D]G1SVD should pass .TRUE. rather
-than MATV. [bug fix by lck]
-
-From dmg Thu May 28 17:13 EDT 1987
-[D]HQR2 replaced by versions adapted from EISPACK II
-(to fix a bug in DHQR2).
-
-From dmg Tue Aug 11 11:04 EDT 1987
-EXTERNAL statements shifted in *NSX routines of Optimization Chapter ($$).
-
-From dmg Tue Aug 18 12:52:30 EDT 1987
-[ D]G7QTS: massaged to prevent loop when lower and upper Gerschgorin
-bounds are exact.
-
-From dmg Tue Sep 29 09:10:05 EDT 1987
-Typos in NS[FG][B ] documentation: change IINC to INCC everywhere, and
-change "For the example discussed in B"
-to "For B in the example discussed" .
-
-From dmg Wed Sep 30 16:00:00 EDT 1987
-DP6MDC ($$) should declare SAVE rather than PSAVE . [fix from nls and lck]
-
-From dmg Sun Oct 8 18:00:00 EST 1987
-MNSX and SMNSX ($$): RSTAK should be dimensioned 1000 (rather
-than 500 -- for consistency with the rest of Port).
-
-From dmg Fri Jan 29 22:00:00 EST 1988
-I1MACH, R1MACH, D1MACH: constants for CDC machines corrected.
-
-From dmg Fri Sep 23 09:44:00 EDT 1988
-[RD]1MACH: sanity check (stuff involving SC) added.
-
-From dmg Tue Nov 29 07:25:00 EST 1988
-[ D]A4PPG ($$): bug fixes from Linda Kaufman
-
-From dmg Mon Dec 19 18:26:00 EST 1988
-[ D]S[37]GRD: more robust scaling: changed
- "H = TWO*(AFXETA*AGI/(AAI**2))**(ONE/THREE)" into
- "H = TWO * (AFXETA*AGI)**(ONE/THREE) * AAI**(-TWO/THREE)"
-
-From dmg Wed Mar 15 06:15 EST 1989
-[ D]G4ETC and [ D]L4PH1 ($$): bug fixes from Linda Kaufman
-(affecting [ D]IQP with bounds = [RD]1MACH(2) ).
-
-From dmg Mon Jul 24 23:55 EDT 1989
-[ D]NSF: second call on CALCA (just after 160 CONTINUE) should
-pass IV(NFGCAL) rather than NF.
-
-From dmg Fri Aug 4 10:47:00 EDT 1989
-[ D]POSTW: K should appear in a DATA stmt:
- DATA K/0/
-and, for Fortran 77, should appear in a SAVE statement.
-
-From dmg Sat Jan 13 18:58:00 EST 1990
-DSPMLE ($$): lines 104-107: the SETERR call omitted IERR as the
-penultimate parameter: the continuation line should be
- 1 IERR, 2)
-
-From dmg Wed Jan 17 15:18:00 EST 1990
-C5APP ($$): should call MOVEBR rather than MOVEBD.
-N5ERR ($$): the Fortran 77 version should declare MESSG to be
- CHARACTER*1 MESSG(NMESSG)
-ASYM, DASYM, DSYM, SYM ($$): the SETERR call omitted the
-string-length argument, 16 (arg 2).
-
-From dmg Sat Jan 20 17:12:14 EST 1990
-DNSF1 ($$): should declare DFMIN to be DOUBLE PRECISION.
-
-From dmg Tue Feb 13 09:53:00 EST 1990
-[ D]G7LIT and [ D]G7ITB: should set IV(RESTOR) properly when declining
-to evaluate the objective function during "internal doubling". This
-sometime affects the separable nonlinear least-squares routines.
-
-From dmg Sun Apr 1 17:05:04 EDT 1990
-[ D]RN2G[B ]: adjusted to ask just once rather than twice for the
-initial residual in the unusual case where the residual and Jacobian
-matrix are provided in "hunks" (i.e., ND < N).
-
-From dmg Tue Apr 3 19:18:08 EDT 1990
-[ D]NSF and [ D]N2GB: comments about minimum values of LIV and LV corrected.
-
-From dmg Sun Apr 15 00:12:50 EDT 1990
-Minor modifications in [ D]G7ITB, [ D]G7LIT, [ D]RNSG -- should be
-invisible to current PORT uses of these routines.
-
-From dmg Mon May 14 09:57:36 EDT 1990
-[ D]RMN[GH][B ] changed to set IV(RESTOR) properly when declining
-to evaluate the objective function during "internal doubling". This
-only matters if you're calling one of these routines directly and
-you rely on IV(RESTOR).
-
-From dmg Wed May 16 00:14:43 EDT 1990
-[ D]RMNH[B ] changed to set the initial radius as the nonlinear
-least squares solvers do, to V(LMAX0)/(1 + V(PHMXFC)) (rather than
-just to V(LMAX0)), so that the first step tried is guaranteed to have
-2-norm at most V(LMAX0).
-
-From dmg Tue Aug 14 01:12:47 EDT 1990
-[ D]G7ITB changed to return IV(1) = 82 (as per the Usage Summary)
-when some lower bound exceeds the corresponding upper bound.
-
-From dmg Fri Sep 28 11:37:51 EDT 1990
-Comments on lengths of IV and LIV corrected in [ D][ R][MN[FGH]B.
-(The numbers in the Port manual are correct.)
-
-From dmg Tue Oct 16 12:35:13 EDT 1990
-[ D]N2LRD and [ D]N2RDP: scale of regression diagnostic vector changed:
-it is now scaled (in [ D]N2LRD) by 1/sqrt(f*) when f* is nonzero,
-where f* is the "optimal" objective value; the printing in [ D]N2RDP
-reflects this change. This change makes the regression diagnostic
-vector independent of "response scale", i.e., of the scale of the
-residual vector.
-
-From dmg Fri Jan 18 00:07:12 EST 1991
-[ D]G7QTS: insert
- IF (UK .LT. LK) UK = LK
-just before
- IF (ALPHAK .LT. LK) GO TO 210
-to prevent a rare loop due to roundoff errors.
-
-From dmg Mon Apr 15 14:38:42 EDT 1991
-[ D]A4PPS ($$) updated to fix a stack-overwrite bug in [ D]LINP[AR]
-that sometimes manifested itself when a variable had identical
-simple lower and upper bounds. (Thanks to lck for the fix.)
-
-From dmg Mon May 6 17:01:59 EDT 1991
-[ D]4CLM, [ D]L4P2, [ D]L4PH1 ($$) modified to correct a bug in
-[ D]LINP[AR]. Possible symptom: continuing to iterate at
-an optimal solution. (Thanks to lck for the fix.)
-
-From dmg Fri May 10 13:18:46 EDT 1991
-Further tweak by lck to [ D]L4P2 ($$).
-
-From dmg Sat 22 Jun 16:55:34 EDT 1991
-Trivial change to declarations in [ d]s7dmp.f:
-change "X(*), Y(N), Z(*)" to "X(*), Y(*), Z(N)".
-
-From dmg Wed 26 Jun 18:59:26 EDT 1991
-Tweak (from ehg) to D1MACH: in response to a SUN Fortran compiler
-bug, integer arrays involved in EQUIVALENCE and DATA are now
-dimensioned (2) rather than (4), and comments point out the machines
-where (2) must be changed to (4).
-
-From dmg Sat Jul 6 09:47:17 EDT 1991
-[ D]A7SST: use correct tolerance [V(SCTOL)] both places the singular-
-convergence test is made: change V(RFCTOL) to V(SCTOL) in the line
- 290 IF (-V(NREDUC) .LE. V(RFCTOL) * DABS(V(F0))) IV(IRC) = 11
-
-From dmg Thu Sep 12 09:56:31 EDT 1991
-parck.f: change D11.3 to E11.3 in the FORMAT labelled 130.
-
-From dmg Sat Jan 18 00:24:24 EST 1992
-Correct comments in [ d]rn2gb.f:
-< C LIV...... LENGTH OF IV... LIV MUST BE AT LEAST P + 80.
-< C LV....... LENGTH OF V... LV MUST BE AT LEAST 105 + P*(2*P+16).
----
-> C LIV...... LENGTH OF IV... LIV MUST BE AT LEAST 4*P + 82.
-> C LV....... LENGTH OF V... LV MUST BE AT LEAST 105 + P*(2*P+20).
-
-From dmg Sat Mar 21 00:42:45 EST 1992
-Comments in D1MACH about IEEE constants tweaked.
-
-From dmg Tue May 19 22:57:44 EDT 1992
-Commented C source appended just before the END lines of [IRD]1MACH.
-
-From dmg Tue Jul 28 08:52:38 EDT 1992
-DRPOLY and D[12345789]RPLY ($$) changed to do all calculations in
-double precision (to circumvent exponent range limitations on
-machines, such as IEEE arithmetic machines, in which single
-precision has a smaller exponent range than double).
-
-From dmg Tue Mar 9 13:19:23 EST 1993
-[ d]n2g[b ].f: move "NN = N2 - N1 + 1" down 3 lines, so it comes after
-"IF (IV1 .GT. 2) GO TO 10". This only matters if your machine checks
-for uninitialized integer variables.
-
-From dmg Thu May 13 22:08:11 EDT 1993
-[ d]a7ssT.f: add "V(F) = V(FLSTGD)" to block labelled 60 (to restore
-function value when IV(TOOBIG) is nonzero). This matters if the next
-function evaluation would exceed the function evaluation limit.
-
-Fri Jun 10 13:09:15 EDT 1994
-[ d]l4ph1.f: lines 86 and 87 ($$): change (I) to (II) throughout.
-
-Wed Feb 15 11:38:13 EST 1995
-[ d]n2g[b ].f: correct volume number in comment on NL2SOL paper.
-
-Mon Jun 5 16:56:53 EDT 1995
-[ d]l7mst.f: fix bug in rescaling fast-Givens transformations: the new
-scale wasn't stored when no rotation was necessary (a rarely seen bug).
-
-Sun Jun 18 00:22:57 EDT 1995
-[ d]a7sst.f: zero IV(TOOBIG) when nonzero. Sometimes a longer step is
-attempted before accepting a step that would give a decrease. If this
-longer step caused IV(TOOBIG) to be nonzero, it might be left nonzero
-during the gradient evaluation, leading to an incorrect message about
-the gradient not being computable.
-[ d]rmng.f: fix a wrong goto (used in singular-convergence test).
-[ d]rmn[gh][b ].f: initialize V(F0) to the initial function value.
-
-Fri Sep 15 11:24:08 EDT 1995
-burm1.f: fix glitch in test for overly tight convergence tolerance:
-70c70
-< IDIG = IFLR(R1MACH(5)*FLOAT(I1MACH(11)))
----
-> IDIG = IFLR(R1MACH(5)*FLOAT(I1MACH(14)))
-(burm1.f is only in the AT&T-proprietary part of PORT.)
-[ d]rnsg[b ].f: (not really a bug): adjust second call of [ D]RN2G[B ]
-to pass a copy of NML for arg N2. This is the change to drnsg.f:
-107c107
-< 1 IPIV1, IER, IV1, J1, JLEN, K, LH, LI, LL1O2, MD, N1,
----
-> 1 IPIV1, IER, IV1, J1, JLEN, K, LH, LI, LL1O2, MD, N1, N2,
-210c210,211
-< 30 CALL DRN2G(V(D1), V(DR1L), IV, LIV, LV, NML, N, N1, NML, P,
----
-> 30 N2 = NML
-> CALL DRN2G(V(D1), V(DR1L), IV, LIV, LV, NML, N, N1, N2, P,
-[ d][ r]ns[fg].f: comment that estimated covariance matrices are
-ordered (alf,c): nonlinear parameters first, then linear parameters.
-
-Fri Mar 13 10:51:19 EST 1998
-e9rint.f and seterr.f adjusted so (in the default Fortran 77 format)
-they do not reference I1MACH(6), but simply know that each character
-contains one character.
-
-Thu Nov 18 12:38:30 EST 1999
-[ d]l9stp.f: lines 98, 101: change IW(0) to IW(1). This only affects
-the error number reported when [ d]l7pf gives a funny return.
-
-Mon Oct 21 14:19:47 EDT 2002
-[ d]a7ss5.f: accept a step that gives a small function reduction if,
-after considering any alternate model, two further trial steps with
-reduced radii did not produce a better step.
-i7shft.f: for a forthcoming addition to the PORT library, allow
-negative K to request a right-circular shift of X(-K), ..., X(N)
-by one position.
-
-Thu Nov 14 09:29:58 EST 2002
-[ d]rn2gb.f: fix a bug in handling problems with N < P (a nonlinear
-least-squares problem with bounds on the parameters being estimated
-and fewer observations than parameters being estimated).
-
-Thu Apr 29 21:53:03 MDT 2004
- [ d]r7tvm.f: fix a performance bug that afflicted [ d]n2[fg]b on
-square systems (as many residuals as optimization variables).
- [ d]g7itb.f: fix a performance bug that afflicted [d]n2[fg]b
-after a rejected trial step. The wrong model might have been chosen.
- [ d]g7lit.f and [ d]g7itb.f: Restore the "step" vector after rejecting
-a proposed alternate trial function evaluation because the preducted
-function reduction is too small. This would affect the choice of model
-(Gauss-Newton or augmented) for the next iteration.
- The above bug fixes also affect the corresponding separable nonlinear
-least-squares solvers [ d]ns[fg][b ].
diff --git a/CEP/PyBDSM/src/port3/CMakeLists.txt b/CEP/PyBDSM/src/port3/CMakeLists.txt
deleted file mode 100644
index 2aa02a58a6b7c11a5620cae9233541b127ae31d8..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/CMakeLists.txt
+++ /dev/null
@@ -1,16 +0,0 @@
-## ----------------------------------------------------------------------
-## $Id$
-## ----------------------------------------------------------------------
-
-enable_language(Fortran)
-
-# Always use -fPIC to enable linking with shared libs.
-add_library(port3 STATIC
- dnsg.f dn2g.f drnsg.f drn2g.f
- d1mach.f da7sst.f dc7vfn.f dd7tpr.f dd7upd.f df7hes.f dg7lit.f dg7qts.f
- ditsum.f divset.f dl7itv.f dl7ivm.f dl7mst.f dl7nvr.f dl7sqr.f dl7srt.f
- dl7svn.f dl7svx.f dl7tsq.f dl7tvm.f dl7vml.f dn2cvp.f dn2lrd.f dn2rdp.f
- do7prd.f dparck.f dq7apl.f dq7rad.f dq7rfh.f dr7mdc.f drldst.f ds7cpr.f
- ds7lup.f ds7lvm.f dv2axy.f dv2nrm.f dv7cpy.f dv7dfl.f dv7prm.f dv7scl.f
- dv7scp.f dv7swp.f i1mach.f i7mdcn.f stopx.f)
-set_target_properties(port3 PROPERTIES COMPILE_FLAGS "-fPIC")
diff --git a/CEP/PyBDSM/src/port3/CMakeLists.txt_port3 b/CEP/PyBDSM/src/port3/CMakeLists.txt_port3
deleted file mode 100644
index 30826fb4d471f4cb040332b1516c1ac487bfb7ac..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/CMakeLists.txt_port3
+++ /dev/null
@@ -1,39 +0,0 @@
-## ----------------------------------------------------------------------
-## $Id$
-## ----------------------------------------------------------------------
-
-enable_language(Fortran)
-
-set (port3_sources
- dnsg.f dn2g.f drnsg.f drn2g.f
- d1mach.f da7sst.f dc7vfn.f dd7tpr.f dd7upd.f df7hes.f dg7lit.f dg7qts.f
- ditsum.f divset.f dl7itv.f dl7ivm.f dl7mst.f dl7nvr.f dl7sqr.f dl7srt.f
- dl7svn.f dl7svx.f dl7tsq.f dl7tvm.f dl7vml.f dn2cvp.f dn2lrd.f dn2rdp.f
- do7prd.f dparck.f dq7apl.f dq7rad.f dq7rfh.f dr7mdc.f drldst.f ds7cpr.f
- ds7lup.f ds7lvm.f dv2axy.f dv2nrm.f dv7cpy.f dv7dfl.f dv7prm.f dv7scl.f
- dv7scp.f dv7swp.f i1mach.f i7mdcn.f stopx.f)
-
-## FIXME: there should be better way that creating shared library
-add_library (port3 SHARED ${port3_sources})
-
-## set additional target properties
-if (APPLE)
- set_target_properties (port3
- PROPERTIES
- PREFIX ""
- SUFFIX .so
- LINK_FLAGS "-fPIC -flat_namespace"
- )
-else (APPLE)
- set_target_properties (port3
- PROPERTIES
- PREFIX ""
- SUFFIX .so
- LINK_FLAGS "-fPIC -shared"
- )
-endif (APPLE)
-
-## ----------------------------------------------------------------------
-## Installation
-install (TARGETS port3 DESTINATION lib)
-
diff --git a/CEP/PyBDSM/src/port3/Makefile b/CEP/PyBDSM/src/port3/Makefile
deleted file mode 100644
index f2ee8cedc793524dc6dab2a4094f8267227142ad..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/Makefile
+++ /dev/null
@@ -1,476 +0,0 @@
-# CMAKE generated file: DO NOT EDIT!
-# Generated by "Unix Makefiles" Generator, CMake Version 2.8
-
-# Default target executed when no arguments are given to make.
-default_target: all
-.PHONY : default_target
-
-#=============================================================================
-# Special targets provided by cmake.
-
-# Disable implicit rules so canoncical targets will work.
-.SUFFIXES:
-
-# Remove some rules from gmake that .SUFFIXES does not remove.
-SUFFIXES =
-
-.SUFFIXES: .hpux_make_needs_suffix_list
-
-# Suppress display of executed commands.
-$(VERBOSE).SILENT:
-
-# A target that is always out of date.
-cmake_force:
-.PHONY : cmake_force
-
-#=============================================================================
-# Set environment variables for the build.
-
-# The shell in which to execute make rules.
-SHELL = /bin/sh
-
-# The CMake executable.
-CMAKE_COMMAND = "/Applications/CMake 2.8-0.app/Contents/bin/cmake"
-
-# The command to remove a file.
-RM = "/Applications/CMake 2.8-0.app/Contents/bin/cmake" -E remove -f
-
-# The program to use to edit the cache.
-CMAKE_EDIT_COMMAND = "/Applications/CMake 2.8-0.app/Contents/bin/ccmake"
-
-# The top-level source directory on which CMake was run.
-CMAKE_SOURCE_DIR = /Users/mohan/lofarsoft/src/pybdsm/implement
-
-# The top-level build directory on which CMake was run.
-CMAKE_BINARY_DIR = /Users/mohan/lofarsoft/src/pybdsm/implement
-
-#=============================================================================
-# Targets provided globally by CMake.
-
-# Special rule for the target edit_cache
-edit_cache:
- @$(CMAKE_COMMAND) -E cmake_echo_color --switch=$(COLOR) --cyan "Running CMake cache editor..."
- "/Applications/CMake 2.8-0.app/Contents/bin/ccmake" -H$(CMAKE_SOURCE_DIR) -B$(CMAKE_BINARY_DIR)
-.PHONY : edit_cache
-
-# Special rule for the target edit_cache
-edit_cache/fast: edit_cache
-.PHONY : edit_cache/fast
-
-# Special rule for the target install
-install: preinstall
- @$(CMAKE_COMMAND) -E cmake_echo_color --switch=$(COLOR) --cyan "Install the project..."
- "/Applications/CMake 2.8-0.app/Contents/bin/cmake" -P cmake_install.cmake
-.PHONY : install
-
-# Special rule for the target install
-install/fast: preinstall/fast
- @$(CMAKE_COMMAND) -E cmake_echo_color --switch=$(COLOR) --cyan "Install the project..."
- "/Applications/CMake 2.8-0.app/Contents/bin/cmake" -P cmake_install.cmake
-.PHONY : install/fast
-
-# Special rule for the target install/local
-install/local: preinstall
- @$(CMAKE_COMMAND) -E cmake_echo_color --switch=$(COLOR) --cyan "Installing only the local directory..."
- "/Applications/CMake 2.8-0.app/Contents/bin/cmake" -DCMAKE_INSTALL_LOCAL_ONLY=1 -P cmake_install.cmake
-.PHONY : install/local
-
-# Special rule for the target install/local
-install/local/fast: install/local
-.PHONY : install/local/fast
-
-# Special rule for the target install/strip
-install/strip: preinstall
- @$(CMAKE_COMMAND) -E cmake_echo_color --switch=$(COLOR) --cyan "Installing the project stripped..."
- "/Applications/CMake 2.8-0.app/Contents/bin/cmake" -DCMAKE_INSTALL_DO_STRIP=1 -P cmake_install.cmake
-.PHONY : install/strip
-
-# Special rule for the target install/strip
-install/strip/fast: install/strip
-.PHONY : install/strip/fast
-
-# Special rule for the target list_install_components
-list_install_components:
- @$(CMAKE_COMMAND) -E cmake_echo_color --switch=$(COLOR) --cyan "Available install components are: \"Unspecified\""
-.PHONY : list_install_components
-
-# Special rule for the target list_install_components
-list_install_components/fast: list_install_components
-.PHONY : list_install_components/fast
-
-# Special rule for the target rebuild_cache
-rebuild_cache:
- @$(CMAKE_COMMAND) -E cmake_echo_color --switch=$(COLOR) --cyan "Running CMake to regenerate build system..."
- "/Applications/CMake 2.8-0.app/Contents/bin/cmake" -H$(CMAKE_SOURCE_DIR) -B$(CMAKE_BINARY_DIR)
-.PHONY : rebuild_cache
-
-# Special rule for the target rebuild_cache
-rebuild_cache/fast: rebuild_cache
-.PHONY : rebuild_cache/fast
-
-# The main all target
-all: cmake_check_build_system
- cd /Users/mohan/lofarsoft/src/pybdsm/implement && $(CMAKE_COMMAND) -E cmake_progress_start /Users/mohan/lofarsoft/src/pybdsm/implement/CMakeFiles /Users/mohan/lofarsoft/src/pybdsm/implement/port3/CMakeFiles/progress.marks
- cd /Users/mohan/lofarsoft/src/pybdsm/implement && $(MAKE) -f CMakeFiles/Makefile2 port3/all
- $(CMAKE_COMMAND) -E cmake_progress_start /Users/mohan/lofarsoft/src/pybdsm/implement/CMakeFiles 0
-.PHONY : all
-
-# The main clean target
-clean:
- cd /Users/mohan/lofarsoft/src/pybdsm/implement && $(MAKE) -f CMakeFiles/Makefile2 port3/clean
-.PHONY : clean
-
-# The main clean target
-clean/fast: clean
-.PHONY : clean/fast
-
-# Prepare targets for installation.
-preinstall: all
- cd /Users/mohan/lofarsoft/src/pybdsm/implement && $(MAKE) -f CMakeFiles/Makefile2 port3/preinstall
-.PHONY : preinstall
-
-# Prepare targets for installation.
-preinstall/fast:
- cd /Users/mohan/lofarsoft/src/pybdsm/implement && $(MAKE) -f CMakeFiles/Makefile2 port3/preinstall
-.PHONY : preinstall/fast
-
-# clear depends
-depend:
- cd /Users/mohan/lofarsoft/src/pybdsm/implement && $(CMAKE_COMMAND) -H$(CMAKE_SOURCE_DIR) -B$(CMAKE_BINARY_DIR) --check-build-system CMakeFiles/Makefile.cmake 1
-.PHONY : depend
-
-# Convenience name for target.
-port3/CMakeFiles/port3.dir/rule:
- cd /Users/mohan/lofarsoft/src/pybdsm/implement && $(MAKE) -f CMakeFiles/Makefile2 port3/CMakeFiles/port3.dir/rule
-.PHONY : port3/CMakeFiles/port3.dir/rule
-
-# Convenience name for target.
-port3: port3/CMakeFiles/port3.dir/rule
-.PHONY : port3
-
-# fast build rule for target.
-port3/fast:
- cd /Users/mohan/lofarsoft/src/pybdsm/implement && $(MAKE) -f port3/CMakeFiles/port3.dir/build.make port3/CMakeFiles/port3.dir/build
-.PHONY : port3/fast
-
-# target to build an object file
-d1mach.o:
- cd /Users/mohan/lofarsoft/src/pybdsm/implement && $(MAKE) -f port3/CMakeFiles/port3.dir/build.make port3/CMakeFiles/port3.dir/d1mach.o
-.PHONY : d1mach.o
-
-# target to build an object file
-da7sst.o:
- cd /Users/mohan/lofarsoft/src/pybdsm/implement && $(MAKE) -f port3/CMakeFiles/port3.dir/build.make port3/CMakeFiles/port3.dir/da7sst.o
-.PHONY : da7sst.o
-
-# target to build an object file
-dc7vfn.o:
- cd /Users/mohan/lofarsoft/src/pybdsm/implement && $(MAKE) -f port3/CMakeFiles/port3.dir/build.make port3/CMakeFiles/port3.dir/dc7vfn.o
-.PHONY : dc7vfn.o
-
-# target to build an object file
-dd7tpr.o:
- cd /Users/mohan/lofarsoft/src/pybdsm/implement && $(MAKE) -f port3/CMakeFiles/port3.dir/build.make port3/CMakeFiles/port3.dir/dd7tpr.o
-.PHONY : dd7tpr.o
-
-# target to build an object file
-dd7upd.o:
- cd /Users/mohan/lofarsoft/src/pybdsm/implement && $(MAKE) -f port3/CMakeFiles/port3.dir/build.make port3/CMakeFiles/port3.dir/dd7upd.o
-.PHONY : dd7upd.o
-
-# target to build an object file
-df7hes.o:
- cd /Users/mohan/lofarsoft/src/pybdsm/implement && $(MAKE) -f port3/CMakeFiles/port3.dir/build.make port3/CMakeFiles/port3.dir/df7hes.o
-.PHONY : df7hes.o
-
-# target to build an object file
-dg7lit.o:
- cd /Users/mohan/lofarsoft/src/pybdsm/implement && $(MAKE) -f port3/CMakeFiles/port3.dir/build.make port3/CMakeFiles/port3.dir/dg7lit.o
-.PHONY : dg7lit.o
-
-# target to build an object file
-dg7qts.o:
- cd /Users/mohan/lofarsoft/src/pybdsm/implement && $(MAKE) -f port3/CMakeFiles/port3.dir/build.make port3/CMakeFiles/port3.dir/dg7qts.o
-.PHONY : dg7qts.o
-
-# target to build an object file
-ditsum.o:
- cd /Users/mohan/lofarsoft/src/pybdsm/implement && $(MAKE) -f port3/CMakeFiles/port3.dir/build.make port3/CMakeFiles/port3.dir/ditsum.o
-.PHONY : ditsum.o
-
-# target to build an object file
-divset.o:
- cd /Users/mohan/lofarsoft/src/pybdsm/implement && $(MAKE) -f port3/CMakeFiles/port3.dir/build.make port3/CMakeFiles/port3.dir/divset.o
-.PHONY : divset.o
-
-# target to build an object file
-dl7itv.o:
- cd /Users/mohan/lofarsoft/src/pybdsm/implement && $(MAKE) -f port3/CMakeFiles/port3.dir/build.make port3/CMakeFiles/port3.dir/dl7itv.o
-.PHONY : dl7itv.o
-
-# target to build an object file
-dl7ivm.o:
- cd /Users/mohan/lofarsoft/src/pybdsm/implement && $(MAKE) -f port3/CMakeFiles/port3.dir/build.make port3/CMakeFiles/port3.dir/dl7ivm.o
-.PHONY : dl7ivm.o
-
-# target to build an object file
-dl7mst.o:
- cd /Users/mohan/lofarsoft/src/pybdsm/implement && $(MAKE) -f port3/CMakeFiles/port3.dir/build.make port3/CMakeFiles/port3.dir/dl7mst.o
-.PHONY : dl7mst.o
-
-# target to build an object file
-dl7nvr.o:
- cd /Users/mohan/lofarsoft/src/pybdsm/implement && $(MAKE) -f port3/CMakeFiles/port3.dir/build.make port3/CMakeFiles/port3.dir/dl7nvr.o
-.PHONY : dl7nvr.o
-
-# target to build an object file
-dl7sqr.o:
- cd /Users/mohan/lofarsoft/src/pybdsm/implement && $(MAKE) -f port3/CMakeFiles/port3.dir/build.make port3/CMakeFiles/port3.dir/dl7sqr.o
-.PHONY : dl7sqr.o
-
-# target to build an object file
-dl7srt.o:
- cd /Users/mohan/lofarsoft/src/pybdsm/implement && $(MAKE) -f port3/CMakeFiles/port3.dir/build.make port3/CMakeFiles/port3.dir/dl7srt.o
-.PHONY : dl7srt.o
-
-# target to build an object file
-dl7svn.o:
- cd /Users/mohan/lofarsoft/src/pybdsm/implement && $(MAKE) -f port3/CMakeFiles/port3.dir/build.make port3/CMakeFiles/port3.dir/dl7svn.o
-.PHONY : dl7svn.o
-
-# target to build an object file
-dl7svx.o:
- cd /Users/mohan/lofarsoft/src/pybdsm/implement && $(MAKE) -f port3/CMakeFiles/port3.dir/build.make port3/CMakeFiles/port3.dir/dl7svx.o
-.PHONY : dl7svx.o
-
-# target to build an object file
-dl7tsq.o:
- cd /Users/mohan/lofarsoft/src/pybdsm/implement && $(MAKE) -f port3/CMakeFiles/port3.dir/build.make port3/CMakeFiles/port3.dir/dl7tsq.o
-.PHONY : dl7tsq.o
-
-# target to build an object file
-dl7tvm.o:
- cd /Users/mohan/lofarsoft/src/pybdsm/implement && $(MAKE) -f port3/CMakeFiles/port3.dir/build.make port3/CMakeFiles/port3.dir/dl7tvm.o
-.PHONY : dl7tvm.o
-
-# target to build an object file
-dl7vml.o:
- cd /Users/mohan/lofarsoft/src/pybdsm/implement && $(MAKE) -f port3/CMakeFiles/port3.dir/build.make port3/CMakeFiles/port3.dir/dl7vml.o
-.PHONY : dl7vml.o
-
-# target to build an object file
-dn2cvp.o:
- cd /Users/mohan/lofarsoft/src/pybdsm/implement && $(MAKE) -f port3/CMakeFiles/port3.dir/build.make port3/CMakeFiles/port3.dir/dn2cvp.o
-.PHONY : dn2cvp.o
-
-# target to build an object file
-dn2g.o:
- cd /Users/mohan/lofarsoft/src/pybdsm/implement && $(MAKE) -f port3/CMakeFiles/port3.dir/build.make port3/CMakeFiles/port3.dir/dn2g.o
-.PHONY : dn2g.o
-
-# target to build an object file
-dn2lrd.o:
- cd /Users/mohan/lofarsoft/src/pybdsm/implement && $(MAKE) -f port3/CMakeFiles/port3.dir/build.make port3/CMakeFiles/port3.dir/dn2lrd.o
-.PHONY : dn2lrd.o
-
-# target to build an object file
-dn2rdp.o:
- cd /Users/mohan/lofarsoft/src/pybdsm/implement && $(MAKE) -f port3/CMakeFiles/port3.dir/build.make port3/CMakeFiles/port3.dir/dn2rdp.o
-.PHONY : dn2rdp.o
-
-# target to build an object file
-dnsg.o:
- cd /Users/mohan/lofarsoft/src/pybdsm/implement && $(MAKE) -f port3/CMakeFiles/port3.dir/build.make port3/CMakeFiles/port3.dir/dnsg.o
-.PHONY : dnsg.o
-
-# target to build an object file
-do7prd.o:
- cd /Users/mohan/lofarsoft/src/pybdsm/implement && $(MAKE) -f port3/CMakeFiles/port3.dir/build.make port3/CMakeFiles/port3.dir/do7prd.o
-.PHONY : do7prd.o
-
-# target to build an object file
-dparck.o:
- cd /Users/mohan/lofarsoft/src/pybdsm/implement && $(MAKE) -f port3/CMakeFiles/port3.dir/build.make port3/CMakeFiles/port3.dir/dparck.o
-.PHONY : dparck.o
-
-# target to build an object file
-dq7apl.o:
- cd /Users/mohan/lofarsoft/src/pybdsm/implement && $(MAKE) -f port3/CMakeFiles/port3.dir/build.make port3/CMakeFiles/port3.dir/dq7apl.o
-.PHONY : dq7apl.o
-
-# target to build an object file
-dq7rad.o:
- cd /Users/mohan/lofarsoft/src/pybdsm/implement && $(MAKE) -f port3/CMakeFiles/port3.dir/build.make port3/CMakeFiles/port3.dir/dq7rad.o
-.PHONY : dq7rad.o
-
-# target to build an object file
-dq7rfh.o:
- cd /Users/mohan/lofarsoft/src/pybdsm/implement && $(MAKE) -f port3/CMakeFiles/port3.dir/build.make port3/CMakeFiles/port3.dir/dq7rfh.o
-.PHONY : dq7rfh.o
-
-# target to build an object file
-dr7mdc.o:
- cd /Users/mohan/lofarsoft/src/pybdsm/implement && $(MAKE) -f port3/CMakeFiles/port3.dir/build.make port3/CMakeFiles/port3.dir/dr7mdc.o
-.PHONY : dr7mdc.o
-
-# target to build an object file
-drldst.o:
- cd /Users/mohan/lofarsoft/src/pybdsm/implement && $(MAKE) -f port3/CMakeFiles/port3.dir/build.make port3/CMakeFiles/port3.dir/drldst.o
-.PHONY : drldst.o
-
-# target to build an object file
-drn2g.o:
- cd /Users/mohan/lofarsoft/src/pybdsm/implement && $(MAKE) -f port3/CMakeFiles/port3.dir/build.make port3/CMakeFiles/port3.dir/drn2g.o
-.PHONY : drn2g.o
-
-# target to build an object file
-drnsg.o:
- cd /Users/mohan/lofarsoft/src/pybdsm/implement && $(MAKE) -f port3/CMakeFiles/port3.dir/build.make port3/CMakeFiles/port3.dir/drnsg.o
-.PHONY : drnsg.o
-
-# target to build an object file
-ds7cpr.o:
- cd /Users/mohan/lofarsoft/src/pybdsm/implement && $(MAKE) -f port3/CMakeFiles/port3.dir/build.make port3/CMakeFiles/port3.dir/ds7cpr.o
-.PHONY : ds7cpr.o
-
-# target to build an object file
-ds7lup.o:
- cd /Users/mohan/lofarsoft/src/pybdsm/implement && $(MAKE) -f port3/CMakeFiles/port3.dir/build.make port3/CMakeFiles/port3.dir/ds7lup.o
-.PHONY : ds7lup.o
-
-# target to build an object file
-ds7lvm.o:
- cd /Users/mohan/lofarsoft/src/pybdsm/implement && $(MAKE) -f port3/CMakeFiles/port3.dir/build.make port3/CMakeFiles/port3.dir/ds7lvm.o
-.PHONY : ds7lvm.o
-
-# target to build an object file
-dv2axy.o:
- cd /Users/mohan/lofarsoft/src/pybdsm/implement && $(MAKE) -f port3/CMakeFiles/port3.dir/build.make port3/CMakeFiles/port3.dir/dv2axy.o
-.PHONY : dv2axy.o
-
-# target to build an object file
-dv2nrm.o:
- cd /Users/mohan/lofarsoft/src/pybdsm/implement && $(MAKE) -f port3/CMakeFiles/port3.dir/build.make port3/CMakeFiles/port3.dir/dv2nrm.o
-.PHONY : dv2nrm.o
-
-# target to build an object file
-dv7cpy.o:
- cd /Users/mohan/lofarsoft/src/pybdsm/implement && $(MAKE) -f port3/CMakeFiles/port3.dir/build.make port3/CMakeFiles/port3.dir/dv7cpy.o
-.PHONY : dv7cpy.o
-
-# target to build an object file
-dv7dfl.o:
- cd /Users/mohan/lofarsoft/src/pybdsm/implement && $(MAKE) -f port3/CMakeFiles/port3.dir/build.make port3/CMakeFiles/port3.dir/dv7dfl.o
-.PHONY : dv7dfl.o
-
-# target to build an object file
-dv7prm.o:
- cd /Users/mohan/lofarsoft/src/pybdsm/implement && $(MAKE) -f port3/CMakeFiles/port3.dir/build.make port3/CMakeFiles/port3.dir/dv7prm.o
-.PHONY : dv7prm.o
-
-# target to build an object file
-dv7scl.o:
- cd /Users/mohan/lofarsoft/src/pybdsm/implement && $(MAKE) -f port3/CMakeFiles/port3.dir/build.make port3/CMakeFiles/port3.dir/dv7scl.o
-.PHONY : dv7scl.o
-
-# target to build an object file
-dv7scp.o:
- cd /Users/mohan/lofarsoft/src/pybdsm/implement && $(MAKE) -f port3/CMakeFiles/port3.dir/build.make port3/CMakeFiles/port3.dir/dv7scp.o
-.PHONY : dv7scp.o
-
-# target to build an object file
-dv7swp.o:
- cd /Users/mohan/lofarsoft/src/pybdsm/implement && $(MAKE) -f port3/CMakeFiles/port3.dir/build.make port3/CMakeFiles/port3.dir/dv7swp.o
-.PHONY : dv7swp.o
-
-# target to build an object file
-i1mach.o:
- cd /Users/mohan/lofarsoft/src/pybdsm/implement && $(MAKE) -f port3/CMakeFiles/port3.dir/build.make port3/CMakeFiles/port3.dir/i1mach.o
-.PHONY : i1mach.o
-
-# target to build an object file
-i7mdcn.o:
- cd /Users/mohan/lofarsoft/src/pybdsm/implement && $(MAKE) -f port3/CMakeFiles/port3.dir/build.make port3/CMakeFiles/port3.dir/i7mdcn.o
-.PHONY : i7mdcn.o
-
-# target to build an object file
-stopx.o:
- cd /Users/mohan/lofarsoft/src/pybdsm/implement && $(MAKE) -f port3/CMakeFiles/port3.dir/build.make port3/CMakeFiles/port3.dir/stopx.o
-.PHONY : stopx.o
-
-# Help Target
-help:
- @echo "The following are some of the valid targets for this Makefile:"
- @echo "... all (the default if no target is provided)"
- @echo "... clean"
- @echo "... depend"
- @echo "... edit_cache"
- @echo "... install"
- @echo "... install/local"
- @echo "... install/strip"
- @echo "... list_install_components"
- @echo "... port3"
- @echo "... rebuild_cache"
- @echo "... d1mach.o"
- @echo "... da7sst.o"
- @echo "... dc7vfn.o"
- @echo "... dd7tpr.o"
- @echo "... dd7upd.o"
- @echo "... df7hes.o"
- @echo "... dg7lit.o"
- @echo "... dg7qts.o"
- @echo "... ditsum.o"
- @echo "... divset.o"
- @echo "... dl7itv.o"
- @echo "... dl7ivm.o"
- @echo "... dl7mst.o"
- @echo "... dl7nvr.o"
- @echo "... dl7sqr.o"
- @echo "... dl7srt.o"
- @echo "... dl7svn.o"
- @echo "... dl7svx.o"
- @echo "... dl7tsq.o"
- @echo "... dl7tvm.o"
- @echo "... dl7vml.o"
- @echo "... dn2cvp.o"
- @echo "... dn2g.o"
- @echo "... dn2lrd.o"
- @echo "... dn2rdp.o"
- @echo "... dnsg.o"
- @echo "... do7prd.o"
- @echo "... dparck.o"
- @echo "... dq7apl.o"
- @echo "... dq7rad.o"
- @echo "... dq7rfh.o"
- @echo "... dr7mdc.o"
- @echo "... drldst.o"
- @echo "... drn2g.o"
- @echo "... drnsg.o"
- @echo "... ds7cpr.o"
- @echo "... ds7lup.o"
- @echo "... ds7lvm.o"
- @echo "... dv2axy.o"
- @echo "... dv2nrm.o"
- @echo "... dv7cpy.o"
- @echo "... dv7dfl.o"
- @echo "... dv7prm.o"
- @echo "... dv7scl.o"
- @echo "... dv7scp.o"
- @echo "... dv7swp.o"
- @echo "... i1mach.o"
- @echo "... i7mdcn.o"
- @echo "... stopx.o"
-.PHONY : help
-
-
-
-#=============================================================================
-# Special targets to cleanup operation of make.
-
-# Special rule to run CMake to check the build system integrity.
-# No rule that depends on this can have commands that come from listfiles
-# because they might be regenerated.
-cmake_check_build_system:
- cd /Users/mohan/lofarsoft/src/pybdsm/implement && $(CMAKE_COMMAND) -H$(CMAKE_SOURCE_DIR) -B$(CMAKE_BINARY_DIR) --check-build-system CMakeFiles/Makefile.cmake 0
-.PHONY : cmake_check_build_system
-
diff --git a/CEP/PyBDSM/src/port3/README b/CEP/PyBDSM/src/port3/README
deleted file mode 100644
index f2b3d9a6c4d7b275dd4c8b84ca3bb7b9b09aa669..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/README
+++ /dev/null
@@ -1,72 +0,0 @@
-In general, contents of the PORT3 library are available by license.
-However, the following utility routines are publicly available:
-a0xtrp d0xtrp dalloc dxtrap e9rint enter entsrc eprint erroff i0tk00
-i0tk01 i8save i8tsel ialloc istkgt istkin istkmd istkqu istkrl istkst
-leave movebc movebd movebi movebl movebr movefc movefd movefi movefl
-movefr mtstak n5err nerror nirall retsrc s88fmt setc setd seterr
-seti setl setr srecap stinit xtrap.
-
-Also available are the up-to-date versions of NL2SOL (TOMS algorithm
-573): n2f and n2g correspond to NL2SNO and NL2SOL;
-n2p is a variant of NL2SOL that allows the residual vector
-and Jacobian matrix to be passed in pieces, rather than all at once;
-n2[fgp]b are versions of NL2SOL that handle simple bounds;
-ns[fg] are versions for separable nonlinear least-squares, and
-ns[fg]b are versions for separable nonlinear least-squares with
-simple bounds. dn[s2][fgp][b ] are the double-precision versions.
-
-Similarly available are current versions of SMSNO, SUMSL, HUMSL (TOMS
-algorithm 611) for general unconstrained minimization:
-mnf uses function values only;
-mng uses function and gradient values;
-mnh uses function, gradient, and Hessian values;
-mn[fgh]b are versions that handle simple bounds;
-dmn[fgh][b ] are double-precision versions.
-
-Postscript for "Usage Summary for Selected Optimization Routines",
-which is relevant to [ d]n[2f][fg][b ] and [ d]mn[fgh][b ], is
-available at
- http://netlib.bell-labs.com/cm/cs/cstr/153.ps.gz
-
-To PORT source files xxx1.f xxx2.f ... xxxn.f and all PORT routines
-these files call, send the E-mail message
- send xxx1 xxx2 ... xxxn from port
-to netlib@netlib.bell-labs.com .
-
-There is a subdirectory "ex" of a few examples.
-For more information, try a request of the form
- send index for port/ex
-There is also a subdirectory "chk" of implementation checkout programs.
-
-The PORT Mathematical Subroutine Library
-Phyllis A. Fox, Editor
-1984, AT&T Bell Telephone Laboratories, Inc.
-
-The entire PORT library is now available without charge for
-non-commercial use under a non-exclusive limited-use software
-agreement: see
-
- http://www.bell-labs.com/topic/swdist/
-
-or go directly to
-
- http://www.bell-labs.com/project/PORT/
-
-Postscript for the PORT 3 Manual is available as
-
- http://www.bell-labs.com/project/PORT/doc/port3doc.tar.gz
-
-For commercial uses of the PORT library, contact
- Edward S. Cartier
- Lucent Technologies
- Software Solutions Group
- 2 Paragon Way, room 3A-25
- Freehold, NJ 07728, U.S.A.
- phone +1-732-577-2720
- E-mail ecartier@lucent.com
- Web http://www.bell-labs.com/org/ssg/
-
-For a summary of ways to get things from netlib, send the two-word
-E-mail message "send readme" to netlib@netlib.bell-labs.com .
-
-##########################################################
diff --git a/CEP/PyBDSM/src/port3/a0xtrp.f b/CEP/PyBDSM/src/port3/a0xtrp.f
deleted file mode 100644
index 7f108aeb135b14c08303d1abf7ac42d48a389ac2..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/a0xtrp.f
+++ /dev/null
@@ -1,73 +0,0 @@
- SUBROUTINE A0XTRP(TM,M,NVAR,NG,KMAX,XPOLY,T,ERROR,EBEST,RHG,EMAG,
- 1 ESAVE)
-C
- REAL TM(NVAR),NG(M),T(NVAR,KMAX),RHG(1)
-C REAL RHG(MIN(M-1,KMAX))
- REAL ERROR(NVAR,1),EBEST(NVAR),EMAG(1)
-C REAL ERROR(NVAR,MIN(M-1,KMAX)),EMAG(MIN(M-1,KMAX))
- LOGICAL XPOLY,ESAVE
-C
- REAL U,V,TI,TV,TEMP
- REAL ERR
-C
- IF (M.GT.1) GO TO 20
-C
-C ... INITIALIZE T.
-C
- DO 10 I=1,NVAR
- 10 T(I,1)=TM(I)
-C
- GO TO 80
-C
- 20 MR=MIN0(M-1,KMAX)
-C
- DO 30 J=1,MR
- MMJ=M-J
- RHG(J)=NG(M)/NG(MMJ)
- EMAG(J)=1.0E0+1.0E0/(RHG(J)-1.0E0)
- IF (XPOLY) RHG(J)=RHG(J)-1.0E0
- 30 CONTINUE
-C
- DO 70 I=1,NVAR
-C
- V=0.0E0
- U=T(I,1)
- TI=TM(I)
- T(I,1)=TI
-C
- DO 60 J=1,MR
-C
-C ......... OBTAIN SIGNED ERROR ESTIMATE.
-C
- ERR=(T(I,J)-U)*EMAG(J)
- IF (ESAVE) ERROR(I,J)=ERR
- ERR=ABS(ERR)
- IF (J.EQ.1) EBEST(I)=ERR
- EBEST(I)=AMIN1(EBEST(I),ERR)
- IF (EBEST(I).EQ.ERR) JBEST=J
-C
- IF (J.EQ.KMAX) GO TO 60
-C
- IF (XPOLY) GO TO 40
-C
-C ......... RATIONAL EXTRAPOLATION.
-C
- TV=TI-V
- TEMP=RHG(J)*(U-V)-TV
- IF (TEMP.NE.0.0E0) TI=TI+(TI-U)*(TV/TEMP)
- V=U
- GO TO 50
-C
-C ......... POLYNOMIAL EXTRAPOLATION.
-C
- 40 TI=TI+(TI-U)/RHG(J)
-C
- 50 U=T(I,J+1)
- T(I,J+1)=TI
- 60 CONTINUE
-C
- 70 TM(I)=T(I,JBEST)
-C
- 80 RETURN
-C
- END
diff --git a/CEP/PyBDSM/src/port3/a7sst.f b/CEP/PyBDSM/src/port3/a7sst.f
deleted file mode 100644
index 4368e9bb5ce7b34d7fe3de72f8fa1b4efeffd77e..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/a7sst.f
+++ /dev/null
@@ -1,534 +0,0 @@
- SUBROUTINE A7SST(IV, LIV, LV, V)
-C
-C *** ASSESS CANDIDATE STEP (***SOL VERSION 2.3) ***
-C
- INTEGER LIV, LV
- INTEGER IV(LIV)
- REAL V(LV)
-C
-C *** PURPOSE ***
-C
-C THIS SUBROUTINE IS CALLED BY AN UNCONSTRAINED MINIMIZATION
-C ROUTINE TO ASSESS THE NEXT CANDIDATE STEP. IT MAY RECOMMEND ONE
-C OF SEVERAL COURSES OF ACTION, SUCH AS ACCEPTING THE STEP, RECOM-
-C PUTING IT USING THE SAME OR A NEW QUADRATIC MODEL, OR HALTING DUE
-C TO CONVERGENCE OR FALSE CONVERGENCE. SEE THE RETURN CODE LISTING
-C BELOW.
-C
-C-------------------------- PARAMETER USAGE --------------------------
-C
-C IV (I/O) INTEGER PARAMETER AND SCRATCH VECTOR -- SEE DESCRIPTION
-C BELOW OF IV VALUES REFERENCED.
-C LIV (IN) LENGTH OF IV ARRAY.
-C LV (IN) LENGTH OF V ARRAY.
-C V (I/O) REAL PARAMETER AND SCRATCH VECTOR -- SEE DESCRIPTION
-C BELOW OF V VALUES REFERENCED.
-C
-C *** IV VALUES REFERENCED ***
-C
-C IV(IRC) (I/O) ON INPUT FOR THE FIRST STEP TRIED IN A NEW ITERATION,
-C IV(IRC) SHOULD BE SET TO 3 OR 4 (THE VALUE TO WHICH IT IS
-C SET WHEN STEP IS DEFINITELY TO BE ACCEPTED). ON INPUT
-C AFTER STEP HAS BEEN RECOMPUTED, IV(IRC) SHOULD BE
-C UNCHANGED SINCE THE PREVIOUS RETURN OF A7SST.
-C ON OUTPUT, IV(IRC) IS A RETURN CODE HAVING ONE OF THE
-C FOLLOWING VALUES...
-C 1 = SWITCH MODELS OR TRY SMALLER STEP.
-C 2 = SWITCH MODELS OR ACCEPT STEP.
-C 3 = ACCEPT STEP AND DETERMINE V(RADFAC) BY GRADIENT
-C TESTS.
-C 4 = ACCEPT STEP, V(RADFAC) HAS BEEN DETERMINED.
-C 5 = RECOMPUTE STEP (USING THE SAME MODEL).
-C 6 = RECOMPUTE STEP WITH RADIUS = V(LMAXS) BUT DO NOT
-C EVALUATE THE OBJECTIVE FUNCTION.
-C 7 = X-CONVERGENCE (SEE V(XCTOL)).
-C 8 = RELATIVE FUNCTION CONVERGENCE (SEE V(RFCTOL)).
-C 9 = BOTH X- AND RELATIVE FUNCTION CONVERGENCE.
-C 10 = ABSOLUTE FUNCTION CONVERGENCE (SEE V(AFCTOL)).
-C 11 = SINGULAR CONVERGENCE (SEE V(LMAXS)).
-C 12 = FALSE CONVERGENCE (SEE V(XFTOL)).
-C 13 = IV(IRC) WAS OUT OF RANGE ON INPUT.
-C RETURN CODE I HAS PRECEDENCE OVER I+1 FOR I = 9, 10, 11.
-C IV(MLSTGD) (I/O) SAVED VALUE OF IV(MODEL).
-C IV(MODEL) (I/O) ON INPUT, IV(MODEL) SHOULD BE AN INTEGER IDENTIFYING
-C THE CURRENT QUADRATIC MODEL OF THE OBJECTIVE FUNCTION.
-C IF A PREVIOUS STEP YIELDED A BETTER FUNCTION REDUCTION,
-C THEN IV(MODEL) WILL BE SET TO IV(MLSTGD) ON OUTPUT.
-C IV(NFCALL) (IN) INVOCATION COUNT FOR THE OBJECTIVE FUNCTION.
-C IV(NFGCAL) (I/O) VALUE OF IV(NFCALL) AT STEP THAT GAVE THE BIGGEST
-C FUNCTION REDUCTION THIS ITERATION. IV(NFGCAL) REMAINS
-C UNCHANGED UNTIL A FUNCTION REDUCTION IS OBTAINED.
-C IV(RADINC) (I/O) THE NUMBER OF RADIUS INCREASES (OR MINUS THE NUMBER
-C OF DECREASES) SO FAR THIS ITERATION.
-C IV(RESTOR) (OUT) SET TO 1 IF V(F) HAS BEEN RESTORED AND X SHOULD BE
-C RESTORED TO ITS INITIAL VALUE, TO 2 IF X SHOULD BE SAVED,
-C TO 3 IF X SHOULD BE RESTORED FROM THE SAVED VALUE, AND TO
-C 0 OTHERWISE.
-C IV(STAGE) (I/O) COUNT OF THE NUMBER OF MODELS TRIED SO FAR IN THE
-C CURRENT ITERATION.
-C IV(STGLIM) (IN) MAXIMUM NUMBER OF MODELS TO CONSIDER.
-C IV(SWITCH) (OUT) SET TO 0 UNLESS A NEW MODEL IS BEING TRIED AND IT
-C GIVES A SMALLER FUNCTION VALUE THAN THE PREVIOUS MODEL,
-C IN WHICH CASE A7SST SETS IV(SWITCH) = 1.
-C IV(TOOBIG) (I/O) IS NONZERO ON INPUT IF STEP WAS TOO BIG (E.G., IF
-C IT WOULD CAUSE OVERFLOW). IT IS SET TO 0 ON RETURN.
-C IV(XIRC) (I/O) VALUE THAT IV(IRC) WOULD HAVE IN THE ABSENCE OF
-C CONVERGENCE, FALSE CONVERGENCE, AND OVERSIZED STEPS.
-C
-C *** V VALUES REFERENCED ***
-C
-C V(AFCTOL) (IN) ABSOLUTE FUNCTION CONVERGENCE TOLERANCE. IF THE
-C ABSOLUTE VALUE OF THE CURRENT FUNCTION VALUE V(F) IS LESS
-C THAN V(AFCTOL) AND A7SST DOES NOT RETURN WITH
-C IV(IRC) = 11, THEN A7SST RETURNS WITH IV(IRC) = 10.
-C V(DECFAC) (IN) FACTOR BY WHICH TO DECREASE RADIUS WHEN IV(TOOBIG) IS
-C NONZERO.
-C V(DSTNRM) (IN) THE 2-NORM OF D*STEP.
-C V(DSTSAV) (I/O) VALUE OF V(DSTNRM) ON SAVED STEP.
-C V(DST0) (IN) THE 2-NORM OF D TIMES THE NEWTON STEP (WHEN DEFINED,
-C I.E., FOR V(NREDUC) .GE. 0).
-C V(F) (I/O) ON BOTH INPUT AND OUTPUT, V(F) IS THE OBJECTIVE FUNC-
-C TION VALUE AT X. IF X IS RESTORED TO A PREVIOUS VALUE,
-C THEN V(F) IS RESTORED TO THE CORRESPONDING VALUE.
-C V(FDIF) (OUT) THE FUNCTION REDUCTION V(F0) - V(F) (FOR THE OUTPUT
-C VALUE OF V(F) IF AN EARLIER STEP GAVE A BIGGER FUNCTION
-C DECREASE, AND FOR THE INPUT VALUE OF V(F) OTHERWISE).
-C V(FLSTGD) (I/O) SAVED VALUE OF V(F).
-C V(F0) (IN) OBJECTIVE FUNCTION VALUE AT START OF ITERATION.
-C V(GTSLST) (I/O) VALUE OF V(GTSTEP) ON SAVED STEP.
-C V(GTSTEP) (IN) INNER PRODUCT BETWEEN STEP AND GRADIENT.
-C V(INCFAC) (IN) MINIMUM FACTOR BY WHICH TO INCREASE RADIUS.
-C V(LMAXS) (IN) MAXIMUM REASONABLE STEP SIZE (AND INITIAL STEP BOUND).
-C IF THE ACTUAL FUNCTION DECREASE IS NO MORE THAN TWICE
-C WHAT WAS PREDICTED, IF A RETURN WITH IV(IRC) = 7, 8, OR 9
-C DOES NOT OCCUR, IF V(DSTNRM) .GT. V(LMAXS) OR THE CURRENT
-C STEP IS A NEWTON STEP, AND IF
-C V(PREDUC) .LE. V(SCTOL) * ABS(V(F0)), THEN A7SST RETURNS
-C WITH IV(IRC) = 11. IF SO DOING APPEARS WORTHWHILE, THEN
-C A7SST REPEATS THIS TEST (DISALLOWING A FULL NEWTON STEP)
-C WITH V(PREDUC) COMPUTED FOR A STEP OF LENGTH V(LMAXS)
-C (BY A RETURN WITH IV(IRC) = 6).
-C V(NREDUC) (I/O) FUNCTION REDUCTION PREDICTED BY QUADRATIC MODEL FOR
-C NEWTON STEP. IF A7SST IS CALLED WITH IV(IRC) = 6, I.E.,
-C IF V(PREDUC) HAS BEEN COMPUTED WITH RADIUS = V(LMAXS) FOR
-C _USE_ IN THE SINGULAR CONVERGENCE TEST, THEN V(NREDUC) IS
-C SET TO -V(PREDUC) BEFORE THE LATTER IS RESTORED.
-C V(PLSTGD) (I/O) VALUE OF V(PREDUC) ON SAVED STEP.
-C V(PREDUC) (I/O) FUNCTION REDUCTION PREDICTED BY QUADRATIC MODEL FOR
-C CURRENT STEP.
-C V(RADFAC) (OUT) FACTOR TO BE USED IN DETERMINING THE NEW RADIUS,
-C WHICH SHOULD BE V(RADFAC)*DST, WHERE DST IS EITHER THE
-C OUTPUT VALUE OF V(DSTNRM) OR THE 2-NORM OF
-C DIAG(NEWD)*STEP FOR THE OUTPUT VALUE OF STEP AND THE
-C UPDATED VERSION, NEWD, OF THE SCALE VECTOR D. FOR
-C IV(IRC) = 3, V(RADFAC) = 1.0 IS RETURNED.
-C V(RDFCMN) (IN) MINIMUM VALUE FOR V(RADFAC) IN TERMS OF THE INPUT
-C VALUE OF V(DSTNRM) -- SUGGESTED VALUE = 0.1.
-C V(RDFCMX) (IN) MAXIMUM VALUE FOR V(RADFAC) -- SUGGESTED VALUE = 4.0.
-C V(RELDX) (IN) SCALED RELATIVE CHANGE IN X CAUSED BY STEP, COMPUTED
-C (E.G.) BY FUNCTION RLDST AS
-C MAX (D(I)*ABS(X(I)-X0(I)), 1 .LE. I .LE. P) /
-C MAX (D(I)*(ABS(X(I))+ABS(X0(I))), 1 .LE. I .LE. P).
-C V(RFCTOL) (IN) RELATIVE FUNCTION CONVERGENCE TOLERANCE. IF THE
-C ACTUAL FUNCTION REDUCTION IS AT MOST TWICE WHAT WAS PRE-
-C DICTED AND V(NREDUC) .LE. V(RFCTOL)*ABS(V(F0)), THEN
-C A7SST RETURNS WITH IV(IRC) = 8 OR 9.
-C V(SCTOL) (IN) SINGULAR CONVERGENCE TOLERANCE -- SEE V(LMAXS).
-C V(STPPAR) (IN) MARQUARDT PARAMETER -- 0 MEANS FULL NEWTON STEP.
-C V(TUNER1) (IN) TUNING CONSTANT USED TO DECIDE IF THE FUNCTION
-C REDUCTION WAS MUCH LESS THAN EXPECTED. SUGGESTED
-C VALUE = 0.1.
-C V(TUNER2) (IN) TUNING CONSTANT USED TO DECIDE IF THE FUNCTION
-C REDUCTION WAS LARGE ENOUGH TO ACCEPT STEP. SUGGESTED
-C VALUE = 10**-4.
-C V(TUNER3) (IN) TUNING CONSTANT USED TO DECIDE IF THE RADIUS
-C SHOULD BE INCREASED. SUGGESTED VALUE = 0.75.
-C V(XCTOL) (IN) X-CONVERGENCE CRITERION. IF STEP IS A NEWTON STEP
-C (V(STPPAR) = 0) HAVING V(RELDX) .LE. V(XCTOL) AND GIVING
-C AT MOST TWICE THE PREDICTED FUNCTION DECREASE, THEN
-C A7SST RETURNS IV(IRC) = 7 OR 9.
-C V(XFTOL) (IN) FALSE CONVERGENCE TOLERANCE. IF STEP GAVE NO OR ONLY
-C A SMALL FUNCTION DECREASE AND V(RELDX) .LE. V(XFTOL),
-C THEN A7SST RETURNS WITH IV(IRC) = 12.
-C
-C------------------------------- NOTES -------------------------------
-C
-C *** APPLICATION AND USAGE RESTRICTIONS ***
-C
-C THIS ROUTINE IS CALLED AS PART OF THE NL2SOL (NONLINEAR
-C LEAST-SQUARES) PACKAGE. IT MAY BE USED IN ANY UNCONSTRAINED
-C MINIMIZATION SOLVER THAT USES DOGLEG, GOLDFELD-QUANDT-TROTTER,
-C OR LEVENBERG-MARQUARDT STEPS.
-C
-C *** ALGORITHM NOTES ***
-C
-C SEE (1) FOR FURTHER DISCUSSION OF THE ASSESSING AND MODEL
-C SWITCHING STRATEGIES. WHILE NL2SOL CONSIDERS ONLY TWO MODELS,
-C A7SST IS DESIGNED TO HANDLE ANY NUMBER OF MODELS.
-C
-C *** USAGE NOTES ***
-C
-C ON THE FIRST CALL OF AN ITERATION, ONLY THE I/O VARIABLES
-C STEP, X, IV(IRC), IV(MODEL), V(F), V(DSTNRM), V(GTSTEP), AND
-C V(PREDUC) NEED HAVE BEEN INITIALIZED. BETWEEN CALLS, NO I/O
-C VALUES EXCEPT STEP, X, IV(MODEL), V(F) AND THE STOPPING TOLER-
-C ANCES SHOULD BE CHANGED.
-C AFTER A RETURN FOR CONVERGENCE OR FALSE CONVERGENCE, ONE CAN
-C CHANGE THE STOPPING TOLERANCES AND CALL A7SST AGAIN, IN WHICH
-C CASE THE STOPPING TESTS WILL BE REPEATED.
-C
-C *** REFERENCES ***
-C
-C (1) DENNIS, J.E., JR., GAY, D.M., AND WELSCH, R.E. (1981),
-C AN ADAPTIVE NONLINEAR LEAST-SQUARES ALGORITHM,
-C ACM TRANS. MATH. SOFTWARE, VOL. 7, NO. 3.
-C
-C (2) POWELL, M.J.D. (1970) A FORTRAN SUBROUTINE FOR SOLVING
-C SYSTEMS OF NONLINEAR ALGEBRAIC EQUATIONS, IN NUMERICAL
-C METHODS FOR NONLINEAR ALGEBRAIC EQUATIONS, EDITED BY
-C P. RABINOWITZ, GORDON AND BREACH, LONDON.
-C
-C *** HISTORY ***
-C
-C JOHN DENNIS DESIGNED MUCH OF THIS ROUTINE, STARTING WITH
-C IDEAS IN (2). ROY WELSCH SUGGESTED THE MODEL SWITCHING STRATEGY.
-C DAVID GAY AND STEPHEN PETERS CAST THIS SUBROUTINE INTO A MORE
-C PORTABLE FORM (WINTER 1977), AND DAVID GAY CAST IT INTO ITS
-C PRESENT FORM (FALL 1978), WITH MINOR CHANGES TO THE SINGULAR
-C CONVERGENCE TEST IN MAY, 1984 (TO DEAL WITH FULL NEWTON STEPS).
-C
-C *** GENERAL ***
-C
-C THIS SUBROUTINE WAS WRITTEN IN CONNECTION WITH RESEARCH
-C SUPPORTED BY THE NATIONAL SCIENCE FOUNDATION UNDER GRANTS
-C MCS-7600324, DCR75-10143, 76-14311DSS, MCS76-11989, AND
-C MCS-7906671.
-C
-C------------------------ EXTERNAL QUANTITIES ------------------------
-C
-C *** NO EXTERNAL FUNCTIONS AND SUBROUTINES ***
-C
-C-------------------------- LOCAL VARIABLES --------------------------
-C
- LOGICAL GOODX
- INTEGER I, NFC
- REAL EMAX, EMAXS, GTS, RFAC1, XMAX
- REAL HALF, ONE, ONEP2, TWO, ZERO
-C
-C *** SUBSCRIPTS FOR IV AND V ***
-C
- INTEGER AFCTOL, DECFAC, DSTNRM, DSTSAV, DST0, F, FDIF, FLSTGD, F0,
- 1 GTSLST, GTSTEP, INCFAC, IRC, LMAXS, MLSTGD, MODEL, NFCALL,
- 2 NFGCAL, NREDUC, PLSTGD, PREDUC, RADFAC, RADINC, RDFCMN,
- 3 RDFCMX, RELDX, RESTOR, RFCTOL, SCTOL, STAGE, STGLIM,
- 4 STPPAR, SWITCH, TOOBIG, TUNER1, TUNER2, TUNER3, XCTOL,
- 5 XFTOL, XIRC
-C
-C *** DATA INITIALIZATIONS ***
-C
-C/6
-C DATA HALF/0.5E+0/, ONE/1.E+0/, ONEP2/1.2E+0/, TWO/2.E+0/,
-C 1 ZERO/0.E+0/
-C/7
- PARAMETER (HALF=0.5E+0, ONE=1.E+0, ONEP2=1.2E+0, TWO=2.E+0,
- 1 ZERO=0.E+0)
-C/
-C
-C/6
-C DATA IRC/29/, MLSTGD/32/, MODEL/5/, NFCALL/6/, NFGCAL/7/,
-C 1 RADINC/8/, RESTOR/9/, STAGE/10/, STGLIM/11/, SWITCH/12/,
-C 2 TOOBIG/2/, XIRC/13/
-C/7
- PARAMETER (IRC=29, MLSTGD=32, MODEL=5, NFCALL=6, NFGCAL=7,
- 1 RADINC=8, RESTOR=9, STAGE=10, STGLIM=11, SWITCH=12,
- 2 TOOBIG=2, XIRC=13)
-C/
-C/6
-C DATA AFCTOL/31/, DECFAC/22/, DSTNRM/2/, DST0/3/, DSTSAV/18/,
-C 1 F/10/, FDIF/11/, FLSTGD/12/, F0/13/, GTSLST/14/, GTSTEP/4/,
-C 2 INCFAC/23/, LMAXS/36/, NREDUC/6/, PLSTGD/15/, PREDUC/7/,
-C 3 RADFAC/16/, RDFCMN/24/, RDFCMX/25/, RELDX/17/, RFCTOL/32/,
-C 4 SCTOL/37/, STPPAR/5/, TUNER1/26/, TUNER2/27/, TUNER3/28/,
-C 5 XCTOL/33/, XFTOL/34/
-C/7
- PARAMETER (AFCTOL=31, DECFAC=22, DSTNRM=2, DST0=3, DSTSAV=18,
- 1 F=10, FDIF=11, FLSTGD=12, F0=13, GTSLST=14, GTSTEP=4,
- 2 INCFAC=23, LMAXS=36, NREDUC=6, PLSTGD=15, PREDUC=7,
- 3 RADFAC=16, RDFCMN=24, RDFCMX=25, RELDX=17, RFCTOL=32,
- 4 SCTOL=37, STPPAR=5, TUNER1=26, TUNER2=27, TUNER3=28,
- 5 XCTOL=33, XFTOL=34)
-C/
-C
-C+++++++++++++++++++++++++++++++ BODY ++++++++++++++++++++++++++++++++
-C
- NFC = IV(NFCALL)
- IV(SWITCH) = 0
- IV(RESTOR) = 0
- RFAC1 = ONE
- GOODX = .TRUE.
- I = IV(IRC)
- IF (I .GE. 1 .AND. I .LE. 12)
- 1 GO TO (20,30,10,10,40,280,220,220,220,220,220,170), I
- IV(IRC) = 13
- GO TO 999
-C
-C *** INITIALIZE FOR NEW ITERATION ***
-C
- 10 IV(STAGE) = 1
- IV(RADINC) = 0
- V(FLSTGD) = V(F0)
- IF (IV(TOOBIG) .EQ. 0) GO TO 110
- IV(STAGE) = -1
- IV(XIRC) = I
- GO TO 60
-C
-C *** STEP WAS RECOMPUTED WITH NEW MODEL OR SMALLER RADIUS ***
-C *** FIRST DECIDE WHICH ***
-C
- 20 IF (IV(MODEL) .NE. IV(MLSTGD)) GO TO 30
-C *** OLD MODEL RETAINED, SMALLER RADIUS TRIED ***
-C *** DO NOT CONSIDER ANY MORE NEW MODELS THIS ITERATION ***
- IV(STAGE) = IV(STGLIM)
- IV(RADINC) = -1
- GO TO 110
-C
-C *** A NEW MODEL IS BEING TRIED. DECIDE WHETHER TO KEEP IT. ***
-C
- 30 IV(STAGE) = IV(STAGE) + 1
-C
-C *** NOW WE ADD THE POSSIBILITY THAT STEP WAS RECOMPUTED WITH ***
-C *** THE SAME MODEL, PERHAPS BECAUSE OF AN OVERSIZED STEP. ***
-C
- 40 IF (IV(STAGE) .GT. 0) GO TO 50
-C
-C *** STEP WAS RECOMPUTED BECAUSE IT WAS TOO BIG. ***
-C
- IF (IV(TOOBIG) .NE. 0) GO TO 60
-C
-C *** RESTORE IV(STAGE) AND PICK UP WHERE WE LEFT OFF. ***
-C
- IV(STAGE) = -IV(STAGE)
- I = IV(XIRC)
- GO TO (20, 30, 110, 110, 70), I
-C
- 50 IF (IV(TOOBIG) .EQ. 0) GO TO 70
-C
-C *** HANDLE OVERSIZE STEP ***
-C
- IV(TOOBIG) = 0
- IF (IV(RADINC) .GT. 0) GO TO 80
- IV(STAGE) = -IV(STAGE)
- IV(XIRC) = IV(IRC)
-C
- 60 IV(TOOBIG) = 0
- V(RADFAC) = V(DECFAC)
- IV(RADINC) = IV(RADINC) - 1
- IV(IRC) = 5
- IV(RESTOR) = 1
- V(F) = V(FLSTGD)
- GO TO 999
-C
- 70 IF (V(F) .LT. V(FLSTGD)) GO TO 110
-C
-C *** THE NEW STEP IS A LOSER. RESTORE OLD MODEL. ***
-C
- IF (IV(MODEL) .EQ. IV(MLSTGD)) GO TO 80
- IV(MODEL) = IV(MLSTGD)
- IV(SWITCH) = 1
-C
-C *** RESTORE STEP, ETC. ONLY IF A PREVIOUS STEP DECREASED V(F).
-C
- 80 IF (V(FLSTGD) .GE. V(F0)) GO TO 110
- IF (IV(STAGE) .LT. IV(STGLIM)) THEN
- GOODX = .FALSE.
- ELSE IF (NFC .LT. IV(NFGCAL) + IV(STGLIM) + 2) THEN
- GOODX = .FALSE.
- ELSE IF (IV(SWITCH) .NE. 0) THEN
- GOODX = .FALSE.
- ENDIF
- IV(RESTOR) = 3
- V(F) = V(FLSTGD)
- V(PREDUC) = V(PLSTGD)
- V(GTSTEP) = V(GTSLST)
- IF (IV(SWITCH) .EQ. 0) RFAC1 = V(DSTNRM) / V(DSTSAV)
- V(DSTNRM) = V(DSTSAV)
- IF (GOODX) THEN
-C
-C *** ACCEPT PREVIOUS SLIGHTLY REDUCING STEP ***
-C
- V(FDIF) = V(F0) - V(F)
- IV(IRC) = 4
- V(RADFAC) = RFAC1
- GO TO 999
- ENDIF
- NFC = IV(NFGCAL)
-C
- 110 V(FDIF) = V(F0) - V(F)
- IF (V(FDIF) .GT. V(TUNER2) * V(PREDUC)) GO TO 140
- IF (IV(RADINC) .GT. 0) GO TO 140
-C
-C *** NO (OR ONLY A TRIVIAL) FUNCTION DECREASE
-C *** -- SO TRY NEW MODEL OR SMALLER RADIUS
-C
- IF (V(F) .LT. V(F0)) GO TO 120
- IV(MLSTGD) = IV(MODEL)
- V(FLSTGD) = V(F)
- V(F) = V(F0)
- IV(RESTOR) = 1
- GO TO 130
- 120 IV(NFGCAL) = NFC
- 130 IV(IRC) = 1
- IF (IV(STAGE) .LT. IV(STGLIM)) GO TO 160
- IV(IRC) = 5
- IV(RADINC) = IV(RADINC) - 1
- GO TO 160
-C
-C *** NONTRIVIAL FUNCTION DECREASE ACHIEVED ***
-C
- 140 IV(NFGCAL) = NFC
- RFAC1 = ONE
- V(DSTSAV) = V(DSTNRM)
- IF (V(FDIF) .GT. V(PREDUC)*V(TUNER1)) GO TO 190
-C
-C *** DECREASE WAS MUCH LESS THAN PREDICTED -- EITHER CHANGE MODELS
-C *** OR ACCEPT STEP WITH DECREASED RADIUS.
-C
- IF (IV(STAGE) .GE. IV(STGLIM)) GO TO 150
-C *** CONSIDER SWITCHING MODELS ***
- IV(IRC) = 2
- GO TO 160
-C
-C *** ACCEPT STEP WITH DECREASED RADIUS ***
-C
- 150 IV(IRC) = 4
-C
-C *** SET V(RADFAC) TO FLETCHER*S DECREASE FACTOR ***
-C
- 160 IV(XIRC) = IV(IRC)
- EMAX = V(GTSTEP) + V(FDIF)
- V(RADFAC) = HALF * RFAC1
- IF (EMAX .LT. V(GTSTEP)) V(RADFAC) = RFAC1 * AMAX1(V(RDFCMN),
- 1 HALF * V(GTSTEP)/EMAX)
-C
-C *** DO FALSE CONVERGENCE TEST ***
-C
- 170 IF (V(RELDX) .LE. V(XFTOL)) GO TO 180
- IV(IRC) = IV(XIRC)
- IF (V(F) .LT. V(F0)) GO TO 200
- GO TO 230
-C
- 180 IV(IRC) = 12
- GO TO 240
-C
-C *** HANDLE GOOD FUNCTION DECREASE ***
-C
- 190 IF (V(FDIF) .LT. (-V(TUNER3) * V(GTSTEP))) GO TO 210
-C
-C *** INCREASING RADIUS LOOKS WORTHWHILE. SEE IF WE JUST
-C *** RECOMPUTED STEP WITH A DECREASED RADIUS OR RESTORED STEP
-C *** AFTER RECOMPUTING IT WITH A LARGER RADIUS.
-C
- IF (IV(RADINC) .LT. 0) GO TO 210
- IF (IV(RESTOR) .EQ. 1) GO TO 210
- IF (IV(RESTOR) .EQ. 3) GO TO 210
-C
-C *** WE DID NOT. TRY A LONGER STEP UNLESS THIS WAS A NEWTON
-C *** STEP.
-C
- V(RADFAC) = V(RDFCMX)
- GTS = V(GTSTEP)
- IF (V(FDIF) .LT. (HALF/V(RADFAC) - ONE) * GTS)
- 1 V(RADFAC) = AMAX1(V(INCFAC), HALF*GTS/(GTS + V(FDIF)))
- IV(IRC) = 4
- IF (V(STPPAR) .EQ. ZERO) GO TO 230
- IF (V(DST0) .GE. ZERO .AND. (V(DST0) .LT. TWO*V(DSTNRM)
- 1 .OR. V(NREDUC) .LT. ONEP2*V(FDIF))) GO TO 230
-C *** STEP WAS NOT A NEWTON STEP. RECOMPUTE IT WITH
-C *** A LARGER RADIUS.
- IV(IRC) = 5
- IV(RADINC) = IV(RADINC) + 1
-C
-C *** SAVE VALUES CORRESPONDING TO GOOD STEP ***
-C
- 200 V(FLSTGD) = V(F)
- IV(MLSTGD) = IV(MODEL)
- IF (IV(RESTOR) .EQ. 0) IV(RESTOR) = 2
- V(DSTSAV) = V(DSTNRM)
- IV(NFGCAL) = NFC
- V(PLSTGD) = V(PREDUC)
- V(GTSLST) = V(GTSTEP)
- GO TO 230
-C
-C *** ACCEPT STEP WITH RADIUS UNCHANGED ***
-C
- 210 V(RADFAC) = ONE
- IV(IRC) = 3
- GO TO 230
-C
-C *** COME HERE FOR A RESTART AFTER CONVERGENCE ***
-C
- 220 IV(IRC) = IV(XIRC)
- IF (V(DSTSAV) .GE. ZERO) GO TO 240
- IV(IRC) = 12
- GO TO 240
-C
-C *** PERFORM CONVERGENCE TESTS ***
-C
- 230 IV(XIRC) = IV(IRC)
- 240 IF (IV(RESTOR) .EQ. 1 .AND. V(FLSTGD) .LT. V(F0)) IV(RESTOR) = 3
- IF ( ABS(V(F)) .LT. V(AFCTOL)) IV(IRC) = 10
- IF (HALF * V(FDIF) .GT. V(PREDUC)) GO TO 999
- EMAX = V(RFCTOL) * ABS(V(F0))
- EMAXS = V(SCTOL) * ABS(V(F0))
- IF (V(PREDUC) .LE. EMAXS .AND. (V(DSTNRM) .GT. V(LMAXS) .OR.
- 1 V(STPPAR) .EQ. ZERO)) IV(IRC) = 11
- IF (V(DST0) .LT. ZERO) GO TO 250
- I = 0
- IF ((V(NREDUC) .GT. ZERO .AND. V(NREDUC) .LE. EMAX) .OR.
- 1 (V(NREDUC) .EQ. ZERO. AND. V(PREDUC) .EQ. ZERO)) I = 2
- IF (V(STPPAR) .EQ. ZERO .AND. V(RELDX) .LE. V(XCTOL)
- 1 .AND. GOODX) I = I + 1
- IF (I .GT. 0) IV(IRC) = I + 6
-C
-C *** CONSIDER RECOMPUTING STEP OF LENGTH V(LMAXS) FOR SINGULAR
-C *** CONVERGENCE TEST.
-C
- 250 IF (IV(IRC) .GT. 5 .AND. IV(IRC) .NE. 12) GO TO 999
- IF (V(STPPAR) .EQ. ZERO) GO TO 999
- IF (V(DSTNRM) .GT. V(LMAXS)) GO TO 260
- IF (V(PREDUC) .GE. EMAXS) GO TO 999
- IF (V(DST0) .LE. ZERO) GO TO 270
- IF (HALF * V(DST0) .LE. V(LMAXS)) GO TO 999
- GO TO 270
- 260 IF (HALF * V(DSTNRM) .LE. V(LMAXS)) GO TO 999
- XMAX = V(LMAXS) / V(DSTNRM)
- IF (XMAX * (TWO - XMAX) * V(PREDUC) .GE. EMAXS) GO TO 999
- 270 IF (V(NREDUC) .LT. ZERO) GO TO 290
-C
-C *** RECOMPUTE V(PREDUC) FOR _USE_ IN SINGULAR CONVERGENCE TEST ***
-C
- V(GTSLST) = V(GTSTEP)
- V(DSTSAV) = V(DSTNRM)
- IF (IV(IRC) .EQ. 12) V(DSTSAV) = -V(DSTSAV)
- V(PLSTGD) = V(PREDUC)
- I = IV(RESTOR)
- IV(RESTOR) = 2
- IF (I .EQ. 3) IV(RESTOR) = 0
- IV(IRC) = 6
- GO TO 999
-C
-C *** PERFORM SINGULAR CONVERGENCE TEST WITH RECOMPUTED V(PREDUC) ***
-C
- 280 V(GTSTEP) = V(GTSLST)
- V(DSTNRM) = ABS(V(DSTSAV))
- IV(IRC) = IV(XIRC)
- IF (V(DSTSAV) .LE. ZERO) IV(IRC) = 12
- V(NREDUC) = -V(PREDUC)
- V(PREDUC) = V(PLSTGD)
- IV(RESTOR) = 3
- 290 IF (-V(NREDUC) .LE. V(SCTOL) * ABS(V(F0))) IV(IRC) = 11
-C
- 999 RETURN
-C
-C *** LAST LINE OF A7SST FOLLOWS ***
- END
diff --git a/CEP/PyBDSM/src/port3/a9rntc.f b/CEP/PyBDSM/src/port3/a9rntc.f
deleted file mode 100644
index 0caeb20a18fe80f0bef734bc3feb3489f7453af4..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/a9rntc.f
+++ /dev/null
@@ -1,222 +0,0 @@
- SUBROUTINE A9RNTC(A, NITEMS, IOUT, MCOL, W, D)
-C
-C THIS IS THE DOCUMENTED ROUTINE APRNTC, BUT WITHOUT THE CALLS TO
-C SETERR- BECAUSE IT IS CALLED BY SETERR.
-C
-C THIS SUBROUTINE PRINTS OUT NITEMS FROM THE COMPLEX ARRAY, A, ON
-C OUTPUT UNIT IOUT, USING A MAXIMUM OF MCOL PRINT SPACES.
-C THE OUTPUT FORMAT IS 2(1PEW.D).
-C THE PROGRAM PUTS AS MANY VALUES ON A LINE AS POSSIBLE.
-C W SHOULD BE INPUT AS THE ACTUAL WIDTH +1 FOR A SPACE BETWEEN VALUES.
-C
-C DUPLICATE LINES ARE NOT ALL PRINTED, BUT ARE INDICATED BY ASTERISKS.
-C
-C WRITTEN BY DAN WARNER, REVISED BY PHYL FOX, OCTOBER 21, 1982.
-C
-C THE LINE WIDTH IS COMPUTED AS THE MINIMUM OF THE INPUT MCOL AND 160.
-C IF THE LINE WIDTH IS TO BE INCREASED ABOVE 160, THE BUFFERS LINE()
-C AND LAST(), WHICH THE VALUES TO BE PRINTED ON ONE LINE, MUST
-C BE DIMENSIONED ACCORDINGLY.
-C
-C INPUT PARAMETERS -
-C
-C A - THE START OF THE COMPLEX ARRAY TO BE PRINTED
-C
-C NITEMS - THE NUMBER OF ITEMS TO BE PRINTED
-C
-C IOUT - THE OUTPUT UNIT FOR PRINTING
-C
-C MCOL - THE NUMBER OF SPACES ACROSS THE LINE
-C
-C W - THE WIDTH OF THE PRINTED VALUE (1PEW.D)
-C
-C D - THE NUMBER OF DIGITS AFTER THE DECIMAL POINT (1PEW.D)
-C
-C
-C ERROR STATES - NONE. LOWER LEVEL ROUTINE CALLED BY
-C SETERR, SO IT CANNOT CALL SETERR.
-C
- INTEGER NITEMS, IOUT, MCOL, W, D
-C/R
-C REAL A(2,NITEMS)
-C/C
- COMPLEX A(NITEMS)
-C/
-C
- INTEGER MAX0, MIN0, WW, DD, EMIN, EMAX,
- 1 EXPENT, I1MACH, ICEIL, IABS, I10WID
-C/6S
-C INTEGER IFMT1(20), IFMT2(18), BLANK, STAR
-C INTEGER IFMT1C(20), IFMT2C(18)
-C EQUIVALENCE (IFMT1(1),IFMT1C(1)), (IFMT2(1),IFMT2C(1))
-C/7S
- CHARACTER*1 IFMT1(20), IFMT2(18), BLANK, STAR
- CHARACTER*20 IFMT1C
- CHARACTER*18 IFMT2C
- EQUIVALENCE (IFMT1(1),IFMT1C), (IFMT2(1),IFMT2C)
-C/
- INTEGER INDW, NCOL, COUNT, I, J, K, ILINE, ILAST
- LOGICAL DUP
-C/R
-C REAL LINE(2,18), LAST(2,18)
-C/C
- COMPLEX LINE(18), LAST(18)
-C/
- REAL LOGETA
-C
-C/6S
-C DATA BLANK/1H /, STAR/1H*/, INDW/7/, EXPENT/0/
-C/7S
- DATA BLANK/' '/, STAR/'*'/, INDW/7/, EXPENT/0/
-C/
-C
-C IFMT1 IS FOR THE ASTERISK LINES- IFMT2 FOR THE DATA LINES
-C
-C/6S
-C DATA IFMT1( 1) /1H(/, IFMT2( 1) /1H(/
-C DATA IFMT1( 2) /1H1/, IFMT2( 2) /1H1/
-C DATA IFMT1( 3) /1HA/, IFMT2( 3) /1HA/
-C DATA IFMT1( 4) /1H1/, IFMT2( 4) /1H1/
-C DATA IFMT1( 5) /1H,/, IFMT2( 5) /1H,/
-C DATA IFMT1( 6) /1H5/, IFMT2( 6) /1HI/
-C DATA IFMT1( 7) /1HX/, IFMT2( 7) /1H7/
-C DATA IFMT1( 8) /1H,/, IFMT2( 8) /1H,/
-C DATA IFMT1( 9) /1H2/, IFMT2( 9) /1H1/
-C DATA IFMT1(10) /1HA/, IFMT2(10) /1HP/
-C DATA IFMT1(11) /1H1/, IFMT2(11) /1H /
-C DATA IFMT1(12) /1H,/, IFMT2(12) /1HE/
-C DATA IFMT1(13) /1H /, IFMT2(13) /1H /
-C DATA IFMT1(14) /1H /, IFMT2(14) /1H /
-C DATA IFMT1(15) /1HX/, IFMT2(15) /1H./
-C DATA IFMT1(16) /1H,/, IFMT2(16) /1H /
-C DATA IFMT1(17) /1H2/, IFMT2(17) /1H /
-C DATA IFMT1(18) /1HA/, IFMT2(18) /1H)/
-C DATA IFMT1(19) /1H1/
-C DATA IFMT1(20) /1H)/
-C/7S
- DATA IFMT1( 1) /'('/, IFMT2( 1) /'('/
- DATA IFMT1( 2) /'1'/, IFMT2( 2) /'1'/
- DATA IFMT1( 3) /'A'/, IFMT2( 3) /'A'/
- DATA IFMT1( 4) /'1'/, IFMT2( 4) /'1'/
- DATA IFMT1( 5) /','/, IFMT2( 5) /','/
- DATA IFMT1( 6) /'5'/, IFMT2( 6) /'I'/
- DATA IFMT1( 7) /'X'/, IFMT2( 7) /'7'/
- DATA IFMT1( 8) /','/, IFMT2( 8) /','/
- DATA IFMT1( 9) /'2'/, IFMT2( 9) /'1'/
- DATA IFMT1(10) /'A'/, IFMT2(10) /'P'/
- DATA IFMT1(11) /'1'/, IFMT2(11) /' '/
- DATA IFMT1(12) /','/, IFMT2(12) /'E'/
- DATA IFMT1(13) /' '/, IFMT2(13) /' '/
- DATA IFMT1(14) /' '/, IFMT2(14) /' '/
- DATA IFMT1(15) /'X'/, IFMT2(15) /'.'/
- DATA IFMT1(16) /','/, IFMT2(16) /' '/
- DATA IFMT1(17) /'2'/, IFMT2(17) /' '/
- DATA IFMT1(18) /'A'/, IFMT2(18) /')'/
- DATA IFMT1(19) /'1'/
- DATA IFMT1(20) /')'/
-C/
-C
-C EXPENT IS USED AS A FIRST-TIME SWITCH TO SIGNAL IF THE
-C MACHINE-VALUE CONSTANTS HAVE BEEN COMPUTED.
-C
- IF (EXPENT .GT. 0) GO TO 10
- LOGETA = ALOG10(FLOAT(I1MACH(10)))
- EMIN = ICEIL(LOGETA*FLOAT(IABS(I1MACH(12)-1)))
- EMAX = ICEIL(LOGETA*FLOAT(I1MACH(13)))
- EXPENT = I10WID(MAX0(EMIN, EMAX))
-C
-C COMPUTE THE FORMATS.
-C
- 10 WW = MIN0(99, MAX0(W, 5+EXPENT))
- CALL S88FMT(2, WW, IFMT2(13))
- DD = MIN0(D, (WW-(5+EXPENT)))
- CALL S88FMT(2, DD, IFMT2(16))
-C
-C NCOL IS THE NUMBER OF VALUES TO BE PRINTED ACROSS THE LINE.
-C
- NCOL = MAX0(1, MIN0(9, (MIN0(MCOL,160)-INDW)/(2*WW)))
- CALL S88FMT(1, (2*NCOL), IFMT2(11))
- WW = WW-2
-C
-C THE ASTERISKS ARE POSITIONED RIGHT-ADJUSTED IN THE W-WIDTH SPACE.
- CALL S88FMT(2, WW, IFMT1(13))
-C
-C I COUNTS THE NUMBER OF ITEMS TO BE PRINTED,
-C J COUNTS THE NUMBER ON A GIVEN LINE,
-C COUNT COUNTS THE NUMBER OF DUPLICATE LINES.
-C
- I = 1
- J = 0
- COUNT = 0
-C
-C THE LOGICAL OF THE FOLLOWING IS ROUGHLY THIS -
-C IF THERE ARE STILL MORE ITEMS TO BE PRINTED, A LINE-
-C FULL IS PUT INTO THE ARRAY, LINE.
-C WHENEVER A LINE IS PRINTED OUT, IT IS ALSO STUFFED INTO
-C THE ARRAY, LAST, TO COMPARE WITH THE NEXT ONE COMING IN
-C TO CHECK FOR REPEAT OR DUPLICATED LINES.
-C ALSO WHENEVER A LINE IS WRITTEN OUT, THE DUPLICATION
-C COUNTER, COUNT, IS SET TO ONE.
-C THE ONLY MILDLY TRICKY PART IS TO NOTE THAT COUNT HAS TO
-C GO TO 3 BEFORE A LINE OF ASTERISKS IS PRINTED BECAUSE
-C OF COURSE NO SUCH LINE IS PRINTED FOR JUST A PAIR OF
-C DUPLICATE LINES.
-C
-C ILINE IS PRINTED AS THE INDEX OF THE FIRST ARRAY ELEMENT
-C IN A LINE.
-C
-C
- 20 IF (I .GT. NITEMS) GO TO 90
- J = J+1
-C/R
-C LINE(1,J) = A(1,I)
-C LINE(2,J) = A(2,I)
-C/C
- LINE(J) = A(I)
-C/
- IF (J .EQ. 1) ILINE = I
- IF (J .LT. NCOL .AND. I .LT. NITEMS) GO TO 80
- IF (COUNT .EQ. 0) GO TO 50
- DUP = .TRUE.
- DO 30 K=1,NCOL
-C/R
-C IF (LAST(1,K) .NE. LINE(1,K) .OR.
-C 1 LAST(2,K) .NE. LINE(2,K))
-C 2 DUP = .FALSE.
-C/C
- IF (REAL(LAST(K)) .NE. REAL(LINE(K)) .OR.
- 1 AIMAG(LAST(K)) .NE. AIMAG(LINE(K)))
- 2 DUP = .FALSE.
-C/
- 30 CONTINUE
- IF (I .EQ. NITEMS .AND. J .LT. NCOL) DUP = .FALSE.
- IF (.NOT. DUP .AND. COUNT .EQ. 1) GO TO 50
- IF (.NOT. DUP) GO TO 40
- COUNT = COUNT+1
- IF (COUNT .EQ. 3) WRITE(IOUT, IFMT1C) BLANK,
- 1 STAR, STAR, STAR, STAR
- IF (I .EQ. NITEMS) GO TO 50
- GO TO 70
-C/R
-C 40 WRITE(IOUT, IFMT2C) BLANK, ILAST, (LAST(1,K),
-C 1 LAST(2,K), K=1,NCOL)
-C 50 WRITE(IOUT, IFMT2C) BLANK, ILINE, (LINE(1,K),
-C 1 LINE(2,K), K=1,J)
-C/C
- 40 WRITE(IOUT, IFMT2C) BLANK, ILAST, (LAST(K), K=1,NCOL)
- 50 WRITE(IOUT, IFMT2C) BLANK, ILINE, (LINE(K), K=1,J)
-C/
- COUNT = 1
- DO 60 K=1,NCOL
-C/R
-C LAST(1,K) = LINE(1,K)
-C 60 LAST(2,K) = LINE(2,K)
-C/C
- 60 LAST(K) = LINE(K)
-C/
- 70 ILAST = ILINE
- J = 0
- 80 I = I+1
- GO TO 20
- 90 RETURN
- END
diff --git a/CEP/PyBDSM/src/port3/a9rntd.f b/CEP/PyBDSM/src/port3/a9rntd.f
deleted file mode 100644
index 2cffb821afd2baaffccefc5fc86dd581b1ad5b81..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/a9rntd.f
+++ /dev/null
@@ -1,185 +0,0 @@
- SUBROUTINE A9RNTD(A, NITEMS, IOUT, MCOL, W, D)
-C
-C THIS IS THE DOCUMENTED ROUTINE APRNTD, BUT WITHOUT THE CALLS TO
-C SETERR - BECAUSE IT IS CALLED BY SETERR.
-C
-C THIS SUBROUTINE PRINTS OUT NITEMS FROM THE DOUBLE PRECISION ARRAY,
-C A, ON OUTPUT UNIT IOUT, USING A MAXIMUM OF MCOL PRINT SPACES.
-C THE OUTPUT FORMAT IS 1PDW.D.
-C THE PROGRAM PUTS AS MANY VALUES ON A LINE AS POSSIBLE.
-C W SHOULD BE INPUT AS THE ACTUAL WIDTH +1 FOR A SPACE BETWEEN VALUES.
-C
-C DUPLICATE LINES ARE NOT ALL PRINTED, BUT ARE INDICATED BY ASTERISKS.
-C
-C WRITTEN BY DAN WARNER, REVISED BY PHYL FOX, OCTOBER 21, 1982.
-C
-C THE LINE WIDTH IS COMPUTED AS THE MINIMUM OF THE INPUT MCOL AND 160.
-C IF THE LINE WIDTH IS TO BE INCREASED ABOVE 160, THE BUFFERS LINE()
-C AND LAST(), WHICH THE VALUES TO BE PRINTED ON ONE LINE, MUST
-C BE DIMENSIONED ACCORDINGLY.
-C
-C INPUT PARAMETERS -
-C
-C A - THE START OF THE DOUBLE PRECISION ARRAY TO BE PRINTED
-C
-C NITEMS - THE NUMBER OF ITEMS TO BE PRINTED
-C
-C IOUT - THE OUTPUT UNIT FOR PRINTING
-C
-C MCOL - THE NUMBER OF SPACES ACROSS THE LINE
-C
-C W - THE WIDTH OF THE PRINTED VALUE (1PDW.D)
-C
-C D - THE NUMBER OF DIGITS AFTER THE DECIMAL POINT (1PDW.D)
-C
-C
-C ERROR STATES - NONE. LOWER LEVEL ROUTINE CALLED BY
-C SETERR, SO IT CANNOT CALL SETERR.
-C
- INTEGER NITEMS, IOUT, MCOL, W, D
- DOUBLE PRECISION A(NITEMS)
-C
- INTEGER MAX0, MIN0, WW, DD, EMIN, EMAX,
- 1 EXPENT, I1MACH, ICEIL, IABS, I10WID
-C/6S
-C INTEGER IFMT1(20), IFMT1C(20), IFMT2(18), IFMT2C(18), BLANK, STAR
-C EQUIVALENCE (IFMT1(1), IFMT1C(1)), (IFMT2(1), IFMT2C(1))
-C/7S
- CHARACTER*1 IFMT1(20), IFMT2(18), BLANK, STAR
- CHARACTER*20 IFMT1C
- CHARACTER*18 IFMT2C
- EQUIVALENCE (IFMT1(1), IFMT1C), (IFMT2(1), IFMT2C)
-C/
- INTEGER INDW, NCOL, COUNT, I, J, K, ILINE, ILAST
- LOGICAL DUP
- DOUBLE PRECISION LINE(18), LAST(18)
- REAL LOGETA
-C
-C/6S
-C DATA BLANK/1H /, STAR/1H*/, INDW/7/, EXPENT/0/
-C/7S
- DATA BLANK/' '/, STAR/'*'/, INDW/7/, EXPENT/0/
-C/
-C
-C IFMT1 IS FOR THE ASTERISK LINES- IFMT2 FOR THE DATA LINES
-C
-C/6S
-C DATA IFMT1( 1) /1H(/, IFMT2( 1) /1H(/
-C DATA IFMT1( 2) /1H1/, IFMT2( 2) /1H1/
-C DATA IFMT1( 3) /1HA/, IFMT2( 3) /1HA/
-C DATA IFMT1( 4) /1H1/, IFMT2( 4) /1H1/
-C DATA IFMT1( 5) /1H,/, IFMT2( 5) /1H,/
-C DATA IFMT1( 6) /1H5/, IFMT2( 6) /1HI/
-C DATA IFMT1( 7) /1HX/, IFMT2( 7) /1H7/
-C DATA IFMT1( 8) /1H,/, IFMT2( 8) /1H,/
-C DATA IFMT1( 9) /1H2/, IFMT2( 9) /1H1/
-C DATA IFMT1(10) /1HA/, IFMT2(10) /1HP/
-C DATA IFMT1(11) /1H1/, IFMT2(11) /1H /
-C DATA IFMT1(12) /1H,/, IFMT2(12) /1HD/
-C DATA IFMT1(13) /1H /, IFMT2(13) /1H /
-C DATA IFMT1(14) /1H /, IFMT2(14) /1H /
-C DATA IFMT1(15) /1HX/, IFMT2(15) /1H./
-C DATA IFMT1(16) /1H,/, IFMT2(16) /1H /
-C DATA IFMT1(17) /1H2/, IFMT2(17) /1H /
-C DATA IFMT1(18) /1HA/, IFMT2(18) /1H)/
-C DATA IFMT1(19) /1H1/
-C DATA IFMT1(20) /1H)/
-C/7S
- DATA IFMT1( 1) /'('/, IFMT2( 1) /'('/
- DATA IFMT1( 2) /'1'/, IFMT2( 2) /'1'/
- DATA IFMT1( 3) /'A'/, IFMT2( 3) /'A'/
- DATA IFMT1( 4) /'1'/, IFMT2( 4) /'1'/
- DATA IFMT1( 5) /','/, IFMT2( 5) /','/
- DATA IFMT1( 6) /'5'/, IFMT2( 6) /'I'/
- DATA IFMT1( 7) /'X'/, IFMT2( 7) /'7'/
- DATA IFMT1( 8) /','/, IFMT2( 8) /','/
- DATA IFMT1( 9) /'2'/, IFMT2( 9) /'1'/
- DATA IFMT1(10) /'A'/, IFMT2(10) /'P'/
- DATA IFMT1(11) /'1'/, IFMT2(11) /' '/
- DATA IFMT1(12) /','/, IFMT2(12) /'D'/
- DATA IFMT1(13) /' '/, IFMT2(13) /' '/
- DATA IFMT1(14) /' '/, IFMT2(14) /' '/
- DATA IFMT1(15) /'X'/, IFMT2(15) /'.'/
- DATA IFMT1(16) /','/, IFMT2(16) /' '/
- DATA IFMT1(17) /'2'/, IFMT2(17) /' '/
- DATA IFMT1(18) /'A'/, IFMT2(18) /')'/
- DATA IFMT1(19) /'1'/
- DATA IFMT1(20) /')'/
-C/
-C
-C EXPENT IS USED AS A FIRST-TIME SWITCH TO SIGNAL IF THE
-C MACHINE-VALUE CONSTANTS HAVE BEEN COMPUTED.
-C
- IF (EXPENT .GT. 0) GO TO 10
- LOGETA = ALOG10(FLOAT(I1MACH(10)))
- EMIN = ICEIL(LOGETA*FLOAT(IABS(I1MACH(15)-1)))
- EMAX = ICEIL(LOGETA*FLOAT(I1MACH(16)))
- EXPENT = I10WID(MAX0(EMIN, EMAX))
-C
-C COMPUTE THE FORMATS.
-C
- 10 WW = MIN0(99, MAX0(W, 5+EXPENT))
- CALL S88FMT(2, WW, IFMT2(13))
- DD = MIN0(D, (WW-(5+EXPENT)))
- CALL S88FMT(2, DD, IFMT2(16))
-C
-C NCOL IS THE NUMBER OF VALUES TO BE PRINTED ACROSS THE LINE.
-C
- NCOL = MAX0(1, MIN0(9, (MIN0(MCOL,160)-INDW)/WW))
- CALL S88FMT(1, NCOL, IFMT2(11))
- WW = WW-2
-C THE ASTERISKS ARE POSITIONED RIGHT-ADJUSTED IN THE W-WIDTH SPACE.
- CALL S88FMT(2, WW, IFMT1(13))
-C
-C I COUNTS THE NUMBER OF ITEMS TO BE PRINTED,
-C J COUNTS THE NUMBER ON A GIVEN LINE,
-C COUNT COUNTS THE NUMBER OF DUPLICATE LINES.
-C
- I = 1
- J = 0
- COUNT = 0
-C
-C THE LOGICAL OF THE FOLLOWING IS ROUGHLY THIS -
-C IF THERE ARE STILL MORE ITEMS TO BE PRINTED, A LINE-
-C FULL IS PUT INTO THE ARRAY, LINE.
-C WHENEVER A LINE IS PRINTED OUT, IT IS ALSO STUFFED INTO
-C THE ARRAY, LAST, TO COMPARE WITH THE NEXT ONE COMING IN
-C TO CHECK FOR REPEAT OR DUPLICATED LINES.
-C ALSO WHENEVER A LINE IS WRITTEN OUT, THE DUPLICATION
-C COUNTER, COUNT, IS SET TO ONE.
-C THE ONLY MILDLY TRICKY PART IS TO NOTE THAT COUNT HAS TO
-C GO TO 3 BEFORE A LINE OF ASTERISKS IS PRINTED BECAUSE
-C OF COURSE NO SUCH LINE IS PRINTED FOR JUST A PAIR OF
-C DUPLICATE LINES.
-C
-C ILINE IS PRINTED AS THE INDEX OF THE FIRST ARRAY ELEMENT
-C IN A LINE.
-C
- 20 IF (I .GT. NITEMS) GO TO 90
- J = J+1
- LINE(J) = A(I)
- IF (J .EQ. 1) ILINE = I
- IF (J .LT. NCOL .AND. I .LT. NITEMS) GO TO 80
- IF (COUNT .EQ. 0) GO TO 50
- DUP = .TRUE.
- DO 30 K=1,NCOL
- 30 IF (LAST(K) .NE. LINE(K)) DUP = .FALSE.
- IF (I .EQ. NITEMS .AND. J .LT. NCOL) DUP = .FALSE.
- IF (.NOT. DUP .AND. COUNT .EQ. 1) GO TO 50
- IF (.NOT. DUP) GO TO 40
- COUNT = COUNT+1
- IF (COUNT .EQ. 3) WRITE(IOUT, IFMT1C) BLANK,
- 1 STAR, STAR, STAR, STAR
- IF (I .EQ. NITEMS) GO TO 50
- GO TO 70
- 40 WRITE(IOUT, IFMT2C) BLANK, ILAST, (LAST(K), K=1,NCOL)
- 50 WRITE(IOUT, IFMT2C) BLANK, ILINE, (LINE(K), K=1,J)
- COUNT = 1
- DO 60 K=1,NCOL
- 60 LAST(K) = LINE(K)
- 70 ILAST = ILINE
- J = 0
- 80 I = I+1
- GO TO 20
- 90 RETURN
- END
diff --git a/CEP/PyBDSM/src/port3/a9rnti.f b/CEP/PyBDSM/src/port3/a9rnti.f
deleted file mode 100644
index bbec54a521ca1110896c082085d0c6b88c0d4c8f..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/a9rnti.f
+++ /dev/null
@@ -1,170 +0,0 @@
- SUBROUTINE A9RNTI(A, NITEMS, IOUT, MCOL, W)
-C
-C THIS IS THE DOCUMENTED ROUTINE APRNTI, BUT WITHOUT THE CALLS TO
-C SETERR - BECAUSE IT IS CALLED BY SETERR.
-C
-C THIS SUBROUTINE PRINTS OUT NITEMS FROM THE INTEGER ARRAY, A, ON
-C OUTPUT UNIT IOUT, USING A MAXIMUM OF MCOL PRINT SPACES.
-C THE OUTPUT FORMAT IS IW.
-C THE PROGRAM PUTS AS MANY VALUES ON A LINE AS POSSIBLE.
-C W SHOULD BE INPUT AS THE ACTUAL WIDTH +1 FOR A SPACE BETWEEN VALUES.
-C
-C DUPLICATE LINES ARE NOT ALL PRINTED, BUT ARE INDICATED BY ASTERISKS.
-C
-C WRITTEN BY DAN WARNER, REVISED BY PHYL FOX, OCTOBER 21, 1982.
-C
-C THE LINE WIDTH IS COMPUTED AS THE MINIMUM OF THE INPUT MCOL AND 160.
-C IF THE LINE WIDTH IS TO BE INCREASED ABOVE 160, THE BUFFERS LINE()
-C AND LAST(), WHICH THE VALUES TO BE PRINTED ON ONE LINE, MUST
-C BE DIMENSIONED ACCORDINGLY.
-C
-C INPUT PARAMETERS -
-C
-C A - THE START OF THE INTEGER ARRAY TO BE PRINTED
-C
-C NITEMS - THE NUMBER OF ITEMS TO BE PRINTED
-C
-C IOUT - THE OUTPUT UNIT FOR PRINTING
-C
-C MCOL - THE NUMBER OF SPACES ACROSS THE LINE
-C
-C W - THE WIDTH OF THE PRINTED VALUE (IW)
-C
-C
-C ERROR STATES - NONE. LOWER LEVEL ROUTINE CALLED BY
-C SETERR, SO IT CANNOT CALL SETERR.
-C
-C
- INTEGER NITEMS, IOUT, MCOL, W
- INTEGER A(NITEMS)
-C
- INTEGER MAX0, MIN0, WW
-C/6S
-C INTEGER IFMT1(20), IFMT1C(20), IFMT2(14), IFMT2C(14), BLANK, STAR
-C EQUIVALENCE (IFMT1(1), IFMT1C(1)), (IFMT2(1), IFMT2C(1))
-C/7S
- CHARACTER*1 IFMT1(20), IFMT2(14), BLANK, STAR
- CHARACTER*20 IFMT1C
- CHARACTER*14 IFMT2C
- EQUIVALENCE (IFMT1(1), IFMT1C), (IFMT2(1), IFMT2C)
-C/
- INTEGER INDW, NCOL, COUNT, I, J, K, ILINE, ILAST
- LOGICAL DUP
- INTEGER LINE(40), LAST(40)
-C
-C/6S
-C DATA BLANK/1H /, STAR/1H*/, INDW/7/
-C/7S
- DATA BLANK/' '/, STAR/'*'/, INDW/7/
-C/
-C
-C IFMT1 IS FOR THE ASTERISK LINES- IFMT2 FOR THE DATA LINES
-C
-C/6S
-C DATA IFMT1( 1) /1H(/, IFMT2( 1) /1H(/
-C DATA IFMT1( 2) /1H1/, IFMT2( 2) /1H1/
-C DATA IFMT1( 3) /1HA/, IFMT2( 3) /1HA/
-C DATA IFMT1( 4) /1H1/, IFMT2( 4) /1H1/
-C DATA IFMT1( 5) /1H,/, IFMT2( 5) /1H,/
-C DATA IFMT1( 6) /1H5/, IFMT2( 6) /1HI/
-C DATA IFMT1( 7) /1HX/, IFMT2( 7) /1H7/
-C DATA IFMT1( 8) /1H,/, IFMT2( 8) /1H,/
-C DATA IFMT1( 9) /1H2/, IFMT2( 9) /1H /
-C DATA IFMT1(10) /1HA/, IFMT2(10) /1H /
-C DATA IFMT1(11) /1H1/, IFMT2(11) /1HI/
-C DATA IFMT1(12) /1H,/, IFMT2(12) /1H /
-C DATA IFMT1(13) /1H /, IFMT2(13) /1H /
-C DATA IFMT1(14) /1H /, IFMT2(14) /1H)/
-C DATA IFMT1(15) /1HX/
-C DATA IFMT1(16) /1H,/
-C DATA IFMT1(17) /1H2/
-C DATA IFMT1(18) /1HA/
-C DATA IFMT1(19) /1H1/
-C DATA IFMT1(20) /1H)/
-C/7S
- DATA IFMT1( 1) /'('/, IFMT2( 1) /'('/
- DATA IFMT1( 2) /'1'/, IFMT2( 2) /'1'/
- DATA IFMT1( 3) /'A'/, IFMT2( 3) /'A'/
- DATA IFMT1( 4) /'1'/, IFMT2( 4) /'1'/
- DATA IFMT1( 5) /','/, IFMT2( 5) /','/
- DATA IFMT1( 6) /'5'/, IFMT2( 6) /'I'/
- DATA IFMT1( 7) /'X'/, IFMT2( 7) /'7'/
- DATA IFMT1( 8) /','/, IFMT2( 8) /','/
- DATA IFMT1( 9) /'2'/, IFMT2( 9) /' '/
- DATA IFMT1(10) /'A'/, IFMT2(10) /' '/
- DATA IFMT1(11) /'1'/, IFMT2(11) /'I'/
- DATA IFMT1(12) /','/, IFMT2(12) /' '/
- DATA IFMT1(13) /' '/, IFMT2(13) /' '/
- DATA IFMT1(14) /' '/, IFMT2(14) /')'/
- DATA IFMT1(15) /'X'/
- DATA IFMT1(16) /','/
- DATA IFMT1(17) /'2'/
- DATA IFMT1(18) /'A'/
- DATA IFMT1(19) /'1'/
- DATA IFMT1(20) /')'/
-C/
-C
-C COMPUTE THE FORMATS.
-C
- WW = MIN0(99, MAX0(W, 2))
- CALL S88FMT(2, WW, IFMT2(12))
- NCOL = MAX0(1, MIN0(99, (MIN0(MCOL,160) - INDW)/WW))
- CALL S88FMT(2, NCOL, IFMT2(9))
- WW = WW-2
- CALL S88FMT(2, WW, IFMT1(13))
-C
-C THE ASTERISKS ARE POSITIONED RIGHT-ADJUSTED IN THE W-WIDTH SPACE.
- CALL S88FMT(2, WW, IFMT1(13))
-C
-C I COUNTS THE NUMBER OF ITEMS TO BE PRINTED,
-C J COUNTS THE NUMBER ON A GIVEN LINE,
-C COUNT COUNTS THE NUMBER OF DUPLICATE LINES.
-C
- 10 I = 1
- J = 0
- COUNT = 0
-C
-C THE LOGICAL OF THE FOLLOWING IS ROUGHLY THIS -
-C IF THERE ARE STILL MORE ITEMS TO BE PRINTED, A LINE-
-C FULL IS PUT INTO THE ARRAY, LINE.
-C WHENEVER A LINE IS PRINTED OUT, IT IS ALSO STUFFED INTO
-C THE ARRAY, LAST, TO COMPARE WITH THE NEXT ONE COMING IN
-C TO CHECK FOR REPEAT OR DUPLICATED LINES.
-C ALSO WHENEVER A LINE IS WRITTEN OUT, THE DUPLICATION
-C COUNTER, COUNT, IS SET TO ONE.
-C THE ONLY MILDLY TRICKY PART IS TO NOTE THAT COUNT HAS TO
-C GO TO 3 BEFORE A LINE OF ASTERISKS IS PRINTED BECAUSE
-C OF COURSE NO SUCH LINE IS PRINTED FOR JUST A PAIR OF
-C DUPLICATE LINES.
-C
-C ILINE IS PRINTED AS THE INDEX OF THE FIRST ARRAY ELEMENT
-C IN A LINE.
-C
- 20 IF (I .GT. NITEMS) GO TO 90
- J = J+1
- LINE(J) = A(I)
- IF (J .EQ. 1) ILINE = I
- IF (J .LT. NCOL .AND. I .LT. NITEMS) GO TO 80
- IF (COUNT .EQ. 0) GO TO 50
- DUP = .TRUE.
- DO 30 K=1,NCOL
- 30 IF (LAST(K) .NE. LINE(K)) DUP = .FALSE.
- IF (I .EQ. NITEMS .AND. J .LT. NCOL) DUP = .FALSE.
- IF (.NOT. DUP .AND. COUNT .EQ. 1) GO TO 50
- IF (.NOT. DUP) GO TO 40
- COUNT = COUNT+1
- IF (COUNT .EQ. 3) WRITE(IOUT, IFMT1C) BLANK,
- 1 STAR, STAR, STAR, STAR
- IF (I .EQ. NITEMS) GO TO 50
- GO TO 70
- 40 WRITE(IOUT, IFMT2C) BLANK, ILAST, (LAST(K), K=1,NCOL)
- 50 WRITE(IOUT, IFMT2C) BLANK, ILINE, (LINE(K), K=1,J)
- COUNT = 1
- DO 60 K=1,NCOL
- 60 LAST(K) = LINE(K)
- 70 ILAST = ILINE
- J = 0
- 80 I = I+1
- GO TO 20
- 90 RETURN
- END
diff --git a/CEP/PyBDSM/src/port3/a9rntl.f b/CEP/PyBDSM/src/port3/a9rntl.f
deleted file mode 100644
index 2487a5cc1589a0edde781ed6e52ba95422b7d362..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/a9rntl.f
+++ /dev/null
@@ -1,166 +0,0 @@
- SUBROUTINE A9RNTL(A, NITEMS, IOUT, MCOL)
-C
-C THIS IS THE DOCUMENTED ROUTINE APRNTL, BUT WITHOUT THE CALLS TO
-C SETERR - BECAUSE IT IS CALLED BY SETERR.
-C
-C THIS SUBROUTINE PRINTS OUT NITEMS FROM THE LOGICAL ARRAY, A, ON
-C OUTPUT UNIT IOUT, USING A MAXIMUM OF MCOL PRINT SPACES.
-C THE T OR F VALUES ARE PRINTED RIGHT-ADJUSTED IN A FIELD OF WIDTH 4.
-C
-C DUPLICATE LINES ARE NOT ALL PRINTED, BUT ARE INDICATED BY ASTERISKS.
-C
-C WRITTEN BY DAN WARNER, REVISED BY PHYL FOX, OCTOBER 21, 1982.
-C
-C THE LINE WIDTH IS COMPUTED AS THE MINIMUM OF THE INPUT MCOL AND 160.
-C IF THE LINE WIDTH IS TO BE INCREASED ABOVE 160, THE BUFFERS LINE()
-C AND LAST(), WHICH THE VALUES TO BE PRINTED ON ONE LINE, MUST
-C BE DIMENSIONED ACCORDINGLY.
-C
-C INPUT PARAMETERS -
-C
-C A - THE START OF THE LOGICAL ARRAY TO BE PRINTED
-C
-C NITEMS - THE NUMBER OF ITEMS TO BE PRINTED
-C
-C IOUT - THE OUTPUT UNIT FOR PRINTING
-C
-C MCOL - THE NUMBER OF SPACES ACROSS THE LINE
-C
-C
-C ERROR STATES - NONE. LOWER LEVEL ROUTINE CALLED BY
-C SETERR, SO IT CANNOT CALL SETERR.
-C
-C
- INTEGER NITEMS, IOUT, MCOL
- LOGICAL A(NITEMS)
-C
- INTEGER MAX0, MIN0
-C/6S
-C INTEGER IFMT1(20), IFMT1C(20), IFMT2(19), IFMT2C(19), BLANK,
-C 1 STAR, TCHAR, FCHAR
-C INTEGER LINE(40), LAST(40)
-C EQUIVALENCE (IFMT1(1), IFMT1C(1)), (IFMT2(1), IFMT2C(1))
-C/7S
- CHARACTER*1 IFMT1(20), IFMT2(19), BLANK, STAR, TCHAR, FCHAR
- CHARACTER*20 IFMT1C
- CHARACTER*19 IFMT2C
- EQUIVALENCE (IFMT1(1), IFMT1C), (IFMT2(1), IFMT2C)
- CHARACTER*1 LINE(40), LAST(40)
-C/
- INTEGER INDW, NCOL, COUNT, I, J, K, ILINE, ILAST
- LOGICAL DUP
-C
-C/6S
-C DATA BLANK/1H /, STAR/1H*/, TCHAR/1HT/, FCHAR/1HF/, INDW/7/
-C/7S
- DATA BLANK/' '/, STAR/'*'/, TCHAR/'T'/, FCHAR/'F'/, INDW/7/
-C/
-C
-C
-C IFMT1 IS FOR THE ASTERISK LINES- IFMT2 FOR THE DATA LINES
-C
-C/6S
-C DATA IFMT1( 1) /1H(/, IFMT2( 1) /1H(/
-C DATA IFMT1( 2) /1H1/, IFMT2( 2) /1H1/
-C DATA IFMT1( 3) /1HA/, IFMT2( 3) /1HA/
-C DATA IFMT1( 4) /1H1/, IFMT2( 4) /1H1/
-C DATA IFMT1( 5) /1H,/, IFMT2( 5) /1H,/
-C DATA IFMT1( 6) /1H5/, IFMT2( 6) /1HI/
-C DATA IFMT1( 7) /1HX/, IFMT2( 7) /1H7/
-C DATA IFMT1( 8) /1H,/, IFMT2( 8) /1H,/
-C DATA IFMT1( 9) /1H2/, IFMT2( 9) /1H /
-C DATA IFMT1(10) /1HA/, IFMT2(10) /1H /
-C DATA IFMT1(11) /1H1/, IFMT2(11) /1H(/
-C DATA IFMT1(12) /1H,/, IFMT2(12) /1H3/
-C DATA IFMT1(13) /1H /, IFMT2(13) /1HX/
-C DATA IFMT1(14) /1H2/, IFMT2(14) /1H,/
-C DATA IFMT1(15) /1HX/, IFMT2(15) /1H1/
-C DATA IFMT1(16) /1H,/, IFMT2(16) /1HA/
-C DATA IFMT1(17) /1H2/, IFMT2(17) /1H1/
-C DATA IFMT1(18) /1HA/, IFMT2(18) /1H)/
-C DATA IFMT1(19) /1H1/, IFMT2(19) /1H)/
-C DATA IFMT1(20) /1H)/
-C/7S
- DATA IFMT1( 1) /'('/, IFMT2( 1) /'('/
- DATA IFMT1( 2) /'1'/, IFMT2( 2) /'1'/
- DATA IFMT1( 3) /'A'/, IFMT2( 3) /'A'/
- DATA IFMT1( 4) /'1'/, IFMT2( 4) /'1'/
- DATA IFMT1( 5) /','/, IFMT2( 5) /','/
- DATA IFMT1( 6) /'5'/, IFMT2( 6) /'I'/
- DATA IFMT1( 7) /'X'/, IFMT2( 7) /'7'/
- DATA IFMT1( 8) /','/, IFMT2( 8) /','/
- DATA IFMT1( 9) /'2'/, IFMT2( 9) /' '/
- DATA IFMT1(10) /'A'/, IFMT2(10) /' '/
- DATA IFMT1(11) /'1'/, IFMT2(11) /'('/
- DATA IFMT1(12) /','/, IFMT2(12) /'3'/
- DATA IFMT1(13) /' '/, IFMT2(13) /'X'/
- DATA IFMT1(14) /'2'/, IFMT2(14) /','/
- DATA IFMT1(15) /'X'/, IFMT2(15) /'1'/
- DATA IFMT1(16) /','/, IFMT2(16) /'A'/
- DATA IFMT1(17) /'2'/, IFMT2(17) /'1'/
- DATA IFMT1(18) /'A'/, IFMT2(18) /')'/
- DATA IFMT1(19) /'1'/, IFMT2(19) /')'/
- DATA IFMT1(20) /')'/
-C/
-C
-C
-C COMPUTE THE NUMBER OF FIELDS OF 4 ACROSS A LINE.
-C
- NCOL = MAX0(1, MIN0(99, (MIN0(MCOL,160)-INDW)/4))
-C
-C THE ASTERISKS ARE POSITIONED RIGHT-ADJUSTED IN THE 4-CHARACTER SPACE.
- CALL S88FMT(2, NCOL, IFMT2(9))
-C
-C I COUNTS THE NUMBER OF ITEMS TO BE PRINTED,
-C J COUNTS THE NUMBER ON A GIVEN LINE,
-C COUNT COUNTS THE NUMBER OF DUPLICATE LINES.
-C
- 10 I = 1
- J = 0
- COUNT = 0
-C
-C THE LOGICAL OF THE FOLLOWING IS ROUGHLY THIS -
-C IF THERE ARE STILL MORE ITEMS TO BE PRINTED, A LINE-
-C FULL IS PUT INTO THE ARRAY, LINE.
-C WHENEVER A LINE IS PRINTED OUT, IT IS ALSO STUFFED INTO
-C THE ARRAY, LAST, TO COMPARE WITH THE NEXT ONE COMING IN
-C TO CHECK FOR REPEAT OR DUPLICATED LINES.
-C ALSO WHENEVER A LINE IS WRITTEN OUT, THE DUPLICATION
-C COUNTER, COUNT, IS SET TO ONE.
-C THE ONLY MILDLY TRICKY PART IS TO NOTE THAT COUNT HAS TO
-C GO TO 3 BEFORE A LINE OF ASTERISKS IS PRINTED BECAUSE
-C OF COURSE NO SUCH LINE IS PRINTED FOR JUST A PAIR OF
-C DUPLICATE LINES.
-C
-C ILINE IS PRINTED AS THE INDEX OF THE FIRST ARRAY ELEMENT
-C IN A LINE.
-C
- 20 IF (I .GT. NITEMS) GO TO 90
- J = J+1
- LINE(J) = FCHAR
- IF ( A(I) ) LINE(J) = TCHAR
- IF (J .EQ. 1) ILINE = I
- IF (J .LT. NCOL .AND. I .LT. NITEMS) GO TO 80
- IF (COUNT .EQ. 0) GO TO 50
- DUP = .TRUE.
- DO 30 K=1,NCOL
- 30 IF (LAST(K) .NE. LINE(K)) DUP = .FALSE.
- IF (I .EQ. NITEMS .AND. J .LT. NCOL) DUP = .FALSE.
- IF (.NOT. DUP .AND. COUNT .EQ. 1) GO TO 50
- IF (.NOT. DUP) GO TO 40
- COUNT = COUNT+1
- IF (COUNT .EQ. 3) WRITE(IOUT, IFMT1C) BLANK,
- 1 STAR, STAR, STAR, STAR
- IF (I .EQ. NITEMS) GO TO 50
- GO TO 70
- 40 WRITE(IOUT, IFMT2C) BLANK, ILAST, (LAST(K), K=1,NCOL)
- 50 WRITE(IOUT, IFMT2C) BLANK, ILINE, (LINE(K), K=1,J)
- COUNT = 1
- DO 60 K=1,NCOL
- 60 LAST(K) = LINE(K)
- 70 ILAST = ILINE
- J = 0
- 80 I = I+1
- GO TO 20
- 90 RETURN
- END
diff --git a/CEP/PyBDSM/src/port3/a9rntr.f b/CEP/PyBDSM/src/port3/a9rntr.f
deleted file mode 100644
index a47b28bb49a71f3459d3b0f174d9e259b5177aeb..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/a9rntr.f
+++ /dev/null
@@ -1,187 +0,0 @@
- SUBROUTINE A9RNTR(A, NITEMS, IOUT, MCOL, W, D)
-C
-C THIS IS THE DOCUMENTED ROUTINE APRNTR, BUT WITHOUT THE CALLS TO
-C SETERR - BECAUSE IT IS CALLED BY SETERR.
-C
-C THIS SUBROUTINE PRINTS OUT NITEMS FROM THE REAL ARRAY, A, ON
-C OUTPUT UNIT IOUT, USING A MAXIMUM OF MCOL PRINT SPACES.
-C THE OUTPUT FORMAT IS 1PEW.D.
-C THE PROGRAM PUTS AS MANY VALUES ON A LINE AS POSSIBLE.
-C W SHOULD BE INPUT AS THE ACTUAL WIDTH +1 FOR A SPACE BETWEEN VALUES.
-C
-C DUPLICATE LINES ARE NOT ALL PRINTED, BUT ARE INDICATED BY ASTERISKS.
-C
-C WRITTEN BY DAN WARNER, REVISED BY PHYL FOX, OCTOBER 21, 1982.
-C
-C THE LINE WIDTH IS COMPUTED AS THE MINIMUM OF THE INPUT MCOL AND 160.
-C IF THE LINE WIDTH IS TO BE INCREASED ABOVE 160, THE BUFFERS LINE()
-C AND LAST(), WHICH THE VALUES TO BE PRINTED ON ONE LINE, MUST
-C BE DIMENSIONED ACCORDINGLY.
-C
-C INPUT PARAMETERS -
-C
-C A - THE START OF THE REAL ARRAY TO BE PRINTED
-C
-C NITEMS - THE NUMBER OF ITEMS TO BE PRINTED
-C
-C IOUT - THE OUTPUT UNIT FOR PRINTING
-C
-C MCOL - THE NUMBER OF SPACES ACROSS THE LINE
-C
-C W - THE WIDTH OF THE PRINTED VALUE (1PEW.D)
-C
-C D - THE NUMBER OF DIGITS AFTER THE DECIMAL POINT (1PEW.D)
-C
-C
-C ERROR STATES - NONE. LOWER LEVEL ROUTINE CALLED BY
-C SETERR, SO IT CANNOT CALL SETERR.
-C
-C
- INTEGER NITEMS, IOUT, MCOL, W, D
- REAL A(NITEMS)
-C
- INTEGER MAX0, MIN0, WW, DD, EMIN, EMAX,
- 1 EXPENT, I1MACH, ICEIL, IABS, I10WID
-C/6S
-C INTEGER IFMT1(20), IFMT1C(20), IFMT2(18), IFMT2C(18), BLANK, STAR
-C EQUIVALENCE (IFMT1(1), IFMT1C(1)), (IFMT2(1), IFMT2C(1))
-C/7S
- CHARACTER*1 IFMT1(20), IFMT2(18), BLANK, STAR
- CHARACTER*20 IFMT1C
- CHARACTER*18 IFMT2C
- EQUIVALENCE (IFMT1(1), IFMT1C), (IFMT2(1), IFMT2C)
-C/
- INTEGER INDW, NCOL, COUNT, I, J, K, ILINE, ILAST
- LOGICAL DUP
- REAL LINE(18), LAST(18), LOGETA
-C
-C/6S
-C DATA BLANK/1H /, STAR/1H*/, INDW/7/, EXPENT/0/
-C/7S
- DATA BLANK/' '/, STAR/'*'/, INDW/7/, EXPENT/0/
-C/
-C
-C IFMT1 IS FOR THE ASTERISK LINES- IFMT2 FOR THE DATA LINES
-C
-C/6S
-C DATA IFMT1( 1) /1H(/, IFMT2( 1) /1H(/
-C DATA IFMT1( 2) /1H1/, IFMT2( 2) /1H1/
-C DATA IFMT1( 3) /1HA/, IFMT2( 3) /1HA/
-C DATA IFMT1( 4) /1H1/, IFMT2( 4) /1H1/
-C DATA IFMT1( 5) /1H,/, IFMT2( 5) /1H,/
-C DATA IFMT1( 6) /1H5/, IFMT2( 6) /1HI/
-C DATA IFMT1( 7) /1HX/, IFMT2( 7) /1H7/
-C DATA IFMT1( 8) /1H,/, IFMT2( 8) /1H,/
-C DATA IFMT1( 9) /1H2/, IFMT2( 9) /1H1/
-C DATA IFMT1(10) /1HA/, IFMT2(10) /1HP/
-C DATA IFMT1(11) /1H1/, IFMT2(11) /1H /
-C DATA IFMT1(12) /1H,/, IFMT2(12) /1HE/
-C DATA IFMT1(13) /1H /, IFMT2(13) /1H /
-C DATA IFMT1(14) /1H /, IFMT2(14) /1H /
-C DATA IFMT1(15) /1HX/, IFMT2(15) /1H./
-C DATA IFMT1(16) /1H,/, IFMT2(16) /1H /
-C DATA IFMT1(17) /1H2/, IFMT2(17) /1H /
-C DATA IFMT1(18) /1HA/, IFMT2(18) /1H)/
-C DATA IFMT1(19) /1H1/
-C DATA IFMT1(20) /1H)/
-C/7S
- DATA IFMT1( 1) /'('/, IFMT2( 1) /'('/
- DATA IFMT1( 2) /'1'/, IFMT2( 2) /'1'/
- DATA IFMT1( 3) /'A'/, IFMT2( 3) /'A'/
- DATA IFMT1( 4) /'1'/, IFMT2( 4) /'1'/
- DATA IFMT1( 5) /','/, IFMT2( 5) /','/
- DATA IFMT1( 6) /'5'/, IFMT2( 6) /'I'/
- DATA IFMT1( 7) /'X'/, IFMT2( 7) /'7'/
- DATA IFMT1( 8) /','/, IFMT2( 8) /','/
- DATA IFMT1( 9) /'2'/, IFMT2( 9) /'1'/
- DATA IFMT1(10) /'A'/, IFMT2(10) /'P'/
- DATA IFMT1(11) /'1'/, IFMT2(11) /' '/
- DATA IFMT1(12) /','/, IFMT2(12) /'E'/
- DATA IFMT1(13) /' '/, IFMT2(13) /' '/
- DATA IFMT1(14) /' '/, IFMT2(14) /' '/
- DATA IFMT1(15) /'X'/, IFMT2(15) /'.'/
- DATA IFMT1(16) /','/, IFMT2(16) /' '/
- DATA IFMT1(17) /'2'/, IFMT2(17) /' '/
- DATA IFMT1(18) /'A'/, IFMT2(18) /')'/
- DATA IFMT1(19) /'1'/
- DATA IFMT1(20) /')'/
-C/
-C
-C
-C EXPENT IS USED AS A FIRST-TIME SWITCH TO SIGNAL IF THE
-C MACHINE-VALUE CONSTANTS HAVE BEEN COMPUTED.
-C
- IF (EXPENT .GT. 0) GO TO 10
- LOGETA = ALOG10(FLOAT(I1MACH(10)))
- EMIN = ICEIL(LOGETA*FLOAT(IABS(I1MACH(12)-1)))
- EMAX = ICEIL(LOGETA*FLOAT(I1MACH(13)))
- EXPENT = I10WID(MAX0(EMIN, EMAX))
-C
-C COMPUTE THE FORMATS.
-C
- 10 WW = MIN0(99, MAX0(W, 5+EXPENT))
- CALL S88FMT(2, WW, IFMT2(13))
- DD = MIN0(D, (WW-(5+EXPENT)))
- CALL S88FMT(2, DD, IFMT2(16))
-C
-C NCOL IS THE NUMBER OF VALUES TO BE PRINTED ACROSS THE LINE.
-C
- NCOL = MAX0(1, MIN0(9, (MIN0(MCOL,160)-INDW)/WW))
- CALL S88FMT(1, NCOL, IFMT2(11))
- WW = WW-2
-C
-C THE ASTERISKS ARE POSITIONED RIGHT-ADJUSTED IN THE W-WIDTH SPACE.
- CALL S88FMT(2, WW, IFMT1(13))
-C
-C I COUNTS THE NUMBER OF ITEMS TO BE PRINTED,
-C J COUNTS THE NUMBER ON A GIVEN LINE,
-C COUNT COUNTS THE NUMBER OF DUPLICATE LINES.
-C
- I = 1
- J = 0
- COUNT = 0
-C
-C THE LOGICAL OF THE FOLLOWING IS ROUGHLY THIS -
-C IF THERE ARE STILL MORE ITEMS TO BE PRINTED, A LINE-
-C FULL IS PUT INTO THE ARRAY, LINE.
-C WHENEVER A LINE IS PRINTED OUT, IT IS ALSO STUFFED INTO
-C THE ARRAY, LAST, TO COMPARE WITH THE NEXT ONE COMING IN
-C TO CHECK FOR REPEAT OR DUPLICATED LINES.
-C ALSO WHENEVER A LINE IS WRITTEN OUT, THE DUPLICATION
-C COUNTER, COUNT, IS SET TO ONE.
-C THE ONLY MILDLY TRICKY PART IS TO NOTE THAT COUNT HAS TO
-C GO TO 3 BEFORE A LINE OF ASTERISKS IS PRINTED BECAUSE
-C OF COURSE NO SUCH LINE IS PRINTED FOR JUST A PAIR OF
-C DUPLICATE LINES.
-C
-C ILINE IS PRINTED AS THE INDEX OF THE FIRST ARRAY ELEMENT
-C IN A LINE.
-C
- 20 IF (I .GT. NITEMS) GO TO 90
- J = J+1
- LINE(J) = A(I)
- IF (J .EQ. 1) ILINE = I
- IF (J .LT. NCOL .AND. I .LT. NITEMS) GO TO 80
- IF (COUNT .EQ. 0) GO TO 50
- DUP = .TRUE.
- DO 30 K=1,NCOL
- 30 IF (LAST(K) .NE. LINE(K)) DUP = .FALSE.
- IF (I .EQ. NITEMS .AND. J .LT. NCOL) DUP = .FALSE.
- IF (.NOT. DUP .AND. COUNT .EQ. 1) GO TO 50
- IF (.NOT. DUP) GO TO 40
- COUNT = COUNT+1
- IF (COUNT .EQ. 3) WRITE(IOUT, IFMT1C) BLANK,
- 1 STAR, STAR, STAR, STAR
- IF (I .EQ. NITEMS) GO TO 50
- GO TO 70
- 40 WRITE(IOUT, IFMT2C) BLANK, ILAST, (LAST(K), K=1,NCOL)
- 50 WRITE(IOUT, IFMT2C) BLANK, ILINE, (LINE(K), K=1,J)
- COUNT = 1
- DO 60 K=1,NCOL
- 60 LAST(K) = LINE(K)
- 70 ILAST = ILINE
- J = 0
- 80 I = I+1
- GO TO 20
- 90 RETURN
- END
diff --git a/CEP/PyBDSM/src/port3/aprntc.f b/CEP/PyBDSM/src/port3/aprntc.f
deleted file mode 100644
index 3abb88f079a5360afded7dc0c886c44155f47e00..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/aprntc.f
+++ /dev/null
@@ -1,259 +0,0 @@
- SUBROUTINE APRNTC(A, NITEMS, IOUT, MCOL, W, D)
-C
-C THIS SUBROUTINE PRINTS OUT NITEMS FROM THE COMPLEX ARRAY, A, ON
-C OUTPUT UNIT IOUT, USING A MAXIMUM OF MCOL PRINT SPACES.
-C THE OUTPUT FORMAT IS 2(1PEW.D).
-C THE PROGRAM PUTS AS MANY VALUES ON A LINE AS POSSIBLE.
-C W SHOULD BE INPUT AS THE ACTUAL WIDTH +1 FOR A SPACE BETWEEN VALUES.
-C
-C DUPLICATE LINES ARE NOT ALL PRINTED, BUT ARE INDICATED BY ASTERISKS.
-C
-C WRITTEN BY DAN WARNER, REVISED BY PHYL FOX, OCTOBER 21, 1982.
-C
-C THE LINE WIDTH IS COMPUTED AS THE MINIMUM OF THE INPUT MCOL AND 160.
-C IF THE LINE WIDTH IS TO BE INCREASED ABOVE 160, THE BUFFERS LINE()
-C AND LAST(), WHICH THE VALUES TO BE PRINTED ON ONE LINE, MUST
-C BE DIMENSIONED ACCORDINGLY.
-C
-C INPUT PARAMETERS -
-C
-C A - THE START OF THE COMPLEX ARRAY TO BE PRINTED
-C
-C NITEMS - THE NUMBER OF ITEMS TO BE PRINTED
-C
-C IOUT - THE OUTPUT UNIT FOR PRINTING
-C
-C MCOL - THE NUMBER OF SPACES ACROSS THE LINE
-C
-C W - THE WIDTH OF THE PRINTED VALUE (1PEW.D)
-C
-C D - THE NUMBER OF DIGITS AFTER THE DECIMAL POINT (1PEW.D)
-C
-C
-C ERROR STATES -
-C
-C 1 - NITEMS .LE. ZERO
-C
-C 2 - W .GT. MCOL
-C
-C 3 - D .LT. ZERO
-C
-C 4 - W .LT. D+6
-C
- INTEGER NITEMS, IOUT, MCOL, W, D
-C/R
-C REAL A(2,NITEMS)
-C/C
- COMPLEX A(NITEMS)
-C/
-C
- INTEGER MAX0, MIN0, WW, DD, EMIN, EMAX,
- 1 EXPENT, I1MACH, ICEIL, IABS, I10WID
-C/6S
-C INTEGER IFMT1(20), IFMT2(18), BLANK, STAR
-C INTEGER IFMT1C(20), IFMT2C(18)
-C EQUIVALENCE (IFMT1(1),IFMT1C(1)), (IFMT2(1),IFMT2C(1))
-C/7S
- CHARACTER*1 IFMT1(20), IFMT2(18), BLANK, STAR
- CHARACTER*20 IFMT1C
- CHARACTER*18 IFMT2C
- EQUIVALENCE (IFMT1(1),IFMT1C), (IFMT2(1),IFMT2C)
-C/
- INTEGER INDW, NCOL, COUNT, I, J, K, ILINE, ILAST
- LOGICAL DUP
-C/R
-C REAL LINE(2,18), LAST(2,18)
-C/C
- COMPLEX LINE(18), LAST(18)
-C/
- REAL LOGETA
-C
-C/6S
-C DATA BLANK/1H /, STAR/1H*/, INDW/7/, EXPENT/0/
-C/7S
- DATA BLANK/' '/, STAR/'*'/, INDW/7/, EXPENT/0/
-C/
-C
-C IFMT1 IS FOR THE ASTERISK LINES, IFMT2 FOR THE DATA LINES
-C
-C/6S
-C DATA IFMT1( 1) /1H(/, IFMT2( 1) /1H(/
-C DATA IFMT1( 2) /1H1/, IFMT2( 2) /1H1/
-C DATA IFMT1( 3) /1HA/, IFMT2( 3) /1HA/
-C DATA IFMT1( 4) /1H1/, IFMT2( 4) /1H1/
-C DATA IFMT1( 5) /1H,/, IFMT2( 5) /1H,/
-C DATA IFMT1( 6) /1H5/, IFMT2( 6) /1HI/
-C DATA IFMT1( 7) /1HX/, IFMT2( 7) /1H7/
-C DATA IFMT1( 8) /1H,/, IFMT2( 8) /1H,/
-C DATA IFMT1( 9) /1H2/, IFMT2( 9) /1H1/
-C DATA IFMT1(10) /1HA/, IFMT2(10) /1HP/
-C DATA IFMT1(11) /1H1/, IFMT2(11) /1H /
-C DATA IFMT1(12) /1H,/, IFMT2(12) /1HE/
-C DATA IFMT1(13) /1H /, IFMT2(13) /1H /
-C DATA IFMT1(14) /1H /, IFMT2(14) /1H /
-C DATA IFMT1(15) /1HX/, IFMT2(15) /1H./
-C DATA IFMT1(16) /1H,/, IFMT2(16) /1H /
-C DATA IFMT1(17) /1H2/, IFMT2(17) /1H /
-C DATA IFMT1(18) /1HA/, IFMT2(18) /1H)/
-C DATA IFMT1(19) /1H1/
-C DATA IFMT1(20) /1H)/
-C/7S
- DATA IFMT1( 1) /'('/, IFMT2( 1) /'('/
- DATA IFMT1( 2) /'1'/, IFMT2( 2) /'1'/
- DATA IFMT1( 3) /'A'/, IFMT2( 3) /'A'/
- DATA IFMT1( 4) /'1'/, IFMT2( 4) /'1'/
- DATA IFMT1( 5) /','/, IFMT2( 5) /','/
- DATA IFMT1( 6) /'5'/, IFMT2( 6) /'I'/
- DATA IFMT1( 7) /'X'/, IFMT2( 7) /'7'/
- DATA IFMT1( 8) /','/, IFMT2( 8) /','/
- DATA IFMT1( 9) /'2'/, IFMT2( 9) /'1'/
- DATA IFMT1(10) /'A'/, IFMT2(10) /'P'/
- DATA IFMT1(11) /'1'/, IFMT2(11) /' '/
- DATA IFMT1(12) /','/, IFMT2(12) /'E'/
- DATA IFMT1(13) /' '/, IFMT2(13) /' '/
- DATA IFMT1(14) /' '/, IFMT2(14) /' '/
- DATA IFMT1(15) /'X'/, IFMT2(15) /'.'/
- DATA IFMT1(16) /','/, IFMT2(16) /' '/
- DATA IFMT1(17) /'2'/, IFMT2(17) /' '/
- DATA IFMT1(18) /'A'/, IFMT2(18) /')'/
- DATA IFMT1(19) /'1'/
- DATA IFMT1(20) /')'/
-C/
-C
-C/6S
-C IF (NITEMS .LE. 0) CALL
-C 1 SETERR(27H APRNTC - NITEMS .LE. ZERO, 27, 1, 2)
-C/7S
- IF (NITEMS .LE. 0) CALL
- 1 SETERR(' APRNTC - NITEMS .LE. ZERO', 27, 1, 2)
-C/
-C
-C/6S
-C IF (W .GT. MCOL) CALL
-C 1 SETERR(22H APRNTC - W .GT. MCOL, 22, 2, 2)
-C/7S
- IF (W .GT. MCOL) CALL
- 1 SETERR(' APRNTC - W .GT. MCOL', 22, 2, 2)
-C/
-C
-C/6S
-C IF (D .LT. 0) CALL
-C 1 SETERR(22H APRNTC - D .LT. ZERO, 22, 3, 2)
-C/7S
- IF (D .LT. 0) CALL
- 1 SETERR(' APRNTC - D .LT. ZERO', 22, 3, 2)
-C/
-C
-C/6S
-C IF (W .LT. D+6) CALL
-C 1 SETERR(21H APRNTC - W .LT. D+6, 21, 4, 2)
-C/7S
- IF (W .LT. D+6) CALL
- 1 SETERR(' APRNTC - W .LT. D+6', 21, 4, 2)
-C/
-C
-C
-C EXPENT IS USED AS A FIRST-TIME SWITCH TO SIGNAL IF THE
-C MACHINE-VALUE CONSTANTS HAVE BEEN COMPUTED.
-C
- IF (EXPENT .GT. 0) GO TO 10
- LOGETA = ALOG10(FLOAT(I1MACH(10)))
- EMIN = ICEIL(LOGETA*FLOAT(IABS(I1MACH(12)-1)))
- EMAX = ICEIL(LOGETA*FLOAT(I1MACH(13)))
- EXPENT = I10WID(MAX0(EMIN, EMAX))
-C
-C COMPUTE THE FORMATS.
-C
- 10 WW = MIN0(99, MAX0(W, 5+EXPENT))
- CALL S88FMT(2, WW, IFMT2(13))
- DD = MIN0(D, (WW-(5+EXPENT)))
- CALL S88FMT(2, DD, IFMT2(16))
-C
-C NCOL IS THE NUMBER OF VALUES TO BE PRINTED ACROSS THE LINE.
-C
- NCOL = MAX0(1, MIN0(9, (MIN0(MCOL,160)-INDW)/(2*WW)))
- CALL S88FMT(1, (2*NCOL), IFMT2(11))
- WW = WW-2
-C
-C THE ASTERISKS ARE POSITIONED RIGHT-ADJUSTED IN THE W-WIDTH SPACE.
- CALL S88FMT(2, WW, IFMT1(13))
-C
-C I COUNTS THE NUMBER OF ITEMS TO BE PRINTED,
-C J COUNTS THE NUMBER ON A GIVEN LINE,
-C COUNT COUNTS THE NUMBER OF DUPLICATE LINES.
-C
- I = 1
- J = 0
- COUNT = 0
-C
-C THE LOGICAL OF THE FOLLOWING IS ROUGHLY THIS -
-C IF THERE ARE STILL MORE ITEMS TO BE PRINTED, A LINE-
-C FULL IS PUT INTO THE ARRAY, LINE.
-C WHENEVER A LINE IS PRINTED OUT, IT IS ALSO STUFFED INTO
-C THE ARRAY, LAST, TO COMPARE WITH THE NEXT ONE COMING IN
-C TO CHECK FOR REPEAT OR DUPLICATED LINES.
-C ALSO WHENEVER A LINE IS WRITTEN OUT, THE DUPLICATION
-C COUNTER, COUNT, IS SET TO ONE.
-C THE ONLY MILDLY TRICKY PART IS TO NOTE THAT COUNT HAS TO
-C GO TO 3 BEFORE A LINE OF ASTERISKS IS PRINTED BECAUSE
-C OF COURSE NO SUCH LINE IS PRINTED FOR JUST A PAIR OF
-C DUPLICATE LINES.
-C
-C ILINE IS PRINTED AS THE INDEX OF THE FIRST ARRAY ELEMENT
-C IN A LINE.
-C
-C
- 20 IF (I .GT. NITEMS) GO TO 90
- J = J+1
-C/R
-C LINE(1,J) = A(1,J)
-C LINE(2,J) = A(2,J)
-C/C
- LINE(J) = A(I)
-C/
- IF (J .EQ. 1) ILINE = I
- IF (J .LT. NCOL .AND. I .LT. NITEMS) GO TO 80
- IF (COUNT .EQ. 0) GO TO 50
- DUP = .TRUE.
- DO 30 K=1,NCOL
-C/R
-C IF (LAST(1,K) .NE. LINE(1,K) .OR.
-C 1 LAST(2,K) .NE. LINE(2,K))
-C 2 DUP = .FALSE.
-C/C
- IF (REAL(LAST(K)) .NE. REAL(LINE(K)) .OR.
- 1 AIMAG(LAST(K)) .NE. AIMAG(LINE(K)))
- 2 DUP = .FALSE.
-C/
- 30 CONTINUE
- IF (I .EQ. NITEMS .AND. J .LT. NCOL) DUP = .FALSE.
- IF (.NOT. DUP .AND. COUNT .EQ. 1) GO TO 50
- IF (.NOT. DUP) GO TO 40
- COUNT = COUNT+1
- IF (COUNT .EQ. 3) WRITE(IOUT, IFMT1C) BLANK,
- 1 STAR, STAR, STAR, STAR
- IF (I .EQ. NITEMS) GO TO 50
- GO TO 70
-C/R
-C 40 WRITE(IOUT, IFMT2C) BLANK, ILAST, (LAST(1,K),
-C 1 LAST(2,K), K=1,NCOL)
-C 50 WRITE(IOUT, IFMT2C) BLANK, ILINE, (LINE(1,K),
-C 1 LINE(2,K), K=1,J)
-C/C
- 40 WRITE(IOUT, IFMT2C) BLANK, ILAST, (LAST(K), K=1,NCOL)
- 50 WRITE(IOUT, IFMT2C) BLANK, ILINE, (LINE(K), K=1,J)
-C/
- COUNT = 1
- DO 60 K=1,NCOL
-C/R
-C LAST(1,K) = LINE(1,K)
-C 60 LAST(2,K) = LINE(2,K)
-C/C
- 60 LAST(K) = LINE(K)
-C/
- 70 ILAST = ILINE
- J = 0
- 80 I = I+1
- GO TO 20
- 90 RETURN
- END
diff --git a/CEP/PyBDSM/src/port3/aprntd.f b/CEP/PyBDSM/src/port3/aprntd.f
deleted file mode 100644
index 0f8fb1f866d385f0188e24a0468046c5dfc98535..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/aprntd.f
+++ /dev/null
@@ -1,221 +0,0 @@
- SUBROUTINE APRNTD(A, NITEMS, IOUT, MCOL, W, D)
-C
-C THIS SUBROUTINE PRINTS OUT NITEMS FROM THE DOUBLE PRECISION ARRAY,
-C A, ON OUTPUT UNIT IOUT, USING A MAXIMUM OF MCOL PRINT SPACES.
-C THE OUTPUT FORMAT IS 1PDW.D.
-C THE PROGRAM PUTS AS MANY VALUES ON A LINE AS POSSIBLE.
-C W SHOULD BE INPUT AS THE ACTUAL WIDTH +1 FOR A SPACE BETWEEN VALUES.
-C
-C DUPLICATE LINES ARE NOT ALL PRINTED, BUT ARE INDICATED BY ASTERISKS.
-C
-C WRITTEN BY DAN WARNER, REVISED BY PHYL FOX, OCTOBER 21, 1982.
-C
-C THE LINE WIDTH IS COMPUTED AS THE MINIMUM OF THE INPUT MCOL AND 160.
-C IF THE LINE WIDTH IS TO BE INCREASED ABOVE 160, THE BUFFERS LINE()
-C AND LAST(), WHICH THE VALUES TO BE PRINTED ON ONE LINE, MUST
-C BE DIMENSIONED ACCORDINGLY.
-C
-C INPUT PARAMETERS -
-C
-C A - THE START OF THE DOUBLE PRECISION ARRAY TO BE PRINTED
-C
-C NITEMS - THE NUMBER OF ITEMS TO BE PRINTED
-C
-C IOUT - THE OUTPUT UNIT FOR PRINTING
-C
-C MCOL - THE NUMBER OF SPACES ACROSS THE LINE
-C
-C W - THE WIDTH OF THE PRINTED VALUE (1PDW.D)
-C
-C D - THE NUMBER OF DIGITS AFTER THE DECIMAL POINT (1PDW.D)
-C
-C
-C ERROR STATES -
-C
-C 1 - NITEMS .LE. ZERO
-C
-C 2 - W .GT. MCOL
-C
-C 3 - D .LT. ZERO
-C
-C 4 - W .LT. D+6
-C
- INTEGER NITEMS, IOUT, MCOL, W, D
- DOUBLE PRECISION A(NITEMS)
-C
- INTEGER MAX0, MIN0, WW, DD, EMIN, EMAX,
- 1 EXPENT, I1MACH, ICEIL, IABS, I10WID
-C/6S
-C INTEGER IFMT1(20), IFMT1C(20), IFMT2(18), IFMT2C(18), BLANK, STAR
-C EQUIVALENCE (IFMT1(1),IFMT1C(1)), (IFMT2(1),IFMT2C(1))
-C/7S
- CHARACTER*1 IFMT1(20), IFMT2(18), BLANK, STAR
- CHARACTER*20 IFMT1C
- CHARACTER*18 IFMT2C
- EQUIVALENCE (IFMT1(1),IFMT1C), (IFMT2(1),IFMT2C)
-C/
- INTEGER INDW, NCOL, COUNT, I, J, K, ILINE, ILAST
- LOGICAL DUP
- DOUBLE PRECISION LINE(18), LAST(18)
- REAL LOGETA
-C
-C/6S
-C DATA BLANK/1H /, STAR/1H*/, INDW/7/, EXPENT/0/
-C/7S
- DATA BLANK/' '/, STAR/'*'/, INDW/7/, EXPENT/0/
-C/
-C
-C IFMT1 IS FOR THE ASTERISK LINES, IFMT2 FOR THE DATA LINES
-C
-C/6S
-C DATA IFMT1( 1) /1H(/, IFMT2( 1) /1H(/
-C DATA IFMT1( 2) /1H1/, IFMT2( 2) /1H1/
-C DATA IFMT1( 3) /1HA/, IFMT2( 3) /1HA/
-C DATA IFMT1( 4) /1H1/, IFMT2( 4) /1H1/
-C DATA IFMT1( 5) /1H,/, IFMT2( 5) /1H,/
-C DATA IFMT1( 6) /1H5/, IFMT2( 6) /1HI/
-C DATA IFMT1( 7) /1HX/, IFMT2( 7) /1H7/
-C DATA IFMT1( 8) /1H,/, IFMT2( 8) /1H,/
-C DATA IFMT1( 9) /1H2/, IFMT2( 9) /1H1/
-C DATA IFMT1(10) /1HA/, IFMT2(10) /1HP/
-C DATA IFMT1(11) /1H1/, IFMT2(11) /1H /
-C DATA IFMT1(12) /1H,/, IFMT2(12) /1HD/
-C DATA IFMT1(13) /1H /, IFMT2(13) /1H /
-C DATA IFMT1(14) /1H /, IFMT2(14) /1H /
-C DATA IFMT1(15) /1HX/, IFMT2(15) /1H./
-C DATA IFMT1(16) /1H,/, IFMT2(16) /1H /
-C DATA IFMT1(17) /1H2/, IFMT2(17) /1H /
-C DATA IFMT1(18) /1HA/, IFMT2(18) /1H)/
-C DATA IFMT1(19) /1H1/
-C DATA IFMT1(20) /1H)/
-C/7S
- DATA IFMT1( 1) /'('/, IFMT2( 1) /'('/
- DATA IFMT1( 2) /'1'/, IFMT2( 2) /'1'/
- DATA IFMT1( 3) /'A'/, IFMT2( 3) /'A'/
- DATA IFMT1( 4) /'1'/, IFMT2( 4) /'1'/
- DATA IFMT1( 5) /','/, IFMT2( 5) /','/
- DATA IFMT1( 6) /'5'/, IFMT2( 6) /'I'/
- DATA IFMT1( 7) /'X'/, IFMT2( 7) /'7'/
- DATA IFMT1( 8) /','/, IFMT2( 8) /','/
- DATA IFMT1( 9) /'2'/, IFMT2( 9) /'1'/
- DATA IFMT1(10) /'A'/, IFMT2(10) /'P'/
- DATA IFMT1(11) /'1'/, IFMT2(11) /' '/
- DATA IFMT1(12) /','/, IFMT2(12) /'D'/
- DATA IFMT1(13) /' '/, IFMT2(13) /' '/
- DATA IFMT1(14) /' '/, IFMT2(14) /' '/
- DATA IFMT1(15) /'X'/, IFMT2(15) /'.'/
- DATA IFMT1(16) /','/, IFMT2(16) /' '/
- DATA IFMT1(17) /'2'/, IFMT2(17) /' '/
- DATA IFMT1(18) /'A'/, IFMT2(18) /')'/
- DATA IFMT1(19) /'1'/
- DATA IFMT1(20) /')'/
-C/
-C
-C/6S
-C IF (NITEMS .LE. 0) CALL
-C 1 SETERR(27H APRNTD - NITEMS .LE. ZERO, 27, 1, 2)
-C/7S
- IF (NITEMS .LE. 0) CALL
- 1 SETERR(' APRNTD - NITEMS .LE. ZERO', 27, 1, 2)
-C/
-C
-C/6S
-C IF (W .GT. MCOL) CALL
-C 1 SETERR(22H APRNTD - W .GT. MCOL, 22, 2, 2)
-C/7S
- IF (W .GT. MCOL) CALL
- 1 SETERR(' APRNTD - W .GT. MCOL', 22, 2, 2)
-C/
-C
-C/6S
-C IF (D .LT. 0) CALL
-C 1 SETERR(22H APRNTD - D .LT. ZERO, 22, 3, 2)
-C/7S
- IF (D .LT. 0) CALL
- 1 SETERR(' APRNTD - D .LT. ZERO', 22, 3, 2)
-C/
-C
-C/6S
-C IF (W .LT. D+6) CALL
-C 1 SETERR(21H APRNTD - W .LT. D+6, 21, 4, 2)
-C/7S
- IF (W .LT. D+6) CALL
- 1 SETERR(' APRNTD - W .LT. D+6', 21, 4, 2)
-C/
-C
-C EXPENT IS USED AS A FIRST-TIME SWITCH TO SIGNAL IF THE
-C MACHINE-VALUE CONSTANTS HAVE BEEN COMPUTED.
-C
- IF (EXPENT .GT. 0) GO TO 10
- LOGETA = ALOG10(FLOAT(I1MACH(10)))
- EMIN = ICEIL(LOGETA*FLOAT(IABS(I1MACH(15)-1)))
- EMAX = ICEIL(LOGETA*FLOAT(I1MACH(16)))
- EXPENT = I10WID(MAX0(EMIN, EMAX))
-C
-C COMPUTE THE FORMATS.
-C
- 10 WW = MIN0(99, MAX0(W, 5+EXPENT))
- CALL S88FMT(2, WW, IFMT2(13))
- DD = MIN0(D, (WW-(5+EXPENT)))
- CALL S88FMT(2, DD, IFMT2(16))
-C
-C NCOL IS THE NUMBER OF VALUES TO BE PRINTED ACROSS THE LINE.
-C
- NCOL = MAX0(1, MIN0(9, (MIN0(MCOL,160)-INDW)/WW))
- CALL S88FMT(1, NCOL, IFMT2(11))
- WW = WW-2
-C THE ASTERISKS ARE POSITIONED RIGHT-ADJUSTED IN THE W-WIDTH SPACE.
- CALL S88FMT(2, WW, IFMT1(13))
-C
-C I COUNTS THE NUMBER OF ITEMS TO BE PRINTED,
-C J COUNTS THE NUMBER ON A GIVEN LINE,
-C COUNT COUNTS THE NUMBER OF DUPLICATE LINES.
-C
- I = 1
- J = 0
- COUNT = 0
-C
-C THE LOGICAL OF THE FOLLOWING IS ROUGHLY THIS -
-C IF THERE ARE STILL MORE ITEMS TO BE PRINTED, A LINE-
-C FULL IS PUT INTO THE ARRAY, LINE.
-C WHENEVER A LINE IS PRINTED OUT, IT IS ALSO STUFFED INTO
-C THE ARRAY, LAST, TO COMPARE WITH THE NEXT ONE COMING IN
-C TO CHECK FOR REPEAT OR DUPLICATED LINES.
-C ALSO WHENEVER A LINE IS WRITTEN OUT, THE DUPLICATION
-C COUNTER, COUNT, IS SET TO ONE.
-C THE ONLY MILDLY TRICKY PART IS TO NOTE THAT COUNT HAS TO
-C GO TO 3 BEFORE A LINE OF ASTERISKS IS PRINTED BECAUSE
-C OF COURSE NO SUCH LINE IS PRINTED FOR JUST A PAIR OF
-C DUPLICATE LINES.
-C
-C ILINE IS PRINTED AS THE INDEX OF THE FIRST ARRAY ELEMENT
-C IN A LINE.
-C
- 20 IF (I .GT. NITEMS) GO TO 90
- J = J+1
- LINE(J) = A(I)
- IF (J .EQ. 1) ILINE = I
- IF (J .LT. NCOL .AND. I .LT. NITEMS) GO TO 80
- IF (COUNT .EQ. 0) GO TO 50
- DUP = .TRUE.
- DO 30 K=1,NCOL
- 30 IF (LAST(K) .NE. LINE(K)) DUP = .FALSE.
- IF (I .EQ. NITEMS .AND. J .LT. NCOL) DUP = .FALSE.
- IF (.NOT. DUP .AND. COUNT .EQ. 1) GO TO 50
- IF (.NOT. DUP) GO TO 40
- COUNT = COUNT+1
- IF (COUNT .EQ. 3) WRITE(IOUT, IFMT1C) BLANK,
- 1 STAR, STAR, STAR, STAR
- IF (I .EQ. NITEMS) GO TO 50
- GO TO 70
- 40 WRITE(IOUT, IFMT2C) BLANK, ILAST, (LAST(K), K=1,NCOL)
- 50 WRITE(IOUT, IFMT2C) BLANK, ILINE, (LINE(K), K=1,J)
- COUNT = 1
- DO 60 K=1,NCOL
- 60 LAST(K) = LINE(K)
- 70 ILAST = ILINE
- J = 0
- 80 I = I+1
- GO TO 20
- 90 RETURN
- END
diff --git a/CEP/PyBDSM/src/port3/aprnti.f b/CEP/PyBDSM/src/port3/aprnti.f
deleted file mode 100644
index 92f458965a9c6a2f50c37128e088ed7218ef4266..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/aprnti.f
+++ /dev/null
@@ -1,185 +0,0 @@
- SUBROUTINE APRNTI(A, NITEMS, IOUT, MCOL, W)
-C
-C THIS SUBROUTINE PRINTS OUT NITEMS FROM THE INTEGER ARRAY, A, ON
-C OUTPUT UNIT IOUT, USING A MAXIMUM OF MCOL PRINT SPACES.
-C THE OUTPUT FORMAT IS IW.
-C THE PROGRAM PUTS AS MANY VALUES ON A LINE AS POSSIBLE.
-C W SHOULD BE INPUT AS THE ACTUAL WIDTH +1 FOR A SPACE BETWEEN VALUES.
-C
-C DUPLICATE LINES ARE NOT ALL PRINTED, BUT ARE INDICATED BY ASTERISKS.
-C
-C WRITTEN BY DAN WARNER, REVISED BY PHYL FOX, OCTOBER 21, 1982.
-C
-C THE LINE WIDTH IS COMPUTED AS THE MINIMUM OF THE INPUT MCOL AND 160.
-C IF THE LINE WIDTH IS TO BE INCREASED ABOVE 160, THE BUFFERS LINE()
-C AND LAST(), WHICH THE VALUES TO BE PRINTED ON ONE LINE, MUST
-C BE DIMENSIONED ACCORDINGLY.
-C
-C INPUT PARAMETERS -
-C
-C A - THE START OF THE INTEGER ARRAY TO BE PRINTED
-C
-C NITEMS - THE NUMBER OF ITEMS TO BE PRINTED
-C
-C IOUT - THE OUTPUT UNIT FOR PRINTING
-C
-C MCOL - THE NUMBER OF SPACES ACROSS THE LINE
-C
-C W - THE WIDTH OF THE PRINTED VALUE (IW)
-C
-C
-C ERROR STATES -
-C
-C 1 - NITEMS .LE. ZERO
-C
-C 2 - W .GT. MCOL
-C
- INTEGER NITEMS, IOUT, MCOL, W
- INTEGER A(NITEMS)
-C
- INTEGER MAX0, MIN0, WW
-C/6S
-C INTEGER IFMT1(20), IFMT1C(20), IFMT2(14), IFMT2C(14), BLANK, STAR
-C EQUIVALENCE (IFMT1(1),IFMT1C(1)), (IFMT2(1),IFMT2C(1))
-C/7S
- CHARACTER*1 IFMT1(20), IFMT2(14), BLANK, STAR
- CHARACTER*20 IFMT1C
- CHARACTER*14 IFMT2C
- EQUIVALENCE (IFMT1(1),IFMT1C), (IFMT2(1),IFMT2C)
-C/
- INTEGER INDW, NCOL, COUNT, I, J, K, ILINE, ILAST
- LOGICAL DUP
- INTEGER LINE(40), LAST(40)
-C
-C/6S
-C DATA BLANK/1H /, STAR/1H*/, INDW/7/
-C/7S
- DATA BLANK/' '/, STAR/'*'/, INDW/7/
-C/
-C
-C IFMT1 IS FOR THE ASTERISK LINES, IFMT2 FOR THE DATA LINES
-C
-C/6S
-C DATA IFMT1( 1) /1H(/, IFMT2( 1) /1H(/
-C DATA IFMT1( 2) /1H1/, IFMT2( 2) /1H1/
-C DATA IFMT1( 3) /1HA/, IFMT2( 3) /1HA/
-C DATA IFMT1( 4) /1H1/, IFMT2( 4) /1H1/
-C DATA IFMT1( 5) /1H,/, IFMT2( 5) /1H,/
-C DATA IFMT1( 6) /1H5/, IFMT2( 6) /1HI/
-C DATA IFMT1( 7) /1HX/, IFMT2( 7) /1H7/
-C DATA IFMT1( 8) /1H,/, IFMT2( 8) /1H,/
-C DATA IFMT1( 9) /1H2/, IFMT2( 9) /1H /
-C DATA IFMT1(10) /1HA/, IFMT2(10) /1H /
-C DATA IFMT1(11) /1H1/, IFMT2(11) /1HI/
-C DATA IFMT1(12) /1H,/, IFMT2(12) /1H /
-C DATA IFMT1(13) /1H /, IFMT2(13) /1H /
-C DATA IFMT1(14) /1H /, IFMT2(14) /1H)/
-C DATA IFMT1(15) /1HX/
-C DATA IFMT1(16) /1H,/
-C DATA IFMT1(17) /1H2/
-C DATA IFMT1(18) /1HA/
-C DATA IFMT1(19) /1H1/
-C DATA IFMT1(20) /1H)/
-C/7S
- DATA IFMT1( 1) /'('/, IFMT2( 1) /'('/
- DATA IFMT1( 2) /'1'/, IFMT2( 2) /'1'/
- DATA IFMT1( 3) /'A'/, IFMT2( 3) /'A'/
- DATA IFMT1( 4) /'1'/, IFMT2( 4) /'1'/
- DATA IFMT1( 5) /','/, IFMT2( 5) /','/
- DATA IFMT1( 6) /'5'/, IFMT2( 6) /'I'/
- DATA IFMT1( 7) /'X'/, IFMT2( 7) /'7'/
- DATA IFMT1( 8) /','/, IFMT2( 8) /','/
- DATA IFMT1( 9) /'2'/, IFMT2( 9) /' '/
- DATA IFMT1(10) /'A'/, IFMT2(10) /' '/
- DATA IFMT1(11) /'1'/, IFMT2(11) /'I'/
- DATA IFMT1(12) /','/, IFMT2(12) /' '/
- DATA IFMT1(13) /' '/, IFMT2(13) /' '/
- DATA IFMT1(14) /' '/, IFMT2(14) /')'/
- DATA IFMT1(15) /'X'/
- DATA IFMT1(16) /','/
- DATA IFMT1(17) /'2'/
- DATA IFMT1(18) /'A'/
- DATA IFMT1(19) /'1'/
- DATA IFMT1(20) /')'/
-C/
-C
-C/6S
-C IF (NITEMS .LE. 0) CALL
-C 1 SETERR(27H APRNTI - NITEMS .LE. ZERO, 27, 1, 2)
-C/7S
- IF (NITEMS .LE. 0) CALL
- 1 SETERR(' APRNTI - NITEMS .LE. ZERO', 27, 1, 2)
-C/
-C
-C/6S
-C IF (W .GT. MCOL) CALL
-C 1 SETERR(22H APRNTI - W .GT. MCOL, 22, 2, 2)
-C/7S
- IF (W .GT. MCOL) CALL
- 1 SETERR(' APRNTI - W .GT. MCOL', 22, 2, 2)
-C/
-C
-C COMPUTE THE FORMATS.
-C
- WW = MIN0(99, MAX0(W, 2))
- CALL S88FMT(2, WW, IFMT2(12))
- NCOL = MAX0(1, MIN0(99, (MIN0(MCOL,160) - INDW)/WW))
- CALL S88FMT(2, NCOL, IFMT2(9))
- WW = WW-2
- CALL S88FMT(2, WW, IFMT1(13))
-C
-C THE ASTERISKS ARE POSITIONED RIGHT-ADJUSTED IN THE W-WIDTH SPACE.
- CALL S88FMT(2, WW, IFMT1(13))
-C
-C I COUNTS THE NUMBER OF ITEMS TO BE PRINTED,
-C J COUNTS THE NUMBER ON A GIVEN LINE,
-C COUNT COUNTS THE NUMBER OF DUPLICATE LINES.
-C
- 10 I = 1
- J = 0
- COUNT = 0
-C
-C THE LOGICAL OF THE FOLLOWING IS ROUGHLY THIS -
-C IF THERE ARE STILL MORE ITEMS TO BE PRINTED, A LINE-
-C FULL IS PUT INTO THE ARRAY, LINE.
-C WHENEVER A LINE IS PRINTED OUT, IT IS ALSO STUFFED INTO
-C THE ARRAY, LAST, TO COMPARE WITH THE NEXT ONE COMING IN
-C TO CHECK FOR REPEAT OR DUPLICATED LINES.
-C ALSO WHENEVER A LINE IS WRITTEN OUT, THE DUPLICATION
-C COUNTER, COUNT, IS SET TO ONE.
-C THE ONLY MILDLY TRICKY PART IS TO NOTE THAT COUNT HAS TO
-C GO TO 3 BEFORE A LINE OF ASTERISKS IS PRINTED BECAUSE
-C OF COURSE NO SUCH LINE IS PRINTED FOR JUST A PAIR OF
-C DUPLICATE LINES.
-C
-C ILINE IS PRINTED AS THE INDEX OF THE FIRST ARRAY ELEMENT
-C IN A LINE.
-C
- 20 IF (I .GT. NITEMS) GO TO 90
- J = J+1
- LINE(J) = A(I)
- IF (J .EQ. 1) ILINE = I
- IF (J .LT. NCOL .AND. I .LT. NITEMS) GO TO 80
- IF (COUNT .EQ. 0) GO TO 50
- DUP = .TRUE.
- DO 30 K=1,NCOL
- 30 IF (LAST(K) .NE. LINE(K)) DUP = .FALSE.
- IF (I .EQ. NITEMS .AND. J .LT. NCOL) DUP = .FALSE.
- IF (.NOT. DUP .AND. COUNT .EQ. 1) GO TO 50
- IF (.NOT. DUP) GO TO 40
- COUNT = COUNT+1
- IF (COUNT .EQ. 3) WRITE(IOUT, IFMT1C) BLANK,
- 1 STAR, STAR, STAR, STAR
- IF (I .EQ. NITEMS) GO TO 50
- GO TO 70
- 40 WRITE(IOUT, IFMT2C) BLANK, ILAST, (LAST(K), K=1,NCOL)
- 50 WRITE(IOUT, IFMT2C) BLANK, ILINE, (LINE(K), K=1,J)
- COUNT = 1
- DO 60 K=1,NCOL
- 60 LAST(K) = LINE(K)
- 70 ILAST = ILINE
- J = 0
- 80 I = I+1
- GO TO 20
- 90 RETURN
- END
diff --git a/CEP/PyBDSM/src/port3/aprntl.f b/CEP/PyBDSM/src/port3/aprntl.f
deleted file mode 100644
index fb6a13550546e16016e05c41b1c4b9381ecd77de..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/aprntl.f
+++ /dev/null
@@ -1,169 +0,0 @@
- SUBROUTINE APRNTL(A, NITEMS, IOUT, MCOL)
-C
-C THIS SUBROUTINE PRINTS OUT NITEMS FROM THE LOGICAL ARRAY, A, ON
-C OUTPUT UNIT IOUT, USING A MAXIMUM OF MCOL PRINT SPACES.
-C THE T OR F VALUES ARE PRINTED RIGHT-ADJUSTED IN A FIELD OF WIDTH 4.
-C
-C DUPLICATE LINES ARE NOT ALL PRINTED, BUT ARE INDICATED BY ASTERISKS.
-C
-C WRITTEN BY DAN WARNER, REVISED BY PHYL FOX, OCTOBER 21, 1982.
-C
-C THE LINE WIDTH IS COMPUTED AS THE MINIMUM OF THE INPUT MCOL AND 160.
-C IF THE LINE WIDTH IS TO BE INCREASED ABOVE 160, THE BUFFERS LINE()
-C AND LAST(), WHICH THE VALUES TO BE PRINTED ON ONE LINE, MUST
-C BE DIMENSIONED ACCORDINGLY.
-C
-C INPUT PARAMETERS -
-C
-C A - THE START OF THE LOGICAL ARRAY TO BE PRINTED
-C
-C NITEMS - THE NUMBER OF ITEMS TO BE PRINTED
-C
-C IOUT - THE OUTPUT UNIT FOR PRINTING
-C
-C MCOL - THE NUMBER OF SPACES ACROSS THE LINE
-C
-C
-C ERROR STATES -
-C
-C 1 - NITEMS .LE. ZERO
-C
- INTEGER NITEMS, IOUT, MCOL
- LOGICAL A(NITEMS)
-C
- INTEGER MAX0, MIN0
-C/6S
-C INTEGER IFMT1(20), IFMT1C(20), IFMT2(19), IFMT2C(19)
-C EQUIVALENCE (IFMT1(1),IFMT1C(1)), (IFMT2(1),IFMT2C(1))
-C INTEGER BLANK, FCHAR, STAR, TCHAR
-C/7S
- CHARACTER*1 IFMT1(20), IFMT2(19), BLANK, FCHAR, STAR, TCHAR
- CHARACTER*20 IFMT1C
- CHARACTER*19 IFMT2C
- EQUIVALENCE (IFMT1(1),IFMT1C), (IFMT2(1),IFMT2C)
-C/
- INTEGER INDW, NCOL, COUNT, I, J, K, ILINE, ILAST
- LOGICAL DUP
-C/6S
-C INTEGER LINE(40), LAST(40)
-C DATA BLANK/1H /, STAR/1H*/, TCHAR/1HT/, FCHAR/1HF/, INDW/7/
-C/7S
- CHARACTER*1 LINE(40), LAST(40)
- DATA BLANK/' '/, STAR/'*'/, TCHAR/'T'/, FCHAR/'F'/, INDW/7/
-C/
-C
-C
-C IFMT1 IS FOR THE ASTERISK LINES, IFMT2 FOR THE DATA LINES
-C
-C/6S
-C DATA IFMT1( 1) /1H(/, IFMT2( 1) /1H(/
-C DATA IFMT1( 2) /1H1/, IFMT2( 2) /1H1/
-C DATA IFMT1( 3) /1HA/, IFMT2( 3) /1HA/
-C DATA IFMT1( 4) /1H1/, IFMT2( 4) /1H1/
-C DATA IFMT1( 5) /1H,/, IFMT2( 5) /1H,/
-C DATA IFMT1( 6) /1H5/, IFMT2( 6) /1HI/
-C DATA IFMT1( 7) /1HX/, IFMT2( 7) /1H7/
-C DATA IFMT1( 8) /1H,/, IFMT2( 8) /1H,/
-C DATA IFMT1( 9) /1H2/, IFMT2( 9) /1H /
-C DATA IFMT1(10) /1HA/, IFMT2(10) /1H /
-C DATA IFMT1(11) /1H1/, IFMT2(11) /1H(/
-C DATA IFMT1(12) /1H,/, IFMT2(12) /1H3/
-C DATA IFMT1(13) /1H /, IFMT2(13) /1HX/
-C DATA IFMT1(14) /1H2/, IFMT2(14) /1H,/
-C DATA IFMT1(15) /1HX/, IFMT2(15) /1H1/
-C DATA IFMT1(16) /1H,/, IFMT2(16) /1HA/
-C DATA IFMT1(17) /1H2/, IFMT2(17) /1H1/
-C DATA IFMT1(18) /1HA/, IFMT2(18) /1H)/
-C DATA IFMT1(19) /1H1/, IFMT2(19) /1H)/
-C DATA IFMT1(20) /1H)/
-C/7S
- DATA IFMT1( 1) /'('/, IFMT2( 1) /'('/
- DATA IFMT1( 2) /'1'/, IFMT2( 2) /'1'/
- DATA IFMT1( 3) /'A'/, IFMT2( 3) /'A'/
- DATA IFMT1( 4) /'1'/, IFMT2( 4) /'1'/
- DATA IFMT1( 5) /','/, IFMT2( 5) /','/
- DATA IFMT1( 6) /'5'/, IFMT2( 6) /'I'/
- DATA IFMT1( 7) /'X'/, IFMT2( 7) /'7'/
- DATA IFMT1( 8) /','/, IFMT2( 8) /','/
- DATA IFMT1( 9) /'2'/, IFMT2( 9) /' '/
- DATA IFMT1(10) /'A'/, IFMT2(10) /' '/
- DATA IFMT1(11) /'1'/, IFMT2(11) /'('/
- DATA IFMT1(12) /','/, IFMT2(12) /'3'/
- DATA IFMT1(13) /' '/, IFMT2(13) /'X'/
- DATA IFMT1(14) /'2'/, IFMT2(14) /','/
- DATA IFMT1(15) /'X'/, IFMT2(15) /'1'/
- DATA IFMT1(16) /','/, IFMT2(16) /'A'/
- DATA IFMT1(17) /'2'/, IFMT2(17) /'1'/
- DATA IFMT1(18) /'A'/, IFMT2(18) /')'/
- DATA IFMT1(19) /'1'/, IFMT2(19) /')'/
- DATA IFMT1(20) /')'/
-C/
-C
-C/6S
-C IF (NITEMS .LE. 0) CALL
-C 1 SETERR(27H APRNTL - NITEMS .LE. ZERO, 27, 1, 2)
-C/7S
- IF (NITEMS .LE. 0) CALL
- 1 SETERR(' APRNTL - NITEMS .LE. ZERO', 27, 1, 2)
-C/
-C
-C COMPUTE THE NUMBER OF FIELDS OF 4 ACROSS A LINE.
-C
- NCOL = MAX0(1, MIN0(99, (MIN0(MCOL,160)-INDW)/4))
-C
-C THE ASTERISKS ARE POSITIONED RIGHT-ADJUSTED IN THE 4-CHARACTER SPACE.
- CALL S88FMT(2, NCOL, IFMT2(9))
-C
-C I COUNTS THE NUMBER OF ITEMS TO BE PRINTED,
-C J COUNTS THE NUMBER ON A GIVEN LINE,
-C COUNT COUNTS THE NUMBER OF DUPLICATE LINES.
-C
- 10 I = 1
- J = 0
- COUNT = 0
-C
-C THE LOGICAL OF THE FOLLOWING IS ROUGHLY THIS -
-C IF THERE ARE STILL MORE ITEMS TO BE PRINTED, A LINE-
-C FULL IS PUT INTO THE ARRAY, LINE.
-C WHENEVER A LINE IS PRINTED OUT, IT IS ALSO STUFFED INTO
-C THE ARRAY, LAST, TO COMPARE WITH THE NEXT ONE COMING IN
-C TO CHECK FOR REPEAT OR DUPLICATED LINES.
-C ALSO WHENEVER A LINE IS WRITTEN OUT, THE DUPLICATION
-C COUNTER, COUNT, IS SET TO ONE.
-C THE ONLY MILDLY TRICKY PART IS TO NOTE THAT COUNT HAS TO
-C GO TO 3 BEFORE A LINE OF ASTERISKS IS PRINTED BECAUSE
-C OF COURSE NO SUCH LINE IS PRINTED FOR JUST A PAIR OF
-C DUPLICATE LINES.
-C
-C ILINE IS PRINTED AS THE INDEX OF THE FIRST ARRAY ELEMENT
-C IN A LINE.
-C
- 20 IF (I .GT. NITEMS) GO TO 90
- J = J+1
- LINE(J) = FCHAR
- IF ( A(I) ) LINE(J) = TCHAR
- IF (J .EQ. 1) ILINE = I
- IF (J .LT. NCOL .AND. I .LT. NITEMS) GO TO 80
- IF (COUNT .EQ. 0) GO TO 50
- DUP = .TRUE.
- DO 30 K=1,NCOL
- 30 IF (LAST(K) .NE. LINE(K)) DUP = .FALSE.
- IF (I .EQ. NITEMS .AND. J .LT. NCOL) DUP = .FALSE.
- IF (.NOT. DUP .AND. COUNT .EQ. 1) GO TO 50
- IF (.NOT. DUP) GO TO 40
- COUNT = COUNT+1
- IF (COUNT .EQ. 3) WRITE(IOUT, IFMT1C) BLANK,
- 1 STAR, STAR, STAR, STAR
- IF (I .EQ. NITEMS) GO TO 50
- GO TO 70
- 40 WRITE(IOUT, IFMT2C) BLANK, ILAST, (LAST(K), K=1,NCOL)
- 50 WRITE(IOUT, IFMT2C) BLANK, ILINE, (LINE(K), K=1,J)
- COUNT = 1
- DO 60 K=1,NCOL
- 60 LAST(K) = LINE(K)
- 70 ILAST = ILINE
- J = 0
- 80 I = I+1
- GO TO 20
- 90 RETURN
- END
diff --git a/CEP/PyBDSM/src/port3/aprntr.f b/CEP/PyBDSM/src/port3/aprntr.f
deleted file mode 100644
index 0cd02eb7dc7482b726240b20561066c4886a1b9a..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/aprntr.f
+++ /dev/null
@@ -1,222 +0,0 @@
- SUBROUTINE APRNTR(A, NITEMS, IOUT, MCOL, W, D)
-C
-C THIS SUBROUTINE PRINTS OUT NITEMS FROM THE REAL ARRAY, A, ON
-C OUTPUT UNIT IOUT, USING A MAXIMUM OF MCOL PRINT SPACES.
-C THE OUTPUT FORMAT IS 1PEW.D.
-C THE PROGRAM PUTS AS MANY VALUES ON A LINE AS POSSIBLE.
-C W SHOULD BE INPUT AS THE ACTUAL WIDTH +1 FOR A SPACE BETWEEN VALUES.
-C
-C DUPLICATE LINES ARE NOT ALL PRINTED, BUT ARE INDICATED BY ASTERISKS.
-C
-C WRITTEN BY DAN WARNER, REVISED BY PHYL FOX, OCTOBER 21, 1982.
-C
-C THE LINE WIDTH IS COMPUTED AS THE MINIMUM OF THE INPUT MCOL AND 160.
-C IF THE LINE WIDTH IS TO BE INCREASED ABOVE 160, THE BUFFERS LINE()
-C AND LAST(), WHICH THE VALUES TO BE PRINTED ON ONE LINE, MUST
-C BE DIMENSIONED ACCORDINGLY.
-C
-C INPUT PARAMETERS -
-C
-C A - THE START OF THE REAL ARRAY TO BE PRINTED
-C
-C NITEMS - THE NUMBER OF ITEMS TO BE PRINTED
-C
-C IOUT - THE OUTPUT UNIT FOR PRINTING
-C
-C MCOL - THE NUMBER OF SPACES ACROSS THE LINE
-C
-C W - THE WIDTH OF THE PRINTED VALUE (1PEW.D)
-C
-C D - THE NUMBER OF DIGITS AFTER THE DECIMAL POINT (1PEW.D)
-C
-C
-C ERROR STATES -
-C
-C 1 - NITEMS .LE. ZERO
-C
-C 2 - W .GT. MCOL
-C
-C 3 - D .LT. ZERO
-C
-C 4 - W .LT. D+6
-C
- INTEGER NITEMS, IOUT, MCOL, W, D
- REAL A(NITEMS)
-C
- INTEGER MAX0, MIN0, WW, DD, EMIN, EMAX,
- 1 EXPENT, I1MACH, ICEIL, IABS, I10WID
-C/6S
-C INTEGER IFMT1(20), IFMT1C(20), IFMT2(18), IFMT2C(18), BLANK, STAR
-C EQUIVALENCE (IFMT1(1),IFMT1C(1)), (IFMT2(1),IFMT2C(1))
-C/7S
- CHARACTER*1 IFMT1(20), IFMT2(18), BLANK, STAR
- CHARACTER*20 IFMT1C
- CHARACTER*18 IFMT2C
- EQUIVALENCE (IFMT1(1),IFMT1C), (IFMT2(1),IFMT2C)
-C/
- INTEGER INDW, NCOL, COUNT, I, J, K, ILINE, ILAST
- LOGICAL DUP
- REAL LINE(18), LAST(18), LOGETA
-C
-C/6S
-C DATA BLANK/1H /, STAR/1H*/, INDW/7/, EXPENT/0/
-C/7S
- DATA BLANK/' '/, STAR/'*'/, INDW/7/, EXPENT/0/
-C/
-C
-C IFMT1 IS FOR THE ASTERISK LINES, IFMT2 FOR THE DATA LINES
-C
-C/6S
-C DATA IFMT1( 1) /1H(/, IFMT2( 1) /1H(/
-C DATA IFMT1( 2) /1H1/, IFMT2( 2) /1H1/
-C DATA IFMT1( 3) /1HA/, IFMT2( 3) /1HA/
-C DATA IFMT1( 4) /1H1/, IFMT2( 4) /1H1/
-C DATA IFMT1( 5) /1H,/, IFMT2( 5) /1H,/
-C DATA IFMT1( 6) /1H5/, IFMT2( 6) /1HI/
-C DATA IFMT1( 7) /1HX/, IFMT2( 7) /1H7/
-C DATA IFMT1( 8) /1H,/, IFMT2( 8) /1H,/
-C DATA IFMT1( 9) /1H2/, IFMT2( 9) /1H1/
-C DATA IFMT1(10) /1HA/, IFMT2(10) /1HP/
-C DATA IFMT1(11) /1H1/, IFMT2(11) /1H /
-C DATA IFMT1(12) /1H,/, IFMT2(12) /1HE/
-C DATA IFMT1(13) /1H /, IFMT2(13) /1H /
-C DATA IFMT1(14) /1H /, IFMT2(14) /1H /
-C DATA IFMT1(15) /1HX/, IFMT2(15) /1H./
-C DATA IFMT1(16) /1H,/, IFMT2(16) /1H /
-C DATA IFMT1(17) /1H2/, IFMT2(17) /1H /
-C DATA IFMT1(18) /1HA/, IFMT2(18) /1H)/
-C DATA IFMT1(19) /1H1/
-C DATA IFMT1(20) /1H)/
-C/7S
- DATA IFMT1( 1) /'('/, IFMT2( 1) /'('/
- DATA IFMT1( 2) /'1'/, IFMT2( 2) /'1'/
- DATA IFMT1( 3) /'A'/, IFMT2( 3) /'A'/
- DATA IFMT1( 4) /'1'/, IFMT2( 4) /'1'/
- DATA IFMT1( 5) /','/, IFMT2( 5) /','/
- DATA IFMT1( 6) /'5'/, IFMT2( 6) /'I'/
- DATA IFMT1( 7) /'X'/, IFMT2( 7) /'7'/
- DATA IFMT1( 8) /','/, IFMT2( 8) /','/
- DATA IFMT1( 9) /'2'/, IFMT2( 9) /'1'/
- DATA IFMT1(10) /'A'/, IFMT2(10) /'P'/
- DATA IFMT1(11) /'1'/, IFMT2(11) /' '/
- DATA IFMT1(12) /','/, IFMT2(12) /'E'/
- DATA IFMT1(13) /' '/, IFMT2(13) /' '/
- DATA IFMT1(14) /' '/, IFMT2(14) /' '/
- DATA IFMT1(15) /'X'/, IFMT2(15) /'.'/
- DATA IFMT1(16) /','/, IFMT2(16) /' '/
- DATA IFMT1(17) /'2'/, IFMT2(17) /' '/
- DATA IFMT1(18) /'A'/, IFMT2(18) /')'/
- DATA IFMT1(19) /'1'/
- DATA IFMT1(20) /')'/
-C/
-C
-C/6S
-C IF (NITEMS .LE. 0) CALL
-C 1 SETERR(27H APRNTR - NITEMS .LE. ZERO, 27, 1, 2)
-C/7S
- IF (NITEMS .LE. 0) CALL
- 1 SETERR(' APRNTR - NITEMS .LE. ZERO', 27, 1, 2)
-C/
-C
-C/6S
-C IF (W .GT. MCOL) CALL
-C 1 SETERR(22H APRNTR - W .GT. MCOL, 22, 2, 2)
-C/7S
- IF (W .GT. MCOL) CALL
- 1 SETERR(' APRNTR - W .GT. MCOL', 22, 2, 2)
-C/
-C
-C/6S
-C IF (D .LT. 0) CALL
-C 1 SETERR(22H APRNTR - D .LT. ZERO, 22, 3, 2)
-C/7S
- IF (D .LT. 0) CALL
- 1 SETERR(' APRNTR - D .LT. ZERO', 22, 3, 2)
-C/
-C
-C/6S
-C IF (W .LT. D+6) CALL
-C 1 SETERR(21H APRNTR - W .LT. D+6, 21, 4, 2)
-C/7S
- IF (W .LT. D+6) CALL
- 1 SETERR(' APRNTR - W .LT. D+6', 21, 4, 2)
-C/
-C
-C
-C EXPENT IS USED AS A FIRST-TIME SWITCH TO SIGNAL IF THE
-C MACHINE-VALUE CONSTANTS HAVE BEEN COMPUTED.
-C
- IF (EXPENT .GT. 0) GO TO 10
- LOGETA = ALOG10(FLOAT(I1MACH(10)))
- EMIN = ICEIL(LOGETA*FLOAT(IABS(I1MACH(12)-1)))
- EMAX = ICEIL(LOGETA*FLOAT(I1MACH(13)))
- EXPENT = I10WID(MAX0(EMIN, EMAX))
-C
-C COMPUTE THE FORMATS.
-C
- 10 WW = MIN0(99, MAX0(W, 5+EXPENT))
- CALL S88FMT(2, WW, IFMT2(13))
- DD = MIN0(D, (WW-(5+EXPENT)))
- CALL S88FMT(2, DD, IFMT2(16))
-C
-C NCOL IS THE NUMBER OF VALUES TO BE PRINTED ACROSS THE LINE.
-C
- NCOL = MAX0(1, MIN0(9, (MIN0(MCOL,160)-INDW)/WW))
- CALL S88FMT(1, NCOL, IFMT2(11))
- WW = WW-2
-C
-C THE ASTERISKS ARE POSITIONED RIGHT-ADJUSTED IN THE W-WIDTH SPACE.
- CALL S88FMT(2, WW, IFMT1(13))
-C
-C I COUNTS THE NUMBER OF ITEMS TO BE PRINTED,
-C J COUNTS THE NUMBER ON A GIVEN LINE,
-C COUNT COUNTS THE NUMBER OF DUPLICATE LINES.
-C
- I = 1
- J = 0
- COUNT = 0
-C
-C THE LOGICAL OF THE FOLLOWING IS ROUGHLY THIS -
-C IF THERE ARE STILL MORE ITEMS TO BE PRINTED, A LINE-
-C FULL IS PUT INTO THE ARRAY, LINE.
-C WHENEVER A LINE IS PRINTED OUT, IT IS ALSO STUFFED INTO
-C THE ARRAY, LAST, TO COMPARE WITH THE NEXT ONE COMING IN
-C TO CHECK FOR REPEAT OR DUPLICATED LINES.
-C ALSO WHENEVER A LINE IS WRITTEN OUT, THE DUPLICATION
-C COUNTER, COUNT, IS SET TO ONE.
-C THE ONLY MILDLY TRICKY PART IS TO NOTE THAT COUNT HAS TO
-C GO TO 3 BEFORE A LINE OF ASTERISKS IS PRINTED BECAUSE
-C OF COURSE NO SUCH LINE IS PRINTED FOR JUST A PAIR OF
-C DUPLICATE LINES.
-C
-C ILINE IS PRINTED AS THE INDEX OF THE FIRST ARRAY ELEMENT
-C IN A LINE.
-C
- 20 IF (I .GT. NITEMS) GO TO 90
- J = J+1
- LINE(J) = A(I)
- IF (J .EQ. 1) ILINE = I
- IF (J .LT. NCOL .AND. I .LT. NITEMS) GO TO 80
- IF (COUNT .EQ. 0) GO TO 50
- DUP = .TRUE.
- DO 30 K=1,NCOL
- 30 IF (LAST(K) .NE. LINE(K)) DUP = .FALSE.
- IF (I .EQ. NITEMS .AND. J .LT. NCOL) DUP = .FALSE.
- IF (.NOT. DUP .AND. COUNT .EQ. 1) GO TO 50
- IF (.NOT. DUP) GO TO 40
- COUNT = COUNT+1
- IF (COUNT .EQ. 3) WRITE(IOUT, IFMT1C) BLANK,
- 1 STAR, STAR, STAR, STAR
- IF (I .EQ. NITEMS) GO TO 50
- GO TO 70
- 40 WRITE(IOUT, IFMT2C) BLANK, ILAST, (LAST(K), K=1,NCOL)
- 50 WRITE(IOUT, IFMT2C) BLANK, ILINE, (LINE(K), K=1,J)
- COUNT = 1
- DO 60 K=1,NCOL
- 60 LAST(K) = LINE(K)
- 70 ILAST = ILINE
- J = 0
- 80 I = I+1
- GO TO 20
- 90 RETURN
- END
diff --git a/CEP/PyBDSM/src/port3/c6lcf.f b/CEP/PyBDSM/src/port3/c6lcf.f
deleted file mode 100644
index f1e288760107c2c2d71b0209e20930494a0abf91..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/c6lcf.f
+++ /dev/null
@@ -1,7 +0,0 @@
- SUBROUTINE C6LCF(P,X,NF,F,IU,UR,UF)
- INTEGER P,IU
- REAL X(P),F,UR
- EXTERNAL UF
- CALL UF(P,X,NF,F)
- RETURN
- END
diff --git a/CEP/PyBDSM/src/port3/c7vfn.f b/CEP/PyBDSM/src/port3/c7vfn.f
deleted file mode 100644
index 97c57e19fd3594e5108d812aa6de44315c6cc251..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/c7vfn.f
+++ /dev/null
@@ -1,54 +0,0 @@
- SUBROUTINE C7VFN(IV, L, LH, LIV, LV, N, P, V)
-C
-C *** FINISH COVARIANCE COMPUTATION FOR RN2G, RNSG ***
-C
- INTEGER LH, LIV, LV, N, P
- INTEGER IV(LIV)
- REAL L(LH), V(LV)
-C
- EXTERNAL L7NVR, L7TSQ, V7SCL
-C
-C *** LOCAL VARIABLES ***
-C
- INTEGER COV, I
- REAL HALF
-C
-C *** SUBSCRIPTS FOR IV AND V ***
-C
- INTEGER CNVCOD, COVMAT, F, FDH, H, MODE, RDREQ, REGD
-C
-C/6
-C DATA CNVCOD/55/, COVMAT/26/, F/10/, FDH/74/, H/56/, MODE/35/,
-C 1 RDREQ/57/, REGD/67/
-C/7
- PARAMETER (CNVCOD=55, COVMAT=26, F=10, FDH=74, H=56, MODE=35,
- 1 RDREQ=57, REGD=67)
-C/
- DATA HALF/0.5E+0/
-C
-C *** BODY ***
-C
- IV(1) = IV(CNVCOD)
- I = IV(MODE) - P
- IV(MODE) = 0
- IV(CNVCOD) = 0
- IF (IV(FDH) .LE. 0) GO TO 999
- IF ((I-2)**2 .EQ. 1) IV(REGD) = 1
- IF (MOD(IV(RDREQ),2) .NE. 1) GO TO 999
-C
-C *** FINISH COMPUTING COVARIANCE MATRIX = INVERSE OF F.D. HESSIAN.
-C
- COV = IABS(IV(H))
- IV(FDH) = 0
-C
- IF (IV(COVMAT) .NE. 0) GO TO 999
- IF (I .GE. 2) GO TO 10
- CALL L7NVR(P, V(COV), L)
- CALL L7TSQ(P, V(COV), V(COV))
-C
- 10 CALL V7SCL(LH, V(COV), V(F)/(HALF * FLOAT(MAX0(1,N-P))), V(COV))
- IV(COVMAT) = COV
-C
- 999 RETURN
-C *** LAST LINE OF C7VFN FOLLOWS ***
- END
diff --git a/CEP/PyBDSM/src/port3/call.f b/CEP/PyBDSM/src/port3/call.f
deleted file mode 100644
index 6bb398e788cf5f83826af67752fd2a82cb786be7..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/call.f
+++ /dev/null
@@ -1,2 +0,0 @@
- call n2f
- end
diff --git a/CEP/PyBDSM/src/port3/cddiv.f b/CEP/PyBDSM/src/port3/cddiv.f
deleted file mode 100644
index 6090e139cac9b7a9623b23597eb025ed618fb8cb..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/cddiv.f
+++ /dev/null
@@ -1,34 +0,0 @@
- SUBROUTINE CDDIV(A,B,C)
- DOUBLE PRECISION A(2),B(2),C(2),G,H,T
-C
-C THIS ROUTINE DOES COMPLEX DOUBLE PRECISION
-C DIVISION (C=A/B), FOLLOWING THE METHOD
-C GIVEN IN ALGOL ON PAGES 357 AND 358 OF
-C WILKINSON AND REINSCHS BOOK-
-C HANDBOOK FOR AUTOMATIC COMPUTATION
-C SPRINGER-VERLAG 1971
-C
-C THIS VERSION HAS BEEN CHANGED SLIGHTLY TO PREVENT
-C INPUTS A AND B FROM BEING DESTROYED.
-C WRITTEN MARCH 20, 1975 BY P. FOX
-C
-C FOR ACCURACY THE COMPUTATION IS DONE DIFFERENTLY
-C DEPENDING ON WHETHER THE REAL OR IMAGINARY PART OF
-C B IS LARGER
-C
- IF ( DABS(B(1)) .GT. DABS(B(2)) ) GO TO 10
- H = B(1)/B(2)
- G = H*B(1) + B(2)
- T = A(1)
- C(1) = (H * T + A(2))/G
- C(2) = (H * A(2) - T)/G
- RETURN
-C
-C IF THE REAL PART OF B IS LARGER THAN THE IMAGINARY-
- 10 H = B(2)/B(1)
- G = H*B(2) + B(1)
- T = A(1)
- C(1) = ( T + H * A(2))/G
- C(2) = (A(2) - H * T)/G
- RETURN
- END
diff --git a/CEP/PyBDSM/src/port3/cmake_install.cmake b/CEP/PyBDSM/src/port3/cmake_install.cmake
deleted file mode 100644
index 765f31185c20eb00698d76c503fbcc1e809bcb4c..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/cmake_install.cmake
+++ /dev/null
@@ -1,41 +0,0 @@
-# Install script for directory: /Users/mohan/lofarsoft/src/pybdsm/implement/port3
-
-# Set the install prefix
-IF(NOT DEFINED CMAKE_INSTALL_PREFIX)
- SET(CMAKE_INSTALL_PREFIX "/usr/local")
-ENDIF(NOT DEFINED CMAKE_INSTALL_PREFIX)
-STRING(REGEX REPLACE "/$" "" CMAKE_INSTALL_PREFIX "${CMAKE_INSTALL_PREFIX}")
-
-# Set the install configuration name.
-IF(NOT DEFINED CMAKE_INSTALL_CONFIG_NAME)
- IF(BUILD_TYPE)
- STRING(REGEX REPLACE "^[^A-Za-z0-9_]+" ""
- CMAKE_INSTALL_CONFIG_NAME "${BUILD_TYPE}")
- ELSE(BUILD_TYPE)
- SET(CMAKE_INSTALL_CONFIG_NAME "")
- ENDIF(BUILD_TYPE)
- MESSAGE(STATUS "Install configuration: \"${CMAKE_INSTALL_CONFIG_NAME}\"")
-ENDIF(NOT DEFINED CMAKE_INSTALL_CONFIG_NAME)
-
-# Set the component getting installed.
-IF(NOT CMAKE_INSTALL_COMPONENT)
- IF(COMPONENT)
- MESSAGE(STATUS "Install component: \"${COMPONENT}\"")
- SET(CMAKE_INSTALL_COMPONENT "${COMPONENT}")
- ELSE(COMPONENT)
- SET(CMAKE_INSTALL_COMPONENT)
- ENDIF(COMPONENT)
-ENDIF(NOT CMAKE_INSTALL_COMPONENT)
-
-IF(NOT CMAKE_INSTALL_COMPONENT OR "${CMAKE_INSTALL_COMPONENT}" STREQUAL "Unspecified")
- FILE(INSTALL DESTINATION "${CMAKE_INSTALL_PREFIX}/lib" TYPE SHARED_LIBRARY FILES "/Users/mohan/lofarsoft/src/pybdsm/implement/port3/port3.so")
- IF(EXISTS "$ENV{DESTDIR}${CMAKE_INSTALL_PREFIX}/lib/port3.so")
- EXECUTE_PROCESS(COMMAND "/usr/bin/install_name_tool"
- -id "port3.so"
- "$ENV{DESTDIR}${CMAKE_INSTALL_PREFIX}/lib/port3.so")
- IF(CMAKE_INSTALL_DO_STRIP)
- EXECUTE_PROCESS(COMMAND "/usr/bin/strip" "$ENV{DESTDIR}${CMAKE_INSTALL_PREFIX}/lib/port3.so")
- ENDIF(CMAKE_INSTALL_DO_STRIP)
- ENDIF(EXISTS "$ENV{DESTDIR}${CMAKE_INSTALL_PREFIX}/lib/port3.so")
-ENDIF(NOT CMAKE_INSTALL_COMPONENT OR "${CMAKE_INSTALL_COMPONENT}" STREQUAL "Unspecified")
-
diff --git a/CEP/PyBDSM/src/port3/d0xtrp.f b/CEP/PyBDSM/src/port3/d0xtrp.f
deleted file mode 100644
index 64ed105a540c4aa2b58787d304d9d764b8f35be2..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/d0xtrp.f
+++ /dev/null
@@ -1,73 +0,0 @@
- SUBROUTINE D0XTRP(TM,M,NVAR,NG,KMAX,XPOLY,T,ERROR,EBEST,RHG,EMAG,
- 1 ESAVE)
-C
- DOUBLE PRECISION TM(NVAR),NG(M),T(NVAR,KMAX),RHG(1)
-C DOUBLE PRECISION RHG(MIN(M-1,KMAX))
- REAL ERROR(NVAR,1),EBEST(NVAR),EMAG(1)
-C REAL ERROR(NVAR,MIN(M-1,KMAX)),EMAG(MIN(M-1,KMAX))
- LOGICAL XPOLY,ESAVE
-C
- DOUBLE PRECISION U,V,TI,TV,TEMP
- REAL ERR
-C
- IF (M.GT.1) GO TO 20
-C
-C ... INITIALIZE T.
-C
- DO 10 I=1,NVAR
- 10 T(I,1)=TM(I)
-C
- GO TO 80
-C
- 20 MR=MIN0(M-1,KMAX)
-C
- DO 30 J=1,MR
- MMJ=M-J
- RHG(J)=NG(M)/NG(MMJ)
- EMAG(J)=1.0D0+1.0D0/(RHG(J)-1.0D0)
- IF (XPOLY) RHG(J)=RHG(J)-1.0D0
- 30 CONTINUE
-C
- DO 70 I=1,NVAR
-C
- V=0.0D0
- U=T(I,1)
- TI=TM(I)
- T(I,1)=TI
-C
- DO 60 J=1,MR
-C
-C ......... OBTAIN SIGNED ERROR ESTIMATE.
-C
- ERR=(T(I,J)-U)*EMAG(J)
- IF (ESAVE) ERROR(I,J)=ERR
- ERR=ABS(ERR)
- IF (J.EQ.1) EBEST(I)=ERR
- EBEST(I)=AMIN1(EBEST(I),ERR)
- IF (EBEST(I).EQ.ERR) JBEST=J
-C
- IF (J.EQ.KMAX) GO TO 60
-C
- IF (XPOLY) GO TO 40
-C
-C ......... RATIONAL EXTRAPOLATION.
-C
- TV=TI-V
- TEMP=RHG(J)*(U-V)-TV
- IF (TEMP.NE.0.0D0) TI=TI+(TI-U)*(TV/TEMP)
- V=U
- GO TO 50
-C
-C ......... POLYNOMIAL EXTRAPOLATION.
-C
- 40 TI=TI+(TI-U)/RHG(J)
-C
- 50 U=T(I,J+1)
- T(I,J+1)=TI
- 60 CONTINUE
-C
- 70 TM(I)=T(I,JBEST)
-C
- 80 RETURN
-C
- END
diff --git a/CEP/PyBDSM/src/port3/d1mach.f b/CEP/PyBDSM/src/port3/d1mach.f
deleted file mode 100644
index a321954554c3a9e23b5f0e55c0647692c1483eb6..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/d1mach.f
+++ /dev/null
@@ -1,212 +0,0 @@
- DOUBLE PRECISION FUNCTION D1MACH(I)
- INTEGER I
-C
-C DOUBLE-PRECISION MACHINE CONSTANTS
-C D1MACH( 1) = B**(EMIN-1), THE SMALLEST POSITIVE MAGNITUDE.
-C D1MACH( 2) = B**EMAX*(1 - B**(-T)), THE LARGEST MAGNITUDE.
-C D1MACH( 3) = B**(-T), THE SMALLEST RELATIVE SPACING.
-C D1MACH( 4) = B**(1-T), THE LARGEST RELATIVE SPACING.
-C D1MACH( 5) = LOG10(B)
-C
- INTEGER SMALL(2)
- INTEGER LARGE(2)
- INTEGER RIGHT(2)
- INTEGER DIVER(2)
- INTEGER LOG10(2)
- INTEGER SC, CRAY1(38), J
-C *************************
-C commented out by Usov. We don't have CRAY machines anyway :)
-C COMMON /D9MACH/ CRAY1
-C *************************
- SAVE SMALL, LARGE, RIGHT, DIVER, LOG10, SC
- DOUBLE PRECISION DMACH(5)
- EQUIVALENCE (DMACH(1),SMALL(1))
- EQUIVALENCE (DMACH(2),LARGE(1))
- EQUIVALENCE (DMACH(3),RIGHT(1))
- EQUIVALENCE (DMACH(4),DIVER(1))
- EQUIVALENCE (DMACH(5),LOG10(1))
-C THIS VERSION ADAPTS AUTOMATICALLY TO MOST CURRENT MACHINES.
-C R1MACH CAN HANDLE AUTO-DOUBLE COMPILING, BUT THIS VERSION OF
-C D1MACH DOES NOT, BECAUSE WE DO NOT HAVE QUAD CONSTANTS FOR
-C MANY MACHINES YET.
-C TO COMPILE ON OLDER MACHINES, ADD A C IN COLUMN 1
-C ON THE NEXT LINE
- DATA SC/0/
-C AND REMOVE THE C FROM COLUMN 1 IN ONE OF THE SECTIONS BELOW.
-C CONSTANTS FOR EVEN OLDER MACHINES CAN BE OBTAINED BY
-C mail netlib@research.bell-labs.com
-C send old1mach from blas
-C PLEASE SEND CORRECTIONS TO dmg OR ehg@bell-labs.com.
-C
-C MACHINE CONSTANTS FOR THE HONEYWELL DPS 8/70 SERIES.
-C DATA SMALL(1),SMALL(2) / O402400000000, O000000000000 /
-C DATA LARGE(1),LARGE(2) / O376777777777, O777777777777 /
-C DATA RIGHT(1),RIGHT(2) / O604400000000, O000000000000 /
-C DATA DIVER(1),DIVER(2) / O606400000000, O000000000000 /
-C DATA LOG10(1),LOG10(2) / O776464202324, O117571775714 /, SC/987/
-C
-C MACHINE CONSTANTS FOR PDP-11 FORTRANS SUPPORTING
-C 32-BIT INTEGERS.
-C DATA SMALL(1),SMALL(2) / 8388608, 0 /
-C DATA LARGE(1),LARGE(2) / 2147483647, -1 /
-C DATA RIGHT(1),RIGHT(2) / 612368384, 0 /
-C DATA DIVER(1),DIVER(2) / 620756992, 0 /
-C DATA LOG10(1),LOG10(2) / 1067065498, -2063872008 /, SC/987/
-C
-C MACHINE CONSTANTS FOR THE UNIVAC 1100 SERIES.
-C DATA SMALL(1),SMALL(2) / O000040000000, O000000000000 /
-C DATA LARGE(1),LARGE(2) / O377777777777, O777777777777 /
-C DATA RIGHT(1),RIGHT(2) / O170540000000, O000000000000 /
-C DATA DIVER(1),DIVER(2) / O170640000000, O000000000000 /
-C DATA LOG10(1),LOG10(2) / O177746420232, O411757177572 /, SC/987/
-C
-C ON FIRST CALL, IF NO DATA UNCOMMENTED, TEST MACHINE TYPES.
- IF (SC .NE. 987) THEN
- DMACH(1) = 1.D13
- IF ( SMALL(1) .EQ. 1117925532
- * .AND. SMALL(2) .EQ. -448790528) THEN
-* *** IEEE BIG ENDIAN ***
- SMALL(1) = 1048576
- SMALL(2) = 0
- LARGE(1) = 2146435071
- LARGE(2) = -1
- RIGHT(1) = 1017118720
- RIGHT(2) = 0
- DIVER(1) = 1018167296
- DIVER(2) = 0
- LOG10(1) = 1070810131
- LOG10(2) = 1352628735
- ELSE IF ( SMALL(2) .EQ. 1117925532
- * .AND. SMALL(1) .EQ. -448790528) THEN
-* *** IEEE LITTLE ENDIAN ***
- SMALL(2) = 1048576
- SMALL(1) = 0
- LARGE(2) = 2146435071
- LARGE(1) = -1
- RIGHT(2) = 1017118720
- RIGHT(1) = 0
- DIVER(2) = 1018167296
- DIVER(1) = 0
- LOG10(2) = 1070810131
- LOG10(1) = 1352628735
- ELSE IF ( SMALL(1) .EQ. -2065213935
- * .AND. SMALL(2) .EQ. 10752) THEN
-* *** VAX WITH D_FLOATING ***
- SMALL(1) = 128
- SMALL(2) = 0
- LARGE(1) = -32769
- LARGE(2) = -1
- RIGHT(1) = 9344
- RIGHT(2) = 0
- DIVER(1) = 9472
- DIVER(2) = 0
- LOG10(1) = 546979738
- LOG10(2) = -805796613
- ELSE IF ( SMALL(1) .EQ. 1267827943
- * .AND. SMALL(2) .EQ. 704643072) THEN
-* *** IBM MAINFRAME ***
- SMALL(1) = 1048576
- SMALL(2) = 0
- LARGE(1) = 2147483647
- LARGE(2) = -1
- RIGHT(1) = 856686592
- RIGHT(2) = 0
- DIVER(1) = 873463808
- DIVER(2) = 0
- LOG10(1) = 1091781651
- LOG10(2) = 1352628735
- ELSE IF ( SMALL(1) .EQ. 1120022684
- * .AND. SMALL(2) .EQ. -448790528) THEN
-* *** CONVEX C-1 ***
- SMALL(1) = 1048576
- SMALL(2) = 0
- LARGE(1) = 2147483647
- LARGE(2) = -1
- RIGHT(1) = 1019215872
- RIGHT(2) = 0
- DIVER(1) = 1020264448
- DIVER(2) = 0
- LOG10(1) = 1072907283
- LOG10(2) = 1352628735
- ELSE IF ( SMALL(1) .EQ. 815547074
- * .AND. SMALL(2) .EQ. 58688) THEN
-* *** VAX G-FLOATING ***
- SMALL(1) = 16
- SMALL(2) = 0
- LARGE(1) = -32769
- LARGE(2) = -1
- RIGHT(1) = 15552
- RIGHT(2) = 0
- DIVER(1) = 15568
- DIVER(2) = 0
- LOG10(1) = 1142112243
- LOG10(2) = 2046775455
- ELSE
- DMACH(2) = 1.D27 + 1
- DMACH(3) = 1.D27
- LARGE(2) = LARGE(2) - RIGHT(2)
- IF (LARGE(2) .EQ. 64 .AND. SMALL(2) .EQ. 0) THEN
- CRAY1(1) = 67291416
- DO 10 J = 1, 20
- CRAY1(J+1) = CRAY1(J) + CRAY1(J)
- 10 CONTINUE
- CRAY1(22) = CRAY1(21) + 321322
- DO 20 J = 22, 37
- CRAY1(J+1) = CRAY1(J) + CRAY1(J)
- 20 CONTINUE
- IF (CRAY1(38) .EQ. SMALL(1)) THEN
-* *** CRAY ***
- CALL I1MCRY(SMALL(1), J, 8285, 8388608, 0)
- SMALL(2) = 0
- CALL I1MCRY(LARGE(1), J, 24574, 16777215, 16777215)
- CALL I1MCRY(LARGE(2), J, 0, 16777215, 16777214)
- CALL I1MCRY(RIGHT(1), J, 16291, 8388608, 0)
- RIGHT(2) = 0
- CALL I1MCRY(DIVER(1), J, 16292, 8388608, 0)
- DIVER(2) = 0
- CALL I1MCRY(LOG10(1), J, 16383, 10100890, 8715215)
- CALL I1MCRY(LOG10(2), J, 0, 16226447, 9001388)
- ELSE
- WRITE(*,9000)
- STOP 779
- END IF
- ELSE
- WRITE(*,9000)
- STOP 779
- END IF
- END IF
- SC = 987
- END IF
-* SANITY CHECK
- IF (DMACH(4) .GE. 1.0D0) STOP 778
- IF (I .LT. 1 .OR. I .GT. 5) THEN
- WRITE(*,*) 'D1MACH(I): I =',I,' is out of bounds.'
- STOP
- END IF
- D1MACH = DMACH(I)
- RETURN
- 9000 FORMAT(/' Adjust D1MACH by uncommenting data statements'/
- *' appropriate for your machine.')
-* /* Standard C source for D1MACH -- remove the * in column 1 */
-*#include <stdio.h>
-*#include <float.h>
-*#include <math.h>
-*double d1mach_(long *i)
-*{
-* switch(*i){
-* case 1: return DBL_MIN;
-* case 2: return DBL_MAX;
-* case 3: return DBL_EPSILON/FLT_RADIX;
-* case 4: return DBL_EPSILON;
-* case 5: return log10((double)FLT_RADIX);
-* }
-* fprintf(stderr, "invalid argument: d1mach(%ld)\n", *i);
-* exit(1); return 0; /* some compilers demand return values */
-*}
- END
- SUBROUTINE I1MCRY(A, A1, B, C, D)
-**** SPECIAL COMPUTATION FOR OLD CRAY MACHINES ****
- INTEGER A, A1, B, C, D
- A1 = 16777216*B + C
- A = 16777216*A1 + D
- END
diff --git a/CEP/PyBDSM/src/port3/d4sqr.f b/CEP/PyBDSM/src/port3/d4sqr.f
deleted file mode 100644
index 79bb47ca8c1e51bb6b12c1f6fa366ab95e88fe72..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/d4sqr.f
+++ /dev/null
@@ -1,37 +0,0 @@
- SUBROUTINE D4SQR(K, M, N, Q, R, B, RHS)
- INTEGER M
- INTEGER N
- REAL Q(K, 1), R( 1), B(1), RHS(K)
- INTEGER I
- REAL BETA, ALPHA,U, X
-C
-C THIS SUBROUTINE UPDATES THE QR DECOMPOSTION WHENE A NEW
-C ROW CONTAINED IN B IS ADDED TO THE MATRIX
-C
- M=M+1
- MM1=M-1
-C
-C ZERO OUT ROW AND COLUMN OF Q MATRIX
-C
- Q(M,M)=1.
- IF(M.EQ.1)RETURN
- DO 10 II=1,MM1
- Q(M,II)=0.0
- Q(II,M)=0.0
- 10 CONTINUE
- X=RHS(M)
- IF (N.EQ.0) RETURN
- IS=1
- DO 20 I=1,N
- CALL SROTG(R(IS), B(I), ALPHA, BETA)
- CALL SROT(M, Q(I, 1), K, Q(M, 1), K, ALPHA, BETA)
- U=RHS(I)
- RHS(I)=ALPHA*U+BETA*X
- X=-BETA*U+ALPHA*X
- IS=IS+I+1
- IF (N-I.GE.1)
- 1 CALL SROT2(N-I,R(IS-1),I+1,B(I+1),-1,ALPHA,BETA)
- 20 CONTINUE
- RHS(M)=X
- RETURN
- END
diff --git a/CEP/PyBDSM/src/port3/d7dgb.f b/CEP/PyBDSM/src/port3/d7dgb.f
deleted file mode 100644
index 8318aae44b21186fb4765aae2bf75ff5d91df070..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/d7dgb.f
+++ /dev/null
@@ -1,177 +0,0 @@
- SUBROUTINE D7DGB(B, D, DIG, DST, G, IPIV, KA, L, LV, P, PC,
- 1 NWTST, STEP, TD, TG, V, W, X0)
-C
-C *** COMPUTE DOUBLE-DOGLEG STEP, SUBJECT TO SIMPLE BOUNDS ON X ***
-C
- INTEGER LV, KA, P, PC
- INTEGER IPIV(P)
- REAL B(2,P), D(P), DIG(P), DST(P), G(P), L(1),
- 1 NWTST(P), STEP(P), TD(P), TG(P), V(LV), W(P),
- 2 X0(P)
-C
-C DIMENSION L(P*(P+1)/2)
-C
- REAL D7TPR, R7MDC, V2NRM
- EXTERNAL D7DOG, D7TPR, I7SHFT, L7ITV, L7IVM, L7TVM, L7VML,
- 1 Q7RSH, R7MDC, V2NRM, V2AXY, V7CPY, V7IPR, V7SCP,
- 2 V7SHF, V7VMP
-C
-C *** LOCAL VARIABLES ***
-C
- INTEGER I, J, K, P1, P1M1
- REAL DNWTST, GHINVG, GNORM, GNORM0, NRED, PRED, RAD,
- 1 T, T1, T2, TI, X0I, XI
- REAL HALF, MEPS2, ONE, TWO, ZERO
-C
-C *** V SUBSCRIPTS ***
-C
- INTEGER DGNORM, DST0, DSTNRM, GRDFAC, GTHG, GTSTEP, NREDUC,
- 1 NWTFAC, PREDUC, RADIUS, STPPAR
-C
-C/6
-C DATA DGNORM/1/, DST0/3/, DSTNRM/2/, GRDFAC/45/, GTHG/44/,
-C 1 GTSTEP/4/, NREDUC/6/, NWTFAC/46/, PREDUC/7/, RADIUS/8/,
-C 2 STPPAR/5/
-C/7
- PARAMETER (DGNORM=1, DST0=3, DSTNRM=2, GRDFAC=45, GTHG=44,
- 1 GTSTEP=4, NREDUC=6, NWTFAC=46, PREDUC=7, RADIUS=8,
- 2 STPPAR=5)
-C/
-C/6
-C DATA HALF/0.5E+0/, ONE/1.E+0/, TWO/2.E+0/, ZERO/0.E+0/
-C/7
- PARAMETER (HALF=0.5E+0, ONE=1.E+0, TWO=2.E+0, ZERO=0.E+0)
- SAVE MEPS2
-C/
- DATA MEPS2/0.E+0/
-C
-C+++++++++++++++++++++++++++++++ BODY ++++++++++++++++++++++++++++++++
-C
- IF (MEPS2 .LE. ZERO) MEPS2 = TWO * R7MDC(3)
- GNORM0 = V(DGNORM)
- V(DSTNRM) = ZERO
- IF (KA .LT. 0) GO TO 10
- DNWTST = V(DST0)
- NRED = V(NREDUC)
- 10 PRED = ZERO
- V(STPPAR) = ZERO
- RAD = V(RADIUS)
- IF (PC .GT. 0) GO TO 20
- DNWTST = ZERO
- CALL V7SCP(P, STEP, ZERO)
- GO TO 140
-C
- 20 P1 = PC
- CALL V7CPY(P, TD, D)
- CALL V7IPR(P, IPIV, TD)
- CALL V7SCP(PC, DST, ZERO)
- CALL V7CPY(P, TG, G)
- CALL V7IPR(P, IPIV, TG)
-C
- 30 CALL L7IVM(P1, NWTST, L, TG)
- GHINVG = D7TPR(P1, NWTST, NWTST)
- V(NREDUC) = HALF * GHINVG
- CALL L7ITV(P1, NWTST, L, NWTST)
- CALL V7VMP(P1, STEP, NWTST, TD, 1)
- V(DST0) = V2NRM(PC, STEP)
- IF (KA .GE. 0) GO TO 40
- KA = 0
- DNWTST = V(DST0)
- NRED = V(NREDUC)
- 40 V(RADIUS) = RAD - V(DSTNRM)
- IF (V(RADIUS) .LE. ZERO) GO TO 100
- CALL V7VMP(P1, DIG, TG, TD, -1)
- GNORM = V2NRM(P1, DIG)
- IF (GNORM .LE. ZERO) GO TO 100
- V(DGNORM) = GNORM
- CALL V7VMP(P1, DIG, DIG, TD, -1)
- CALL L7TVM(P1, W, L, DIG)
- V(GTHG) = V2NRM(P1, W)
- KA = KA + 1
- CALL D7DOG(DIG, LV, P1, NWTST, STEP, V)
-C
-C *** FIND T SUCH THAT X - T*STEP IS STILL FEASIBLE.
-C
- T = ONE
- K = 0
- DO 70 I = 1, P1
- J = IPIV(I)
- X0I = X0(J) + DST(I)/TD(I)
- XI = X0I + STEP(I)
- IF (XI .LT. B(1,J)) GO TO 50
- IF (XI .LE. B(2,J)) GO TO 70
- TI = (B(2,J) - X0I) / STEP(I)
- J = I
- GO TO 60
- 50 TI = (B(1,J) - X0I) / STEP(I)
- J = -I
- 60 IF (T .LE. TI) GO TO 70
- K = J
- T = TI
- 70 CONTINUE
-C
-C *** UPDATE DST, TG, AND PRED ***
-C
- CALL V7VMP(P1, STEP, STEP, TD, 1)
- CALL V2AXY(P1, DST, T, STEP, DST)
- V(DSTNRM) = V2NRM(PC, DST)
- T1 = T * V(GRDFAC)
- T2 = T * V(NWTFAC)
- PRED = PRED - T1*GNORM * ((T2 + ONE)*GNORM)
- 1 - T2 * (ONE + HALF*T2)*GHINVG
- 2 - HALF * (V(GTHG)*T1)**2
- IF (K .EQ. 0) GO TO 100
- CALL L7VML(P1, W, L, W)
- T2 = ONE - T2
- DO 80 I = 1, P1
- 80 TG(I) = T2*TG(I) - T1*W(I)
-C
-C *** PERMUTE L, ETC. IF NECESSARY ***
-C
- P1M1 = P1 - 1
- J = IABS(K)
- IF (J .EQ. P1) GO TO 90
- CALL Q7RSH(J, P1, .FALSE., TG, L, W)
- CALL I7SHFT(P1, J, IPIV)
- CALL V7SHF(P1, J, TG)
- CALL V7SHF(P1, J, TD)
- CALL V7SHF(P1, J, DST)
- 90 IF (K .LT. 0) IPIV(P1) = -IPIV(P1)
- P1 = P1M1
- IF (P1 .GT. 0) GO TO 30
-C
-C *** UNSCALE STEP, UPDATE X AND DIHDI ***
-C
- 100 CALL V7SCP(P, STEP, ZERO)
- DO 110 I = 1, PC
- J = IABS(IPIV(I))
- STEP(J) = DST(I) / TD(I)
- 110 CONTINUE
-C
-C *** FUDGE STEP TO ENSURE THAT IT FORCES APPROPRIATE COMPONENTS
-C *** TO THEIR BOUNDS ***
-C
- IF (P1 .GE. PC) GO TO 140
- CALL V2AXY(P, TD, ONE, STEP, X0)
- K = P1 + 1
- DO 130 I = K, PC
- J = IPIV(I)
- T = MEPS2
- IF (J .GT. 0) GO TO 120
- T = -T
- J = -J
- IPIV(I) = J
- 120 T = T * AMAX1( ABS(TD(J)), ABS(X0(J)))
- STEP(J) = STEP(J) + T
- 130 CONTINUE
-C
- 140 V(DGNORM) = GNORM0
- V(NREDUC) = NRED
- V(PREDUC) = PRED
- V(RADIUS) = RAD
- V(DST0) = DNWTST
- V(GTSTEP) = D7TPR(P, STEP, G)
-C
- 999 RETURN
-C *** LAST LINE OF D7DGB FOLLOWS ***
- END
diff --git a/CEP/PyBDSM/src/port3/d7dog.f b/CEP/PyBDSM/src/port3/d7dog.f
deleted file mode 100644
index 75cf7e6c95f5ee3fb1fcc38752b370311b9fcf1a..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/d7dog.f
+++ /dev/null
@@ -1,201 +0,0 @@
- SUBROUTINE D7DOG(DIG, LV, N, NWTSTP, STEP, V)
-C
-C *** COMPUTE DOUBLE DOGLEG STEP ***
-C
-C *** PARAMETER DECLARATIONS ***
-C
- INTEGER LV, N
- REAL DIG(N), NWTSTP(N), STEP(N), V(LV)
-C
-C *** PURPOSE ***
-C
-C THIS SUBROUTINE COMPUTES A CANDIDATE STEP (FOR _USE_ IN AN UNCON-
-C STRAINED MINIMIZATION CODE) BY THE DOUBLE DOGLEG ALGORITHM OF
-C DENNIS AND MEI (REF. 1), WHICH IS A VARIATION ON POWELL*S DOGLEG
-C SCHEME (REF. 2, P. 95).
-C
-C-------------------------- PARAMETER USAGE --------------------------
-C
-C DIG (INPUT) DIAG(D)**-2 * G -- SEE ALGORITHM NOTES.
-C G (INPUT) THE CURRENT GRADIENT VECTOR.
-C LV (INPUT) LENGTH OF V.
-C N (INPUT) NUMBER OF COMPONENTS IN DIG, G, NWTSTP, AND STEP.
-C NWTSTP (INPUT) NEGATIVE NEWTON STEP -- SEE ALGORITHM NOTES.
-C STEP (OUTPUT) THE COMPUTED STEP.
-C V (I/O) VALUES ARRAY, THE FOLLOWING COMPONENTS OF WHICH ARE
-C USED HERE...
-C V(BIAS) (INPUT) BIAS FOR RELAXED NEWTON STEP, WHICH IS V(BIAS) OF
-C THE WAY FROM THE FULL NEWTON TO THE FULLY RELAXED NEWTON
-C STEP. RECOMMENDED VALUE = 0.8 .
-C V(DGNORM) (INPUT) 2-NORM OF DIAG(D)**-1 * G -- SEE ALGORITHM NOTES.
-C V(DSTNRM) (OUTPUT) 2-NORM OF DIAG(D) * STEP, WHICH IS V(RADIUS)
-C UNLESS V(STPPAR) = 0 -- SEE ALGORITHM NOTES.
-C V(DST0) (INPUT) 2-NORM OF DIAG(D) * NWTSTP -- SEE ALGORITHM NOTES.
-C V(GRDFAC) (OUTPUT) THE COEFFICIENT OF DIG IN THE STEP RETURNED --
-C STEP(I) = V(GRDFAC)*DIG(I) + V(NWTFAC)*NWTSTP(I).
-C V(GTHG) (INPUT) SQUARE-ROOT OF (DIG**T) * (HESSIAN) * DIG -- SEE
-C ALGORITHM NOTES.
-C V(GTSTEP) (OUTPUT) INNER PRODUCT BETWEEN G AND STEP.
-C V(NREDUC) (OUTPUT) FUNCTION REDUCTION PREDICTED FOR THE FULL NEWTON
-C STEP.
-C V(NWTFAC) (OUTPUT) THE COEFFICIENT OF NWTSTP IN THE STEP RETURNED --
-C SEE V(GRDFAC) ABOVE.
-C V(PREDUC) (OUTPUT) FUNCTION REDUCTION PREDICTED FOR THE STEP RETURNED.
-C V(RADIUS) (INPUT) THE TRUST REGION RADIUS. D TIMES THE STEP RETURNED
-C HAS 2-NORM V(RADIUS) UNLESS V(STPPAR) = 0.
-C V(STPPAR) (OUTPUT) CODE TELLING HOW STEP WAS COMPUTED... 0 MEANS A
-C FULL NEWTON STEP. BETWEEN 0 AND 1 MEANS V(STPPAR) OF THE
-C WAY FROM THE NEWTON TO THE RELAXED NEWTON STEP. BETWEEN
-C 1 AND 2 MEANS A TRUE DOUBLE DOGLEG STEP, V(STPPAR) - 1 OF
-C THE WAY FROM THE RELAXED NEWTON TO THE CAUCHY STEP.
-C GREATER THAN 2 MEANS 1 / (V(STPPAR) - 1) TIMES THE CAUCHY
-C STEP.
-C
-C------------------------------- NOTES -------------------------------
-C
-C *** ALGORITHM NOTES ***
-C
-C LET G AND H BE THE CURRENT GRADIENT AND HESSIAN APPROXIMA-
-C TION RESPECTIVELY AND LET D BE THE CURRENT SCALE VECTOR. THIS
-C ROUTINE ASSUMES DIG = DIAG(D)**-2 * G AND NWTSTP = H**-1 * G.
-C THE STEP COMPUTED IS THE SAME ONE WOULD GET BY REPLACING G AND H
-C BY DIAG(D)**-1 * G AND DIAG(D)**-1 * H * DIAG(D)**-1,
-C COMPUTING STEP, AND TRANSLATING STEP BACK TO THE ORIGINAL
-C VARIABLES, I.E., PREMULTIPLYING IT BY DIAG(D)**-1.
-C
-C *** REFERENCES ***
-C
-C 1. DENNIS, J.E., AND MEI, H.H.W. (1979), TWO NEW UNCONSTRAINED OPTI-
-C MIZATION ALGORITHMS WHICH _USE_ FUNCTION AND GRADIENT
-C VALUES, J. OPTIM. THEORY APPLIC. 28, PP. 453-482.
-C 2. POWELL, M.J.D. (1970), A HYBRID METHOD FOR NON-LINEAR EQUATIONS,
-C IN NUMERICAL METHODS FOR NON-LINEAR EQUATIONS, EDITED BY
-C P. RABINOWITZ, GORDON AND BREACH, LONDON.
-C
-C *** GENERAL ***
-C
-C CODED BY DAVID M. GAY.
-C THIS SUBROUTINE WAS WRITTEN IN CONNECTION WITH RESEARCH SUPPORTED
-C BY THE NATIONAL SCIENCE FOUNDATION UNDER GRANTS MCS-7600324 AND
-C MCS-7906671.
-C
-C------------------------ EXTERNAL QUANTITIES ------------------------
-C
-C *** INTRINSIC FUNCTIONS ***
-C/+
- REAL SQRT
-C/
-C-------------------------- LOCAL VARIABLES --------------------------
-C
- INTEGER I
- REAL CFACT, CNORM, CTRNWT, GHINVG, FEMNSQ, GNORM,
- 1 NWTNRM, RELAX, RLAMBD, T, T1, T2
- REAL HALF, ONE, TWO, ZERO
-C
-C *** V SUBSCRIPTS ***
-C
- INTEGER BIAS, DGNORM, DSTNRM, DST0, GRDFAC, GTHG, GTSTEP,
- 1 NREDUC, NWTFAC, PREDUC, RADIUS, STPPAR
-C
-C *** DATA INITIALIZATIONS ***
-C
-C/6
-C DATA HALF/0.5E+0/, ONE/1.E+0/, TWO/2.E+0/, ZERO/0.E+0/
-C/7
- PARAMETER (HALF=0.5E+0, ONE=1.E+0, TWO=2.E+0, ZERO=0.E+0)
-C/
-C
-C/6
-C DATA BIAS/43/, DGNORM/1/, DSTNRM/2/, DST0/3/, GRDFAC/45/,
-C 1 GTHG/44/, GTSTEP/4/, NREDUC/6/, NWTFAC/46/, PREDUC/7/,
-C 2 RADIUS/8/, STPPAR/5/
-C/7
- PARAMETER (BIAS=43, DGNORM=1, DSTNRM=2, DST0=3, GRDFAC=45,
- 1 GTHG=44, GTSTEP=4, NREDUC=6, NWTFAC=46, PREDUC=7,
- 2 RADIUS=8, STPPAR=5)
-C/
-C
-C+++++++++++++++++++++++++++++++ BODY ++++++++++++++++++++++++++++++++
-C
- NWTNRM = V(DST0)
- RLAMBD = ONE
- IF (NWTNRM .GT. ZERO) RLAMBD = V(RADIUS) / NWTNRM
- GNORM = V(DGNORM)
- GHINVG = TWO * V(NREDUC)
- V(GRDFAC) = ZERO
- V(NWTFAC) = ZERO
- IF (RLAMBD .LT. ONE) GO TO 30
-C
-C *** THE NEWTON STEP IS INSIDE THE TRUST REGION ***
-C
- V(STPPAR) = ZERO
- V(DSTNRM) = NWTNRM
- V(GTSTEP) = -GHINVG
- V(PREDUC) = V(NREDUC)
- V(NWTFAC) = -ONE
- DO 20 I = 1, N
- 20 STEP(I) = -NWTSTP(I)
- GO TO 999
-C
- 30 V(DSTNRM) = V(RADIUS)
- CFACT = (GNORM / V(GTHG))**2
-C *** CAUCHY STEP = -CFACT * G.
- CNORM = GNORM * CFACT
- RELAX = ONE - V(BIAS) * (ONE - GNORM*CNORM/GHINVG)
- IF (RLAMBD .LT. RELAX) GO TO 50
-C
-C *** STEP IS BETWEEN RELAXED NEWTON AND FULL NEWTON STEPS ***
-C
- V(STPPAR) = ONE - (RLAMBD - RELAX) / (ONE - RELAX)
- T = -RLAMBD
- V(GTSTEP) = T * GHINVG
- V(PREDUC) = RLAMBD * (ONE - HALF*RLAMBD) * GHINVG
- V(NWTFAC) = T
- DO 40 I = 1, N
- 40 STEP(I) = T * NWTSTP(I)
- GO TO 999
-C
- 50 IF (CNORM .LT. V(RADIUS)) GO TO 70
-C
-C *** THE CAUCHY STEP LIES OUTSIDE THE TRUST REGION --
-C *** STEP = SCALED CAUCHY STEP ***
-C
- T = -V(RADIUS) / GNORM
- V(GRDFAC) = T
- V(STPPAR) = ONE + CNORM / V(RADIUS)
- V(GTSTEP) = -V(RADIUS) * GNORM
- V(PREDUC) = V(RADIUS)*(GNORM - HALF*V(RADIUS)*(V(GTHG)/GNORM)**2)
- DO 60 I = 1, N
- 60 STEP(I) = T * DIG(I)
- GO TO 999
-C
-C *** COMPUTE DOGLEG STEP BETWEEN CAUCHY AND RELAXED NEWTON ***
-C *** FEMUR = RELAXED NEWTON STEP MINUS CAUCHY STEP ***
-C
- 70 CTRNWT = CFACT * RELAX * GHINVG / GNORM
-C *** CTRNWT = INNER PROD. OF CAUCHY AND RELAXED NEWTON STEPS,
-C *** SCALED BY GNORM**-1.
- T1 = CTRNWT - GNORM*CFACT**2
-C *** T1 = INNER PROD. OF FEMUR AND CAUCHY STEP, SCALED BY
-C *** GNORM**-1.
- T2 = V(RADIUS)*(V(RADIUS)/GNORM) - GNORM*CFACT**2
- T = RELAX * NWTNRM
- FEMNSQ = (T/GNORM)*T - CTRNWT - T1
-C *** FEMNSQ = SQUARE OF 2-NORM OF FEMUR, SCALED BY GNORM**-1.
- T = T2 / (T1 + SQRT(T1**2 + FEMNSQ*T2))
-C *** DOGLEG STEP = CAUCHY STEP + T * FEMUR.
- T1 = (T - ONE) * CFACT
- V(GRDFAC) = T1
- T2 = -T * RELAX
- V(NWTFAC) = T2
- V(STPPAR) = TWO - T
- V(GTSTEP) = T1*GNORM**2 + T2*GHINVG
- V(PREDUC) = -T1*GNORM * ((T2 + ONE)*GNORM)
- 1 - T2 * (ONE + HALF*T2)*GHINVG
- 2 - HALF * (V(GTHG)*T1)**2
- DO 80 I = 1, N
- 80 STEP(I) = T1*DIG(I) + T2*NWTSTP(I)
-C
- 999 RETURN
-C *** LAST LINE OF D7DOG FOLLOWS ***
- END
diff --git a/CEP/PyBDSM/src/port3/d7dup.f b/CEP/PyBDSM/src/port3/d7dup.f
deleted file mode 100644
index 2f7592cccf2ec875a5b9475b66b47b1d83b30613..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/d7dup.f
+++ /dev/null
@@ -1,48 +0,0 @@
- SUBROUTINE D7DUP(D, HDIAG, IV, LIV, LV, N, V)
-C
-C *** UPDATE SCALE VECTOR D FOR MNH ***
-C
-C *** PARAMETER DECLARATIONS ***
-C
- INTEGER LIV, LV, N
- INTEGER IV(LIV)
- REAL D(N), HDIAG(N), V(LV)
-C
-C *** LOCAL VARIABLES ***
-C
- INTEGER DTOLI, D0I, I
- REAL T, VDFAC
-C
-C *** INTRINSIC FUNCTIONS ***
-C/+
- REAL SQRT
-C/
-C *** SUBSCRIPTS FOR IV AND V ***
-C
- INTEGER DFAC, DTOL, DTYPE, NITER
-C/6
-C DATA DFAC/41/, DTOL/59/, DTYPE/16/, NITER/31/
-C/7
- PARAMETER (DFAC=41, DTOL=59, DTYPE=16, NITER=31)
-C/
-C
-C------------------------------- BODY --------------------------------
-C
- I = IV(DTYPE)
- IF (I .EQ. 1) GO TO 10
- IF (IV(NITER) .GT. 0) GO TO 999
-C
- 10 DTOLI = IV(DTOL)
- D0I = DTOLI + N
- VDFAC = V(DFAC)
- DO 20 I = 1, N
- T = AMAX1( SQRT( ABS(HDIAG(I))), VDFAC*D(I))
- IF (T .LT. V(DTOLI)) T = AMAX1(V(DTOLI), V(D0I))
- D(I) = T
- DTOLI = DTOLI + 1
- D0I = D0I + 1
- 20 CONTINUE
-C
- 999 RETURN
-C *** LAST CARD OF D7DUP FOLLOWS ***
- END
diff --git a/CEP/PyBDSM/src/port3/d7egr.f b/CEP/PyBDSM/src/port3/d7egr.f
deleted file mode 100644
index 5f353f754c8995de55850e5f33c37429319a91f0..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/d7egr.f
+++ /dev/null
@@ -1,133 +0,0 @@
- SUBROUTINE D7EGR(N,INDROW,JPNTR,INDCOL,IPNTR,NDEG,IWA,BWA)
- INTEGER N
- INTEGER INDROW(1),JPNTR(1),INDCOL(1),IPNTR(1),NDEG(N),IWA(N)
- LOGICAL BWA(N)
-C **********
-C
-C SUBROUTINE D7EGR
-C
-C GIVEN THE SPARSITY PATTERN OF AN M BY N MATRIX A,
-C THIS SUBROUTINE DETERMINES THE DEGREE SEQUENCE FOR
-C THE INTERSECTION GRAPH OF THE COLUMNS OF A.
-C
-C IN GRAPH-THEORY TERMINOLOGY, THE INTERSECTION GRAPH OF
-C THE COLUMNS OF A IS THE LOOPLESS GRAPH G WITH VERTICES
-C A(J), J = 1,2,...,N WHERE A(J) IS THE J-TH COLUMN OF A
-C AND WITH EDGE (A(I),A(J)) IF AND ONLY IF COLUMNS I AND J
-C HAVE A NON-ZERO IN THE SAME ROW POSITION.
-C
-C NOTE THAT THE VALUE OF M IS NOT NEEDED BY D7EGR AND IS
-C THEREFORE NOT PRESENT IN THE SUBROUTINE STATEMENT.
-C
-C THE SUBROUTINE STATEMENT IS
-C
-C SUBROUTINE D7EGR(N,INDROW,JPNTR,INDCOL,IPNTR,NDEG,IWA,BWA)
-C
-C WHERE
-C
-C N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER
-C OF COLUMNS OF A.
-C
-C INDROW IS AN INTEGER INPUT ARRAY WHICH CONTAINS THE ROW
-C INDICES FOR THE NON-ZEROES IN THE MATRIX A.
-C
-C JPNTR IS AN INTEGER INPUT ARRAY OF LENGTH N + 1 WHICH
-C SPECIFIES THE LOCATIONS OF THE ROW INDICES IN INDROW.
-C THE ROW INDICES FOR COLUMN J ARE
-C
-C INDROW(K), K = JPNTR(J),...,JPNTR(J+1)-1.
-C
-C NOTE THAT JPNTR(N+1)-1 IS THEN THE NUMBER OF NON-ZERO
-C ELEMENTS OF THE MATRIX A.
-C
-C INDCOL IS AN INTEGER INPUT ARRAY WHICH CONTAINS THE
-C COLUMN INDICES FOR THE NON-ZEROES IN THE MATRIX A.
-C
-C IPNTR IS AN INTEGER INPUT ARRAY OF LENGTH M + 1 WHICH
-C SPECIFIES THE LOCATIONS OF THE COLUMN INDICES IN INDCOL.
-C THE COLUMN INDICES FOR ROW I ARE
-C
-C INDCOL(K), K = IPNTR(I),...,IPNTR(I+1)-1.
-C
-C NOTE THAT IPNTR(M+1)-1 IS THEN THE NUMBER OF NON-ZERO
-C ELEMENTS OF THE MATRIX A.
-C
-C NDEG IS AN INTEGER OUTPUT ARRAY OF LENGTH N WHICH
-C SPECIFIES THE DEGREE SEQUENCE. THE DEGREE OF THE
-C J-TH COLUMN OF A IS NDEG(J).
-C
-C IWA IS AN INTEGER WORK ARRAY OF LENGTH N.
-C
-C BWA IS A LOGICAL WORK ARRAY OF LENGTH N.
-C
-C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. JUNE 1982.
-C THOMAS F. COLEMAN, BURTON S. GARBOW, JORGE J. MORE
-C
-C **********
- INTEGER DEG,IC,IP,IPL,IPU,IR,JCOL,JP,JPL,JPU
-C
-C INITIALIZATION BLOCK.
-C
- DO 10 JP = 1, N
- NDEG(JP) = 0
- BWA(JP) = .FALSE.
- 10 CONTINUE
-C
-C COMPUTE THE DEGREE SEQUENCE BY DETERMINING THE CONTRIBUTIONS
-C TO THE DEGREES FROM THE CURRENT(JCOL) COLUMN AND FURTHER
-C COLUMNS WHICH HAVE NOT YET BEEN CONSIDERED.
-C
- IF (N .LT. 2) GO TO 90
- DO 80 JCOL = 2, N
- BWA(JCOL) = .TRUE.
- DEG = 0
-C
-C DETERMINE ALL POSITIONS (IR,JCOL) WHICH CORRESPOND
-C TO NON-ZEROES IN THE MATRIX.
-C
- JPL = JPNTR(JCOL)
- JPU = JPNTR(JCOL+1) - 1
- IF (JPU .LT. JPL) GO TO 50
- DO 40 JP = JPL, JPU
- IR = INDROW(JP)
-C
-C FOR EACH ROW IR, DETERMINE ALL POSITIONS (IR,IC)
-C WHICH CORRESPOND TO NON-ZEROES IN THE MATRIX.
-C
- IPL = IPNTR(IR)
- IPU = IPNTR(IR+1) - 1
- DO 30 IP = IPL, IPU
- IC = INDCOL(IP)
-C
-C ARRAY BWA MARKS COLUMNS WHICH HAVE CONTRIBUTED TO
-C THE DEGREE COUNT OF COLUMN JCOL. UPDATE THE DEGREE
-C COUNTS OF THESE COLUMNS. ARRAY IWA RECORDS THE
-C MARKED COLUMNS.
-C
- IF (BWA(IC)) GO TO 20
- BWA(IC) = .TRUE.
- NDEG(IC) = NDEG(IC) + 1
- DEG = DEG + 1
- IWA(DEG) = IC
- 20 CONTINUE
- 30 CONTINUE
- 40 CONTINUE
- 50 CONTINUE
-C
-C UN-MARK THE COLUMNS RECORDED BY IWA AND FINALIZE THE
-C DEGREE COUNT OF COLUMN JCOL.
-C
- IF (DEG .LT. 1) GO TO 70
- DO 60 JP = 1, DEG
- IC = IWA(JP)
- BWA(IC) = .FALSE.
- 60 CONTINUE
- NDEG(JCOL) = NDEG(JCOL) + DEG
- 70 CONTINUE
- 80 CONTINUE
- 90 CONTINUE
- RETURN
-C
-C LAST CARD OF SUBROUTINE D7EGR.
-C
- END
diff --git a/CEP/PyBDSM/src/port3/d7mlp.f b/CEP/PyBDSM/src/port3/d7mlp.f
deleted file mode 100644
index 0254f5261d4bfb3c8e368a8c41c410d706e0a74c..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/d7mlp.f
+++ /dev/null
@@ -1,37 +0,0 @@
- SUBROUTINE D7MLP(N, X, Y, Z, K)
-C
-C *** SET X = DIAG(Y)**K * Z
-C *** FOR X, Z = LOWER TRIANG. MATRICES STORED COMPACTLY BY ROW
-C *** K = 1 OR -1.
-C
- INTEGER N, K
-C/6
-C REAL X(1), Y(N), Z(1)
-C/7
- REAL X(*), Y(N), Z(*)
-C/
- INTEGER I, J, L
- REAL ONE, T
- DATA ONE/1.E+0/
-C
- L = 1
- IF (K .GE. 0) GO TO 30
- DO 20 I = 1, N
- T = ONE / Y(I)
- DO 10 J = 1, I
- X(L) = T * Z(L)
- L = L + 1
- 10 CONTINUE
- 20 CONTINUE
- GO TO 999
-C
- 30 DO 50 I = 1, N
- T = Y(I)
- DO 40 J = 1, I
- X(L) = T * Z(L)
- L = L + 1
- 40 CONTINUE
- 50 CONTINUE
- 999 RETURN
-C *** LAST CARD OF D7MLP FOLLOWS ***
- END
diff --git a/CEP/PyBDSM/src/port3/d7tpr.f b/CEP/PyBDSM/src/port3/d7tpr.f
deleted file mode 100644
index 5d7cd9ada82e154dbc7b07be36a88b9ca908c77b..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/d7tpr.f
+++ /dev/null
@@ -1,38 +0,0 @@
- REAL FUNCTION D7TPR(P, X, Y)
-C
-C *** RETURN THE INNER PRODUCT OF THE P-VECTORS X AND Y. ***
-C
- INTEGER P
- REAL X(P), Y(P)
-C
- INTEGER I
- REAL ONE, SQTETA, T, ZERO
- REAL R7MDC
- EXTERNAL R7MDC
-C
-C *** R7MDC(2) RETURNS A MACHINE-DEPENDENT CONSTANT, SQTETA, WHICH
-C *** IS SLIGHTLY LARGER THAN THE SMALLEST POSITIVE NUMBER THAT
-C *** CAN BE SQUARED WITHOUT UNDERFLOWING.
-C
-C/6
-C DATA ONE/1.E+0/, SQTETA/0.E+0/, ZERO/0.E+0/
-C/7
- PARAMETER (ONE=1.E+0, ZERO=0.E+0)
- DATA SQTETA/0.E+0/
-C/
-C
- D7TPR = ZERO
- IF (P .LE. 0) GO TO 999
- IF (SQTETA .EQ. ZERO) SQTETA = R7MDC(2)
- DO 20 I = 1, P
- T = AMAX1( ABS(X(I)), ABS(Y(I)))
- IF (T .GT. ONE) GO TO 10
- IF (T .LT. SQTETA) GO TO 20
- T = (X(I)/SQTETA)*Y(I)
- IF ( ABS(T) .LT. SQTETA) GO TO 20
- 10 D7TPR = D7TPR + X(I)*Y(I)
- 20 CONTINUE
-C
- 999 RETURN
-C *** LAST LINE OF D7TPR FOLLOWS ***
- END
diff --git a/CEP/PyBDSM/src/port3/d7upd.f b/CEP/PyBDSM/src/port3/d7upd.f
deleted file mode 100644
index d87f3d253d495a0630afb659442f14bc7b1b5ba7..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/d7upd.f
+++ /dev/null
@@ -1,79 +0,0 @@
- SUBROUTINE D7UPD(D, DR, IV, LIV, LV, N, ND, NN, N2, P, V)
-C
-C *** UPDATE SCALE VECTOR D FOR NL2IT ***
-C
-C *** PARAMETER DECLARATIONS ***
-C
- INTEGER LIV, LV, N, ND, NN, N2, P
- INTEGER IV(LIV)
- REAL D(P), DR(ND,P), V(LV)
-C DIMENSION V(*)
-C
-C *** LOCAL VARIABLES ***
-C
- INTEGER D0, I, JCN0, JCN1, JCNI, JTOL0, JTOLI, K, SII
- REAL T, VDFAC
-C
-C *** CONSTANTS ***
-C
- REAL ZERO
-C
-C *** INTRINSIC FUNCTIONS ***
-C/+
- REAL SQRT
-C/
-C *** EXTERNAL SUBROUTINE ***
-C
- EXTERNAL V7SCP
-C
-C V7SCP... SETS ALL COMPONENTS OF A VECTOR TO A SCALAR.
-C
-C *** SUBSCRIPTS FOR IV AND V ***
-C
- INTEGER DFAC, DTYPE, JCN, JTOL, NITER, S
-C/6
-C DATA DFAC/41/, DTYPE/16/, JCN/66/, JTOL/59/, NITER/31/, S/62/
-C/7
- PARAMETER (DFAC=41, DTYPE=16, JCN=66, JTOL=59, NITER=31, S=62)
-C/
-C
-C/6
-C DATA ZERO/0.E+0/
-C/7
- PARAMETER (ZERO=0.E+0)
-C/
-C
-C------------------------------- BODY --------------------------------
-C
- IF (IV(DTYPE) .NE. 1 .AND. IV(NITER) .GT. 0) GO TO 999
- JCN1 = IV(JCN)
- JCN0 = IABS(JCN1) - 1
- IF (JCN1 .LT. 0) GO TO 10
- IV(JCN) = -JCN1
- CALL V7SCP(P, V(JCN1), ZERO)
- 10 DO 30 I = 1, P
- JCNI = JCN0 + I
- T = V(JCNI)
- DO 20 K = 1, NN
- 20 T = AMAX1(T, ABS(DR(K,I)))
- V(JCNI) = T
- 30 CONTINUE
- IF (N2 .LT. N) GO TO 999
- VDFAC = V(DFAC)
- JTOL0 = IV(JTOL) - 1
- D0 = JTOL0 + P
- SII = IV(S) - 1
- DO 50 I = 1, P
- SII = SII + I
- JCNI = JCN0 + I
- T = V(JCNI)
- IF (V(SII) .GT. ZERO) T = AMAX1( SQRT(V(SII)), T)
- JTOLI = JTOL0 + I
- D0 = D0 + 1
- IF (T .LT. V(JTOLI)) T = AMAX1(V(D0), V(JTOLI))
- D(I) = AMAX1(VDFAC*D(I), T)
- 50 CONTINUE
-C
- 999 RETURN
-C *** LAST CARD OF D7UPD FOLLOWS ***
- END
diff --git a/CEP/PyBDSM/src/port3/da7sst.f b/CEP/PyBDSM/src/port3/da7sst.f
deleted file mode 100644
index ee935017d0fe858d04c1def325a6e4ab9de68715..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/da7sst.f
+++ /dev/null
@@ -1,534 +0,0 @@
- SUBROUTINE DA7SST(IV, LIV, LV, V)
-C
-C *** ASSESS CANDIDATE STEP (***SOL VERSION 2.3) ***
-C
- INTEGER LIV, LV
- INTEGER IV(LIV)
- DOUBLE PRECISION V(LV)
-C
-C *** PURPOSE ***
-C
-C THIS SUBROUTINE IS CALLED BY AN UNCONSTRAINED MINIMIZATION
-C ROUTINE TO ASSESS THE NEXT CANDIDATE STEP. IT MAY RECOMMEND ONE
-C OF SEVERAL COURSES OF ACTION, SUCH AS ACCEPTING THE STEP, RECOM-
-C PUTING IT USING THE SAME OR A NEW QUADRATIC MODEL, OR HALTING DUE
-C TO CONVERGENCE OR FALSE CONVERGENCE. SEE THE RETURN CODE LISTING
-C BELOW.
-C
-C-------------------------- PARAMETER USAGE --------------------------
-C
-C IV (I/O) INTEGER PARAMETER AND SCRATCH VECTOR -- SEE DESCRIPTION
-C BELOW OF IV VALUES REFERENCED.
-C LIV (IN) LENGTH OF IV ARRAY.
-C LV (IN) LENGTH OF V ARRAY.
-C V (I/O) REAL PARAMETER AND SCRATCH VECTOR -- SEE DESCRIPTION
-C BELOW OF V VALUES REFERENCED.
-C
-C *** IV VALUES REFERENCED ***
-C
-C IV(IRC) (I/O) ON INPUT FOR THE FIRST STEP TRIED IN A NEW ITERATION,
-C IV(IRC) SHOULD BE SET TO 3 OR 4 (THE VALUE TO WHICH IT IS
-C SET WHEN STEP IS DEFINITELY TO BE ACCEPTED). ON INPUT
-C AFTER STEP HAS BEEN RECOMPUTED, IV(IRC) SHOULD BE
-C UNCHANGED SINCE THE PREVIOUS RETURN OF DA7SST.
-C ON OUTPUT, IV(IRC) IS A RETURN CODE HAVING ONE OF THE
-C FOLLOWING VALUES...
-C 1 = SWITCH MODELS OR TRY SMALLER STEP.
-C 2 = SWITCH MODELS OR ACCEPT STEP.
-C 3 = ACCEPT STEP AND DETERMINE V(RADFAC) BY GRADIENT
-C TESTS.
-C 4 = ACCEPT STEP, V(RADFAC) HAS BEEN DETERMINED.
-C 5 = RECOMPUTE STEP (USING THE SAME MODEL).
-C 6 = RECOMPUTE STEP WITH RADIUS = V(LMAXS) BUT DO NOT
-C EVALUATE THE OBJECTIVE FUNCTION.
-C 7 = X-CONVERGENCE (SEE V(XCTOL)).
-C 8 = RELATIVE FUNCTION CONVERGENCE (SEE V(RFCTOL)).
-C 9 = BOTH X- AND RELATIVE FUNCTION CONVERGENCE.
-C 10 = ABSOLUTE FUNCTION CONVERGENCE (SEE V(AFCTOL)).
-C 11 = SINGULAR CONVERGENCE (SEE V(LMAXS)).
-C 12 = FALSE CONVERGENCE (SEE V(XFTOL)).
-C 13 = IV(IRC) WAS OUT OF RANGE ON INPUT.
-C RETURN CODE I HAS PRECEDENCE OVER I+1 FOR I = 9, 10, 11.
-C IV(MLSTGD) (I/O) SAVED VALUE OF IV(MODEL).
-C IV(MODEL) (I/O) ON INPUT, IV(MODEL) SHOULD BE AN INTEGER IDENTIFYING
-C THE CURRENT QUADRATIC MODEL OF THE OBJECTIVE FUNCTION.
-C IF A PREVIOUS STEP YIELDED A BETTER FUNCTION REDUCTION,
-C THEN IV(MODEL) WILL BE SET TO IV(MLSTGD) ON OUTPUT.
-C IV(NFCALL) (IN) INVOCATION COUNT FOR THE OBJECTIVE FUNCTION.
-C IV(NFGCAL) (I/O) VALUE OF IV(NFCALL) AT STEP THAT GAVE THE BIGGEST
-C FUNCTION REDUCTION THIS ITERATION. IV(NFGCAL) REMAINS
-C UNCHANGED UNTIL A FUNCTION REDUCTION IS OBTAINED.
-C IV(RADINC) (I/O) THE NUMBER OF RADIUS INCREASES (OR MINUS THE NUMBER
-C OF DECREASES) SO FAR THIS ITERATION.
-C IV(RESTOR) (OUT) SET TO 1 IF V(F) HAS BEEN RESTORED AND X SHOULD BE
-C RESTORED TO ITS INITIAL VALUE, TO 2 IF X SHOULD BE SAVED,
-C TO 3 IF X SHOULD BE RESTORED FROM THE SAVED VALUE, AND TO
-C 0 OTHERWISE.
-C IV(STAGE) (I/O) COUNT OF THE NUMBER OF MODELS TRIED SO FAR IN THE
-C CURRENT ITERATION.
-C IV(STGLIM) (IN) MAXIMUM NUMBER OF MODELS TO CONSIDER.
-C IV(SWITCH) (OUT) SET TO 0 UNLESS A NEW MODEL IS BEING TRIED AND IT
-C GIVES A SMALLER FUNCTION VALUE THAN THE PREVIOUS MODEL,
-C IN WHICH CASE DA7SST SETS IV(SWITCH) = 1.
-C IV(TOOBIG) (I/O) IS NONZERO ON INPUT IF STEP WAS TOO BIG (E.G., IF
-C IT WOULD CAUSE OVERFLOW). IT IS SET TO 0 ON RETURN.
-C IV(XIRC) (I/O) VALUE THAT IV(IRC) WOULD HAVE IN THE ABSENCE OF
-C CONVERGENCE, FALSE CONVERGENCE, AND OVERSIZED STEPS.
-C
-C *** V VALUES REFERENCED ***
-C
-C V(AFCTOL) (IN) ABSOLUTE FUNCTION CONVERGENCE TOLERANCE. IF THE
-C ABSOLUTE VALUE OF THE CURRENT FUNCTION VALUE V(F) IS LESS
-C THAN V(AFCTOL) AND DA7SST DOES NOT RETURN WITH
-C IV(IRC) = 11, THEN DA7SST RETURNS WITH IV(IRC) = 10.
-C V(DECFAC) (IN) FACTOR BY WHICH TO DECREASE RADIUS WHEN IV(TOOBIG) IS
-C NONZERO.
-C V(DSTNRM) (IN) THE 2-NORM OF D*STEP.
-C V(DSTSAV) (I/O) VALUE OF V(DSTNRM) ON SAVED STEP.
-C V(DST0) (IN) THE 2-NORM OF D TIMES THE NEWTON STEP (WHEN DEFINED,
-C I.E., FOR V(NREDUC) .GE. 0).
-C V(F) (I/O) ON BOTH INPUT AND OUTPUT, V(F) IS THE OBJECTIVE FUNC-
-C TION VALUE AT X. IF X IS RESTORED TO A PREVIOUS VALUE,
-C THEN V(F) IS RESTORED TO THE CORRESPONDING VALUE.
-C V(FDIF) (OUT) THE FUNCTION REDUCTION V(F0) - V(F) (FOR THE OUTPUT
-C VALUE OF V(F) IF AN EARLIER STEP GAVE A BIGGER FUNCTION
-C DECREASE, AND FOR THE INPUT VALUE OF V(F) OTHERWISE).
-C V(FLSTGD) (I/O) SAVED VALUE OF V(F).
-C V(F0) (IN) OBJECTIVE FUNCTION VALUE AT START OF ITERATION.
-C V(GTSLST) (I/O) VALUE OF V(GTSTEP) ON SAVED STEP.
-C V(GTSTEP) (IN) INNER PRODUCT BETWEEN STEP AND GRADIENT.
-C V(INCFAC) (IN) MINIMUM FACTOR BY WHICH TO INCREASE RADIUS.
-C V(LMAXS) (IN) MAXIMUM REASONABLE STEP SIZE (AND INITIAL STEP BOUND).
-C IF THE ACTUAL FUNCTION DECREASE IS NO MORE THAN TWICE
-C WHAT WAS PREDICTED, IF A RETURN WITH IV(IRC) = 7, 8, OR 9
-C DOES NOT OCCUR, IF V(DSTNRM) .GT. V(LMAXS) OR THE CURRENT
-C STEP IS A NEWTON STEP, AND IF
-C V(PREDUC) .LE. V(SCTOL) * ABS(V(F0)), THEN DA7SST RETURNS
-C WITH IV(IRC) = 11. IF SO DOING APPEARS WORTHWHILE, THEN
-C DA7SST REPEATS THIS TEST (DISALLOWING A FULL NEWTON STEP)
-C WITH V(PREDUC) COMPUTED FOR A STEP OF LENGTH V(LMAXS)
-C (BY A RETURN WITH IV(IRC) = 6).
-C V(NREDUC) (I/O) FUNCTION REDUCTION PREDICTED BY QUADRATIC MODEL FOR
-C NEWTON STEP. IF DA7SST IS CALLED WITH IV(IRC) = 6, I.E.,
-C IF V(PREDUC) HAS BEEN COMPUTED WITH RADIUS = V(LMAXS) FOR
-C _USE_ IN THE SINGULAR CONVERGENCE TEST, THEN V(NREDUC) IS
-C SET TO -V(PREDUC) BEFORE THE LATTER IS RESTORED.
-C V(PLSTGD) (I/O) VALUE OF V(PREDUC) ON SAVED STEP.
-C V(PREDUC) (I/O) FUNCTION REDUCTION PREDICTED BY QUADRATIC MODEL FOR
-C CURRENT STEP.
-C V(RADFAC) (OUT) FACTOR TO BE USED IN DETERMINING THE NEW RADIUS,
-C WHICH SHOULD BE V(RADFAC)*DST, WHERE DST IS EITHER THE
-C OUTPUT VALUE OF V(DSTNRM) OR THE 2-NORM OF
-C DIAG(NEWD)*STEP FOR THE OUTPUT VALUE OF STEP AND THE
-C UPDATED VERSION, NEWD, OF THE SCALE VECTOR D. FOR
-C IV(IRC) = 3, V(RADFAC) = 1.0 IS RETURNED.
-C V(RDFCMN) (IN) MINIMUM VALUE FOR V(RADFAC) IN TERMS OF THE INPUT
-C VALUE OF V(DSTNRM) -- SUGGESTED VALUE = 0.1.
-C V(RDFCMX) (IN) MAXIMUM VALUE FOR V(RADFAC) -- SUGGESTED VALUE = 4.0.
-C V(RELDX) (IN) SCALED RELATIVE CHANGE IN X CAUSED BY STEP, COMPUTED
-C (E.G.) BY FUNCTION DRLDST AS
-C MAX (D(I)*ABS(X(I)-X0(I)), 1 .LE. I .LE. P) /
-C MAX (D(I)*(ABS(X(I))+ABS(X0(I))), 1 .LE. I .LE. P).
-C V(RFCTOL) (IN) RELATIVE FUNCTION CONVERGENCE TOLERANCE. IF THE
-C ACTUAL FUNCTION REDUCTION IS AT MOST TWICE WHAT WAS PRE-
-C DICTED AND V(NREDUC) .LE. V(RFCTOL)*ABS(V(F0)), THEN
-C DA7SST RETURNS WITH IV(IRC) = 8 OR 9.
-C V(SCTOL) (IN) SINGULAR CONVERGENCE TOLERANCE -- SEE V(LMAXS).
-C V(STPPAR) (IN) MARQUARDT PARAMETER -- 0 MEANS FULL NEWTON STEP.
-C V(TUNER1) (IN) TUNING CONSTANT USED TO DECIDE IF THE FUNCTION
-C REDUCTION WAS MUCH LESS THAN EXPECTED. SUGGESTED
-C VALUE = 0.1.
-C V(TUNER2) (IN) TUNING CONSTANT USED TO DECIDE IF THE FUNCTION
-C REDUCTION WAS LARGE ENOUGH TO ACCEPT STEP. SUGGESTED
-C VALUE = 10**-4.
-C V(TUNER3) (IN) TUNING CONSTANT USED TO DECIDE IF THE RADIUS
-C SHOULD BE INCREASED. SUGGESTED VALUE = 0.75.
-C V(XCTOL) (IN) X-CONVERGENCE CRITERION. IF STEP IS A NEWTON STEP
-C (V(STPPAR) = 0) HAVING V(RELDX) .LE. V(XCTOL) AND GIVING
-C AT MOST TWICE THE PREDICTED FUNCTION DECREASE, THEN
-C DA7SST RETURNS IV(IRC) = 7 OR 9.
-C V(XFTOL) (IN) FALSE CONVERGENCE TOLERANCE. IF STEP GAVE NO OR ONLY
-C A SMALL FUNCTION DECREASE AND V(RELDX) .LE. V(XFTOL),
-C THEN DA7SST RETURNS WITH IV(IRC) = 12.
-C
-C------------------------------- NOTES -------------------------------
-C
-C *** APPLICATION AND USAGE RESTRICTIONS ***
-C
-C THIS ROUTINE IS CALLED AS PART OF THE NL2SOL (NONLINEAR
-C LEAST-SQUARES) PACKAGE. IT MAY BE USED IN ANY UNCONSTRAINED
-C MINIMIZATION SOLVER THAT USES DOGLEG, GOLDFELD-QUANDT-TROTTER,
-C OR LEVENBERG-MARQUARDT STEPS.
-C
-C *** ALGORITHM NOTES ***
-C
-C SEE (1) FOR FURTHER DISCUSSION OF THE ASSESSING AND MODEL
-C SWITCHING STRATEGIES. WHILE NL2SOL CONSIDERS ONLY TWO MODELS,
-C DA7SST IS DESIGNED TO HANDLE ANY NUMBER OF MODELS.
-C
-C *** USAGE NOTES ***
-C
-C ON THE FIRST CALL OF AN ITERATION, ONLY THE I/O VARIABLES
-C STEP, X, IV(IRC), IV(MODEL), V(F), V(DSTNRM), V(GTSTEP), AND
-C V(PREDUC) NEED HAVE BEEN INITIALIZED. BETWEEN CALLS, NO I/O
-C VALUES EXCEPT STEP, X, IV(MODEL), V(F) AND THE STOPPING TOLER-
-C ANCES SHOULD BE CHANGED.
-C AFTER A RETURN FOR CONVERGENCE OR FALSE CONVERGENCE, ONE CAN
-C CHANGE THE STOPPING TOLERANCES AND CALL DA7SST AGAIN, IN WHICH
-C CASE THE STOPPING TESTS WILL BE REPEATED.
-C
-C *** REFERENCES ***
-C
-C (1) DENNIS, J.E., JR., GAY, D.M., AND WELSCH, R.E. (1981),
-C AN ADAPTIVE NONLINEAR LEAST-SQUARES ALGORITHM,
-C ACM TRANS. MATH. SOFTWARE, VOL. 7, NO. 3.
-C
-C (2) POWELL, M.J.D. (1970) A FORTRAN SUBROUTINE FOR SOLVING
-C SYSTEMS OF NONLINEAR ALGEBRAIC EQUATIONS, IN NUMERICAL
-C METHODS FOR NONLINEAR ALGEBRAIC EQUATIONS, EDITED BY
-C P. RABINOWITZ, GORDON AND BREACH, LONDON.
-C
-C *** HISTORY ***
-C
-C JOHN DENNIS DESIGNED MUCH OF THIS ROUTINE, STARTING WITH
-C IDEAS IN (2). ROY WELSCH SUGGESTED THE MODEL SWITCHING STRATEGY.
-C DAVID GAY AND STEPHEN PETERS CAST THIS SUBROUTINE INTO A MORE
-C PORTABLE FORM (WINTER 1977), AND DAVID GAY CAST IT INTO ITS
-C PRESENT FORM (FALL 1978), WITH MINOR CHANGES TO THE SINGULAR
-C CONVERGENCE TEST IN MAY, 1984 (TO DEAL WITH FULL NEWTON STEPS).
-C
-C *** GENERAL ***
-C
-C THIS SUBROUTINE WAS WRITTEN IN CONNECTION WITH RESEARCH
-C SUPPORTED BY THE NATIONAL SCIENCE FOUNDATION UNDER GRANTS
-C MCS-7600324, DCR75-10143, 76-14311DSS, MCS76-11989, AND
-C MCS-7906671.
-C
-C------------------------ EXTERNAL QUANTITIES ------------------------
-C
-C *** NO EXTERNAL FUNCTIONS AND SUBROUTINES ***
-C
-C-------------------------- LOCAL VARIABLES --------------------------
-C
- LOGICAL GOODX
- INTEGER I, NFC
- DOUBLE PRECISION EMAX, EMAXS, GTS, RFAC1, XMAX
- DOUBLE PRECISION HALF, ONE, ONEP2, TWO, ZERO
-C
-C *** SUBSCRIPTS FOR IV AND V ***
-C
- INTEGER AFCTOL, DECFAC, DSTNRM, DSTSAV, DST0, F, FDIF, FLSTGD, F0,
- 1 GTSLST, GTSTEP, INCFAC, IRC, LMAXS, MLSTGD, MODEL, NFCALL,
- 2 NFGCAL, NREDUC, PLSTGD, PREDUC, RADFAC, RADINC, RDFCMN,
- 3 RDFCMX, RELDX, RESTOR, RFCTOL, SCTOL, STAGE, STGLIM,
- 4 STPPAR, SWITCH, TOOBIG, TUNER1, TUNER2, TUNER3, XCTOL,
- 5 XFTOL, XIRC
-C
-C *** DATA INITIALIZATIONS ***
-C
-C/6
-C DATA HALF/0.5D+0/, ONE/1.D+0/, ONEP2/1.2D+0/, TWO/2.D+0/,
-C 1 ZERO/0.D+0/
-C/7
- PARAMETER (HALF=0.5D+0, ONE=1.D+0, ONEP2=1.2D+0, TWO=2.D+0,
- 1 ZERO=0.D+0)
-C/
-C
-C/6
-C DATA IRC/29/, MLSTGD/32/, MODEL/5/, NFCALL/6/, NFGCAL/7/,
-C 1 RADINC/8/, RESTOR/9/, STAGE/10/, STGLIM/11/, SWITCH/12/,
-C 2 TOOBIG/2/, XIRC/13/
-C/7
- PARAMETER (IRC=29, MLSTGD=32, MODEL=5, NFCALL=6, NFGCAL=7,
- 1 RADINC=8, RESTOR=9, STAGE=10, STGLIM=11, SWITCH=12,
- 2 TOOBIG=2, XIRC=13)
-C/
-C/6
-C DATA AFCTOL/31/, DECFAC/22/, DSTNRM/2/, DST0/3/, DSTSAV/18/,
-C 1 F/10/, FDIF/11/, FLSTGD/12/, F0/13/, GTSLST/14/, GTSTEP/4/,
-C 2 INCFAC/23/, LMAXS/36/, NREDUC/6/, PLSTGD/15/, PREDUC/7/,
-C 3 RADFAC/16/, RDFCMN/24/, RDFCMX/25/, RELDX/17/, RFCTOL/32/,
-C 4 SCTOL/37/, STPPAR/5/, TUNER1/26/, TUNER2/27/, TUNER3/28/,
-C 5 XCTOL/33/, XFTOL/34/
-C/7
- PARAMETER (AFCTOL=31, DECFAC=22, DSTNRM=2, DST0=3, DSTSAV=18,
- 1 F=10, FDIF=11, FLSTGD=12, F0=13, GTSLST=14, GTSTEP=4,
- 2 INCFAC=23, LMAXS=36, NREDUC=6, PLSTGD=15, PREDUC=7,
- 3 RADFAC=16, RDFCMN=24, RDFCMX=25, RELDX=17, RFCTOL=32,
- 4 SCTOL=37, STPPAR=5, TUNER1=26, TUNER2=27, TUNER3=28,
- 5 XCTOL=33, XFTOL=34)
-C/
-C
-C+++++++++++++++++++++++++++++++ BODY ++++++++++++++++++++++++++++++++
-C
- NFC = IV(NFCALL)
- IV(SWITCH) = 0
- IV(RESTOR) = 0
- RFAC1 = ONE
- GOODX = .TRUE.
- I = IV(IRC)
- IF (I .GE. 1 .AND. I .LE. 12)
- 1 GO TO (20,30,10,10,40,280,220,220,220,220,220,170), I
- IV(IRC) = 13
- GO TO 999
-C
-C *** INITIALIZE FOR NEW ITERATION ***
-C
- 10 IV(STAGE) = 1
- IV(RADINC) = 0
- V(FLSTGD) = V(F0)
- IF (IV(TOOBIG) .EQ. 0) GO TO 110
- IV(STAGE) = -1
- IV(XIRC) = I
- GO TO 60
-C
-C *** STEP WAS RECOMPUTED WITH NEW MODEL OR SMALLER RADIUS ***
-C *** FIRST DECIDE WHICH ***
-C
- 20 IF (IV(MODEL) .NE. IV(MLSTGD)) GO TO 30
-C *** OLD MODEL RETAINED, SMALLER RADIUS TRIED ***
-C *** DO NOT CONSIDER ANY MORE NEW MODELS THIS ITERATION ***
- IV(STAGE) = IV(STGLIM)
- IV(RADINC) = -1
- GO TO 110
-C
-C *** A NEW MODEL IS BEING TRIED. DECIDE WHETHER TO KEEP IT. ***
-C
- 30 IV(STAGE) = IV(STAGE) + 1
-C
-C *** NOW WE ADD THE POSSIBILITY THAT STEP WAS RECOMPUTED WITH ***
-C *** THE SAME MODEL, PERHAPS BECAUSE OF AN OVERSIZED STEP. ***
-C
- 40 IF (IV(STAGE) .GT. 0) GO TO 50
-C
-C *** STEP WAS RECOMPUTED BECAUSE IT WAS TOO BIG. ***
-C
- IF (IV(TOOBIG) .NE. 0) GO TO 60
-C
-C *** RESTORE IV(STAGE) AND PICK UP WHERE WE LEFT OFF. ***
-C
- IV(STAGE) = -IV(STAGE)
- I = IV(XIRC)
- GO TO (20, 30, 110, 110, 70), I
-C
- 50 IF (IV(TOOBIG) .EQ. 0) GO TO 70
-C
-C *** HANDLE OVERSIZE STEP ***
-C
- IV(TOOBIG) = 0
- IF (IV(RADINC) .GT. 0) GO TO 80
- IV(STAGE) = -IV(STAGE)
- IV(XIRC) = IV(IRC)
-C
- 60 IV(TOOBIG) = 0
- V(RADFAC) = V(DECFAC)
- IV(RADINC) = IV(RADINC) - 1
- IV(IRC) = 5
- IV(RESTOR) = 1
- V(F) = V(FLSTGD)
- GO TO 999
-C
- 70 IF (V(F) .LT. V(FLSTGD)) GO TO 110
-C
-C *** THE NEW STEP IS A LOSER. RESTORE OLD MODEL. ***
-C
- IF (IV(MODEL) .EQ. IV(MLSTGD)) GO TO 80
- IV(MODEL) = IV(MLSTGD)
- IV(SWITCH) = 1
-C
-C *** RESTORE STEP, ETC. ONLY IF A PREVIOUS STEP DECREASED V(F).
-C
- 80 IF (V(FLSTGD) .GE. V(F0)) GO TO 110
- IF (IV(STAGE) .LT. IV(STGLIM)) THEN
- GOODX = .FALSE.
- ELSE IF (NFC .LT. IV(NFGCAL) + IV(STGLIM) + 2) THEN
- GOODX = .FALSE.
- ELSE IF (IV(SWITCH) .NE. 0) THEN
- GOODX = .FALSE.
- ENDIF
- IV(RESTOR) = 3
- V(F) = V(FLSTGD)
- V(PREDUC) = V(PLSTGD)
- V(GTSTEP) = V(GTSLST)
- IF (IV(SWITCH) .EQ. 0) RFAC1 = V(DSTNRM) / V(DSTSAV)
- V(DSTNRM) = V(DSTSAV)
- IF (GOODX) THEN
-C
-C *** ACCEPT PREVIOUS SLIGHTLY REDUCING STEP ***
-C
- V(FDIF) = V(F0) - V(F)
- IV(IRC) = 4
- V(RADFAC) = RFAC1
- GO TO 999
- ENDIF
- NFC = IV(NFGCAL)
-C
- 110 V(FDIF) = V(F0) - V(F)
- IF (V(FDIF) .GT. V(TUNER2) * V(PREDUC)) GO TO 140
- IF (IV(RADINC) .GT. 0) GO TO 140
-C
-C *** NO (OR ONLY A TRIVIAL) FUNCTION DECREASE
-C *** -- SO TRY NEW MODEL OR SMALLER RADIUS
-C
- IF (V(F) .LT. V(F0)) GO TO 120
- IV(MLSTGD) = IV(MODEL)
- V(FLSTGD) = V(F)
- V(F) = V(F0)
- IV(RESTOR) = 1
- GO TO 130
- 120 IV(NFGCAL) = NFC
- 130 IV(IRC) = 1
- IF (IV(STAGE) .LT. IV(STGLIM)) GO TO 160
- IV(IRC) = 5
- IV(RADINC) = IV(RADINC) - 1
- GO TO 160
-C
-C *** NONTRIVIAL FUNCTION DECREASE ACHIEVED ***
-C
- 140 IV(NFGCAL) = NFC
- RFAC1 = ONE
- V(DSTSAV) = V(DSTNRM)
- IF (V(FDIF) .GT. V(PREDUC)*V(TUNER1)) GO TO 190
-C
-C *** DECREASE WAS MUCH LESS THAN PREDICTED -- EITHER CHANGE MODELS
-C *** OR ACCEPT STEP WITH DECREASED RADIUS.
-C
- IF (IV(STAGE) .GE. IV(STGLIM)) GO TO 150
-C *** CONSIDER SWITCHING MODELS ***
- IV(IRC) = 2
- GO TO 160
-C
-C *** ACCEPT STEP WITH DECREASED RADIUS ***
-C
- 150 IV(IRC) = 4
-C
-C *** SET V(RADFAC) TO FLETCHER*S DECREASE FACTOR ***
-C
- 160 IV(XIRC) = IV(IRC)
- EMAX = V(GTSTEP) + V(FDIF)
- V(RADFAC) = HALF * RFAC1
- IF (EMAX .LT. V(GTSTEP)) V(RADFAC) = RFAC1 * DMAX1(V(RDFCMN),
- 1 HALF * V(GTSTEP)/EMAX)
-C
-C *** DO FALSE CONVERGENCE TEST ***
-C
- 170 IF (V(RELDX) .LE. V(XFTOL)) GO TO 180
- IV(IRC) = IV(XIRC)
- IF (V(F) .LT. V(F0)) GO TO 200
- GO TO 230
-C
- 180 IV(IRC) = 12
- GO TO 240
-C
-C *** HANDLE GOOD FUNCTION DECREASE ***
-C
- 190 IF (V(FDIF) .LT. (-V(TUNER3) * V(GTSTEP))) GO TO 210
-C
-C *** INCREASING RADIUS LOOKS WORTHWHILE. SEE IF WE JUST
-C *** RECOMPUTED STEP WITH A DECREASED RADIUS OR RESTORED STEP
-C *** AFTER RECOMPUTING IT WITH A LARGER RADIUS.
-C
- IF (IV(RADINC) .LT. 0) GO TO 210
- IF (IV(RESTOR) .EQ. 1) GO TO 210
- IF (IV(RESTOR) .EQ. 3) GO TO 210
-C
-C *** WE DID NOT. TRY A LONGER STEP UNLESS THIS WAS A NEWTON
-C *** STEP.
-C
- V(RADFAC) = V(RDFCMX)
- GTS = V(GTSTEP)
- IF (V(FDIF) .LT. (HALF/V(RADFAC) - ONE) * GTS)
- 1 V(RADFAC) = DMAX1(V(INCFAC), HALF*GTS/(GTS + V(FDIF)))
- IV(IRC) = 4
- IF (V(STPPAR) .EQ. ZERO) GO TO 230
- IF (V(DST0) .GE. ZERO .AND. (V(DST0) .LT. TWO*V(DSTNRM)
- 1 .OR. V(NREDUC) .LT. ONEP2*V(FDIF))) GO TO 230
-C *** STEP WAS NOT A NEWTON STEP. RECOMPUTE IT WITH
-C *** A LARGER RADIUS.
- IV(IRC) = 5
- IV(RADINC) = IV(RADINC) + 1
-C
-C *** SAVE VALUES CORRESPONDING TO GOOD STEP ***
-C
- 200 V(FLSTGD) = V(F)
- IV(MLSTGD) = IV(MODEL)
- IF (IV(RESTOR) .EQ. 0) IV(RESTOR) = 2
- V(DSTSAV) = V(DSTNRM)
- IV(NFGCAL) = NFC
- V(PLSTGD) = V(PREDUC)
- V(GTSLST) = V(GTSTEP)
- GO TO 230
-C
-C *** ACCEPT STEP WITH RADIUS UNCHANGED ***
-C
- 210 V(RADFAC) = ONE
- IV(IRC) = 3
- GO TO 230
-C
-C *** COME HERE FOR A RESTART AFTER CONVERGENCE ***
-C
- 220 IV(IRC) = IV(XIRC)
- IF (V(DSTSAV) .GE. ZERO) GO TO 240
- IV(IRC) = 12
- GO TO 240
-C
-C *** PERFORM CONVERGENCE TESTS ***
-C
- 230 IV(XIRC) = IV(IRC)
- 240 IF (IV(RESTOR) .EQ. 1 .AND. V(FLSTGD) .LT. V(F0)) IV(RESTOR) = 3
- IF (DABS(V(F)) .LT. V(AFCTOL)) IV(IRC) = 10
- IF (HALF * V(FDIF) .GT. V(PREDUC)) GO TO 999
- EMAX = V(RFCTOL) * DABS(V(F0))
- EMAXS = V(SCTOL) * DABS(V(F0))
- IF (V(PREDUC) .LE. EMAXS .AND. (V(DSTNRM) .GT. V(LMAXS) .OR.
- 1 V(STPPAR) .EQ. ZERO)) IV(IRC) = 11
- IF (V(DST0) .LT. ZERO) GO TO 250
- I = 0
- IF ((V(NREDUC) .GT. ZERO .AND. V(NREDUC) .LE. EMAX) .OR.
- 1 (V(NREDUC) .EQ. ZERO. AND. V(PREDUC) .EQ. ZERO)) I = 2
- IF (V(STPPAR) .EQ. ZERO .AND. V(RELDX) .LE. V(XCTOL)
- 1 .AND. GOODX) I = I + 1
- IF (I .GT. 0) IV(IRC) = I + 6
-C
-C *** CONSIDER RECOMPUTING STEP OF LENGTH V(LMAXS) FOR SINGULAR
-C *** CONVERGENCE TEST.
-C
- 250 IF (IV(IRC) .GT. 5 .AND. IV(IRC) .NE. 12) GO TO 999
- IF (V(STPPAR) .EQ. ZERO) GO TO 999
- IF (V(DSTNRM) .GT. V(LMAXS)) GO TO 260
- IF (V(PREDUC) .GE. EMAXS) GO TO 999
- IF (V(DST0) .LE. ZERO) GO TO 270
- IF (HALF * V(DST0) .LE. V(LMAXS)) GO TO 999
- GO TO 270
- 260 IF (HALF * V(DSTNRM) .LE. V(LMAXS)) GO TO 999
- XMAX = V(LMAXS) / V(DSTNRM)
- IF (XMAX * (TWO - XMAX) * V(PREDUC) .GE. EMAXS) GO TO 999
- 270 IF (V(NREDUC) .LT. ZERO) GO TO 290
-C
-C *** RECOMPUTE V(PREDUC) FOR _USE_ IN SINGULAR CONVERGENCE TEST ***
-C
- V(GTSLST) = V(GTSTEP)
- V(DSTSAV) = V(DSTNRM)
- IF (IV(IRC) .EQ. 12) V(DSTSAV) = -V(DSTSAV)
- V(PLSTGD) = V(PREDUC)
- I = IV(RESTOR)
- IV(RESTOR) = 2
- IF (I .EQ. 3) IV(RESTOR) = 0
- IV(IRC) = 6
- GO TO 999
-C
-C *** PERFORM SINGULAR CONVERGENCE TEST WITH RECOMPUTED V(PREDUC) ***
-C
- 280 V(GTSTEP) = V(GTSLST)
- V(DSTNRM) = DABS(V(DSTSAV))
- IV(IRC) = IV(XIRC)
- IF (V(DSTSAV) .LE. ZERO) IV(IRC) = 12
- V(NREDUC) = -V(PREDUC)
- V(PREDUC) = V(PLSTGD)
- IV(RESTOR) = 3
- 290 IF (-V(NREDUC) .LE. V(SCTOL) * DABS(V(F0))) IV(IRC) = 11
-C
- 999 RETURN
-C
-C *** LAST LINE OF DA7SST FOLLOWS ***
- END
diff --git a/CEP/PyBDSM/src/port3/dalloc.f b/CEP/PyBDSM/src/port3/dalloc.f
deleted file mode 100644
index f7ed7483dde16413a54bdd38f7b4f7aa00da9a65..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/dalloc.f
+++ /dev/null
@@ -1,8 +0,0 @@
- SUBROUTINE DALLOC(N)
-C
- CALL I0TK01
- CALL ISTKRL(N)
-C
- RETURN
-C
- END
diff --git a/CEP/PyBDSM/src/port3/dc6lcf.f b/CEP/PyBDSM/src/port3/dc6lcf.f
deleted file mode 100644
index 67f8398f50d3076f107654f249b761a5699850f7..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/dc6lcf.f
+++ /dev/null
@@ -1,7 +0,0 @@
- SUBROUTINE DC6LCF(P,X,NF,F,IU,UR,UF)
- INTEGER P,IU
- DOUBLE PRECISION X(P),F,UR
- EXTERNAL UF
- CALL UF(P,X,NF,F)
- RETURN
- END
diff --git a/CEP/PyBDSM/src/port3/dc7vfn.f b/CEP/PyBDSM/src/port3/dc7vfn.f
deleted file mode 100644
index 171d4cf06f801a8933adab2cf0738cfcd98b5203..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/dc7vfn.f
+++ /dev/null
@@ -1,54 +0,0 @@
- SUBROUTINE DC7VFN(IV, L, LH, LIV, LV, N, P, V)
-C
-C *** FINISH COVARIANCE COMPUTATION FOR DRN2G, DRNSG ***
-C
- INTEGER LH, LIV, LV, N, P
- INTEGER IV(LIV)
- DOUBLE PRECISION L(LH), V(LV)
-C
- EXTERNAL DL7NVR, DL7TSQ, DV7SCL
-C
-C *** LOCAL VARIABLES ***
-C
- INTEGER COV, I
- DOUBLE PRECISION HALF
-C
-C *** SUBSCRIPTS FOR IV AND V ***
-C
- INTEGER CNVCOD, COVMAT, F, FDH, H, MODE, RDREQ, REGD
-C
-C/6
-C DATA CNVCOD/55/, COVMAT/26/, F/10/, FDH/74/, H/56/, MODE/35/,
-C 1 RDREQ/57/, REGD/67/
-C/7
- PARAMETER (CNVCOD=55, COVMAT=26, F=10, FDH=74, H=56, MODE=35,
- 1 RDREQ=57, REGD=67)
-C/
- DATA HALF/0.5D+0/
-C
-C *** BODY ***
-C
- IV(1) = IV(CNVCOD)
- I = IV(MODE) - P
- IV(MODE) = 0
- IV(CNVCOD) = 0
- IF (IV(FDH) .LE. 0) GO TO 999
- IF ((I-2)**2 .EQ. 1) IV(REGD) = 1
- IF (MOD(IV(RDREQ),2) .NE. 1) GO TO 999
-C
-C *** FINISH COMPUTING COVARIANCE MATRIX = INVERSE OF F.D. HESSIAN.
-C
- COV = IABS(IV(H))
- IV(FDH) = 0
-C
- IF (IV(COVMAT) .NE. 0) GO TO 999
- IF (I .GE. 2) GO TO 10
- CALL DL7NVR(P, V(COV), L)
- CALL DL7TSQ(P, V(COV), V(COV))
-C
- 10 CALL DV7SCL(LH, V(COV), V(F)/(HALF * FLOAT(MAX0(1,N-P))), V(COV))
- IV(COVMAT) = COV
-C
- 999 RETURN
-C *** LAST LINE OF DC7VFN FOLLOWS ***
- END
diff --git a/CEP/PyBDSM/src/port3/dd4sqr.f b/CEP/PyBDSM/src/port3/dd4sqr.f
deleted file mode 100644
index 422c25959c1852a836af883b375acd7c70eec7c6..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/dd4sqr.f
+++ /dev/null
@@ -1,37 +0,0 @@
- SUBROUTINE DD4SQR(K, M, N, Q, R, B, RHS)
- INTEGER M
- INTEGER N
- DOUBLE PRECISION Q(K, 1), R( 1), B(1), RHS(K)
- INTEGER I
- DOUBLE PRECISION BETA, ALPHA,U, X
-C
-C THIS SUBROUTINE UPDATES THE QR DECOMPOSTION WHENE A NEW
-C ROW CONTAINED IN B IS ADDED TO THE MATRIX
-C
- M=M+1
- MM1=M-1
-C
-C ZERO OUT ROW AND COLUMN OF Q MATRIX
-C
- Q(M,M)=1.
- IF(M.EQ.1)RETURN
- DO 10 II=1,MM1
- Q(M,II)=0.0D0
- Q(II,M)=0.0D0
- 10 CONTINUE
- X=RHS(M)
- IF (N.EQ.0) RETURN
- IS=1
- DO 20 I=1,N
- CALL DROTG(R(IS), B(I), ALPHA, BETA)
- CALL DROT(M, Q(I, 1), K, Q(M, 1), K, ALPHA, BETA)
- U=RHS(I)
- RHS(I)=ALPHA*U+BETA*X
- X=-BETA*U+ALPHA*X
- IS=IS+I+1
- IF (N-I.GE.1)
- 1 CALL DS4ROT(N-I,R(IS-1),I+1,B(I+1),-1,ALPHA,BETA)
- 20 CONTINUE
- RHS(M)=X
- RETURN
- END
diff --git a/CEP/PyBDSM/src/port3/dd7dgb.f b/CEP/PyBDSM/src/port3/dd7dgb.f
deleted file mode 100644
index 585a052f007e81f096415fbdd459cab7e02f035b..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/dd7dgb.f
+++ /dev/null
@@ -1,177 +0,0 @@
- SUBROUTINE DD7DGB(B, D, DIG, DST, G, IPIV, KA, L, LV, P, PC,
- 1 NWTST, STEP, TD, TG, V, W, X0)
-C
-C *** COMPUTE DOUBLE-DOGLEG STEP, SUBJECT TO SIMPLE BOUNDS ON X ***
-C
- INTEGER LV, KA, P, PC
- INTEGER IPIV(P)
- DOUBLE PRECISION B(2,P), D(P), DIG(P), DST(P), G(P), L(1),
- 1 NWTST(P), STEP(P), TD(P), TG(P), V(LV), W(P),
- 2 X0(P)
-C
-C DIMENSION L(P*(P+1)/2)
-C
- DOUBLE PRECISION DD7TPR, DR7MDC, DV2NRM
- EXTERNAL DD7DOG, DD7TPR, I7SHFT, DL7ITV, DL7IVM, DL7TVM,DL7VML,
- 1 DQ7RSH, DR7MDC, DV2NRM,DV2AXY,DV7CPY, DV7IPR, DV7SCP,
- 2 DV7SHF, DV7VMP
-C
-C *** LOCAL VARIABLES ***
-C
- INTEGER I, J, K, P1, P1M1
- DOUBLE PRECISION DNWTST, GHINVG, GNORM, GNORM0, NRED, PRED, RAD,
- 1 T, T1, T2, TI, X0I, XI
- DOUBLE PRECISION HALF, MEPS2, ONE, TWO, ZERO
-C
-C *** V SUBSCRIPTS ***
-C
- INTEGER DGNORM, DST0, DSTNRM, GRDFAC, GTHG, GTSTEP, NREDUC,
- 1 NWTFAC, PREDUC, RADIUS, STPPAR
-C
-C/6
-C DATA DGNORM/1/, DST0/3/, DSTNRM/2/, GRDFAC/45/, GTHG/44/,
-C 1 GTSTEP/4/, NREDUC/6/, NWTFAC/46/, PREDUC/7/, RADIUS/8/,
-C 2 STPPAR/5/
-C/7
- PARAMETER (DGNORM=1, DST0=3, DSTNRM=2, GRDFAC=45, GTHG=44,
- 1 GTSTEP=4, NREDUC=6, NWTFAC=46, PREDUC=7, RADIUS=8,
- 2 STPPAR=5)
-C/
-C/6
-C DATA HALF/0.5D+0/, ONE/1.D+0/, TWO/2.D+0/, ZERO/0.D+0/
-C/7
- PARAMETER (HALF=0.5D+0, ONE=1.D+0, TWO=2.D+0, ZERO=0.D+0)
- SAVE MEPS2
-C/
- DATA MEPS2/0.D+0/
-C
-C+++++++++++++++++++++++++++++++ BODY ++++++++++++++++++++++++++++++++
-C
- IF (MEPS2 .LE. ZERO) MEPS2 = TWO * DR7MDC(3)
- GNORM0 = V(DGNORM)
- V(DSTNRM) = ZERO
- IF (KA .LT. 0) GO TO 10
- DNWTST = V(DST0)
- NRED = V(NREDUC)
- 10 PRED = ZERO
- V(STPPAR) = ZERO
- RAD = V(RADIUS)
- IF (PC .GT. 0) GO TO 20
- DNWTST = ZERO
- CALL DV7SCP(P, STEP, ZERO)
- GO TO 140
-C
- 20 P1 = PC
- CALL DV7CPY(P, TD, D)
- CALL DV7IPR(P, IPIV, TD)
- CALL DV7SCP(PC, DST, ZERO)
- CALL DV7CPY(P, TG, G)
- CALL DV7IPR(P, IPIV, TG)
-C
- 30 CALL DL7IVM(P1, NWTST, L, TG)
- GHINVG = DD7TPR(P1, NWTST, NWTST)
- V(NREDUC) = HALF * GHINVG
- CALL DL7ITV(P1, NWTST, L, NWTST)
- CALL DV7VMP(P1, STEP, NWTST, TD, 1)
- V(DST0) = DV2NRM(PC, STEP)
- IF (KA .GE. 0) GO TO 40
- KA = 0
- DNWTST = V(DST0)
- NRED = V(NREDUC)
- 40 V(RADIUS) = RAD - V(DSTNRM)
- IF (V(RADIUS) .LE. ZERO) GO TO 100
- CALL DV7VMP(P1, DIG, TG, TD, -1)
- GNORM = DV2NRM(P1, DIG)
- IF (GNORM .LE. ZERO) GO TO 100
- V(DGNORM) = GNORM
- CALL DV7VMP(P1, DIG, DIG, TD, -1)
- CALL DL7TVM(P1, W, L, DIG)
- V(GTHG) = DV2NRM(P1, W)
- KA = KA + 1
- CALL DD7DOG(DIG, LV, P1, NWTST, STEP, V)
-C
-C *** FIND T SUCH THAT X - T*STEP IS STILL FEASIBLE.
-C
- T = ONE
- K = 0
- DO 70 I = 1, P1
- J = IPIV(I)
- X0I = X0(J) + DST(I)/TD(I)
- XI = X0I + STEP(I)
- IF (XI .LT. B(1,J)) GO TO 50
- IF (XI .LE. B(2,J)) GO TO 70
- TI = (B(2,J) - X0I) / STEP(I)
- J = I
- GO TO 60
- 50 TI = (B(1,J) - X0I) / STEP(I)
- J = -I
- 60 IF (T .LE. TI) GO TO 70
- K = J
- T = TI
- 70 CONTINUE
-C
-C *** UPDATE DST, TG, AND PRED ***
-C
- CALL DV7VMP(P1, STEP, STEP, TD, 1)
- CALL DV2AXY(P1, DST, T, STEP, DST)
- V(DSTNRM) = DV2NRM(PC, DST)
- T1 = T * V(GRDFAC)
- T2 = T * V(NWTFAC)
- PRED = PRED - T1*GNORM * ((T2 + ONE)*GNORM)
- 1 - T2 * (ONE + HALF*T2)*GHINVG
- 2 - HALF * (V(GTHG)*T1)**2
- IF (K .EQ. 0) GO TO 100
- CALL DL7VML(P1, W, L, W)
- T2 = ONE - T2
- DO 80 I = 1, P1
- 80 TG(I) = T2*TG(I) - T1*W(I)
-C
-C *** PERMUTE L, ETC. IF NECESSARY ***
-C
- P1M1 = P1 - 1
- J = IABS(K)
- IF (J .EQ. P1) GO TO 90
- CALL DQ7RSH(J, P1, .FALSE., TG, L, W)
- CALL I7SHFT(P1, J, IPIV)
- CALL DV7SHF(P1, J, TG)
- CALL DV7SHF(P1, J, TD)
- CALL DV7SHF(P1, J, DST)
- 90 IF (K .LT. 0) IPIV(P1) = -IPIV(P1)
- P1 = P1M1
- IF (P1 .GT. 0) GO TO 30
-C
-C *** UNSCALE STEP, UPDATE X AND DIHDI ***
-C
- 100 CALL DV7SCP(P, STEP, ZERO)
- DO 110 I = 1, PC
- J = IABS(IPIV(I))
- STEP(J) = DST(I) / TD(I)
- 110 CONTINUE
-C
-C *** FUDGE STEP TO ENSURE THAT IT FORCES APPROPRIATE COMPONENTS
-C *** TO THEIR BOUNDS ***
-C
- IF (P1 .GE. PC) GO TO 140
- CALL DV2AXY(P, TD, ONE, STEP, X0)
- K = P1 + 1
- DO 130 I = K, PC
- J = IPIV(I)
- T = MEPS2
- IF (J .GT. 0) GO TO 120
- T = -T
- J = -J
- IPIV(I) = J
- 120 T = T * DMAX1(DABS(TD(J)), DABS(X0(J)))
- STEP(J) = STEP(J) + T
- 130 CONTINUE
-C
- 140 V(DGNORM) = GNORM0
- V(NREDUC) = NRED
- V(PREDUC) = PRED
- V(RADIUS) = RAD
- V(DST0) = DNWTST
- V(GTSTEP) = DD7TPR(P, STEP, G)
-C
- 999 RETURN
-C *** LAST LINE OF DD7DGB FOLLOWS ***
- END
diff --git a/CEP/PyBDSM/src/port3/dd7dog.f b/CEP/PyBDSM/src/port3/dd7dog.f
deleted file mode 100644
index 5efa6ff67e6a1ebd115de84fd0573cdcece70476..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/dd7dog.f
+++ /dev/null
@@ -1,201 +0,0 @@
- SUBROUTINE DD7DOG(DIG, LV, N, NWTSTP, STEP, V)
-C
-C *** COMPUTE DOUBLE DOGLEG STEP ***
-C
-C *** PARAMETER DECLARATIONS ***
-C
- INTEGER LV, N
- DOUBLE PRECISION DIG(N), NWTSTP(N), STEP(N), V(LV)
-C
-C *** PURPOSE ***
-C
-C THIS SUBROUTINE COMPUTES A CANDIDATE STEP (FOR _USE_ IN AN UNCON-
-C STRAINED MINIMIZATION CODE) BY THE DOUBLE DOGLEG ALGORITHM OF
-C DENNIS AND MEI (REF. 1), WHICH IS A VARIATION ON POWELL*S DOGLEG
-C SCHEME (REF. 2, P. 95).
-C
-C-------------------------- PARAMETER USAGE --------------------------
-C
-C DIG (INPUT) DIAG(D)**-2 * G -- SEE ALGORITHM NOTES.
-C G (INPUT) THE CURRENT GRADIENT VECTOR.
-C LV (INPUT) LENGTH OF V.
-C N (INPUT) NUMBER OF COMPONENTS IN DIG, G, NWTSTP, AND STEP.
-C NWTSTP (INPUT) NEGATIVE NEWTON STEP -- SEE ALGORITHM NOTES.
-C STEP (OUTPUT) THE COMPUTED STEP.
-C V (I/O) VALUES ARRAY, THE FOLLOWING COMPONENTS OF WHICH ARE
-C USED HERE...
-C V(BIAS) (INPUT) BIAS FOR RELAXED NEWTON STEP, WHICH IS V(BIAS) OF
-C THE WAY FROM THE FULL NEWTON TO THE FULLY RELAXED NEWTON
-C STEP. RECOMMENDED VALUE = 0.8 .
-C V(DGNORM) (INPUT) 2-NORM OF DIAG(D)**-1 * G -- SEE ALGORITHM NOTES.
-C V(DSTNRM) (OUTPUT) 2-NORM OF DIAG(D) * STEP, WHICH IS V(RADIUS)
-C UNLESS V(STPPAR) = 0 -- SEE ALGORITHM NOTES.
-C V(DST0) (INPUT) 2-NORM OF DIAG(D) * NWTSTP -- SEE ALGORITHM NOTES.
-C V(GRDFAC) (OUTPUT) THE COEFFICIENT OF DIG IN THE STEP RETURNED --
-C STEP(I) = V(GRDFAC)*DIG(I) + V(NWTFAC)*NWTSTP(I).
-C V(GTHG) (INPUT) SQUARE-ROOT OF (DIG**T) * (HESSIAN) * DIG -- SEE
-C ALGORITHM NOTES.
-C V(GTSTEP) (OUTPUT) INNER PRODUCT BETWEEN G AND STEP.
-C V(NREDUC) (OUTPUT) FUNCTION REDUCTION PREDICTED FOR THE FULL NEWTON
-C STEP.
-C V(NWTFAC) (OUTPUT) THE COEFFICIENT OF NWTSTP IN THE STEP RETURNED --
-C SEE V(GRDFAC) ABOVE.
-C V(PREDUC) (OUTPUT) FUNCTION REDUCTION PREDICTED FOR THE STEP RETURNED.
-C V(RADIUS) (INPUT) THE TRUST REGION RADIUS. D TIMES THE STEP RETURNED
-C HAS 2-NORM V(RADIUS) UNLESS V(STPPAR) = 0.
-C V(STPPAR) (OUTPUT) CODE TELLING HOW STEP WAS COMPUTED... 0 MEANS A
-C FULL NEWTON STEP. BETWEEN 0 AND 1 MEANS V(STPPAR) OF THE
-C WAY FROM THE NEWTON TO THE RELAXED NEWTON STEP. BETWEEN
-C 1 AND 2 MEANS A TRUE DOUBLE DOGLEG STEP, V(STPPAR) - 1 OF
-C THE WAY FROM THE RELAXED NEWTON TO THE CAUCHY STEP.
-C GREATER THAN 2 MEANS 1 / (V(STPPAR) - 1) TIMES THE CAUCHY
-C STEP.
-C
-C------------------------------- NOTES -------------------------------
-C
-C *** ALGORITHM NOTES ***
-C
-C LET G AND H BE THE CURRENT GRADIENT AND HESSIAN APPROXIMA-
-C TION RESPECTIVELY AND LET D BE THE CURRENT SCALE VECTOR. THIS
-C ROUTINE ASSUMES DIG = DIAG(D)**-2 * G AND NWTSTP = H**-1 * G.
-C THE STEP COMPUTED IS THE SAME ONE WOULD GET BY REPLACING G AND H
-C BY DIAG(D)**-1 * G AND DIAG(D)**-1 * H * DIAG(D)**-1,
-C COMPUTING STEP, AND TRANSLATING STEP BACK TO THE ORIGINAL
-C VARIABLES, I.E., PREMULTIPLYING IT BY DIAG(D)**-1.
-C
-C *** REFERENCES ***
-C
-C 1. DENNIS, J.E., AND MEI, H.H.W. (1979), TWO NEW UNCONSTRAINED OPTI-
-C MIZATION ALGORITHMS WHICH _USE_ FUNCTION AND GRADIENT
-C VALUES, J. OPTIM. THEORY APPLIC. 28, PP. 453-482.
-C 2. POWELL, M.J.D. (1970), A HYBRID METHOD FOR NON-LINEAR EQUATIONS,
-C IN NUMERICAL METHODS FOR NON-LINEAR EQUATIONS, EDITED BY
-C P. RABINOWITZ, GORDON AND BREACH, LONDON.
-C
-C *** GENERAL ***
-C
-C CODED BY DAVID M. GAY.
-C THIS SUBROUTINE WAS WRITTEN IN CONNECTION WITH RESEARCH SUPPORTED
-C BY THE NATIONAL SCIENCE FOUNDATION UNDER GRANTS MCS-7600324 AND
-C MCS-7906671.
-C
-C------------------------ EXTERNAL QUANTITIES ------------------------
-C
-C *** INTRINSIC FUNCTIONS ***
-C/+
- DOUBLE PRECISION DSQRT
-C/
-C-------------------------- LOCAL VARIABLES --------------------------
-C
- INTEGER I
- DOUBLE PRECISION CFACT, CNORM, CTRNWT, GHINVG, FEMNSQ, GNORM,
- 1 NWTNRM, RELAX, RLAMBD, T, T1, T2
- DOUBLE PRECISION HALF, ONE, TWO, ZERO
-C
-C *** V SUBSCRIPTS ***
-C
- INTEGER BIAS, DGNORM, DSTNRM, DST0, GRDFAC, GTHG, GTSTEP,
- 1 NREDUC, NWTFAC, PREDUC, RADIUS, STPPAR
-C
-C *** DATA INITIALIZATIONS ***
-C
-C/6
-C DATA HALF/0.5D+0/, ONE/1.D+0/, TWO/2.D+0/, ZERO/0.D+0/
-C/7
- PARAMETER (HALF=0.5D+0, ONE=1.D+0, TWO=2.D+0, ZERO=0.D+0)
-C/
-C
-C/6
-C DATA BIAS/43/, DGNORM/1/, DSTNRM/2/, DST0/3/, GRDFAC/45/,
-C 1 GTHG/44/, GTSTEP/4/, NREDUC/6/, NWTFAC/46/, PREDUC/7/,
-C 2 RADIUS/8/, STPPAR/5/
-C/7
- PARAMETER (BIAS=43, DGNORM=1, DSTNRM=2, DST0=3, GRDFAC=45,
- 1 GTHG=44, GTSTEP=4, NREDUC=6, NWTFAC=46, PREDUC=7,
- 2 RADIUS=8, STPPAR=5)
-C/
-C
-C+++++++++++++++++++++++++++++++ BODY ++++++++++++++++++++++++++++++++
-C
- NWTNRM = V(DST0)
- RLAMBD = ONE
- IF (NWTNRM .GT. ZERO) RLAMBD = V(RADIUS) / NWTNRM
- GNORM = V(DGNORM)
- GHINVG = TWO * V(NREDUC)
- V(GRDFAC) = ZERO
- V(NWTFAC) = ZERO
- IF (RLAMBD .LT. ONE) GO TO 30
-C
-C *** THE NEWTON STEP IS INSIDE THE TRUST REGION ***
-C
- V(STPPAR) = ZERO
- V(DSTNRM) = NWTNRM
- V(GTSTEP) = -GHINVG
- V(PREDUC) = V(NREDUC)
- V(NWTFAC) = -ONE
- DO 20 I = 1, N
- 20 STEP(I) = -NWTSTP(I)
- GO TO 999
-C
- 30 V(DSTNRM) = V(RADIUS)
- CFACT = (GNORM / V(GTHG))**2
-C *** CAUCHY STEP = -CFACT * G.
- CNORM = GNORM * CFACT
- RELAX = ONE - V(BIAS) * (ONE - GNORM*CNORM/GHINVG)
- IF (RLAMBD .LT. RELAX) GO TO 50
-C
-C *** STEP IS BETWEEN RELAXED NEWTON AND FULL NEWTON STEPS ***
-C
- V(STPPAR) = ONE - (RLAMBD - RELAX) / (ONE - RELAX)
- T = -RLAMBD
- V(GTSTEP) = T * GHINVG
- V(PREDUC) = RLAMBD * (ONE - HALF*RLAMBD) * GHINVG
- V(NWTFAC) = T
- DO 40 I = 1, N
- 40 STEP(I) = T * NWTSTP(I)
- GO TO 999
-C
- 50 IF (CNORM .LT. V(RADIUS)) GO TO 70
-C
-C *** THE CAUCHY STEP LIES OUTSIDE THE TRUST REGION --
-C *** STEP = SCALED CAUCHY STEP ***
-C
- T = -V(RADIUS) / GNORM
- V(GRDFAC) = T
- V(STPPAR) = ONE + CNORM / V(RADIUS)
- V(GTSTEP) = -V(RADIUS) * GNORM
- V(PREDUC) = V(RADIUS)*(GNORM - HALF*V(RADIUS)*(V(GTHG)/GNORM)**2)
- DO 60 I = 1, N
- 60 STEP(I) = T * DIG(I)
- GO TO 999
-C
-C *** COMPUTE DOGLEG STEP BETWEEN CAUCHY AND RELAXED NEWTON ***
-C *** FEMUR = RELAXED NEWTON STEP MINUS CAUCHY STEP ***
-C
- 70 CTRNWT = CFACT * RELAX * GHINVG / GNORM
-C *** CTRNWT = INNER PROD. OF CAUCHY AND RELAXED NEWTON STEPS,
-C *** SCALED BY GNORM**-1.
- T1 = CTRNWT - GNORM*CFACT**2
-C *** T1 = INNER PROD. OF FEMUR AND CAUCHY STEP, SCALED BY
-C *** GNORM**-1.
- T2 = V(RADIUS)*(V(RADIUS)/GNORM) - GNORM*CFACT**2
- T = RELAX * NWTNRM
- FEMNSQ = (T/GNORM)*T - CTRNWT - T1
-C *** FEMNSQ = SQUARE OF 2-NORM OF FEMUR, SCALED BY GNORM**-1.
- T = T2 / (T1 + DSQRT(T1**2 + FEMNSQ*T2))
-C *** DOGLEG STEP = CAUCHY STEP + T * FEMUR.
- T1 = (T - ONE) * CFACT
- V(GRDFAC) = T1
- T2 = -T * RELAX
- V(NWTFAC) = T2
- V(STPPAR) = TWO - T
- V(GTSTEP) = T1*GNORM**2 + T2*GHINVG
- V(PREDUC) = -T1*GNORM * ((T2 + ONE)*GNORM)
- 1 - T2 * (ONE + HALF*T2)*GHINVG
- 2 - HALF * (V(GTHG)*T1)**2
- DO 80 I = 1, N
- 80 STEP(I) = T1*DIG(I) + T2*NWTSTP(I)
-C
- 999 RETURN
-C *** LAST LINE OF DD7DOG FOLLOWS ***
- END
diff --git a/CEP/PyBDSM/src/port3/dd7dup.f b/CEP/PyBDSM/src/port3/dd7dup.f
deleted file mode 100644
index 6e31dbd6e6d5d60955ce9a90d2712c12f307f13e..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/dd7dup.f
+++ /dev/null
@@ -1,48 +0,0 @@
- SUBROUTINE DD7DUP(D, HDIAG, IV, LIV, LV, N, V)
-C
-C *** UPDATE SCALE VECTOR D FOR DMNH ***
-C
-C *** PARAMETER DECLARATIONS ***
-C
- INTEGER LIV, LV, N
- INTEGER IV(LIV)
- DOUBLE PRECISION D(N), HDIAG(N), V(LV)
-C
-C *** LOCAL VARIABLES ***
-C
- INTEGER DTOLI, D0I, I
- DOUBLE PRECISION T, VDFAC
-C
-C *** INTRINSIC FUNCTIONS ***
-C/+
- DOUBLE PRECISION DSQRT
-C/
-C *** SUBSCRIPTS FOR IV AND V ***
-C
- INTEGER DFAC, DTOL, DTYPE, NITER
-C/6
-C DATA DFAC/41/, DTOL/59/, DTYPE/16/, NITER/31/
-C/7
- PARAMETER (DFAC=41, DTOL=59, DTYPE=16, NITER=31)
-C/
-C
-C------------------------------- BODY --------------------------------
-C
- I = IV(DTYPE)
- IF (I .EQ. 1) GO TO 10
- IF (IV(NITER) .GT. 0) GO TO 999
-C
- 10 DTOLI = IV(DTOL)
- D0I = DTOLI + N
- VDFAC = V(DFAC)
- DO 20 I = 1, N
- T = DMAX1(DSQRT(DABS(HDIAG(I))), VDFAC*D(I))
- IF (T .LT. V(DTOLI)) T = DMAX1(V(DTOLI), V(D0I))
- D(I) = T
- DTOLI = DTOLI + 1
- D0I = D0I + 1
- 20 CONTINUE
-C
- 999 RETURN
-C *** LAST CARD OF DD7DUP FOLLOWS ***
- END
diff --git a/CEP/PyBDSM/src/port3/dd7mlp.f b/CEP/PyBDSM/src/port3/dd7mlp.f
deleted file mode 100644
index 8542c30b21d54057495f15be61510820241414d7..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/dd7mlp.f
+++ /dev/null
@@ -1,37 +0,0 @@
- SUBROUTINE DD7MLP(N, X, Y, Z, K)
-C
-C *** SET X = DIAG(Y)**K * Z
-C *** FOR X, Z = LOWER TRIANG. MATRICES STORED COMPACTLY BY ROW
-C *** K = 1 OR -1.
-C
- INTEGER N, K
-C/6
-C DOUBLE PRECISION X(1), Y(N), Z(1)
-C/7
- DOUBLE PRECISION X(*), Y(N), Z(*)
-C/
- INTEGER I, J, L
- DOUBLE PRECISION ONE, T
- DATA ONE/1.D+0/
-C
- L = 1
- IF (K .GE. 0) GO TO 30
- DO 20 I = 1, N
- T = ONE / Y(I)
- DO 10 J = 1, I
- X(L) = T * Z(L)
- L = L + 1
- 10 CONTINUE
- 20 CONTINUE
- GO TO 999
-C
- 30 DO 50 I = 1, N
- T = Y(I)
- DO 40 J = 1, I
- X(L) = T * Z(L)
- L = L + 1
- 40 CONTINUE
- 50 CONTINUE
- 999 RETURN
-C *** LAST CARD OF DD7MLP FOLLOWS ***
- END
diff --git a/CEP/PyBDSM/src/port3/dd7tpr.f b/CEP/PyBDSM/src/port3/dd7tpr.f
deleted file mode 100644
index efdf8d2059dd31a8baf5b44d4d2855c2edd8c621..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/dd7tpr.f
+++ /dev/null
@@ -1,38 +0,0 @@
- DOUBLE PRECISION FUNCTION DD7TPR(P, X, Y)
-C
-C *** RETURN THE INNER PRODUCT OF THE P-VECTORS X AND Y. ***
-C
- INTEGER P
- DOUBLE PRECISION X(P), Y(P)
-C
- INTEGER I
- DOUBLE PRECISION ONE, SQTETA, T, ZERO
- DOUBLE PRECISION DR7MDC
- EXTERNAL DR7MDC
-C
-C *** DR7MDC(2) RETURNS A MACHINE-DEPENDENT CONSTANT, SQTETA, WHICH
-C *** IS SLIGHTLY LARGER THAN THE SMALLEST POSITIVE NUMBER THAT
-C *** CAN BE SQUARED WITHOUT UNDERFLOWING.
-C
-C/6
-C DATA ONE/1.D+0/, SQTETA/0.D+0/, ZERO/0.D+0/
-C/7
- PARAMETER (ONE=1.D+0, ZERO=0.D+0)
- DATA SQTETA/0.D+0/
-C/
-C
- DD7TPR = ZERO
- IF (P .LE. 0) GO TO 999
- IF (SQTETA .EQ. ZERO) SQTETA = DR7MDC(2)
- DO 20 I = 1, P
- T = DMAX1(DABS(X(I)), DABS(Y(I)))
- IF (T .GT. ONE) GO TO 10
- IF (T .LT. SQTETA) GO TO 20
- T = (X(I)/SQTETA)*Y(I)
- IF (DABS(T) .LT. SQTETA) GO TO 20
- 10 DD7TPR = DD7TPR + X(I)*Y(I)
- 20 CONTINUE
-C
- 999 RETURN
-C *** LAST LINE OF DD7TPR FOLLOWS ***
- END
diff --git a/CEP/PyBDSM/src/port3/dd7upd.f b/CEP/PyBDSM/src/port3/dd7upd.f
deleted file mode 100644
index dd3e4c5e191b07343d24e4a09aed0e5ebbebdfea..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/dd7upd.f
+++ /dev/null
@@ -1,79 +0,0 @@
- SUBROUTINE DD7UPD(D, DR, IV, LIV, LV, N, ND, NN, N2, P, V)
-C
-C *** UPDATE SCALE VECTOR D FOR NL2IT ***
-C
-C *** PARAMETER DECLARATIONS ***
-C
- INTEGER LIV, LV, N, ND, NN, N2, P
- INTEGER IV(LIV)
- DOUBLE PRECISION D(P), DR(ND,P), V(LV)
-C DIMENSION V(*)
-C
-C *** LOCAL VARIABLES ***
-C
- INTEGER D0, I, JCN0, JCN1, JCNI, JTOL0, JTOLI, K, SII
- DOUBLE PRECISION T, VDFAC
-C
-C *** CONSTANTS ***
-C
- DOUBLE PRECISION ZERO
-C
-C *** INTRINSIC FUNCTIONS ***
-C/+
- DOUBLE PRECISION DSQRT
-C/
-C *** EXTERNAL SUBROUTINE ***
-C
- EXTERNAL DV7SCP
-C
-C DV7SCP... SETS ALL COMPONENTS OF A VECTOR TO A SCALAR.
-C
-C *** SUBSCRIPTS FOR IV AND V ***
-C
- INTEGER DFAC, DTYPE, JCN, JTOL, NITER, S
-C/6
-C DATA DFAC/41/, DTYPE/16/, JCN/66/, JTOL/59/, NITER/31/, S/62/
-C/7
- PARAMETER (DFAC=41, DTYPE=16, JCN=66, JTOL=59, NITER=31, S=62)
-C/
-C
-C/6
-C DATA ZERO/0.D+0/
-C/7
- PARAMETER (ZERO=0.D+0)
-C/
-C
-C------------------------------- BODY --------------------------------
-C
- IF (IV(DTYPE) .NE. 1 .AND. IV(NITER) .GT. 0) GO TO 999
- JCN1 = IV(JCN)
- JCN0 = IABS(JCN1) - 1
- IF (JCN1 .LT. 0) GO TO 10
- IV(JCN) = -JCN1
- CALL DV7SCP(P, V(JCN1), ZERO)
- 10 DO 30 I = 1, P
- JCNI = JCN0 + I
- T = V(JCNI)
- DO 20 K = 1, NN
- 20 T = DMAX1(T, DABS(DR(K,I)))
- V(JCNI) = T
- 30 CONTINUE
- IF (N2 .LT. N) GO TO 999
- VDFAC = V(DFAC)
- JTOL0 = IV(JTOL) - 1
- D0 = JTOL0 + P
- SII = IV(S) - 1
- DO 50 I = 1, P
- SII = SII + I
- JCNI = JCN0 + I
- T = V(JCNI)
- IF (V(SII) .GT. ZERO) T = DMAX1(DSQRT(V(SII)), T)
- JTOLI = JTOL0 + I
- D0 = D0 + 1
- IF (T .LT. V(JTOLI)) T = DMAX1(V(D0), V(JTOLI))
- D(I) = DMAX1(VDFAC*D(I), T)
- 50 CONTINUE
-C
- 999 RETURN
-C *** LAST CARD OF DD7UPD FOLLOWS ***
- END
diff --git a/CEP/PyBDSM/src/port3/deigen.f b/CEP/PyBDSM/src/port3/deigen.f
deleted file mode 100644
index 13a664ccdfb3229652bf80efd4517a36c4eb413e..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/deigen.f
+++ /dev/null
@@ -1,109 +0,0 @@
- SUBROUTINE DEIGEN(NM,N,A,WR,WI,Z)
- DOUBLE PRECISION A(NM,N),WR(N),WI(N),Z(NM,N)
-C
- COMMON/CSTAK/D
- DOUBLE PRECISION D(500)
-C
-C DEIGEN FINDS THE EIGENVALUES AND EIGENVECTORS
-C OF A DOUBLE-PRECISION MATRIX (NOT IMAGINARY) BY
-C CALLING THE SEQUENCE OF SUBROUTINES
-C DORTHE,DORTRA, AND DHQR2, WHICH, IN TURN, ARE
-C THE EISPACK ROUTINES ORTHES, ORTRAN, AND HQR2,
-C ADJUSTED FOR DOUBLE PRECISION.
-C
-C ON INPUT -
-C
-C NM - AN INTEGER INPUT VARIABLE SET EQUAL TO
-C THE ROW DIMENSION OF THE TWO-DIMENSIONAL ARRAYS
-C A AND Z AS SPECIFIED IN THE DIMENSION STATEMENTS
-C FOR A AND Z IN THE CALLING PROGRAM.
-C
-C N - AN INTEGER INPUT VARIABLE SET EQUAL TO THE
-C ORDER OF THE MATRIX A.
-C
-C N MUST NOT BE GREATER THAN NM.
-C
-C A - THE MATRIX, A DOUBLE-PRECISION TWO-DIMENSIONAL
-C ARRAY WITH ROW DIMENSION NM AND COLUMN
-C DIMENSION AT LEAST N.
-C
-C A IS OVERWRITTEN.
-C
-C
-C
-C ON OUTPUT -
-C
-C WR - A DOUBLE-PRECISION ARRAY OF DIMENSION
-C AT LEAST N CONTAINING THE REAL PARTS OF THE EIGENVALUES
-C
-C WI - A DOUBLE-PRECISION ARRAY OF DIMENSION
-C AT LEAST N CONTAINING THE IMAGINARY PARTS OF THE EIGENVALUES.
-C
-C THE EIGENVALUES ARE UNORDERED EXCEPT THAT
-C COMPLEX CONJUGATE PAIRS OF EIGENVALUES
-C APPEAR CONSECUTIVELY WITH THE EIGENVALUE HAVING
-C THE POSITIVE IMAGINARY PART FIRST.
-C
-C Z - A DOUBLE-PRECISION TWO-DIMENSIONAL ARRAY
-C WITH ROW DIMENSION NM AND COLUMN DIMENSION
-C AT LEAST N CONTAINING THE REAL AND IMAGINARY PARTS
-C OF THE EIGENVECTORS.
-C
-C IF THE J-TH EIGENVALUE IS REAL, THE J-TH
-C COLUMN OF Z CONTAINS ITS EIGENVECTOR.
-C
-C IF THE J-TH EIGENVALUE IS COMPLEX WITH
-C POSITIVE REAL PART, THE J-TH AND (J+1)-TH
-C COLUMNS OF Z CONTAIN THE REAL AND IMAGINARY
-C PARTS OF ITS EIGENVECTOR.
-C
-C THE CONJUGATE OF THIS VECTOR IS THE
-C EIGENVECTOR FOR THE CONJUGATE EIGENVALUE.
-C THE EIGENVECTORS ARE NOT NORMALIZED.
-C
-C
-C ERROR STATES -
-C
-C 1 - N IS GREATER THAN NM
-C
-C K - THE K-TH EIGENVALUE COULD NOT BE COMPUTED
-C WITHIN 30 ITERATIONS.
-C
-C THE EIGENVALUES IN THE WR AND WRI ARRAYS
-C SHOULD BE CORRECT FOR INDICES
-C K+1, K+2,...,N, BUT NO EIGENVECTORS ARE COMPUTED.
-C
-C
-C
-C
-C CHECK FOR INPUT ERROR IN N
-C
-C/6S
-C IF (N .GT. NM) CALL SETERR(
-C 1 29HDEIGEN - N IS GREATER THAN NM,29,1,2)
-C/7S
- IF (N .GT. NM) CALL SETERR(
- 1 'DEIGEN - N IS GREATER THAN NM',29,1,2)
-C/
-C
-C ALLOCATE A SCRATCH VECTOR
- IORT = ISTKGT(N,4)
-C
- CALL DORTHE (NM,N,1,N,A,D(IORT))
- CALL DORTRA (NM,N,1,N,A,D(IORT),Z)
- CALL DHQR2 (NM,N,1,N,A,WR,WI,Z,IERR)
-C
- IF (IERR .NE. 0) GO TO 10
- CALL ISTKRL(1)
- RETURN
-C/6S
-C 10 CALL SETERR(
-C 1 34HDEIGEN - FAILED ON THAT EIGENVALUE,34,IERR,1)
-C/7S
- 10 CALL SETERR(
- 1 'DEIGEN - FAILED ON THAT EIGENVALUE',34,IERR,1)
-C/
-C
- CALL ISTKRL(1)
- RETURN
- END
diff --git a/CEP/PyBDSM/src/port3/df7dhb.f b/CEP/PyBDSM/src/port3/df7dhb.f
deleted file mode 100644
index 25152072f55f5a5c0a1b785eae1b96f14369cecb..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/df7dhb.f
+++ /dev/null
@@ -1,287 +0,0 @@
- SUBROUTINE DF7DHB(B, D, G, IRT, IV, LIV, LV, P, V, X)
-C
-C *** COMPUTE FINITE-DIFFERENCE HESSIAN, STORE IT IN V STARTING
-C *** AT V(IV(FDH)) = V(-IV(H)). HONOR SIMPLE BOUNDS IN B.
-C
-C *** IF IV(COVREQ) .GE. 0 THEN DF7DHB USES GRADIENT DIFFERENCES,
-C *** OTHERWISE FUNCTION DIFFERENCES. STORAGE IN V IS AS IN DG7LIT.
-C
-C IRT VALUES...
-C 1 = COMPUTE FUNCTION VALUE, I.E., V(F).
-C 2 = COMPUTE G.
-C 3 = DONE.
-C
-C
-C *** PARAMETER DECLARATIONS ***
-C
- INTEGER IRT, LIV, LV, P
- INTEGER IV(LIV)
- DOUBLE PRECISION B(2,P), D(P), G(P), V(LV), X(P)
-C
-C *** LOCAL VARIABLES ***
-C
- LOGICAL OFFSID
- INTEGER GSAVE1, HES, HMI, HPI, HPM, I, K, KIND, L, M, MM1, MM1O2,
- 1 NEWM1, PP1O2, STPI, STPM, STP0
- DOUBLE PRECISION DEL, DEL0, T, XM, XM1
- DOUBLE PRECISION HALF, HLIM, ONE, TWO, ZERO
-C
-C *** EXTERNAL SUBROUTINES ***
-C
- EXTERNAL DV7CPY, DV7SCP
-C
-C DV7CPY.... COPY ONE VECTOR TO ANOTHER.
-C DV7SCP... COPY SCALAR TO ALL COMPONENTS OF A VECTOR.
-C
-C *** SUBSCRIPTS FOR IV AND V ***
-C
- INTEGER COVREQ, DELTA, DELTA0, DLTFDC, F, FDH, FX, H, KAGQT, MODE,
- 1 NFGCAL, SAVEI, SWITCH, TOOBIG, W, XMSAVE
-C
-C/6
-C DATA HALF/0.5D+0/, HLIM/0.1D+0/, ONE/1.D+0/, TWO/2.D+0/,
-C 1 ZERO/0.D+0/
-C/7
- PARAMETER (HALF=0.5D+0, HLIM=0.1D+0, ONE=1.D+0, TWO=2.D+0,
- 1 ZERO=0.D+0)
-C/
-C
-C/6
-C DATA COVREQ/15/, DELTA/52/, DELTA0/44/, DLTFDC/42/, F/10/,
-C 1 FDH/74/, FX/53/, H/56/, KAGQT/33/, MODE/35/, NFGCAL/7/,
-C 2 SAVEI/63/, SWITCH/12/, TOOBIG/2/, W/65/, XMSAVE/51/
-C/7
- PARAMETER (COVREQ=15, DELTA=52, DELTA0=44, DLTFDC=42, F=10,
- 1 FDH=74, FX=53, H=56, KAGQT=33, MODE=35, NFGCAL=7,
- 2 SAVEI=63, SWITCH=12, TOOBIG=2, W=65, XMSAVE=51)
-C/
-C
-C+++++++++++++++++++++++++++++++ BODY ++++++++++++++++++++++++++++++++
-C
- IRT = 4
- KIND = IV(COVREQ)
- M = IV(MODE)
- IF (M .GT. 0) GO TO 10
- HES = IABS(IV(H))
- IV(H) = -HES
- IV(FDH) = 0
- IV(KAGQT) = -1
- V(FX) = V(F)
-C *** SUPPLY ZEROS IN CASE B(1,I) = B(2,I) FOR SOME I ***
- CALL DV7SCP(P*(P+1)/2, V(HES), ZERO)
- 10 IF (M .GT. P) GO TO 999
- IF (KIND .LT. 0) GO TO 120
-C
-C *** COMPUTE FINITE-DIFFERENCE HESSIAN USING BOTH FUNCTION AND
-C *** GRADIENT VALUES.
-C
- GSAVE1 = IV(W) + P
- IF (M .GT. 0) GO TO 20
-C *** FIRST CALL ON DF7DHB. SET GSAVE = G, TAKE FIRST STEP ***
- CALL DV7CPY(P, V(GSAVE1), G)
- IV(SWITCH) = IV(NFGCAL)
- GO TO 80
-C
- 20 DEL = V(DELTA)
- X(M) = V(XMSAVE)
- IF (IV(TOOBIG) .EQ. 0) GO TO 30
-C
-C *** HANDLE OVERSIZE V(DELTA) ***
-C
- DEL0 = V(DELTA0) * DMAX1(ONE/D(M), DABS(X(M)))
- DEL = HALF * DEL
- IF (DABS(DEL/DEL0) .LE. HLIM) GO TO 140
-C
- 30 HES = -IV(H)
-C
-C *** SET G = (G - GSAVE)/DEL ***
-C
- DEL = ONE / DEL
- DO 40 I = 1, P
- G(I) = DEL * (G(I) - V(GSAVE1))
- GSAVE1 = GSAVE1 + 1
- 40 CONTINUE
-C
-C *** ADD G AS NEW COL. TO FINITE-DIFF. HESSIAN MATRIX ***
-C
- K = HES + M*(M-1)/2
- L = K + M - 2
- IF (M .EQ. 1) GO TO 60
-C
-C *** SET H(I,M) = 0.5 * (H(I,M) + G(I)) FOR I = 1 TO M-1 ***
-C
- MM1 = M - 1
- DO 50 I = 1, MM1
- IF (B(1,I) .LT. B(2,I)) V(K) = HALF * (V(K) + G(I))
- K = K + 1
- 50 CONTINUE
-C
-C *** ADD H(I,M) = G(I) FOR I = M TO P ***
-C
- 60 L = L + 1
- DO 70 I = M, P
- IF (B(1,I) .LT. B(2,I)) V(L) = G(I)
- L = L + I
- 70 CONTINUE
-C
- 80 M = M + 1
- IV(MODE) = M
- IF (M .GT. P) GO TO 340
- IF (B(1,M) .GE. B(2,M)) GO TO 80
-C
-C *** CHOOSE NEXT FINITE-DIFFERENCE STEP, RETURN TO GET G THERE ***
-C
- DEL = V(DELTA0) * DMAX1(ONE/D(M), DABS(X(M)))
- XM = X(M)
- IF (XM .LT. ZERO) GO TO 90
- XM1 = XM + DEL
- IF (XM1 .LE. B(2,M)) GO TO 110
- XM1 = XM - DEL
- IF (XM1 .GE. B(1,M)) GO TO 100
- GO TO 280
- 90 XM1 = XM - DEL
- IF (XM1 .GE. B(1,M)) GO TO 100
- XM1 = XM + DEL
- IF (XM1 .LE. B(2,M)) GO TO 110
- GO TO 280
-C
- 100 DEL = -DEL
- 110 V(XMSAVE) = XM
- X(M) = XM1
- V(DELTA) = DEL
- IRT = 2
- GO TO 999
-C
-C *** COMPUTE FINITE-DIFFERENCE HESSIAN USING FUNCTION VALUES ONLY.
-C
- 120 STP0 = IV(W) + P - 1
- MM1 = M - 1
- MM1O2 = M*MM1/2
- HES = -IV(H)
- IF (M .GT. 0) GO TO 130
-C *** FIRST CALL ON DF7DHB. ***
- IV(SAVEI) = 0
- GO TO 240
-C
- 130 IF (IV(TOOBIG) .EQ. 0) GO TO 150
-C *** PUNT IN THE EVENT OF AN OVERSIZE STEP ***
- 140 IV(FDH) = -2
- GO TO 350
- 150 I = IV(SAVEI)
- IF (I .GT. 0) GO TO 190
-C
-C *** SAVE F(X + STP(M)*E(M)) IN H(P,M) ***
-C
- PP1O2 = P * (P-1) / 2
- HPM = HES + PP1O2 + MM1
- V(HPM) = V(F)
-C
-C *** START COMPUTING ROW M OF THE FINITE-DIFFERENCE HESSIAN H. ***
-C
- NEWM1 = 1
- GO TO 260
- 160 HMI = HES + MM1O2
- IF (MM1 .EQ. 0) GO TO 180
- HPI = HES + PP1O2
- DO 170 I = 1, MM1
- T = ZERO
- IF (B(1,I) .LT. B(2,I)) T = V(FX) - (V(F) + V(HPI))
- V(HMI) = T
- HMI = HMI + 1
- HPI = HPI + 1
- 170 CONTINUE
- 180 V(HMI) = V(F) - TWO*V(FX)
- IF (OFFSID) V(HMI) = V(FX) - TWO*V(F)
-C
-C *** COMPUTE FUNCTION VALUES NEEDED TO COMPLETE ROW M OF H. ***
-C
- I = 0
- GO TO 200
-C
- 190 X(I) = V(DELTA)
-C
-C *** FINISH COMPUTING H(M,I) ***
-C
- STPI = STP0 + I
- HMI = HES + MM1O2 + I - 1
- STPM = STP0 + M
- V(HMI) = (V(HMI) + V(F)) / (V(STPI)*V(STPM))
- 200 I = I + 1
- IF (I .GT. M) GO TO 230
- IF (B(1,I) .LT. B(2,I)) GO TO 210
- GO TO 200
-C
- 210 IV(SAVEI) = I
- STPI = STP0 + I
- V(DELTA) = X(I)
- X(I) = X(I) + V(STPI)
- IRT = 1
- IF (I .LT. M) GO TO 999
- NEWM1 = 2
- GO TO 260
- 220 X(M) = V(XMSAVE) - DEL
- IF (OFFSID) X(M) = V(XMSAVE) + TWO*DEL
- GO TO 999
-C
- 230 IV(SAVEI) = 0
- X(M) = V(XMSAVE)
-C
- 240 M = M + 1
- IV(MODE) = M
- IF (M .GT. P) GO TO 330
- IF (B(1,M) .LT. B(2,M)) GO TO 250
- GO TO 240
-C
-C *** PREPARE TO COMPUTE ROW M OF THE FINITE-DIFFERENCE HESSIAN H.
-C *** COMPUTE M-TH STEP SIZE STP(M), THEN RETURN TO OBTAIN
-C *** F(X + STP(M)*E(M)), WHERE E(M) = M-TH STD. UNIT VECTOR.
-C
- 250 V(XMSAVE) = X(M)
- NEWM1 = 3
- 260 XM = V(XMSAVE)
- DEL = V(DLTFDC) * DMAX1(ONE/D(M), DABS(XM))
- XM1 = XM + DEL
- OFFSID = .FALSE.
- IF (XM1 .LE. B(2,M)) GO TO 270
- OFFSID = .TRUE.
- XM1 = XM - DEL
- IF (XM - TWO*DEL .GE. B(1,M)) GO TO 300
- GO TO 280
- 270 IF (XM-DEL .GE. B(1,M)) GO TO 290
- OFFSID = .TRUE.
- IF (XM + TWO*DEL .LE. B(2,M)) GO TO 310
-C
- 280 IV(FDH) = -2
- GO TO 350
-C
- 290 IF (XM .GE. ZERO) GO TO 310
- XM1 = XM - DEL
- 300 DEL = -DEL
- 310 GO TO (160, 220, 320), NEWM1
- 320 X(M) = XM1
- STPM = STP0 + M
- V(STPM) = DEL
- IRT = 1
- GO TO 999
-C
-C *** HANDLE SPECIAL CASE OF B(1,P) = B(2,P) -- CLEAR SCRATCH VALUES
-C *** FROM LAST ROW OF FDH...
-C
- 330 IF (B(1,P) .LT. B(2,P)) GO TO 340
- I = HES + P*(P-1)/2
- CALL DV7SCP(P, V(I), ZERO)
-C
-C *** RESTORE V(F), ETC. ***
-C
- 340 IV(FDH) = HES
- 350 V(F) = V(FX)
- IRT = 3
- IF (KIND .LT. 0) GO TO 999
- IV(NFGCAL) = IV(SWITCH)
- GSAVE1 = IV(W) + P
- CALL DV7CPY(P, G, V(GSAVE1))
- GO TO 999
-C
- 999 RETURN
-C *** LAST LINE OF DF7DHB FOLLOWS ***
- END
diff --git a/CEP/PyBDSM/src/port3/df7hes.f b/CEP/PyBDSM/src/port3/df7hes.f
deleted file mode 100644
index e84c18b23fc2c7f9a4fa0af1b41e7d60206ac0df..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/df7hes.f
+++ /dev/null
@@ -1,247 +0,0 @@
- SUBROUTINE DF7HES(D, G, IRT, IV, LIV, LV, P, V, X)
-C
-C *** COMPUTE FINITE-DIFFERENCE HESSIAN, STORE IT IN V STARTING
-C *** AT V(IV(FDH)) = V(-IV(H)).
-C
-C *** IF IV(COVREQ) .GE. 0 THEN DF7HES USES GRADIENT DIFFERENCES,
-C *** OTHERWISE FUNCTION DIFFERENCES. STORAGE IN V IS AS IN DG7LIT.
-C
-C IRT VALUES...
-C 1 = COMPUTE FUNCTION VALUE, I.E., V(F).
-C 2 = COMPUTE G.
-C 3 = DONE.
-C
-C
-C *** PARAMETER DECLARATIONS ***
-C
- INTEGER IRT, LIV, LV, P
- INTEGER IV(LIV)
- DOUBLE PRECISION D(P), G(P), V(LV), X(P)
-C
-C *** LOCAL VARIABLES ***
-C
- INTEGER GSAVE1, HES, HMI, HPI, HPM, I, K, KIND, L, M, MM1, MM1O2,
- 1 PP1O2, STPI, STPM, STP0
- DOUBLE PRECISION DEL, HALF, NEGPT5, ONE, TWO, ZERO
-C
-C *** EXTERNAL SUBROUTINES ***
-C
- EXTERNAL DV7CPY
-C
-C DV7CPY.... COPY ONE VECTOR TO ANOTHER.
-C
-C *** SUBSCRIPTS FOR IV AND V ***
-C
- INTEGER COVREQ, DELTA, DELTA0, DLTFDC, F, FDH, FX, H, KAGQT, MODE,
- 1 NFGCAL, SAVEI, SWITCH, TOOBIG, W, XMSAVE
-C
-C/6
-C DATA HALF/0.5D+0/, NEGPT5/-0.5D+0/, ONE/1.D+0/, TWO/2.D+0/,
-C 1 ZERO/0.D+0/
-C/7
- PARAMETER (HALF=0.5D+0, NEGPT5=-0.5D+0, ONE=1.D+0, TWO=2.D+0,
- 1 ZERO=0.D+0)
-C/
-C
-C/6
-C DATA COVREQ/15/, DELTA/52/, DELTA0/44/, DLTFDC/42/, F/10/,
-C 1 FDH/74/, FX/53/, H/56/, KAGQT/33/, MODE/35/, NFGCAL/7/,
-C 2 SAVEI/63/, SWITCH/12/, TOOBIG/2/, W/65/, XMSAVE/51/
-C/7
- PARAMETER (COVREQ=15, DELTA=52, DELTA0=44, DLTFDC=42, F=10,
- 1 FDH=74, FX=53, H=56, KAGQT=33, MODE=35, NFGCAL=7,
- 2 SAVEI=63, SWITCH=12, TOOBIG=2, W=65, XMSAVE=51)
-C/
-C
-C+++++++++++++++++++++++++++++++ BODY ++++++++++++++++++++++++++++++++
-C
- IRT = 4
- KIND = IV(COVREQ)
- M = IV(MODE)
- IF (M .GT. 0) GO TO 10
- IV(H) = -IABS(IV(H))
- IV(FDH) = 0
- IV(KAGQT) = -1
- V(FX) = V(F)
- 10 IF (M .GT. P) GO TO 999
- IF (KIND .LT. 0) GO TO 110
-C
-C *** COMPUTE FINITE-DIFFERENCE HESSIAN USING BOTH FUNCTION AND
-C *** GRADIENT VALUES.
-C
- GSAVE1 = IV(W) + P
- IF (M .GT. 0) GO TO 20
-C *** FIRST CALL ON DF7HES. SET GSAVE = G, TAKE FIRST STEP ***
- CALL DV7CPY(P, V(GSAVE1), G)
- IV(SWITCH) = IV(NFGCAL)
- GO TO 90
-C
- 20 DEL = V(DELTA)
- X(M) = V(XMSAVE)
- IF (IV(TOOBIG) .EQ. 0) GO TO 40
-C
-C *** HANDLE OVERSIZE V(DELTA) ***
-C
- IF (DEL*X(M) .GT. ZERO) GO TO 30
-C *** WE ALREADY TRIED SHRINKING V(DELTA), SO QUIT ***
- IV(FDH) = -2
- GO TO 220
-C
-C *** TRY SHRINKING V(DELTA) ***
- 30 DEL = NEGPT5 * DEL
- GO TO 100
-C
- 40 HES = -IV(H)
-C
-C *** SET G = (G - GSAVE)/DEL ***
-C
- DO 50 I = 1, P
- G(I) = (G(I) - V(GSAVE1)) / DEL
- GSAVE1 = GSAVE1 + 1
- 50 CONTINUE
-C
-C *** ADD G AS NEW COL. TO FINITE-DIFF. HESSIAN MATRIX ***
-C
- K = HES + M*(M-1)/2
- L = K + M - 2
- IF (M .EQ. 1) GO TO 70
-C
-C *** SET H(I,M) = 0.5 * (H(I,M) + G(I)) FOR I = 1 TO M-1 ***
-C
- MM1 = M - 1
- DO 60 I = 1, MM1
- V(K) = HALF * (V(K) + G(I))
- K = K + 1
- 60 CONTINUE
-C
-C *** ADD H(I,M) = G(I) FOR I = M TO P ***
-C
- 70 L = L + 1
- DO 80 I = M, P
- V(L) = G(I)
- L = L + I
- 80 CONTINUE
-C
- 90 M = M + 1
- IV(MODE) = M
- IF (M .GT. P) GO TO 210
-C
-C *** CHOOSE NEXT FINITE-DIFFERENCE STEP, RETURN TO GET G THERE ***
-C
- DEL = V(DELTA0) * DMAX1(ONE/D(M), DABS(X(M)))
- IF (X(M) .LT. ZERO) DEL = -DEL
- V(XMSAVE) = X(M)
- 100 X(M) = X(M) + DEL
- V(DELTA) = DEL
- IRT = 2
- GO TO 999
-C
-C *** COMPUTE FINITE-DIFFERENCE HESSIAN USING FUNCTION VALUES ONLY.
-C
- 110 STP0 = IV(W) + P - 1
- MM1 = M - 1
- MM1O2 = M*MM1/2
- IF (M .GT. 0) GO TO 120
-C *** FIRST CALL ON DF7HES. ***
- IV(SAVEI) = 0
- GO TO 200
-C
- 120 I = IV(SAVEI)
- HES = -IV(H)
- IF (I .GT. 0) GO TO 180
- IF (IV(TOOBIG) .EQ. 0) GO TO 140
-C
-C *** HANDLE OVERSIZE STEP ***
-C
- STPM = STP0 + M
- DEL = V(STPM)
- IF (DEL*X(XMSAVE) .GT. ZERO) GO TO 130
-C *** WE ALREADY TRIED SHRINKING THE STEP, SO QUIT ***
- IV(FDH) = -2
- GO TO 220
-C
-C *** TRY SHRINKING THE STEP ***
- 130 DEL = NEGPT5 * DEL
- X(M) = X(XMSAVE) + DEL
- V(STPM) = DEL
- IRT = 1
- GO TO 999
-C
-C *** SAVE F(X + STP(M)*E(M)) IN H(P,M) ***
-C
- 140 PP1O2 = P * (P-1) / 2
- HPM = HES + PP1O2 + MM1
- V(HPM) = V(F)
-C
-C *** START COMPUTING ROW M OF THE FINITE-DIFFERENCE HESSIAN H. ***
-C
- HMI = HES + MM1O2
- IF (MM1 .EQ. 0) GO TO 160
- HPI = HES + PP1O2
- DO 150 I = 1, MM1
- V(HMI) = V(FX) - (V(F) + V(HPI))
- HMI = HMI + 1
- HPI = HPI + 1
- 150 CONTINUE
- 160 V(HMI) = V(F) - TWO*V(FX)
-C
-C *** COMPUTE FUNCTION VALUES NEEDED TO COMPLETE ROW M OF H. ***
-C
- I = 1
-C
- 170 IV(SAVEI) = I
- STPI = STP0 + I
- V(DELTA) = X(I)
- X(I) = X(I) + V(STPI)
- IF (I .EQ. M) X(I) = V(XMSAVE) - V(STPI)
- IRT = 1
- GO TO 999
-C
- 180 X(I) = V(DELTA)
- IF (IV(TOOBIG) .EQ. 0) GO TO 190
-C *** PUNT IN THE EVENT OF AN OVERSIZE STEP ***
- IV(FDH) = -2
- GO TO 220
-C
-C *** FINISH COMPUTING H(M,I) ***
-C
- 190 STPI = STP0 + I
- HMI = HES + MM1O2 + I - 1
- STPM = STP0 + M
- V(HMI) = (V(HMI) + V(F)) / (V(STPI)*V(STPM))
- I = I + 1
- IF (I .LE. M) GO TO 170
- IV(SAVEI) = 0
- X(M) = V(XMSAVE)
-C
- 200 M = M + 1
- IV(MODE) = M
- IF (M .GT. P) GO TO 210
-C
-C *** PREPARE TO COMPUTE ROW M OF THE FINITE-DIFFERENCE HESSIAN H.
-C *** COMPUTE M-TH STEP SIZE STP(M), THEN RETURN TO OBTAIN
-C *** F(X + STP(M)*E(M)), WHERE E(M) = M-TH STD. UNIT VECTOR.
-C
- DEL = V(DLTFDC) * DMAX1(ONE/D(M), DABS(X(M)))
- IF (X(M) .LT. ZERO) DEL = -DEL
- V(XMSAVE) = X(M)
- X(M) = X(M) + DEL
- STPM = STP0 + M
- V(STPM) = DEL
- IRT = 1
- GO TO 999
-C
-C *** RESTORE V(F), ETC. ***
-C
- 210 IV(FDH) = HES
- 220 V(F) = V(FX)
- IRT = 3
- IF (KIND .LT. 0) GO TO 999
- IV(NFGCAL) = IV(SWITCH)
- GSAVE1 = IV(W) + P
- CALL DV7CPY(P, G, V(GSAVE1))
- GO TO 999
-C
- 999 RETURN
-C *** LAST CARD OF DF7HES FOLLOWS ***
- END
diff --git a/CEP/PyBDSM/src/port3/dg7itb.f b/CEP/PyBDSM/src/port3/dg7itb.f
deleted file mode 100644
index c417ca3780827012fcc6fcec080fa16d8f70774b..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/dg7itb.f
+++ /dev/null
@@ -1,859 +0,0 @@
- SUBROUTINE DG7ITB(B, D, G, IV, LIV, LV, P, PS, V, X, Y)
-C
-C *** CARRY OUT NL2SOL-LIKE ITERATIONS FOR GENERALIZED LINEAR ***
-C *** REGRESSION PROBLEMS (AND OTHERS OF SIMILAR STRUCTURE) ***
-C *** HAVING SIMPLE BOUNDS ON THE PARAMETERS BEING ESTIMATED. ***
-C
-C *** PARAMETER DECLARATIONS ***
-C
- INTEGER LIV, LV, P, PS
- INTEGER IV(LIV)
- DOUBLE PRECISION B(2,P), D(P), G(P), V(LV), X(P), Y(P)
-C
-C-------------------------- PARAMETER USAGE --------------------------
-C
-C B.... VECTOR OF LOWER AND UPPER BOUNDS ON X.
-C D.... SCALE VECTOR.
-C IV... INTEGER VALUE ARRAY.
-C LIV.. LENGTH OF IV. MUST BE AT LEAST 80.
-C LH... LENGTH OF H = P*(P+1)/2.
-C LV... LENGTH OF V. MUST BE AT LEAST P*(3*P + 19)/2 + 7.
-C G.... GRADIENT AT X (WHEN IV(1) = 2).
-C HC... GAUSS-NEWTON HESSIAN AT X (WHEN IV(1) = 2).
-C P.... NUMBER OF PARAMETERS (COMPONENTS IN X).
-C PS... NUMBER OF NONZERO ROWS AND COLUMNS IN S.
-C V.... FLOATING-POINT VALUE ARRAY.
-C X.... PARAMETER VECTOR.
-C Y.... PART OF YIELD VECTOR (WHEN IV(1)= 2, SCRATCH OTHERWISE).
-C
-C *** DISCUSSION ***
-C
-C DG7ITB IS SIMILAR TO DG7LIT, EXCEPT FOR THE EXTRA PARAMETER B
-C -- DG7ITB ENFORCES THE BOUNDS B(1,I) .LE. X(I) .LE. B(2,I),
-C I = 1(1)P.
-C DG7ITB PERFORMS NL2SOL-LIKE ITERATIONS FOR A VARIETY OF
-C REGRESSION PROBLEMS THAT ARE SIMILAR TO NONLINEAR LEAST-SQUARES
-C IN THAT THE HESSIAN IS THE SUM OF TWO TERMS, A READILY-COMPUTED
-C FIRST-ORDER TERM AND A SECOND-ORDER TERM. THE CALLER SUPPLIES
-C THE FIRST-ORDER TERM OF THE HESSIAN IN HC (LOWER TRIANGLE, STORED
-C COMPACTLY BY ROWS), AND DG7ITB BUILDS AN APPROXIMATION, S, TO THE
-C SECOND-ORDER TERM. THE CALLER ALSO PROVIDES THE FUNCTION VALUE,
-C GRADIENT, AND PART OF THE YIELD VECTOR USED IN UPDATING S.
-C DG7ITB DECIDES DYNAMICALLY WHETHER OR NOT TO _USE_ S WHEN CHOOSING
-C THE NEXT STEP TO TRY... THE HESSIAN APPROXIMATION USED IS EITHER
-C HC ALONE (GAUSS-NEWTON MODEL) OR HC + S (AUGMENTED MODEL).
-C IF PS .LT. P, THEN ROWS AND COLUMNS PS+1...P OF S ARE KEPT
-C CONSTANT. THEY WILL BE ZERO UNLESS THE CALLER SETS IV(INITS) TO
-C 1 OR 2 AND SUPPLIES NONZERO VALUES FOR THEM, OR THE CALLER SETS
-C IV(INITS) TO 3 OR 4 AND THE FINITE-DIFFERENCE INITIAL S THEN
-C COMPUTED HAS NONZERO VALUES IN THESE ROWS.
-C
-C IF IV(INITS) IS 3 OR 4, THEN THE INITIAL S IS COMPUTED BY
-C FINITE DIFFERENCES. 3 MEANS _USE_ FUNCTION DIFFERENCES, 4 MEANS
-C _USE_ GRADIENT DIFFERENCES. FINITE DIFFERENCING IS DONE THE SAME
-C WAY AS IN COMPUTING A COVARIANCE MATRIX (WITH IV(COVREQ) = -1, -2,
-C 1, OR 2).
-C
-C FOR UPDATING S, DG7ITB ASSUMES THAT THE GRADIENT HAS THE FORM
-C OF A SUM OVER I OF RHO(I,X)*GRAD(R(I,X)), WHERE GRAD DENOTES THE
-C GRADIENT WITH RESPECT TO X. THE TRUE SECOND-ORDER TERM THEN IS
-C THE SUM OVER I OF RHO(I,X)*HESSIAN(R(I,X)). IF X = X0 + STEP,
-C THEN WE WISH TO UPDATE S SO THAT S*STEP IS THE SUM OVER I OF
-C RHO(I,X)*(GRAD(R(I,X)) - GRAD(R(I,X0))). THE CALLER MUST SUPPLY
-C PART OF THIS IN Y, NAMELY THE SUM OVER I OF
-C RHO(I,X)*GRAD(R(I,X0)), WHEN CALLING DG7ITB WITH IV(1) = 2 AND
-C IV(MODE) = 0 (WHERE MODE = 38). G THEN CONTANS THE OTHER PART,
-C SO THAT THE DESIRED YIELD VECTOR IS G - Y. IF PS .LT. P, THEN
-C THE ABOVE DISCUSSION APPLIES ONLY TO THE FIRST PS COMPONENTS OF
-C GRAD(R(I,X)), STEP, AND Y.
-C
-C PARAMETERS IV, P, V, AND X ARE THE SAME AS THE CORRESPONDING
-C ONES TO DN2GB (AND NL2SOL), EXCEPT THAT V CAN BE SHORTER
-C (SINCE THE PART OF V THAT DN2GB USES FOR STORING D, J, AND R IS
-C NOT NEEDED). MOREOVER, COMPARED WITH DN2GB (AND NL2SOL), IV(1)
-C MAY HAVE THE TWO ADDITIONAL OUTPUT VALUES 1 AND 2, WHICH ARE
-C EXPLAINED BELOW, AS IS THE _USE_ OF IV(TOOBIG) AND IV(NFGCAL).
-C THE VALUES IV(D), IV(J), AND IV(R), WHICH ARE OUTPUT VALUES FROM
-C DN2GB (AND DN2FB), ARE NOT REFERENCED BY DG7ITB OR THE
-C SUBROUTINES IT CALLS.
-C
-C WHEN DG7ITB IS FIRST CALLED, I.E., WHEN DG7ITB IS CALLED WITH
-C IV(1) = 0 OR 12, V(F), G, AND HC NEED NOT BE INITIALIZED. TO
-C OBTAIN THESE STARTING VALUES, DG7ITB RETURNS FIRST WITH IV(1) = 1,
-C THEN WITH IV(1) = 2, WITH IV(MODE) = -1 IN BOTH CASES. ON
-C SUBSEQUENT RETURNS WITH IV(1) = 2, IV(MODE) = 0 IMPLIES THAT
-C Y MUST ALSO BE SUPPLIED. (NOTE THAT Y IS USED FOR SCRATCH -- ITS
-C INPUT CONTENTS ARE LOST. BY CONTRAST, HC IS NEVER CHANGED.)
-C ONCE CONVERGENCE HAS BEEN OBTAINED, IV(RDREQ) AND IV(COVREQ) MAY
-C IMPLY THAT A FINITE-DIFFERENCE HESSIAN SHOULD BE COMPUTED FOR USE
-C IN COMPUTING A COVARIANCE MATRIX. IN THIS CASE DG7ITB WILL MAKE
-C A NUMBER OF RETURNS WITH IV(1) = 1 OR 2 AND IV(MODE) POSITIVE.
-C WHEN IV(MODE) IS POSITIVE, Y SHOULD NOT BE CHANGED.
-C
-C IV(1) = 1 MEANS THE CALLER SHOULD SET V(F) (I.E., V(10)) TO F(X), THE
-C FUNCTION VALUE AT X, AND CALL DG7ITB AGAIN, HAVING CHANGED
-C NONE OF THE OTHER PARAMETERS. AN EXCEPTION OCCURS IF F(X)
-C CANNOT BE EVALUATED (E.G. IF OVERFLOW WOULD OCCUR), WHICH
-C MAY HAPPEN BECAUSE OF AN OVERSIZED STEP. IN THIS CASE
-C THE CALLER SHOULD SET IV(TOOBIG) = IV(2) TO 1, WHICH WILL
-C CAUSE DG7ITB TO IGNORE V(F) AND TRY A SMALLER STEP. NOTE
-C THAT THE CURRENT FUNCTION EVALUATION COUNT IS AVAILABLE
-C IN IV(NFCALL) = IV(6). THIS MAY BE USED TO IDENTIFY
-C WHICH COPY OF SAVED INFORMATION SHOULD BE USED IN COM-
-C PUTING G, HC, AND Y THE NEXT TIME DG7ITB RETURNS WITH
-C IV(1) = 2. SEE MLPIT FOR AN EXAMPLE OF THIS.
-C IV(1) = 2 MEANS THE CALLER SHOULD SET G TO G(X), THE GRADIENT OF F AT
-C X. THE CALLER SHOULD ALSO SET HC TO THE GAUSS-NEWTON
-C HESSIAN AT X. IF IV(MODE) = 0, THEN THE CALLER SHOULD
-C ALSO COMPUTE THE PART OF THE YIELD VECTOR DESCRIBED ABOVE.
-C THE CALLER SHOULD THEN CALL DG7ITB AGAIN (WITH IV(1) = 2).
-C THE CALLER MAY ALSO CHANGE D AT THIS TIME, BUT SHOULD NOT
-C CHANGE X. NOTE THAT IV(NFGCAL) = IV(7) CONTAINS THE
-C VALUE THAT IV(NFCALL) HAD DURING THE RETURN WITH
-C IV(1) = 1 IN WHICH X HAD THE SAME VALUE AS IT NOW HAS.
-C IV(NFGCAL) IS EITHER IV(NFCALL) OR IV(NFCALL) - 1. MLPIT
-C IS AN EXAMPLE WHERE THIS INFORMATION IS USED. IF G OR HC
-C CANNOT BE EVALUATED AT X, THEN THE CALLER MAY SET
-C IV(NFGCAL) TO 0, IN WHICH CASE DG7ITB WILL RETURN WITH
-C IV(1) = 15.
-C
-C *** GENERAL ***
-C
-C CODED BY DAVID M. GAY.
-C
-C (SEE NL2SOL FOR REFERENCES.)
-C
-C+++++++++++++++++++++++++++ DECLARATIONS ++++++++++++++++++++++++++++
-C
-C *** LOCAL VARIABLES ***
-C
- LOGICAL HAVQTR, HAVRM
- INTEGER DUMMY, DIG1, G01, H1, HC1, I, I1, IPI, IPIV0, IPIV1,
- 1 IPIV2, IPN, J, K, L, LMAT1, LSTGST, P1, P1LEN, PP1, PP1O2,
- 2 QTR1, RMAT1, RSTRST, STEP1, STPMOD, S1, TD1, TEMP1, TEMP2,
- 3 TG1, W1, WLM1, X01
- DOUBLE PRECISION E, GI, STTSST, T, T1, XI
-C
-C *** CONSTANTS ***
-C
- DOUBLE PRECISION HALF, NEGONE, ONE, ONEP2, ZERO
-C
-C *** EXTERNAL FUNCTIONS AND SUBROUTINES ***
-C
- LOGICAL STOPX
- DOUBLE PRECISION DD7TPR, DRLDST, DV2NRM
- EXTERNAL DA7SST, DD7TPR, DF7DHB, DG7QSB,I7COPY, I7PNVR, I7SHFT,
- 1 DITSUM, DL7MSB, DL7SQR, DL7TVM,DL7VML,DPARCK, DQ7RSH,
- 2 DRLDST, DS7DMP, DS7IPR, DS7LUP, DS7LVM, STOPX, DV2NRM,
- 3 DV2AXY,DV7CPY, DV7IPR, DV7SCP, DV7VMP
-C
-C DA7SST.... ASSESSES CANDIDATE STEP.
-C DD7TPR... RETURNS INNER PRODUCT OF TWO VECTORS.
-C DF7DHB... COMPUTE FINITE-DIFFERENCE HESSIAN (FOR INIT. S MATRIX).
-C DG7QSB... COMPUTES GOLDFELD-QUANDT-TROTTER STEP (AUGMENTED MODEL).
-C I7COPY.... COPIES ONE INTEGER VECTOR TO ANOTHER.
-C I7PNVR... INVERTS PERMUTATION ARRAY.
-C I7SHFT... SHIFTS AN INTEGER VECTOR.
-C DITSUM.... PRINTS ITERATION SUMMARY AND INFO ON INITIAL AND FINAL X.
-C DL7MSB... COMPUTES LEVENBERG-MARQUARDT STEP (GAUSS-NEWTON MODEL).
-C DL7SQR... COMPUTES L * L**T FROM LOWER TRIANGULAR MATRIX L.
-C DL7TVM... COMPUTES L**T * V, V = VECTOR, L = LOWER TRIANGULAR MATRIX.
-C DL7VML.... COMPUTES L * V, V = VECTOR, L = LOWER TRIANGULAR MATRIX.
-C DPARCK.... CHECK VALIDITY OF IV AND V INPUT COMPONENTS.
-C DQ7RSH... SHIFTS A QR FACTORIZATION.
-C DRLDST... COMPUTES V(RELDX) = RELATIVE STEP SIZE.
-C DS7DMP... MULTIPLIES A SYM. MATRIX FORE AND AFT BY A DIAG. MATRIX.
-C DS7IPR... APPLIES PERMUTATION TO (LOWER TRIANG. OF) SYM. MATRIX.
-C DS7LUP... PERFORMS QUASI-NEWTON UPDATE ON COMPACTLY STORED LOWER TRI-
-C ANGLE OF A SYMMETRIC MATRIX.
-C DS7LVM... MULTIPLIES COMPACTLY STORED SYM. MATRIX TIMES VECTOR.
-C STOPX.... RETURNS .TRUE. IF THE BREAK KEY HAS BEEN PRESSED.
-C DV2NRM... RETURNS THE 2-NORM OF A VECTOR.
-C DV2AXY.... COMPUTES SCALAR TIMES ONE VECTOR PLUS ANOTHER.
-C DV7CPY.... COPIES ONE VECTOR TO ANOTHER.
-C DV7IPR... APPLIES A PERMUTATION TO A VECTOR.
-C DV7SCP... SETS ALL ELEMENTS OF A VECTOR TO A SCALAR.
-C DV7VMP... MULTIPLIES (DIVIDES) VECTORS COMPONENTWISE.
-C
-C *** SUBSCRIPTS FOR IV AND V ***
-C
- INTEGER CNVCOD, COSMIN, COVMAT, COVREQ, DGNORM, DIG,
- 1 DSTNRM, F, FDH, FDIF, FUZZ, F0, GTSTEP, H, HC, IERR,
- 2 INCFAC, INITS, IPIVOT, IRC, IVNEED, KAGQT, KALM, LMAT,
- 3 LMAX0, LMAXS, MODE, MODEL, MXFCAL, MXITER, NEXTIV, NEXTV,
- 4 NFCALL, NFGCAL, NFCOV, NGCOV, NGCALL, NITER, NVSAVE, P0,
- 5 PC, PERM, PHMXFC, PREDUC, QTR, RADFAC, RADINC, RADIUS,
- 6 RAD0, RDREQ, REGD, RELDX, RESTOR, RMAT, S, SIZE, STEP,
- 7 STGLIM, STPPAR, SUSED, SWITCH, TOOBIG, TUNER4, TUNER5,
- 8 VNEED, VSAVE, W, WSCALE, XIRC, X0
-C
-C *** IV SUBSCRIPT VALUES ***
-C
-C *** (NOTE THAT P0 AND PC ARE STORED IN IV(G0) AND IV(STLSTG) RESP.)
-C
-C/6
-C DATA CNVCOD/55/, COVMAT/26/, COVREQ/15/, DIG/37/, FDH/74/, H/56/,
-C 1 HC/71/, IERR/75/, INITS/25/, IPIVOT/76/, IRC/29/, IVNEED/3/,
-C 2 KAGQT/33/, KALM/34/, LMAT/42/, MODE/35/, MODEL/5/,
-C 3 MXFCAL/17/, MXITER/18/, NEXTIV/46/, NEXTV/47/, NFCALL/6/,
-C 4 NFGCAL/7/, NFCOV/52/, NGCOV/53/, NGCALL/30/, NITER/31/,
-C 5 P0/48/, PC/41/, PERM/58/, QTR/77/, RADINC/8/, RDREQ/57/,
-C 6 REGD/67/, RESTOR/9/, RMAT/78/, S/62/, STEP/40/, STGLIM/11/,
-C 7 SUSED/64/, SWITCH/12/, TOOBIG/2/, VNEED/4/, VSAVE/60/, W/65/,
-C 8 XIRC/13/, X0/43/
-C/7
- PARAMETER (CNVCOD=55, COVMAT=26, COVREQ=15, DIG=37, FDH=74, H=56,
- 1 HC=71, IERR=75, INITS=25, IPIVOT=76, IRC=29, IVNEED=3,
- 2 KAGQT=33, KALM=34, LMAT=42, MODE=35, MODEL=5,
- 3 MXFCAL=17, MXITER=18, NEXTIV=46, NEXTV=47, NFCALL=6,
- 4 NFGCAL=7, NFCOV=52, NGCOV=53, NGCALL=30, NITER=31,
- 5 P0=48, PC=41, PERM=58, QTR=77, RADINC=8, RDREQ=57,
- 6 REGD=67, RESTOR=9, RMAT=78, S=62, STEP=40, STGLIM=11,
- 7 SUSED=64, SWITCH=12, TOOBIG=2, VNEED=4, VSAVE=60, W=65,
- 8 XIRC=13, X0=43)
-C/
-C
-C *** V SUBSCRIPT VALUES ***
-C
-C/6
-C DATA COSMIN/47/, DGNORM/1/, DSTNRM/2/, F/10/, FDIF/11/, FUZZ/45/,
-C 1 F0/13/, GTSTEP/4/, INCFAC/23/, LMAX0/35/, LMAXS/36/,
-C 2 NVSAVE/9/, PHMXFC/21/, PREDUC/7/, RADFAC/16/, RADIUS/8/,
-C 3 RAD0/9/, RELDX/17/, SIZE/55/, STPPAR/5/, TUNER4/29/,
-C 4 TUNER5/30/, WSCALE/56/
-C/7
- PARAMETER (COSMIN=47, DGNORM=1, DSTNRM=2, F=10, FDIF=11, FUZZ=45,
- 1 F0=13, GTSTEP=4, INCFAC=23, LMAX0=35, LMAXS=36,
- 2 NVSAVE=9, PHMXFC=21, PREDUC=7, RADFAC=16, RADIUS=8,
- 3 RAD0=9, RELDX=17, SIZE=55, STPPAR=5, TUNER4=29,
- 4 TUNER5=30, WSCALE=56)
-C/
-C
-C
-C/6
-C DATA HALF/0.5D+0/, NEGONE/-1.D+0/, ONE/1.D+0/, ONEP2/1.2D+0/,
-C 1 ZERO/0.D+0/
-C/7
- PARAMETER (HALF=0.5D+0, NEGONE=-1.D+0, ONE=1.D+0, ONEP2=1.2D+0,
- 1 ZERO=0.D+0)
-C/
-C
-C+++++++++++++++++++++++++++++++ BODY ++++++++++++++++++++++++++++++++
-C
- I = IV(1)
- IF (I .EQ. 1) GO TO 50
- IF (I .EQ. 2) GO TO 60
-C
- IF (I .LT. 12) GO TO 10
- IF (I .GT. 13) GO TO 10
- IV(VNEED) = IV(VNEED) + P*(3*P + 25)/2 + 7
- IV(IVNEED) = IV(IVNEED) + 4*P
- 10 CALL DPARCK(1, D, IV, LIV, LV, P, V)
- I = IV(1) - 2
- IF (I .GT. 12) GO TO 999
- GO TO (360, 360, 360, 360, 360, 360, 240, 190, 240, 20, 20, 30), I
-C
-C *** STORAGE ALLOCATION ***
-C
- 20 PP1O2 = P * (P + 1) / 2
- IV(S) = IV(LMAT) + PP1O2
- IV(X0) = IV(S) + PP1O2
- IV(STEP) = IV(X0) + 2*P
- IV(DIG) = IV(STEP) + 3*P
- IV(W) = IV(DIG) + 2*P
- IV(H) = IV(W) + 4*P + 7
- IV(NEXTV) = IV(H) + PP1O2
- IV(IPIVOT) = IV(PERM) + 3*P
- IV(NEXTIV) = IV(IPIVOT) + P
- IF (IV(1) .NE. 13) GO TO 30
- IV(1) = 14
- GO TO 999
-C
-C *** INITIALIZATION ***
-C
- 30 IV(NITER) = 0
- IV(NFCALL) = 1
- IV(NGCALL) = 1
- IV(NFGCAL) = 1
- IV(MODE) = -1
- IV(STGLIM) = 2
- IV(TOOBIG) = 0
- IV(CNVCOD) = 0
- IV(COVMAT) = 0
- IV(NFCOV) = 0
- IV(NGCOV) = 0
- IV(RADINC) = 0
- IV(PC) = P
- V(RAD0) = ZERO
- V(STPPAR) = ZERO
- V(RADIUS) = V(LMAX0) / (ONE + V(PHMXFC))
-C
-C *** CHECK CONSISTENCY OF B AND INITIALIZE IP ARRAY ***
-C
- IPI = IV(IPIVOT)
- DO 40 I = 1, P
- IV(IPI) = I
- IPI = IPI + 1
- IF (B(1,I) .GT. B(2,I)) GO TO 680
- 40 CONTINUE
-C
-C *** SET INITIAL MODEL AND S MATRIX ***
-C
- IV(MODEL) = 1
- IV(1) = 1
- IF (IV(S) .LT. 0) GO TO 710
- IF (IV(INITS) .GT. 1) IV(MODEL) = 2
- S1 = IV(S)
- IF (IV(INITS) .EQ. 0 .OR. IV(INITS) .GT. 2)
- 1 CALL DV7SCP(P*(P+1)/2, V(S1), ZERO)
- GO TO 710
-C
-C *** NEW FUNCTION VALUE ***
-C
- 50 IF (IV(MODE) .EQ. 0) GO TO 360
- IF (IV(MODE) .GT. 0) GO TO 590
-C
- IF (IV(TOOBIG) .EQ. 0) GO TO 690
- IV(1) = 63
- GO TO 999
-C
-C *** MAKE SURE GRADIENT COULD BE COMPUTED ***
-C
- 60 IF (IV(TOOBIG) .EQ. 0) GO TO 70
- IV(1) = 65
- GO TO 999
-C
-C *** NEW GRADIENT ***
-C
- 70 IV(KALM) = -1
- IV(KAGQT) = -1
- IV(FDH) = 0
- IF (IV(MODE) .GT. 0) GO TO 590
- IF (IV(HC) .LE. 0 .AND. IV(RMAT) .LE. 0) GO TO 670
-C
-C *** CHOOSE INITIAL PERMUTATION ***
-C
- IPI = IV(IPIVOT)
- IPN = IPI + P - 1
- IPIV2 = IV(PERM) - 1
- K = IV(PC)
- P1 = P
- PP1 = P + 1
- RMAT1 = IV(RMAT)
- HAVRM = RMAT1 .GT. 0
- QTR1 = IV(QTR)
- HAVQTR = QTR1 .GT. 0
-C *** MAKE SURE V(QTR1) IS LEGAL (EVEN WHEN NOT REFERENCED) ***
- W1 = IV(W)
- IF (.NOT. HAVQTR) QTR1 = W1 + P
-C
- DO 100 I = 1, P
- I1 = IV(IPN)
- IPN = IPN - 1
- IF (B(1,I1) .GE. B(2,I1)) GO TO 80
- XI = X(I1)
- GI = G(I1)
- IF (XI .LE. B(1,I1) .AND. GI .GT. ZERO) GO TO 80
- IF (XI .GE. B(2,I1) .AND. GI .LT. ZERO) GO TO 80
-C *** DISALLOW CONVERGENCE IF X(I1) HAS JUST BEEN FREED ***
- J = IPIV2 + I1
- IF (IV(J) .GT. K) IV(CNVCOD) = 0
- GO TO 100
- 80 IF (I1 .GE. P1) GO TO 90
- I1 = PP1 - I
- CALL I7SHFT(P1, I1, IV(IPI))
- IF (HAVRM)
- 1 CALL DQ7RSH(I1, P1, HAVQTR, V(QTR1), V(RMAT1), V(W1))
- 90 P1 = P1 - 1
- 100 CONTINUE
- IV(PC) = P1
-C
-C *** COMPUTE V(DGNORM) (AN OUTPUT VALUE IF WE STOP NOW) ***
-C
- V(DGNORM) = ZERO
- IF (P1 .LE. 0) GO TO 110
- DIG1 = IV(DIG)
- CALL DV7VMP(P, V(DIG1), G, D, -1)
- CALL DV7IPR(P, IV(IPI), V(DIG1))
- V(DGNORM) = DV2NRM(P1, V(DIG1))
- 110 IF (IV(CNVCOD) .NE. 0) GO TO 580
- IF (IV(MODE) .EQ. 0) GO TO 510
- IV(MODE) = 0
- V(F0) = V(F)
- IF (IV(INITS) .LE. 2) GO TO 170
-C
-C *** ARRANGE FOR FINITE-DIFFERENCE INITIAL S ***
-C
- IV(XIRC) = IV(COVREQ)
- IV(COVREQ) = -1
- IF (IV(INITS) .GT. 3) IV(COVREQ) = 1
- IV(CNVCOD) = 70
- GO TO 600
-C
-C *** COME TO NEXT STMT AFTER COMPUTING F.D. HESSIAN FOR INIT. S ***
-C
- 120 H1 = IV(FDH)
- IF (H1 .LE. 0) GO TO 660
- IV(CNVCOD) = 0
- IV(MODE) = 0
- IV(NFCOV) = 0
- IV(NGCOV) = 0
- IV(COVREQ) = IV(XIRC)
- S1 = IV(S)
- PP1O2 = PS * (PS + 1) / 2
- HC1 = IV(HC)
- IF (HC1 .LE. 0) GO TO 130
- CALL DV2AXY(PP1O2, V(S1), NEGONE, V(HC1), V(H1))
- GO TO 140
- 130 RMAT1 = IV(RMAT)
- LMAT1 = IV(LMAT)
- CALL DL7SQR(P, V(LMAT1), V(RMAT1))
- IPI = IV(IPIVOT)
- IPIV1 = IV(PERM) + P
- CALL I7PNVR(P, IV(IPIV1), IV(IPI))
- CALL DS7IPR(P, IV(IPIV1), V(LMAT1))
- CALL DV2AXY(PP1O2, V(S1), NEGONE, V(LMAT1), V(H1))
-C
-C *** ZERO PORTION OF S CORRESPONDING TO FIXED X COMPONENTS ***
-C
- 140 DO 160 I = 1, P
- IF (B(1,I) .LT. B(2,I)) GO TO 160
- K = S1 + I*(I-1)/2
- CALL DV7SCP(I, V(K), ZERO)
- IF (I .GE. P) GO TO 170
- K = K + 2*I - 1
- I1 = I + 1
- DO 150 J = I1, P
- V(K) = ZERO
- K = K + J
- 150 CONTINUE
- 160 CONTINUE
-C
- 170 IV(1) = 2
-C
-C
-C----------------------------- MAIN LOOP -----------------------------
-C
-C
-C *** PRINT ITERATION SUMMARY, CHECK ITERATION LIMIT ***
-C
- 180 CALL DITSUM(D, G, IV, LIV, LV, P, V, X)
- 190 K = IV(NITER)
- IF (K .LT. IV(MXITER)) GO TO 200
- IV(1) = 10
- GO TO 999
- 200 IV(NITER) = K + 1
-C
-C *** UPDATE RADIUS ***
-C
- IF (K .EQ. 0) GO TO 220
- STEP1 = IV(STEP)
- DO 210 I = 1, P
- V(STEP1) = D(I) * V(STEP1)
- STEP1 = STEP1 + 1
- 210 CONTINUE
- STEP1 = IV(STEP)
- T = V(RADFAC) * DV2NRM(P, V(STEP1))
- IF (V(RADFAC) .LT. ONE .OR. T .GT. V(RADIUS)) V(RADIUS) = T
-C
-C *** INITIALIZE FOR START OF NEXT ITERATION ***
-C
- 220 X01 = IV(X0)
- V(F0) = V(F)
- IV(IRC) = 4
- IV(H) = -IABS(IV(H))
- IV(SUSED) = IV(MODEL)
-C
-C *** COPY X TO X0 ***
-C
- CALL DV7CPY(P, V(X01), X)
-C
-C *** CHECK STOPX AND FUNCTION EVALUATION LIMIT ***
-C
- 230 IF (.NOT. STOPX(DUMMY)) GO TO 250
- IV(1) = 11
- GO TO 260
-C
-C *** COME HERE WHEN RESTARTING AFTER FUNC. EVAL. LIMIT OR STOPX.
-C
- 240 IF (V(F) .GE. V(F0)) GO TO 250
- V(RADFAC) = ONE
- K = IV(NITER)
- GO TO 200
-C
- 250 IF (IV(NFCALL) .LT. IV(MXFCAL) + IV(NFCOV)) GO TO 270
- IV(1) = 9
- 260 IF (V(F) .GE. V(F0)) GO TO 999
-C
-C *** IN CASE OF STOPX OR FUNCTION EVALUATION LIMIT WITH
-C *** IMPROVED V(F), EVALUATE THE GRADIENT AT X.
-C
- IV(CNVCOD) = IV(1)
- GO TO 500
-C
-C. . . . . . . . . . . . . COMPUTE CANDIDATE STEP . . . . . . . . . .
-C
- 270 STEP1 = IV(STEP)
- TG1 = IV(DIG)
- TD1 = TG1 + P
- X01 = IV(X0)
- W1 = IV(W)
- H1 = IV(H)
- P1 = IV(PC)
- IPI = IV(PERM)
- IPIV1 = IPI + P
- IPIV2 = IPIV1 + P
- IPIV0 = IV(IPIVOT)
- IF (IV(MODEL) .EQ. 2) GO TO 280
-C
-C *** COMPUTE LEVENBERG-MARQUARDT STEP IF POSSIBLE...
-C
- RMAT1 = IV(RMAT)
- IF (RMAT1 .LE. 0) GO TO 280
- QTR1 = IV(QTR)
- IF (QTR1 .LE. 0) GO TO 280
- LMAT1 = IV(LMAT)
- WLM1 = W1 + P
- CALL DL7MSB(B, D, G, IV(IERR), IV(IPIV0), IV(IPIV1),
- 1 IV(IPIV2), IV(KALM), V(LMAT1), LV, P, IV(P0),
- 2 IV(PC), V(QTR1), V(RMAT1), V(STEP1), V(TD1),
- 3 V(TG1), V, V(W1), V(WLM1), X, V(X01))
-C *** H IS STORED IN THE END OF W AND HAS JUST BEEN OVERWRITTEN,
-C *** SO WE MARK IT INVALID...
- IV(H) = -IABS(H1)
-C *** EVEN IF H WERE STORED ELSEWHERE, IT WOULD BE NECESSARY TO
-C *** MARK INVALID THE INFORMATION DG7QTS MAY HAVE STORED IN V...
- IV(KAGQT) = -1
- GO TO 330
-C
- 280 IF (H1 .GT. 0) GO TO 320
-C
-C *** SET H TO D**-1 * (HC + T1*S) * D**-1. ***
-C
- P1LEN = P1*(P1+1)/2
- H1 = -H1
- IV(H) = H1
- IV(FDH) = 0
- IF (P1 .LE. 0) GO TO 320
-C *** MAKE TEMPORARY PERMUTATION ARRAY ***
- CALL I7COPY(P, IV(IPI), IV(IPIV0))
- J = IV(HC)
- IF (J .GT. 0) GO TO 290
- J = H1
- RMAT1 = IV(RMAT)
- CALL DL7SQR(P1, V(H1), V(RMAT1))
- GO TO 300
- 290 CALL DV7CPY(P*(P+1)/2, V(H1), V(J))
- CALL DS7IPR(P, IV(IPI), V(H1))
- 300 IF (IV(MODEL) .EQ. 1) GO TO 310
- LMAT1 = IV(LMAT)
- S1 = IV(S)
- CALL DV7CPY(P*(P+1)/2, V(LMAT1), V(S1))
- CALL DS7IPR(P, IV(IPI), V(LMAT1))
- CALL DV2AXY(P1LEN, V(H1), ONE, V(LMAT1), V(H1))
- 310 CALL DV7CPY(P, V(TD1), D)
- CALL DV7IPR(P, IV(IPI), V(TD1))
- CALL DS7DMP(P1, V(H1), V(H1), V(TD1), -1)
- IV(KAGQT) = -1
-C
-C *** COMPUTE ACTUAL GOLDFELD-QUANDT-TROTTER STEP ***
-C
- 320 LMAT1 = IV(LMAT)
- CALL DG7QSB(B, D, V(H1), G, IV(IPI), IV(IPIV1), IV(IPIV2),
- 1 IV(KAGQT), V(LMAT1), LV, P, IV(P0), P1, V(STEP1),
- 2 V(TD1), V(TG1), V, V(W1), X, V(X01))
- IF (IV(KALM) .GT. 0) IV(KALM) = 0
-C
- 330 IF (IV(IRC) .NE. 6) GO TO 340
- IF (IV(RESTOR) .NE. 2) GO TO 360
- RSTRST = 2
- GO TO 370
-C
-C *** CHECK WHETHER EVALUATING F(X0 + STEP) LOOKS WORTHWHILE ***
-C
- 340 IV(TOOBIG) = 0
- IF (V(DSTNRM) .LE. ZERO) GO TO 360
- IF (IV(IRC) .NE. 5) GO TO 350
- IF (V(RADFAC) .LE. ONE) GO TO 350
- IF (V(PREDUC) .GT. ONEP2 * V(FDIF)) GO TO 350
- STEP1 = IV(STEP)
- X01 = IV(X0)
- CALL DV2AXY(P, V(STEP1), NEGONE, V(X01), X)
- IF (IV(RESTOR) .NE. 2) GO TO 360
- RSTRST = 0
- GO TO 370
-C
-C *** COMPUTE F(X0 + STEP) ***
-C
- 350 X01 = IV(X0)
- STEP1 = IV(STEP)
- CALL DV2AXY(P, X, ONE, V(STEP1), V(X01))
- IV(NFCALL) = IV(NFCALL) + 1
- IV(1) = 1
- GO TO 710
-C
-C. . . . . . . . . . . . . ASSESS CANDIDATE STEP . . . . . . . . . . .
-C
- 360 RSTRST = 3
- 370 X01 = IV(X0)
- V(RELDX) = DRLDST(P, D, X, V(X01))
- CALL DA7SST(IV, LIV, LV, V)
- STEP1 = IV(STEP)
- LSTGST = X01 + P
- I = IV(RESTOR) + 1
- GO TO (410, 380, 390, 400), I
- 380 CALL DV7CPY(P, X, V(X01))
- GO TO 410
- 390 CALL DV7CPY(P, V(LSTGST), V(STEP1))
- GO TO 410
- 400 CALL DV7CPY(P, V(STEP1), V(LSTGST))
- CALL DV2AXY(P, X, ONE, V(STEP1), V(X01))
- V(RELDX) = DRLDST(P, D, X, V(X01))
- IV(RESTOR) = RSTRST
-C
-C *** IF NECESSARY, SWITCH MODELS ***
-C
- 410 IF (IV(SWITCH) .EQ. 0) GO TO 420
- IV(H) = -IABS(IV(H))
- IV(SUSED) = IV(SUSED) + 2
- L = IV(VSAVE)
- CALL DV7CPY(NVSAVE, V, V(L))
- 420 L = IV(IRC) - 4
- STPMOD = IV(MODEL)
- IF (L .GT. 0) GO TO (440,450,460,460,460,460,460,460,570,510), L
-C
-C *** DECIDE WHETHER TO CHANGE MODELS ***
-C
- E = V(PREDUC) - V(FDIF)
- S1 = IV(S)
- CALL DS7LVM(PS, Y, V(S1), V(STEP1))
- STTSST = HALF * DD7TPR(PS, V(STEP1), Y)
- IF (IV(MODEL) .EQ. 1) STTSST = -STTSST
- IF (DABS(E + STTSST) * V(FUZZ) .GE. DABS(E)) GO TO 430
-C
-C *** SWITCH MODELS ***
-C
- IV(MODEL) = 3 - IV(MODEL)
- IF (-2 .LT. L) GO TO 470
- IV(H) = -IABS(IV(H))
- IV(SUSED) = IV(SUSED) + 2
- L = IV(VSAVE)
- CALL DV7CPY(NVSAVE, V(L), V)
- GO TO 230
-C
- 430 IF (-3 .LT. L) GO TO 470
-C
-C *** RECOMPUTE STEP WITH DIFFERENT RADIUS ***
-C
- 440 V(RADIUS) = V(RADFAC) * V(DSTNRM)
- GO TO 230
-C
-C *** COMPUTE STEP OF LENGTH V(LMAXS) FOR SINGULAR CONVERGENCE TEST
-C
- 450 V(RADIUS) = V(LMAXS)
- GO TO 270
-C
-C *** CONVERGENCE OR FALSE CONVERGENCE ***
-C
- 460 IV(CNVCOD) = L
- IF (V(F) .GE. V(F0)) GO TO 580
- IF (IV(XIRC) .EQ. 14) GO TO 580
- IV(XIRC) = 14
-C
-C. . . . . . . . . . . . PROCESS ACCEPTABLE STEP . . . . . . . . . . .
-C
- 470 IV(COVMAT) = 0
- IV(REGD) = 0
-C
-C *** SEE WHETHER TO SET V(RADFAC) BY GRADIENT TESTS ***
-C
- IF (IV(IRC) .NE. 3) GO TO 500
- STEP1 = IV(STEP)
- TEMP1 = STEP1 + P
- TEMP2 = IV(X0)
-C
-C *** SET TEMP1 = HESSIAN * STEP FOR _USE_ IN GRADIENT TESTS ***
-C
- HC1 = IV(HC)
- IF (HC1 .LE. 0) GO TO 480
- CALL DS7LVM(P, V(TEMP1), V(HC1), V(STEP1))
- GO TO 490
- 480 RMAT1 = IV(RMAT)
- IPIV0 = IV(IPIVOT)
- CALL DV7CPY(P, V(TEMP1), V(STEP1))
- CALL DV7IPR(P, IV(IPIV0), V(TEMP1))
- CALL DL7TVM(P, V(TEMP1), V(RMAT1), V(TEMP1))
- CALL DL7VML(P, V(TEMP1), V(RMAT1), V(TEMP1))
- IPIV1 = IV(PERM) + P
- CALL I7PNVR(P, IV(IPIV1), IV(IPIV0))
- CALL DV7IPR(P, IV(IPIV1), V(TEMP1))
-C
- 490 IF (STPMOD .EQ. 1) GO TO 500
- S1 = IV(S)
- CALL DS7LVM(PS, V(TEMP2), V(S1), V(STEP1))
- CALL DV2AXY(PS, V(TEMP1), ONE, V(TEMP2), V(TEMP1))
-C
-C *** SAVE OLD GRADIENT AND COMPUTE NEW ONE ***
-C
- 500 IV(NGCALL) = IV(NGCALL) + 1
- G01 = IV(W)
- CALL DV7CPY(P, V(G01), G)
- GO TO 690
-C
-C *** INITIALIZATIONS -- G0 = G - G0, ETC. ***
-C
- 510 G01 = IV(W)
- CALL DV2AXY(P, V(G01), NEGONE, V(G01), G)
- STEP1 = IV(STEP)
- TEMP1 = STEP1 + P
- TEMP2 = IV(X0)
- IF (IV(IRC) .NE. 3) GO TO 540
-C
-C *** SET V(RADFAC) BY GRADIENT TESTS ***
-C
-C *** SET TEMP1 = D**-1 * (HESSIAN * STEP + (G(X0) - G(X))) ***
-C
- K = TEMP1
- L = G01
- DO 520 I = 1, P
- V(K) = (V(K) - V(L)) / D(I)
- K = K + 1
- L = L + 1
- 520 CONTINUE
-C
-C *** DO GRADIENT TESTS ***
-C
- IF (DV2NRM(P, V(TEMP1)) .LE. V(DGNORM) * V(TUNER4)) GO TO 530
- IF (DD7TPR(P, G, V(STEP1))
- 1 .GE. V(GTSTEP) * V(TUNER5)) GO TO 540
- 530 V(RADFAC) = V(INCFAC)
-C
-C *** COMPUTE Y VECTOR NEEDED FOR UPDATING S ***
-C
- 540 CALL DV2AXY(PS, Y, NEGONE, Y, G)
-C
-C *** DETERMINE SIZING FACTOR V(SIZE) ***
-C
-C *** SET TEMP1 = S * STEP ***
- S1 = IV(S)
- CALL DS7LVM(PS, V(TEMP1), V(S1), V(STEP1))
-C
- T1 = DABS(DD7TPR(PS, V(STEP1), V(TEMP1)))
- T = DABS(DD7TPR(PS, V(STEP1), Y))
- V(SIZE) = ONE
- IF (T .LT. T1) V(SIZE) = T / T1
-C
-C *** SET G0 TO WCHMTD CHOICE OF FLETCHER AND AL-BAALI ***
-C
- HC1 = IV(HC)
- IF (HC1 .LE. 0) GO TO 550
- CALL DS7LVM(PS, V(G01), V(HC1), V(STEP1))
- GO TO 560
-C
- 550 RMAT1 = IV(RMAT)
- IPIV0 = IV(IPIVOT)
- CALL DV7CPY(P, V(G01), V(STEP1))
- I = G01 + PS
- IF (PS .LT. P) CALL DV7SCP(P-PS, V(I), ZERO)
- CALL DV7IPR(P, IV(IPIV0), V(G01))
- CALL DL7TVM(P, V(G01), V(RMAT1), V(G01))
- CALL DL7VML(P, V(G01), V(RMAT1), V(G01))
- IPIV1 = IV(PERM) + P
- CALL I7PNVR(P, IV(IPIV1), IV(IPIV0))
- CALL DV7IPR(P, IV(IPIV1), V(G01))
-C
- 560 CALL DV2AXY(PS, V(G01), ONE, Y, V(G01))
-C
-C *** UPDATE S ***
-C
- CALL DS7LUP(V(S1), V(COSMIN), PS, V(SIZE), V(STEP1), V(TEMP1),
- 1 V(TEMP2), V(G01), V(WSCALE), Y)
- IV(1) = 2
- GO TO 180
-C
-C. . . . . . . . . . . . . . MISC. DETAILS . . . . . . . . . . . . . .
-C
-C *** BAD PARAMETERS TO ASSESS ***
-C
- 570 IV(1) = 64
- GO TO 999
-C
-C
-C *** CONVERGENCE OBTAINED -- SEE WHETHER TO COMPUTE COVARIANCE ***
-C
- 580 IF (IV(RDREQ) .EQ. 0) GO TO 660
- IF (IV(FDH) .NE. 0) GO TO 660
- IF (IV(CNVCOD) .GE. 7) GO TO 660
- IF (IV(REGD) .GT. 0) GO TO 660
- IF (IV(COVMAT) .GT. 0) GO TO 660
- IF (IABS(IV(COVREQ)) .GE. 3) GO TO 640
- IF (IV(RESTOR) .EQ. 0) IV(RESTOR) = 2
- GO TO 600
-C
-C *** COMPUTE FINITE-DIFFERENCE HESSIAN FOR COMPUTING COVARIANCE ***
-C
- 590 IV(RESTOR) = 0
- 600 CALL DF7DHB(B, D, G, I, IV, LIV, LV, P, V, X)
- GO TO (610, 620, 630), I
- 610 IV(NFCOV) = IV(NFCOV) + 1
- IV(NFCALL) = IV(NFCALL) + 1
- IV(1) = 1
- GO TO 710
-C
- 620 IV(NGCOV) = IV(NGCOV) + 1
- IV(NGCALL) = IV(NGCALL) + 1
- IV(NFGCAL) = IV(NFCALL) + IV(NGCOV)
- GO TO 690
-C
- 630 IF (IV(CNVCOD) .EQ. 70) GO TO 120
- GO TO 660
-C
- 640 H1 = IABS(IV(H))
- IV(FDH) = H1
- IV(H) = -H1
- HC1 = IV(HC)
- IF (HC1 .LE. 0) GO TO 650
- CALL DV7CPY(P*(P+1)/2, V(H1), V(HC1))
- GO TO 660
- 650 RMAT1 = IV(RMAT)
- CALL DL7SQR(P, V(H1), V(RMAT1))
-C
- 660 IV(MODE) = 0
- IV(1) = IV(CNVCOD)
- IV(CNVCOD) = 0
- GO TO 999
-C
-C *** SPECIAL RETURN FOR MISSING HESSIAN INFORMATION -- BOTH
-C *** IV(HC) .LE. 0 AND IV(RMAT) .LE. 0
-C
- 670 IV(1) = 1400
- GO TO 999
-C
-C *** INCONSISTENT B ***
-C
- 680 IV(1) = 82
- GO TO 999
-C
-C *** SAVE, THEN INITIALIZE IPIVOT ARRAY BEFORE COMPUTING G ***
-C
- 690 IV(1) = 2
- J = IV(IPIVOT)
- IPI = IV(PERM)
- CALL I7PNVR(P, IV(IPI), IV(J))
- DO 700 I = 1, P
- IV(J) = I
- J = J + 1
- 700 CONTINUE
-C
-C *** PROJECT X INTO FEASIBLE REGION (PRIOR TO COMPUTING F OR G) ***
-C
- 710 DO 720 I = 1, P
- IF (X(I) .LT. B(1,I)) X(I) = B(1,I)
- IF (X(I) .GT. B(2,I)) X(I) = B(2,I)
- 720 CONTINUE
- IV(TOOBIG) = 0
-C
- 999 RETURN
-C
-C *** LAST LINE OF DG7ITB FOLLOWS ***
- END
diff --git a/CEP/PyBDSM/src/port3/dg7lit.f b/CEP/PyBDSM/src/port3/dg7lit.f
deleted file mode 100644
index 2d137774c33bbcb7731829a5301a16b376affe13..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/dg7lit.f
+++ /dev/null
@@ -1,753 +0,0 @@
- SUBROUTINE DG7LIT(D, G, IV, LIV, LV, P, PS, V, X, Y)
-C
-C *** CARRY OUT NL2SOL-LIKE ITERATIONS FOR GENERALIZED LINEAR ***
-C *** REGRESSION PROBLEMS (AND OTHERS OF SIMILAR STRUCTURE) ***
-C
-C *** PARAMETER DECLARATIONS ***
-C
- INTEGER LIV, LV, P, PS
- INTEGER IV(LIV)
- DOUBLE PRECISION D(P), G(P), V(LV), X(P), Y(P)
-C
-C-------------------------- PARAMETER USAGE --------------------------
-C
-C D.... SCALE VECTOR.
-C IV... INTEGER VALUE ARRAY.
-C LIV.. LENGTH OF IV. MUST BE AT LEAST 82.
-C LH... LENGTH OF H = P*(P+1)/2.
-C LV... LENGTH OF V. MUST BE AT LEAST P*(3*P + 19)/2 + 7.
-C G.... GRADIENT AT X (WHEN IV(1) = 2).
-C P.... NUMBER OF PARAMETERS (COMPONENTS IN X).
-C PS... NUMBER OF NONZERO ROWS AND COLUMNS IN S.
-C V.... FLOATING-POINT VALUE ARRAY.
-C X.... PARAMETER VECTOR.
-C Y.... PART OF YIELD VECTOR (WHEN IV(1)= 2, SCRATCH OTHERWISE).
-C
-C *** DISCUSSION ***
-C
-C DG7LIT PERFORMS NL2SOL-LIKE ITERATIONS FOR A VARIETY OF
-C REGRESSION PROBLEMS THAT ARE SIMILAR TO NONLINEAR LEAST-SQUARES
-C IN THAT THE HESSIAN IS THE SUM OF TWO TERMS, A READILY-COMPUTED
-C FIRST-ORDER TERM AND A SECOND-ORDER TERM. THE CALLER SUPPLIES
-C THE FIRST-ORDER TERM OF THE HESSIAN IN HC (LOWER TRIANGLE, STORED
-C COMPACTLY BY ROWS IN V, STARTING AT IV(HC)), AND DG7LIT BUILDS AN
-C APPROXIMATION, S, TO THE SECOND-ORDER TERM. THE CALLER ALSO
-C PROVIDES THE FUNCTION VALUE, GRADIENT, AND PART OF THE YIELD
-C VECTOR USED IN UPDATING S. DG7LIT DECIDES DYNAMICALLY WHETHER OR
-C NOT TO _USE_ S WHEN CHOOSING THE NEXT STEP TO TRY... THE HESSIAN
-C APPROXIMATION USED IS EITHER HC ALONE (GAUSS-NEWTON MODEL) OR
-C HC + S (AUGMENTED MODEL).
-C
-C IF PS .LT. P, THEN ROWS AND COLUMNS PS+1...P OF S ARE KEPT
-C CONSTANT. THEY WILL BE ZERO UNLESS THE CALLER SETS IV(INITS) TO
-C 1 OR 2 AND SUPPLIES NONZERO VALUES FOR THEM, OR THE CALLER SETS
-C IV(INITS) TO 3 OR 4 AND THE FINITE-DIFFERENCE INITIAL S THEN
-C COMPUTED HAS NONZERO VALUES IN THESE ROWS.
-C
-C IF IV(INITS) IS 3 OR 4, THEN THE INITIAL S IS COMPUTED BY
-C FINITE DIFFERENCES. 3 MEANS _USE_ FUNCTION DIFFERENCES, 4 MEANS
-C _USE_ GRADIENT DIFFERENCES. FINITE DIFFERENCING IS DONE THE SAME
-C WAY AS IN COMPUTING A COVARIANCE MATRIX (WITH IV(COVREQ) = -1, -2,
-C 1, OR 2).
-C
-C FOR UPDATING S,DG7LIT ASSUMES THAT THE GRADIENT HAS THE FORM
-C OF A SUM OVER I OF RHO(I,X)*GRAD(R(I,X)), WHERE GRAD DENOTES THE
-C GRADIENT WITH RESPECT TO X. THE TRUE SECOND-ORDER TERM THEN IS
-C THE SUM OVER I OF RHO(I,X)*HESSIAN(R(I,X)). IF X = X0 + STEP,
-C THEN WE WISH TO UPDATE S SO THAT S*STEP IS THE SUM OVER I OF
-C RHO(I,X)*(GRAD(R(I,X)) - GRAD(R(I,X0))). THE CALLER MUST SUPPLY
-C PART OF THIS IN Y, NAMELY THE SUM OVER I OF
-C RHO(I,X)*GRAD(R(I,X0)), WHEN CALLING DG7LIT WITH IV(1) = 2 AND
-C IV(MODE) = 0 (WHERE MODE = 38). G THEN CONTANS THE OTHER PART,
-C SO THAT THE DESIRED YIELD VECTOR IS G - Y. IF PS .LT. P, THEN
-C THE ABOVE DISCUSSION APPLIES ONLY TO THE FIRST PS COMPONENTS OF
-C GRAD(R(I,X)), STEP, AND Y.
-C
-C PARAMETERS IV, P, V, AND X ARE THE SAME AS THE CORRESPONDING
-C ONES TO NL2SOL (WHICH SEE), EXCEPT THAT V CAN BE SHORTER
-C (SINCE THE PART OF V THAT NL2SOL USES FOR STORING D, J, AND R IS
-C NOT NEEDED). MOREOVER, COMPARED WITH NL2SOL, IV(1) MAY HAVE THE
-C TWO ADDITIONAL OUTPUT VALUES 1 AND 2, WHICH ARE EXPLAINED BELOW,
-C AS IS THE _USE_ OF IV(TOOBIG) AND IV(NFGCAL). THE VALUES IV(D),
-C IV(J), AND IV(R), WHICH ARE OUTPUT VALUES FROM NL2SOL (AND
-C NL2SNO), ARE NOT REFERENCED BY DG7LIT OR THE SUBROUTINES IT CALLS.
-C
-C WHEN DG7LIT IS FIRST CALLED, I.E., WHEN DG7LIT IS CALLED WITH
-C IV(1) = 0 OR 12, V(F), G, AND HC NEED NOT BE INITIALIZED. TO
-C OBTAIN THESE STARTING VALUES,DG7LIT RETURNS FIRST WITH IV(1) = 1,
-C THEN WITH IV(1) = 2, WITH IV(MODE) = -1 IN BOTH CASES. ON
-C SUBSEQUENT RETURNS WITH IV(1) = 2, IV(MODE) = 0 IMPLIES THAT
-C Y MUST ALSO BE SUPPLIED. (NOTE THAT Y IS USED FOR SCRATCH -- ITS
-C INPUT CONTENTS ARE LOST. BY CONTRAST, HC IS NEVER CHANGED.)
-C ONCE CONVERGENCE HAS BEEN OBTAINED, IV(RDREQ) AND IV(COVREQ) MAY
-C IMPLY THAT A FINITE-DIFFERENCE HESSIAN SHOULD BE COMPUTED FOR USE
-C IN COMPUTING A COVARIANCE MATRIX. IN THIS CASE DG7LIT WILL MAKE A
-C NUMBER OF RETURNS WITH IV(1) = 1 OR 2 AND IV(MODE) POSITIVE.
-C WHEN IV(MODE) IS POSITIVE, Y SHOULD NOT BE CHANGED.
-C
-C IV(1) = 1 MEANS THE CALLER SHOULD SET V(F) (I.E., V(10)) TO F(X), THE
-C FUNCTION VALUE AT X, AND CALL DG7LIT AGAIN, HAVING CHANGED
-C NONE OF THE OTHER PARAMETERS. AN EXCEPTION OCCURS IF F(X)
-C CANNOT BE EVALUATED (E.G. IF OVERFLOW WOULD OCCUR), WHICH
-C MAY HAPPEN BECAUSE OF AN OVERSIZED STEP. IN THIS CASE
-C THE CALLER SHOULD SET IV(TOOBIG) = IV(2) TO 1, WHICH WILL
-C CAUSE DG7LIT TO IGNORE V(F) AND TRY A SMALLER STEP. NOTE
-C THAT THE CURRENT FUNCTION EVALUATION COUNT IS AVAILABLE
-C IN IV(NFCALL) = IV(6). THIS MAY BE USED TO IDENTIFY
-C WHICH COPY OF SAVED INFORMATION SHOULD BE USED IN COM-
-C PUTING G, HC, AND Y THE NEXT TIME DG7LIT RETURNS WITH
-C IV(1) = 2. SEE MLPIT FOR AN EXAMPLE OF THIS.
-C IV(1) = 2 MEANS THE CALLER SHOULD SET G TO G(X), THE GRADIENT OF F AT
-C X. THE CALLER SHOULD ALSO SET HC TO THE GAUSS-NEWTON
-C HESSIAN AT X. IF IV(MODE) = 0, THEN THE CALLER SHOULD
-C ALSO COMPUTE THE PART OF THE YIELD VECTOR DESCRIBED ABOVE.
-C THE CALLER SHOULD THEN CALL DG7LIT AGAIN (WITH IV(1) = 2).
-C THE CALLER MAY ALSO CHANGE D AT THIS TIME, BUT SHOULD NOT
-C CHANGE X. NOTE THAT IV(NFGCAL) = IV(7) CONTAINS THE
-C VALUE THAT IV(NFCALL) HAD DURING THE RETURN WITH
-C IV(1) = 1 IN WHICH X HAD THE SAME VALUE AS IT NOW HAS.
-C IV(NFGCAL) IS EITHER IV(NFCALL) OR IV(NFCALL) - 1. MLPIT
-C IS AN EXAMPLE WHERE THIS INFORMATION IS USED. IF G OR HC
-C CANNOT BE EVALUATED AT X, THEN THE CALLER MAY SET
-C IV(TOOBIG) TO 1, IN WHICH CASE DG7LIT WILL RETURN WITH
-C IV(1) = 15.
-C
-C *** GENERAL ***
-C
-C CODED BY DAVID M. GAY.
-C THIS SUBROUTINE WAS WRITTEN IN CONNECTION WITH RESEARCH
-C SUPPORTED IN PART BY D.O.E. GRANT EX-76-A-01-2295 TO MIT/CCREMS.
-C
-C (SEE NL2SOL FOR REFERENCES.)
-C
-C+++++++++++++++++++++++++++ DECLARATIONS ++++++++++++++++++++++++++++
-C
-C *** LOCAL VARIABLES ***
-C
- INTEGER DUMMY, DIG1, G01, H1, HC1, I, IPIV1, J, K, L, LMAT1,
- 1 LSTGST, PP1O2, QTR1, RMAT1, RSTRST, STEP1, STPMOD, S1,
- 2 TEMP1, TEMP2, W1, X01
- DOUBLE PRECISION E, STTSST, T, T1
-C
-C *** CONSTANTS ***
-C
- DOUBLE PRECISION HALF, NEGONE, ONE, ONEP2, ZERO
-C
-C *** EXTERNAL FUNCTIONS AND SUBROUTINES ***
-C
- LOGICAL STOPX
- DOUBLE PRECISION DD7TPR, DL7SVX, DL7SVN, DRLDST, DR7MDC, DV2NRM
- EXTERNAL DA7SST, DD7TPR,DF7HES,DG7QTS,DITSUM, DL7MST,DL7SRT,
- 1 DL7SQR, DL7SVX, DL7SVN, DL7TVM,DL7VML,DPARCK, DRLDST,
- 2 DR7MDC, DS7LUP, DS7LVM, STOPX,DV2AXY,DV7CPY, DV7SCP,
- 3 DV2NRM
-C
-C DA7SST.... ASSESSES CANDIDATE STEP.
-C DD7TPR... RETURNS INNER PRODUCT OF TWO VECTORS.
-C DF7HES.... COMPUTE FINITE-DIFFERENCE HESSIAN (FOR COVARIANCE).
-C DG7QTS.... COMPUTES GOLDFELD-QUANDT-TROTTER STEP (AUGMENTED MODEL).
-C DITSUM.... PRINTS ITERATION SUMMARY AND INFO ON INITIAL AND FINAL X.
-C DL7MST... COMPUTES LEVENBERG-MARQUARDT STEP (GAUSS-NEWTON MODEL).
-C DL7SRT.... COMPUTES CHOLESKY FACTOR OF (LOWER TRIANG. OF) SYM. MATRIX.
-C DL7SQR... COMPUTES L * L**T FROM LOWER TRIANGULAR MATRIX L.
-C DL7TVM... COMPUTES L**T * V, V = VECTOR, L = LOWER TRIANGULAR MATRIX.
-C DL7SVX... ESTIMATES LARGEST SING. VALUE OF LOWER TRIANG. MATRIX.
-C DL7SVN... ESTIMATES SMALLEST SING. VALUE OF LOWER TRIANG. MATRIX.
-C DL7VML.... COMPUTES L * V, V = VECTOR, L = LOWER TRIANGULAR MATRIX.
-C DPARCK.... CHECK VALIDITY OF IV AND V INPUT COMPONENTS.
-C DRLDST... COMPUTES V(RELDX) = RELATIVE STEP SIZE.
-C DR7MDC... RETURNS MACHINE-DEPENDENT CONSTANTS.
-C DS7LUP... PERFORMS QUASI-NEWTON UPDATE ON COMPACTLY STORED LOWER TRI-
-C ANGLE OF A SYMMETRIC MATRIX.
-C STOPX.... RETURNS .TRUE. IF THE BREAK KEY HAS BEEN PRESSED.
-C DV2AXY.... COMPUTES SCALAR TIMES ONE VECTOR PLUS ANOTHER.
-C DV7CPY.... COPIES ONE VECTOR TO ANOTHER.
-C DV7SCP... SETS ALL ELEMENTS OF A VECTOR TO A SCALAR.
-C DV2NRM... RETURNS THE 2-NORM OF A VECTOR.
-C
-C *** SUBSCRIPTS FOR IV AND V ***
-C
- INTEGER CNVCOD, COSMIN, COVMAT, COVREQ, DGNORM, DIG, DSTNRM, F,
- 1 FDH, FDIF, FUZZ, F0, GTSTEP, H, HC, IERR, INCFAC, INITS,
- 2 IPIVOT, IRC, KAGQT, KALM, LMAT, LMAX0, LMAXS, MODE, MODEL,
- 3 MXFCAL, MXITER, NEXTV, NFCALL, NFGCAL, NFCOV, NGCOV,
- 4 NGCALL, NITER, NVSAVE, PHMXFC, PREDUC, QTR, RADFAC,
- 5 RADINC, RADIUS, RAD0, RCOND, RDREQ, REGD, RELDX, RESTOR,
- 6 RMAT, S, SIZE, STEP, STGLIM, STLSTG, STPPAR, SUSED,
- 7 SWITCH, TOOBIG, TUNER4, TUNER5, VNEED, VSAVE, W, WSCALE,
- 8 XIRC, X0
-C
-C *** IV SUBSCRIPT VALUES ***
-C
-C/6
-C DATA CNVCOD/55/, COVMAT/26/, COVREQ/15/, DIG/37/, FDH/74/, H/56/,
-C 1 HC/71/, IERR/75/, INITS/25/, IPIVOT/76/, IRC/29/, KAGQT/33/,
-C 2 KALM/34/, LMAT/42/, MODE/35/, MODEL/5/, MXFCAL/17/,
-C 3 MXITER/18/, NEXTV/47/, NFCALL/6/, NFGCAL/7/, NFCOV/52/,
-C 4 NGCOV/53/, NGCALL/30/, NITER/31/, QTR/77/, RADINC/8/,
-C 5 RDREQ/57/, REGD/67/, RESTOR/9/, RMAT/78/, S/62/, STEP/40/,
-C 6 STGLIM/11/, STLSTG/41/, SUSED/64/, SWITCH/12/, TOOBIG/2/,
-C 7 VNEED/4/, VSAVE/60/, W/65/, XIRC/13/, X0/43/
-C/7
- PARAMETER (CNVCOD=55, COVMAT=26, COVREQ=15, DIG=37, FDH=74, H=56,
- 1 HC=71, IERR=75, INITS=25, IPIVOT=76, IRC=29, KAGQT=33,
- 2 KALM=34, LMAT=42, MODE=35, MODEL=5, MXFCAL=17,
- 3 MXITER=18, NEXTV=47, NFCALL=6, NFGCAL=7, NFCOV=52,
- 4 NGCOV=53, NGCALL=30, NITER=31, QTR=77, RADINC=8,
- 5 RDREQ=57, REGD=67, RESTOR=9, RMAT=78, S=62, STEP=40,
- 6 STGLIM=11, STLSTG=41, SUSED=64, SWITCH=12, TOOBIG=2,
- 7 VNEED=4, VSAVE=60, W=65, XIRC=13, X0=43)
-C/
-C
-C *** V SUBSCRIPT VALUES ***
-C
-C/6
-C DATA COSMIN/47/, DGNORM/1/, DSTNRM/2/, F/10/, FDIF/11/, FUZZ/45/,
-C 1 F0/13/, GTSTEP/4/, INCFAC/23/, LMAX0/35/, LMAXS/36/,
-C 2 NVSAVE/9/, PHMXFC/21/, PREDUC/7/, RADFAC/16/, RADIUS/8/,
-C 3 RAD0/9/, RCOND/53/, RELDX/17/, SIZE/55/, STPPAR/5/,
-C 4 TUNER4/29/, TUNER5/30/, WSCALE/56/
-C/7
- PARAMETER (COSMIN=47, DGNORM=1, DSTNRM=2, F=10, FDIF=11, FUZZ=45,
- 1 F0=13, GTSTEP=4, INCFAC=23, LMAX0=35, LMAXS=36,
- 2 NVSAVE=9, PHMXFC=21, PREDUC=7, RADFAC=16, RADIUS=8,
- 3 RAD0=9, RCOND=53, RELDX=17, SIZE=55, STPPAR=5,
- 4 TUNER4=29, TUNER5=30, WSCALE=56)
-C/
-C
-C
-C/6
-C DATA HALF/0.5D+0/, NEGONE/-1.D+0/, ONE/1.D+0/, ONEP2/1.2D+0/,
-C 1 ZERO/0.D+0/
-C/7
- PARAMETER (HALF=0.5D+0, NEGONE=-1.D+0, ONE=1.D+0, ONEP2=1.2D+0,
- 1 ZERO=0.D+0)
-C/
-C
-C+++++++++++++++++++++++++++++++ BODY ++++++++++++++++++++++++++++++++
-C
- I = IV(1)
- IF (I .EQ. 1) GO TO 40
- IF (I .EQ. 2) GO TO 50
-C
- IF (I .EQ. 12 .OR. I .EQ. 13)
- 1 IV(VNEED) = IV(VNEED) + P*(3*P + 19)/2 + 7
- CALL DPARCK(1, D, IV, LIV, LV, P, V)
- I = IV(1) - 2
- IF (I .GT. 12) GO TO 999
- GO TO (290, 290, 290, 290, 290, 290, 170, 120, 170, 10, 10, 20), I
-C
-C *** STORAGE ALLOCATION ***
-C
- 10 PP1O2 = P * (P + 1) / 2
- IV(S) = IV(LMAT) + PP1O2
- IV(X0) = IV(S) + PP1O2
- IV(STEP) = IV(X0) + P
- IV(STLSTG) = IV(STEP) + P
- IV(DIG) = IV(STLSTG) + P
- IV(W) = IV(DIG) + P
- IV(H) = IV(W) + 4*P + 7
- IV(NEXTV) = IV(H) + PP1O2
- IF (IV(1) .NE. 13) GO TO 20
- IV(1) = 14
- GO TO 999
-C
-C *** INITIALIZATION ***
-C
- 20 IV(NITER) = 0
- IV(NFCALL) = 1
- IV(NGCALL) = 1
- IV(NFGCAL) = 1
- IV(MODE) = -1
- IV(STGLIM) = 2
- IV(TOOBIG) = 0
- IV(CNVCOD) = 0
- IV(COVMAT) = 0
- IV(NFCOV) = 0
- IV(NGCOV) = 0
- IV(RADINC) = 0
- IV(RESTOR) = 0
- IV(FDH) = 0
- V(RAD0) = ZERO
- V(STPPAR) = ZERO
- V(RADIUS) = V(LMAX0) / (ONE + V(PHMXFC))
-C
-C *** SET INITIAL MODEL AND S MATRIX ***
-C
- IV(MODEL) = 1
- IF (IV(S) .LT. 0) GO TO 999
- IF (IV(INITS) .GT. 1) IV(MODEL) = 2
- S1 = IV(S)
- IF (IV(INITS) .EQ. 0 .OR. IV(INITS) .GT. 2)
- 1 CALL DV7SCP(P*(P+1)/2, V(S1), ZERO)
- IV(1) = 1
- J = IV(IPIVOT)
- IF (J .LE. 0) GO TO 999
- DO 30 I = 1, P
- IV(J) = I
- J = J + 1
- 30 CONTINUE
- GO TO 999
-C
-C *** NEW FUNCTION VALUE ***
-C
- 40 IF (IV(MODE) .EQ. 0) GO TO 290
- IF (IV(MODE) .GT. 0) GO TO 520
-C
- IV(1) = 2
- IF (IV(TOOBIG) .EQ. 0) GO TO 999
- IV(1) = 63
- GO TO 999
-C
-C *** NEW GRADIENT ***
-C
- 50 IV(KALM) = -1
- IV(KAGQT) = -1
- IV(FDH) = 0
- IF (IV(MODE) .GT. 0) GO TO 520
-C
-C *** MAKE SURE GRADIENT COULD BE COMPUTED ***
-C
- IF (IV(TOOBIG) .EQ. 0) GO TO 60
- IV(1) = 65
- GO TO 999
- 60 IF (IV(HC) .LE. 0 .AND. IV(RMAT) .LE. 0) GO TO 610
-C
-C *** COMPUTE D**-1 * GRADIENT ***
-C
- DIG1 = IV(DIG)
- K = DIG1
- DO 70 I = 1, P
- V(K) = G(I) / D(I)
- K = K + 1
- 70 CONTINUE
- V(DGNORM) = DV2NRM(P, V(DIG1))
-C
- IF (IV(CNVCOD) .NE. 0) GO TO 510
- IF (IV(MODE) .EQ. 0) GO TO 440
- IV(MODE) = 0
- V(F0) = V(F)
- IF (IV(INITS) .LE. 2) GO TO 100
-C
-C *** ARRANGE FOR FINITE-DIFFERENCE INITIAL S ***
-C
- IV(XIRC) = IV(COVREQ)
- IV(COVREQ) = -1
- IF (IV(INITS) .GT. 3) IV(COVREQ) = 1
- IV(CNVCOD) = 70
- GO TO 530
-C
-C *** COME TO NEXT STMT AFTER COMPUTING F.D. HESSIAN FOR INIT. S ***
-C
- 80 IV(CNVCOD) = 0
- IV(MODE) = 0
- IV(NFCOV) = 0
- IV(NGCOV) = 0
- IV(COVREQ) = IV(XIRC)
- S1 = IV(S)
- PP1O2 = PS * (PS + 1) / 2
- HC1 = IV(HC)
- IF (HC1 .LE. 0) GO TO 90
- CALL DV2AXY(PP1O2, V(S1), NEGONE, V(HC1), V(H1))
- GO TO 100
- 90 RMAT1 = IV(RMAT)
- CALL DL7SQR(PS, V(S1), V(RMAT1))
- CALL DV2AXY(PP1O2, V(S1), NEGONE, V(S1), V(H1))
- 100 IV(1) = 2
-C
-C
-C----------------------------- MAIN LOOP -----------------------------
-C
-C
-C *** PRINT ITERATION SUMMARY, CHECK ITERATION LIMIT ***
-C
- 110 CALL DITSUM(D, G, IV, LIV, LV, P, V, X)
- 120 K = IV(NITER)
- IF (K .LT. IV(MXITER)) GO TO 130
- IV(1) = 10
- GO TO 999
- 130 IV(NITER) = K + 1
-C
-C *** UPDATE RADIUS ***
-C
- IF (K .EQ. 0) GO TO 150
- STEP1 = IV(STEP)
- DO 140 I = 1, P
- V(STEP1) = D(I) * V(STEP1)
- STEP1 = STEP1 + 1
- 140 CONTINUE
- STEP1 = IV(STEP)
- T = V(RADFAC) * DV2NRM(P, V(STEP1))
- IF (V(RADFAC) .LT. ONE .OR. T .GT. V(RADIUS)) V(RADIUS) = T
-C
-C *** INITIALIZE FOR START OF NEXT ITERATION ***
-C
- 150 X01 = IV(X0)
- V(F0) = V(F)
- IV(IRC) = 4
- IV(H) = -IABS(IV(H))
- IV(SUSED) = IV(MODEL)
-C
-C *** COPY X TO X0 ***
-C
- CALL DV7CPY(P, V(X01), X)
-C
-C *** CHECK STOPX AND FUNCTION EVALUATION LIMIT ***
-C
- 160 IF (.NOT. STOPX(DUMMY)) GO TO 180
- IV(1) = 11
- GO TO 190
-C
-C *** COME HERE WHEN RESTARTING AFTER FUNC. EVAL. LIMIT OR STOPX.
-C
- 170 IF (V(F) .GE. V(F0)) GO TO 180
- V(RADFAC) = ONE
- K = IV(NITER)
- GO TO 130
-C
- 180 IF (IV(NFCALL) .LT. IV(MXFCAL) + IV(NFCOV)) GO TO 200
- IV(1) = 9
- 190 IF (V(F) .GE. V(F0)) GO TO 999
-C
-C *** IN CASE OF STOPX OR FUNCTION EVALUATION LIMIT WITH
-C *** IMPROVED V(F), EVALUATE THE GRADIENT AT X.
-C
- IV(CNVCOD) = IV(1)
- GO TO 430
-C
-C. . . . . . . . . . . . . COMPUTE CANDIDATE STEP . . . . . . . . . .
-C
- 200 STEP1 = IV(STEP)
- W1 = IV(W)
- H1 = IV(H)
- T1 = ONE
- IF (IV(MODEL) .EQ. 2) GO TO 210
- T1 = ZERO
-C
-C *** COMPUTE LEVENBERG-MARQUARDT STEP IF POSSIBLE...
-C
- RMAT1 = IV(RMAT)
- IF (RMAT1 .LE. 0) GO TO 210
- QTR1 = IV(QTR)
- IF (QTR1 .LE. 0) GO TO 210
- IPIV1 = IV(IPIVOT)
- CALL DL7MST(D, G, IV(IERR), IV(IPIV1), IV(KALM), P, V(QTR1),
- 1 V(RMAT1), V(STEP1), V, V(W1))
-C *** H IS STORED IN THE END OF W AND HAS JUST BEEN OVERWRITTEN,
-C *** SO WE MARK IT INVALID...
- IV(H) = -IABS(H1)
-C *** EVEN IF H WERE STORED ELSEWHERE, IT WOULD BE NECESSARY TO
-C *** MARK INVALID THE INFORMATION DG7QTS MAY HAVE STORED IN V...
- IV(KAGQT) = -1
- GO TO 260
-C
- 210 IF (H1 .GT. 0) GO TO 250
-C
-C *** SET H TO D**-1 * (HC + T1*S) * D**-1. ***
-C
- H1 = -H1
- IV(H) = H1
- IV(FDH) = 0
- J = IV(HC)
- IF (J .GT. 0) GO TO 220
- J = H1
- RMAT1 = IV(RMAT)
- CALL DL7SQR(P, V(H1), V(RMAT1))
- 220 S1 = IV(S)
- DO 240 I = 1, P
- T = ONE / D(I)
- DO 230 K = 1, I
- V(H1) = T * (V(J) + T1*V(S1)) / D(K)
- J = J + 1
- H1 = H1 + 1
- S1 = S1 + 1
- 230 CONTINUE
- 240 CONTINUE
- H1 = IV(H)
- IV(KAGQT) = -1
-C
-C *** COMPUTE ACTUAL GOLDFELD-QUANDT-TROTTER STEP ***
-C
- 250 DIG1 = IV(DIG)
- LMAT1 = IV(LMAT)
- CALL DG7QTS(D, V(DIG1), V(H1), IV(KAGQT), V(LMAT1), P, V(STEP1),
- 1 V, V(W1))
- IF (IV(KALM) .GT. 0) IV(KALM) = 0
-C
- 260 IF (IV(IRC) .NE. 6) GO TO 270
- IF (IV(RESTOR) .NE. 2) GO TO 290
- RSTRST = 2
- GO TO 300
-C
-C *** CHECK WHETHER EVALUATING F(X0 + STEP) LOOKS WORTHWHILE ***
-C
- 270 IV(TOOBIG) = 0
- IF (V(DSTNRM) .LE. ZERO) GO TO 290
- IF (IV(IRC) .NE. 5) GO TO 280
- IF (V(RADFAC) .LE. ONE) GO TO 280
- IF (V(PREDUC) .GT. ONEP2 * V(FDIF)) GO TO 280
- STEP1 = IV(STEP)
- X01 = IV(X0)
- CALL DV2AXY(P, V(STEP1), NEGONE, V(X01), X)
- IF (IV(RESTOR) .NE. 2) GO TO 290
- RSTRST = 0
- GO TO 300
-C
-C *** COMPUTE F(X0 + STEP) ***
-C
- 280 X01 = IV(X0)
- STEP1 = IV(STEP)
- CALL DV2AXY(P, X, ONE, V(STEP1), V(X01))
- IV(NFCALL) = IV(NFCALL) + 1
- IV(1) = 1
- GO TO 999
-C
-C. . . . . . . . . . . . . ASSESS CANDIDATE STEP . . . . . . . . . . .
-C
- 290 RSTRST = 3
- 300 X01 = IV(X0)
- V(RELDX) = DRLDST(P, D, X, V(X01))
- CALL DA7SST(IV, LIV, LV, V)
- STEP1 = IV(STEP)
- LSTGST = IV(STLSTG)
- I = IV(RESTOR) + 1
- GO TO (340, 310, 320, 330), I
- 310 CALL DV7CPY(P, X, V(X01))
- GO TO 340
- 320 CALL DV7CPY(P, V(LSTGST), V(STEP1))
- GO TO 340
- 330 CALL DV7CPY(P, V(STEP1), V(LSTGST))
- CALL DV2AXY(P, X, ONE, V(STEP1), V(X01))
- V(RELDX) = DRLDST(P, D, X, V(X01))
- IV(RESTOR) = RSTRST
-C
-C *** IF NECESSARY, SWITCH MODELS ***
-C
- 340 IF (IV(SWITCH) .EQ. 0) GO TO 350
- IV(H) = -IABS(IV(H))
- IV(SUSED) = IV(SUSED) + 2
- L = IV(VSAVE)
- CALL DV7CPY(NVSAVE, V, V(L))
- 350 L = IV(IRC) - 4
- STPMOD = IV(MODEL)
- IF (L .GT. 0) GO TO (370,380,390,390,390,390,390,390,500,440), L
-C
-C *** DECIDE WHETHER TO CHANGE MODELS ***
-C
- E = V(PREDUC) - V(FDIF)
- S1 = IV(S)
- CALL DS7LVM(PS, Y, V(S1), V(STEP1))
- STTSST = HALF * DD7TPR(PS, V(STEP1), Y)
- IF (IV(MODEL) .EQ. 1) STTSST = -STTSST
- IF (DABS(E + STTSST) * V(FUZZ) .GE. DABS(E)) GO TO 360
-C
-C *** SWITCH MODELS ***
-C
- IV(MODEL) = 3 - IV(MODEL)
- IF (-2 .LT. L) GO TO 400
- IV(H) = -IABS(IV(H))
- IV(SUSED) = IV(SUSED) + 2
- L = IV(VSAVE)
- CALL DV7CPY(NVSAVE, V(L), V)
- GO TO 160
-C
- 360 IF (-3 .LT. L) GO TO 400
-C
-C *** RECOMPUTE STEP WITH NEW RADIUS ***
-C
- 370 V(RADIUS) = V(RADFAC) * V(DSTNRM)
- GO TO 160
-C
-C *** COMPUTE STEP OF LENGTH V(LMAXS) FOR SINGULAR CONVERGENCE TEST
-C
- 380 V(RADIUS) = V(LMAXS)
- GO TO 200
-C
-C *** CONVERGENCE OR FALSE CONVERGENCE ***
-C
- 390 IV(CNVCOD) = L
- IF (V(F) .GE. V(F0)) GO TO 510
- IF (IV(XIRC) .EQ. 14) GO TO 510
- IV(XIRC) = 14
-C
-C. . . . . . . . . . . . PROCESS ACCEPTABLE STEP . . . . . . . . . . .
-C
- 400 IV(COVMAT) = 0
- IV(REGD) = 0
-C
-C *** SEE WHETHER TO SET V(RADFAC) BY GRADIENT TESTS ***
-C
- IF (IV(IRC) .NE. 3) GO TO 430
- STEP1 = IV(STEP)
- TEMP1 = IV(STLSTG)
- TEMP2 = IV(W)
-C
-C *** SET TEMP1 = HESSIAN * STEP FOR _USE_ IN GRADIENT TESTS ***
-C
- HC1 = IV(HC)
- IF (HC1 .LE. 0) GO TO 410
- CALL DS7LVM(P, V(TEMP1), V(HC1), V(STEP1))
- GO TO 420
- 410 RMAT1 = IV(RMAT)
- CALL DL7TVM(P, V(TEMP1), V(RMAT1), V(STEP1))
- CALL DL7VML(P, V(TEMP1), V(RMAT1), V(TEMP1))
-C
- 420 IF (STPMOD .EQ. 1) GO TO 430
- S1 = IV(S)
- CALL DS7LVM(PS, V(TEMP2), V(S1), V(STEP1))
- CALL DV2AXY(PS, V(TEMP1), ONE, V(TEMP2), V(TEMP1))
-C
-C *** SAVE OLD GRADIENT AND COMPUTE NEW ONE ***
-C
- 430 IV(NGCALL) = IV(NGCALL) + 1
- G01 = IV(W)
- CALL DV7CPY(P, V(G01), G)
- IV(1) = 2
- IV(TOOBIG) = 0
- GO TO 999
-C
-C *** INITIALIZATIONS -- G0 = G - G0, ETC. ***
-C
- 440 G01 = IV(W)
- CALL DV2AXY(P, V(G01), NEGONE, V(G01), G)
- STEP1 = IV(STEP)
- TEMP1 = IV(STLSTG)
- TEMP2 = IV(W)
- IF (IV(IRC) .NE. 3) GO TO 470
-C
-C *** SET V(RADFAC) BY GRADIENT TESTS ***
-C
-C *** SET TEMP1 = D**-1 * (HESSIAN * STEP + (G(X0) - G(X))) ***
-C
- K = TEMP1
- L = G01
- DO 450 I = 1, P
- V(K) = (V(K) - V(L)) / D(I)
- K = K + 1
- L = L + 1
- 450 CONTINUE
-C
-C *** DO GRADIENT TESTS ***
-C
- IF (DV2NRM(P, V(TEMP1)) .LE. V(DGNORM) * V(TUNER4)) GO TO 460
- IF (DD7TPR(P, G, V(STEP1))
- 1 .GE. V(GTSTEP) * V(TUNER5)) GO TO 470
- 460 V(RADFAC) = V(INCFAC)
-C
-C *** COMPUTE Y VECTOR NEEDED FOR UPDATING S ***
-C
- 470 CALL DV2AXY(PS, Y, NEGONE, Y, G)
-C
-C *** DETERMINE SIZING FACTOR V(SIZE) ***
-C
-C *** SET TEMP1 = S * STEP ***
- S1 = IV(S)
- CALL DS7LVM(PS, V(TEMP1), V(S1), V(STEP1))
-C
- T1 = DABS(DD7TPR(PS, V(STEP1), V(TEMP1)))
- T = DABS(DD7TPR(PS, V(STEP1), Y))
- V(SIZE) = ONE
- IF (T .LT. T1) V(SIZE) = T / T1
-C
-C *** SET G0 TO WCHMTD CHOICE OF FLETCHER AND AL-BAALI ***
-C
- HC1 = IV(HC)
- IF (HC1 .LE. 0) GO TO 480
- CALL DS7LVM(PS, V(G01), V(HC1), V(STEP1))
- GO TO 490
-C
- 480 RMAT1 = IV(RMAT)
- CALL DL7TVM(PS, V(G01), V(RMAT1), V(STEP1))
- CALL DL7VML(PS, V(G01), V(RMAT1), V(G01))
-C
- 490 CALL DV2AXY(PS, V(G01), ONE, Y, V(G01))
-C
-C *** UPDATE S ***
-C
- CALL DS7LUP(V(S1), V(COSMIN), PS, V(SIZE), V(STEP1), V(TEMP1),
- 1 V(TEMP2), V(G01), V(WSCALE), Y)
- IV(1) = 2
- GO TO 110
-C
-C. . . . . . . . . . . . . . MISC. DETAILS . . . . . . . . . . . . . .
-C
-C *** BAD PARAMETERS TO ASSESS ***
-C
- 500 IV(1) = 64
- GO TO 999
-C
-C
-C *** CONVERGENCE OBTAINED -- SEE WHETHER TO COMPUTE COVARIANCE ***
-C
- 510 IF (IV(RDREQ) .EQ. 0) GO TO 600
- IF (IV(FDH) .NE. 0) GO TO 600
- IF (IV(CNVCOD) .GE. 7) GO TO 600
- IF (IV(REGD) .GT. 0) GO TO 600
- IF (IV(COVMAT) .GT. 0) GO TO 600
- IF (IABS(IV(COVREQ)) .GE. 3) GO TO 560
- IF (IV(RESTOR) .EQ. 0) IV(RESTOR) = 2
- GO TO 530
-C
-C *** COMPUTE FINITE-DIFFERENCE HESSIAN FOR COMPUTING COVARIANCE ***
-C
- 520 IV(RESTOR) = 0
- 530 CALL DF7HES(D, G, I, IV, LIV, LV, P, V, X)
- GO TO (540, 550, 580), I
- 540 IV(NFCOV) = IV(NFCOV) + 1
- IV(NFCALL) = IV(NFCALL) + 1
- IV(1) = 1
- GO TO 999
-C
- 550 IV(NGCOV) = IV(NGCOV) + 1
- IV(NGCALL) = IV(NGCALL) + 1
- IV(NFGCAL) = IV(NFCALL) + IV(NGCOV)
- IV(1) = 2
- GO TO 999
-C
- 560 H1 = IABS(IV(H))
- IV(H) = -H1
- PP1O2 = P * (P + 1) / 2
- RMAT1 = IV(RMAT)
- IF (RMAT1 .LE. 0) GO TO 570
- LMAT1 = IV(LMAT)
- CALL DV7CPY(PP1O2, V(LMAT1), V(RMAT1))
- V(RCOND) = ZERO
- GO TO 590
- 570 HC1 = IV(HC)
- IV(FDH) = H1
- CALL DV7CPY(P*(P+1)/2, V(H1), V(HC1))
-C
-C *** COMPUTE CHOLESKY FACTOR OF FINITE-DIFFERENCE HESSIAN
-C *** FOR _USE_ IN CALLER*S COVARIANCE CALCULATION...
-C
- 580 LMAT1 = IV(LMAT)
- H1 = IV(FDH)
- IF (H1 .LE. 0) GO TO 600
- IF (IV(CNVCOD) .EQ. 70) GO TO 80
- CALL DL7SRT(1, P, V(LMAT1), V(H1), I)
- IV(FDH) = -1
- V(RCOND) = ZERO
- IF (I .NE. 0) GO TO 600
-C
- 590 IV(FDH) = -1
- STEP1 = IV(STEP)
- T = DL7SVN(P, V(LMAT1), V(STEP1), V(STEP1))
- IF (T .LE. ZERO) GO TO 600
- T = T / DL7SVX(P, V(LMAT1), V(STEP1), V(STEP1))
- IF (T .GT. DR7MDC(4)) IV(FDH) = H1
- V(RCOND) = T
-C
- 600 IV(MODE) = 0
- IV(1) = IV(CNVCOD)
- IV(CNVCOD) = 0
- GO TO 999
-C
-C *** SPECIAL RETURN FOR MISSING HESSIAN INFORMATION -- BOTH
-C *** IV(HC) .LE. 0 AND IV(RMAT) .LE. 0
-C
- 610 IV(1) = 1400
-C
- 999 RETURN
-C
-C *** LAST LINE OF DG7LIT FOLLOWS ***
- END
diff --git a/CEP/PyBDSM/src/port3/dg7qsb.f b/CEP/PyBDSM/src/port3/dg7qsb.f
deleted file mode 100644
index 25901ea6a31c5013258688ea166622b80af3c313..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/dg7qsb.f
+++ /dev/null
@@ -1,88 +0,0 @@
- SUBROUTINE DG7QSB(B, D, DIHDI, G, IPIV, IPIV1, IPIV2, KA, L, LV,
- 1 P, P0, PC, STEP, TD, TG, V, W, X, X0)
-C
-C *** COMPUTE HEURISTIC BOUNDED NEWTON STEP ***
-C
- INTEGER KA, LV, P, P0, PC
- INTEGER IPIV(P), IPIV1(P), IPIV2(P)
- DOUBLE PRECISION B(2,P), D(P), DIHDI(1), G(P), L(1),
- 1 STEP(P,2), TD(P), TG(P), V(LV), W(P), X0(P), X(P)
-C DIMENSION DIHDI(P*(P+1)/2), L(P*(P+1)/2)
-C
- DOUBLE PRECISION DD7TPR
- EXTERNAL DD7TPR,DG7QTS, DS7BQN, DS7IPR,DV7CPY, DV7IPR,
- 1 DV7SCP, DV7VMP
-C
-C *** LOCAL VARIABLES ***
-C
- INTEGER K, KB, KINIT, NS, P1, P10
- DOUBLE PRECISION DS0, NRED, PRED, RAD
- DOUBLE PRECISION ZERO
-C
-C *** V SUBSCRIPTS ***
-C
- INTEGER DST0, DSTNRM, GTSTEP, NREDUC, PREDUC, RADIUS
-C
-C/6
-C DATA DST0/3/, DSTNRM/2/, GTSTEP/4/, NREDUC/6/, PREDUC/7/,
-C 1 RADIUS/8/
-C/7
- PARAMETER (DST0=3, DSTNRM=2, GTSTEP=4, NREDUC=6, PREDUC=7,
- 1 RADIUS=8)
-C/
- DATA ZERO/0.D+0/
-C
-C+++++++++++++++++++++++++++++++ BODY ++++++++++++++++++++++++++++++++
-C
- P1 = PC
- IF (KA .LT. 0) GO TO 10
- NRED = V(NREDUC)
- DS0 = V(DST0)
- GO TO 20
- 10 P0 = 0
- KA = -1
-C
- 20 KINIT = -1
- IF (P0 .EQ. P1) KINIT = KA
- CALL DV7CPY(P, X, X0)
- PRED = ZERO
- RAD = V(RADIUS)
- KB = -1
- V(DSTNRM) = ZERO
- IF (P1 .GT. 0) GO TO 30
- NRED = ZERO
- DS0 = ZERO
- CALL DV7SCP(P, STEP, ZERO)
- GO TO 60
-C
- 30 CALL DV7CPY(P, TD, D)
- CALL DV7IPR(P, IPIV, TD)
- CALL DV7VMP(P, TG, G, D, -1)
- CALL DV7IPR(P, IPIV, TG)
- 40 K = KINIT
- KINIT = -1
- V(RADIUS) = RAD - V(DSTNRM)
- CALL DG7QTS(TD, TG, DIHDI, K, L, P1, STEP, V, W)
- P0 = P1
- IF (KA .GE. 0) GO TO 50
- NRED = V(NREDUC)
- DS0 = V(DST0)
-C
- 50 KA = K
- V(RADIUS) = RAD
- P10 = P1
- CALL DS7BQN(B, D, STEP(1,2), IPIV, IPIV1, IPIV2, KB, L, LV,
- 1 NS, P, P1, STEP, TD, TG, V, W, X, X0)
- IF (NS .GT. 0) CALL DS7IPR(P10, IPIV1, DIHDI)
- PRED = PRED + V(PREDUC)
- IF (NS .NE. 0) P0 = 0
- IF (KB .LE. 0) GO TO 40
-C
- 60 V(DST0) = DS0
- V(NREDUC) = NRED
- V(PREDUC) = PRED
- V(GTSTEP) = DD7TPR(P, G, STEP)
-C
- 999 RETURN
-C *** LAST LINE OF DG7QSB FOLLOWS ***
- END
diff --git a/CEP/PyBDSM/src/port3/dg7qts.f b/CEP/PyBDSM/src/port3/dg7qts.f
deleted file mode 100644
index 6fd2e26d3de36155d775830870f418e1f23625ec..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/dg7qts.f
+++ /dev/null
@@ -1,644 +0,0 @@
- SUBROUTINE DG7QTS(D, DIG, DIHDI, KA, L, P, STEP, V, W)
-C
-C *** COMPUTE GOLDFELD-QUANDT-TROTTER STEP BY MORE-HEBDEN TECHNIQUE ***
-C *** (NL2SOL VERSION 2.2), MODIFIED A LA MORE AND SORENSEN ***
-C
-C *** PARAMETER DECLARATIONS ***
-C
- INTEGER KA, P
- DOUBLE PRECISION D(P), DIG(P), DIHDI(1), L(1), V(21), STEP(P),
- 1 W(1)
-C DIMENSION DIHDI(P*(P+1)/2), L(P*(P+1)/2), W(4*P+7)
-C
-C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
-C
-C *** PURPOSE ***
-C
-C GIVEN THE (COMPACTLY STORED) LOWER TRIANGLE OF A SCALED
-C HESSIAN (APPROXIMATION) AND A NONZERO SCALED GRADIENT VECTOR,
-C THIS SUBROUTINE COMPUTES A GOLDFELD-QUANDT-TROTTER STEP OF
-C APPROXIMATE LENGTH V(RADIUS) BY THE MORE-HEBDEN TECHNIQUE. IN
-C OTHER WORDS, STEP IS COMPUTED TO (APPROXIMATELY) MINIMIZE
-C PSI(STEP) = (G**T)*STEP + 0.5*(STEP**T)*H*STEP SUCH THAT THE
-C 2-NORM OF D*STEP IS AT MOST (APPROXIMATELY) V(RADIUS), WHERE
-C G IS THE GRADIENT, H IS THE HESSIAN, AND D IS A DIAGONAL
-C SCALE MATRIX WHOSE DIAGONAL IS STORED IN THE PARAMETER D.
-C (DG7QTS ASSUMES DIG = D**-1 * G AND DIHDI = D**-1 * H * D**-1.)
-C
-C *** PARAMETER DESCRIPTION ***
-C
-C D (IN) = THE SCALE VECTOR, I.E. THE DIAGONAL OF THE SCALE
-C MATRIX D MENTIONED ABOVE UNDER PURPOSE.
-C DIG (IN) = THE SCALED GRADIENT VECTOR, D**-1 * G. IF G = 0, THEN
-C STEP = 0 AND V(STPPAR) = 0 ARE RETURNED.
-C DIHDI (IN) = LOWER TRIANGLE OF THE SCALED HESSIAN (APPROXIMATION),
-C I.E., D**-1 * H * D**-1, STORED COMPACTLY BY ROWS., I.E.,
-C IN THE ORDER (1,1), (2,1), (2,2), (3,1), (3,2), ETC.
-C KA (I/O) = THE NUMBER OF HEBDEN ITERATIONS (SO FAR) TAKEN TO DETER-
-C MINE STEP. KA .LT. 0 ON INPUT MEANS THIS IS THE FIRST
-C ATTEMPT TO DETERMINE STEP (FOR THE PRESENT DIG AND DIHDI)
-C -- KA IS INITIALIZED TO 0 IN THIS CASE. OUTPUT WITH
-C KA = 0 (OR V(STPPAR) = 0) MEANS STEP = -(H**-1)*G.
-C L (I/O) = WORKSPACE OF LENGTH P*(P+1)/2 FOR CHOLESKY FACTORS.
-C P (IN) = NUMBER OF PARAMETERS -- THE HESSIAN IS A P X P MATRIX.
-C STEP (I/O) = THE STEP COMPUTED.
-C V (I/O) CONTAINS VARIOUS CONSTANTS AND VARIABLES DESCRIBED BELOW.
-C W (I/O) = WORKSPACE OF LENGTH 4*P + 6.
-C
-C *** ENTRIES IN V ***
-C
-C V(DGNORM) (I/O) = 2-NORM OF (D**-1)*G.
-C V(DSTNRM) (OUTPUT) = 2-NORM OF D*STEP.
-C V(DST0) (I/O) = 2-NORM OF D*(H**-1)*G (FOR POS. DEF. H ONLY), OR
-C OVERESTIMATE OF SMALLEST EIGENVALUE OF (D**-1)*H*(D**-1).
-C V(EPSLON) (IN) = MAX. REL. ERROR ALLOWED FOR PSI(STEP). FOR THE
-C STEP RETURNED, PSI(STEP) WILL EXCEED ITS OPTIMAL VALUE
-C BY LESS THAN -V(EPSLON)*PSI(STEP). SUGGESTED VALUE = 0.1.
-C V(GTSTEP) (OUT) = INNER PRODUCT BETWEEN G AND STEP.
-C V(NREDUC) (OUT) = PSI(-(H**-1)*G) = PSI(NEWTON STEP) (FOR POS. DEF.
-C H ONLY -- V(NREDUC) IS SET TO ZERO OTHERWISE).
-C V(PHMNFC) (IN) = TOL. (TOGETHER WITH V(PHMXFC)) FOR ACCEPTING STEP
-C (MORE*S SIGMA). THE ERROR V(DSTNRM) - V(RADIUS) MUST LIE
-C BETWEEN V(PHMNFC)*V(RADIUS) AND V(PHMXFC)*V(RADIUS).
-C V(PHMXFC) (IN) (SEE V(PHMNFC).)
-C SUGGESTED VALUES -- V(PHMNFC) = -0.25, V(PHMXFC) = 0.5.
-C V(PREDUC) (OUT) = PSI(STEP) = PREDICTED OBJ. FUNC. REDUCTION FOR STEP.
-C V(RADIUS) (IN) = RADIUS OF CURRENT (SCALED) TRUST REGION.
-C V(RAD0) (I/O) = VALUE OF V(RADIUS) FROM PREVIOUS CALL.
-C V(STPPAR) (I/O) IS NORMALLY THE MARQUARDT PARAMETER, I.E. THE ALPHA
-C DESCRIBED BELOW UNDER ALGORITHM NOTES. IF H + ALPHA*D**2
-C (SEE ALGORITHM NOTES) IS (NEARLY) SINGULAR, HOWEVER,
-C THEN V(STPPAR) = -ALPHA.
-C
-C *** USAGE NOTES ***
-C
-C IF IT IS DESIRED TO RECOMPUTE STEP USING A DIFFERENT VALUE OF
-C V(RADIUS), THEN THIS ROUTINE MAY BE RESTARTED BY CALLING IT
-C WITH ALL PARAMETERS UNCHANGED EXCEPT V(RADIUS). (THIS EXPLAINS
-C WHY STEP AND W ARE LISTED AS I/O). ON AN INITIAL CALL (ONE WITH
-C KA .LT. 0), STEP AND W NEED NOT BE INITIALIZED AND ONLY COMPO-
-C NENTS V(EPSLON), V(STPPAR), V(PHMNFC), V(PHMXFC), V(RADIUS), AND
-C V(RAD0) OF V MUST BE INITIALIZED.
-C
-C *** ALGORITHM NOTES ***
-C
-C THE DESIRED G-Q-T STEP (REF. 2, 3, 4, 6) SATISFIES
-C (H + ALPHA*D**2)*STEP = -G FOR SOME NONNEGATIVE ALPHA SUCH THAT
-C H + ALPHA*D**2 IS POSITIVE SEMIDEFINITE. ALPHA AND STEP ARE
-C COMPUTED BY A SCHEME ANALOGOUS TO THE ONE DESCRIBED IN REF. 5.
-C ESTIMATES OF THE SMALLEST AND LARGEST EIGENVALUES OF THE HESSIAN
-C ARE OBTAINED FROM THE GERSCHGORIN CIRCLE THEOREM ENHANCED BY A
-C SIMPLE FORM OF THE SCALING DESCRIBED IN REF. 7. CASES IN WHICH
-C H + ALPHA*D**2 IS NEARLY (OR EXACTLY) SINGULAR ARE HANDLED BY
-C THE TECHNIQUE DISCUSSED IN REF. 2. IN THESE CASES, A STEP OF
-C (EXACT) LENGTH V(RADIUS) IS RETURNED FOR WHICH PSI(STEP) EXCEEDS
-C ITS OPTIMAL VALUE BY LESS THAN -V(EPSLON)*PSI(STEP). THE TEST
-C SUGGESTED IN REF. 6 FOR DETECTING THE SPECIAL CASE IS PERFORMED
-C ONCE TWO MATRIX FACTORIZATIONS HAVE BEEN DONE -- DOING SO SOONER
-C SEEMS TO DEGRADE THE PERFORMANCE OF OPTIMIZATION ROUTINES THAT
-C CALL THIS ROUTINE.
-C
-C *** FUNCTIONS AND SUBROUTINES CALLED ***
-C
-C DD7TPR - RETURNS INNER PRODUCT OF TWO VECTORS.
-C DL7ITV - APPLIES INVERSE-TRANSPOSE OF COMPACT LOWER TRIANG. MATRIX.
-C DL7IVM - APPLIES INVERSE OF COMPACT LOWER TRIANG. MATRIX.
-C DL7SRT - FINDS CHOLESKY FACTOR (OF COMPACTLY STORED LOWER TRIANG.).
-C DL7SVN - RETURNS APPROX. TO MIN. SING. VALUE OF LOWER TRIANG. MATRIX.
-C DR7MDC - RETURNS MACHINE-DEPENDENT CONSTANTS.
-C DV2NRM - RETURNS 2-NORM OF A VECTOR.
-C
-C *** REFERENCES ***
-C
-C 1. DENNIS, J.E., GAY, D.M., AND WELSCH, R.E. (1981), AN ADAPTIVE
-C NONLINEAR LEAST-SQUARES ALGORITHM, ACM TRANS. MATH.
-C SOFTWARE, VOL. 7, NO. 3.
-C 2. GAY, D.M. (1981), COMPUTING OPTIMAL LOCALLY CONSTRAINED STEPS,
-C SIAM J. SCI. STATIST. COMPUTING, VOL. 2, NO. 2, PP.
-C 186-197.
-C 3. GOLDFELD, S.M., QUANDT, R.E., AND TROTTER, H.F. (1966),
-C MAXIMIZATION BY QUADRATIC HILL-CLIMBING, ECONOMETRICA 34,
-C PP. 541-551.
-C 4. HEBDEN, M.D. (1973), AN ALGORITHM FOR MINIMIZATION USING EXACT
-C SECOND DERIVATIVES, REPORT T.P. 515, THEORETICAL PHYSICS
-C DIV., A.E.R.E. HARWELL, OXON., ENGLAND.
-C 5. MORE, J.J. (1978), THE LEVENBERG-MARQUARDT ALGORITHM, IMPLEMEN-
-C TATION AND THEORY, PP.105-116 OF SPRINGER LECTURE NOTES
-C IN MATHEMATICS NO. 630, EDITED BY G.A. WATSON, SPRINGER-
-C VERLAG, BERLIN AND NEW YORK.
-C 6. MORE, J.J., AND SORENSEN, D.C. (1981), COMPUTING A TRUST REGION
-C STEP, TECHNICAL REPORT ANL-81-83, ARGONNE NATIONAL LAB.
-C 7. VARGA, R.S. (1965), MINIMAL GERSCHGORIN SETS, PACIFIC J. MATH. 15,
-C PP. 719-729.
-C
-C *** GENERAL ***
-C
-C CODED BY DAVID M. GAY.
-C THIS SUBROUTINE WAS WRITTEN IN CONNECTION WITH RESEARCH
-C SUPPORTED BY THE NATIONAL SCIENCE FOUNDATION UNDER GRANTS
-C MCS-7600324, DCR75-10143, 76-14311DSS, MCS76-11989, AND
-C MCS-7906671.
-C
-C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
-C
-C *** LOCAL VARIABLES ***
-C
- LOGICAL RESTRT
- INTEGER DGGDMX, DIAG, DIAG0, DSTSAV, EMAX, EMIN, I, IM1, INC, IRC,
- 1 J, K, KALIM, KAMIN, K1, LK0, PHIPIN, Q, Q0, UK0, X
- DOUBLE PRECISION ALPHAK, AKI, AKK, DELTA, DST, EPS, GTSTA, LK,
- 1 OLDPHI, PHI, PHIMAX, PHIMIN, PSIFAC, RAD, RADSQ,
- 2 ROOT, SI, SK, SW, T, TWOPSI, T1, T2, UK, WI
-C
-C *** CONSTANTS ***
- DOUBLE PRECISION BIG, DGXFAC, EPSFAC, FOUR, HALF, KAPPA, NEGONE,
- 1 ONE, P001, SIX, THREE, TWO, ZERO
-C
-C *** INTRINSIC FUNCTIONS ***
-C/+
- DOUBLE PRECISION DSQRT
-C/
-C *** EXTERNAL FUNCTIONS AND SUBROUTINES ***
-C
- DOUBLE PRECISION DD7TPR, DL7SVN, DR7MDC, DV2NRM
- EXTERNAL DD7TPR, DL7ITV, DL7IVM,DL7SRT, DL7SVN, DR7MDC, DV2NRM
-C
-C *** SUBSCRIPTS FOR V ***
-C
- INTEGER DGNORM, DSTNRM, DST0, EPSLON, GTSTEP, STPPAR, NREDUC,
- 1 PHMNFC, PHMXFC, PREDUC, RADIUS, RAD0
-C/6
-C DATA DGNORM/1/, DSTNRM/2/, DST0/3/, EPSLON/19/, GTSTEP/4/,
-C 1 NREDUC/6/, PHMNFC/20/, PHMXFC/21/, PREDUC/7/, RADIUS/8/,
-C 2 RAD0/9/, STPPAR/5/
-C/7
- PARAMETER (DGNORM=1, DSTNRM=2, DST0=3, EPSLON=19, GTSTEP=4,
- 1 NREDUC=6, PHMNFC=20, PHMXFC=21, PREDUC=7, RADIUS=8,
- 2 RAD0=9, STPPAR=5)
-C/
-C
-C/6
-C DATA EPSFAC/50.0D+0/, FOUR/4.0D+0/, HALF/0.5D+0/,
-C 1 KAPPA/2.0D+0/, NEGONE/-1.0D+0/, ONE/1.0D+0/, P001/1.0D-3/,
-C 2 SIX/6.0D+0/, THREE/3.0D+0/, TWO/2.0D+0/, ZERO/0.0D+0/
-C/7
- PARAMETER (EPSFAC=50.0D+0, FOUR=4.0D+0, HALF=0.5D+0,
- 1 KAPPA=2.0D+0, NEGONE=-1.0D+0, ONE=1.0D+0, P001=1.0D-3,
- 2 SIX=6.0D+0, THREE=3.0D+0, TWO=2.0D+0, ZERO=0.0D+0)
- SAVE DGXFAC
-C/
- DATA BIG/0.D+0/, DGXFAC/0.D+0/
-C
-C *** BODY ***
-C
- IF (BIG .LE. ZERO) BIG = DR7MDC(6)
-C
-C *** STORE LARGEST ABS. ENTRY IN (D**-1)*H*(D**-1) AT W(DGGDMX).
- DGGDMX = P + 1
-C *** STORE GERSCHGORIN OVER- AND UNDERESTIMATES OF THE LARGEST
-C *** AND SMALLEST EIGENVALUES OF (D**-1)*H*(D**-1) AT W(EMAX)
-C *** AND W(EMIN) RESPECTIVELY.
- EMAX = DGGDMX + 1
- EMIN = EMAX + 1
-C *** FOR _USE_ IN RECOMPUTING STEP, THE FINAL VALUES OF LK, UK, DST,
-C *** AND THE INVERSE DERIVATIVE OF MORE*S PHI AT 0 (FOR POS. DEF.
-C *** H) ARE STORED IN W(LK0), W(UK0), W(DSTSAV), AND W(PHIPIN)
-C *** RESPECTIVELY.
- LK0 = EMIN + 1
- PHIPIN = LK0 + 1
- UK0 = PHIPIN + 1
- DSTSAV = UK0 + 1
-C *** STORE DIAG OF (D**-1)*H*(D**-1) IN W(DIAG),...,W(DIAG0+P).
- DIAG0 = DSTSAV
- DIAG = DIAG0 + 1
-C *** STORE -D*STEP IN W(Q),...,W(Q0+P).
- Q0 = DIAG0 + P
- Q = Q0 + 1
-C *** ALLOCATE STORAGE FOR SCRATCH VECTOR X ***
- X = Q + P
- RAD = V(RADIUS)
- RADSQ = RAD**2
-C *** PHITOL = MAX. ERROR ALLOWED IN DST = V(DSTNRM) = 2-NORM OF
-C *** D*STEP.
- PHIMAX = V(PHMXFC) * RAD
- PHIMIN = V(PHMNFC) * RAD
- PSIFAC = BIG
- T1 = TWO * V(EPSLON) / (THREE * (FOUR * (V(PHMNFC) + ONE) *
- 1 (KAPPA + ONE) + KAPPA + TWO) * RAD)
- IF (T1 .LT. BIG*DMIN1(RAD,ONE)) PSIFAC = T1 / RAD
-C *** OLDPHI IS USED TO DETECT LIMITS OF NUMERICAL ACCURACY. IF
-C *** WE RECOMPUTE STEP AND IT DOES NOT CHANGE, THEN WE ACCEPT IT.
- OLDPHI = ZERO
- EPS = V(EPSLON)
- IRC = 0
- RESTRT = .FALSE.
- KALIM = KA + 50
-C
-C *** START OR RESTART, DEPENDING ON KA ***
-C
- IF (KA .GE. 0) GO TO 290
-C
-C *** FRESH START ***
-C
- K = 0
- UK = NEGONE
- KA = 0
- KALIM = 50
- V(DGNORM) = DV2NRM(P, DIG)
- V(NREDUC) = ZERO
- V(DST0) = ZERO
- KAMIN = 3
- IF (V(DGNORM) .EQ. ZERO) KAMIN = 0
-C
-C *** STORE DIAG(DIHDI) IN W(DIAG0+1),...,W(DIAG0+P) ***
-C
- J = 0
- DO 10 I = 1, P
- J = J + I
- K1 = DIAG0 + I
- W(K1) = DIHDI(J)
- 10 CONTINUE
-C
-C *** DETERMINE W(DGGDMX), THE LARGEST ELEMENT OF DIHDI ***
-C
- T1 = ZERO
- J = P * (P + 1) / 2
- DO 20 I = 1, J
- T = DABS(DIHDI(I))
- IF (T1 .LT. T) T1 = T
- 20 CONTINUE
- W(DGGDMX) = T1
-C
-C *** TRY ALPHA = 0 ***
-C
- 30 CALL DL7SRT(1, P, L, DIHDI, IRC)
- IF (IRC .EQ. 0) GO TO 50
-C *** INDEF. H -- UNDERESTIMATE SMALLEST EIGENVALUE, _USE_ THIS
-C *** ESTIMATE TO INITIALIZE LOWER BOUND LK ON ALPHA.
- J = IRC*(IRC+1)/2
- T = L(J)
- L(J) = ONE
- DO 40 I = 1, IRC
- 40 W(I) = ZERO
- W(IRC) = ONE
- CALL DL7ITV(IRC, W, L, W)
- T1 = DV2NRM(IRC, W)
- LK = -T / T1 / T1
- V(DST0) = -LK
- IF (RESTRT) GO TO 210
- GO TO 70
-C
-C *** POSITIVE DEFINITE H -- COMPUTE UNMODIFIED NEWTON STEP. ***
- 50 LK = ZERO
- T = DL7SVN(P, L, W(Q), W(Q))
- IF (T .GE. ONE) GO TO 60
- IF (V(DGNORM) .GE. T*T*BIG) GO TO 70
- 60 CALL DL7IVM(P, W(Q), L, DIG)
- GTSTA = DD7TPR(P, W(Q), W(Q))
- V(NREDUC) = HALF * GTSTA
- CALL DL7ITV(P, W(Q), L, W(Q))
- DST = DV2NRM(P, W(Q))
- V(DST0) = DST
- PHI = DST - RAD
- IF (PHI .LE. PHIMAX) GO TO 260
- IF (RESTRT) GO TO 210
-C
-C *** PREPARE TO COMPUTE GERSCHGORIN ESTIMATES OF LARGEST (AND
-C *** SMALLEST) EIGENVALUES. ***
-C
- 70 K = 0
- DO 100 I = 1, P
- WI = ZERO
- IF (I .EQ. 1) GO TO 90
- IM1 = I - 1
- DO 80 J = 1, IM1
- K = K + 1
- T = DABS(DIHDI(K))
- WI = WI + T
- W(J) = W(J) + T
- 80 CONTINUE
- 90 W(I) = WI
- K = K + 1
- 100 CONTINUE
-C
-C *** (UNDER-)ESTIMATE SMALLEST EIGENVALUE OF (D**-1)*H*(D**-1) ***
-C
- K = 1
- T1 = W(DIAG) - W(1)
- IF (P .LE. 1) GO TO 120
- DO 110 I = 2, P
- J = DIAG0 + I
- T = W(J) - W(I)
- IF (T .GE. T1) GO TO 110
- T1 = T
- K = I
- 110 CONTINUE
-C
- 120 SK = W(K)
- J = DIAG0 + K
- AKK = W(J)
- K1 = K*(K-1)/2 + 1
- INC = 1
- T = ZERO
- DO 150 I = 1, P
- IF (I .EQ. K) GO TO 130
- AKI = DABS(DIHDI(K1))
- SI = W(I)
- J = DIAG0 + I
- T1 = HALF * (AKK - W(J) + SI - AKI)
- T1 = T1 + DSQRT(T1*T1 + SK*AKI)
- IF (T .LT. T1) T = T1
- IF (I .LT. K) GO TO 140
- 130 INC = I
- 140 K1 = K1 + INC
- 150 CONTINUE
-C
- W(EMIN) = AKK - T
- UK = V(DGNORM)/RAD - W(EMIN)
- IF (V(DGNORM) .EQ. ZERO) UK = UK + P001 + P001*UK
- IF (UK .LE. ZERO) UK = P001
-C
-C *** COMPUTE GERSCHGORIN (OVER-)ESTIMATE OF LARGEST EIGENVALUE ***
-C
- K = 1
- T1 = W(DIAG) + W(1)
- IF (P .LE. 1) GO TO 170
- DO 160 I = 2, P
- J = DIAG0 + I
- T = W(J) + W(I)
- IF (T .LE. T1) GO TO 160
- T1 = T
- K = I
- 160 CONTINUE
-C
- 170 SK = W(K)
- J = DIAG0 + K
- AKK = W(J)
- K1 = K*(K-1)/2 + 1
- INC = 1
- T = ZERO
- DO 200 I = 1, P
- IF (I .EQ. K) GO TO 180
- AKI = DABS(DIHDI(K1))
- SI = W(I)
- J = DIAG0 + I
- T1 = HALF * (W(J) + SI - AKI - AKK)
- T1 = T1 + DSQRT(T1*T1 + SK*AKI)
- IF (T .LT. T1) T = T1
- IF (I .LT. K) GO TO 190
- 180 INC = I
- 190 K1 = K1 + INC
- 200 CONTINUE
-C
- W(EMAX) = AKK + T
- LK = DMAX1(LK, V(DGNORM)/RAD - W(EMAX))
-C
-C *** ALPHAK = CURRENT VALUE OF ALPHA (SEE ALG. NOTES ABOVE). WE
-C *** _USE_ MORE*S SCHEME FOR INITIALIZING IT.
- ALPHAK = DABS(V(STPPAR)) * V(RAD0)/RAD
- ALPHAK = DMIN1(UK, DMAX1(ALPHAK, LK))
-C
- IF (IRC .NE. 0) GO TO 210
-C
-C *** COMPUTE L0 FOR POSITIVE DEFINITE H ***
-C
- CALL DL7IVM(P, W, L, W(Q))
- T = DV2NRM(P, W)
- W(PHIPIN) = RAD / T / T
- LK = DMAX1(LK, PHI*W(PHIPIN))
-C
-C *** SAFEGUARD ALPHAK AND ADD ALPHAK*I TO (D**-1)*H*(D**-1) ***
-C
- 210 KA = KA + 1
- IF (-V(DST0) .GE. ALPHAK .OR. ALPHAK .LT. LK .OR. ALPHAK .GE. UK)
- 1 ALPHAK = UK * DMAX1(P001, DSQRT(LK/UK))
- IF (ALPHAK .LE. ZERO) ALPHAK = HALF * UK
- IF (ALPHAK .LE. ZERO) ALPHAK = UK
- K = 0
- DO 220 I = 1, P
- K = K + I
- J = DIAG0 + I
- DIHDI(K) = W(J) + ALPHAK
- 220 CONTINUE
-C
-C *** TRY COMPUTING CHOLESKY DECOMPOSITION ***
-C
- CALL DL7SRT(1, P, L, DIHDI, IRC)
- IF (IRC .EQ. 0) GO TO 240
-C
-C *** (D**-1)*H*(D**-1) + ALPHAK*I IS INDEFINITE -- OVERESTIMATE
-C *** SMALLEST EIGENVALUE FOR _USE_ IN UPDATING LK ***
-C
- J = (IRC*(IRC+1))/2
- T = L(J)
- L(J) = ONE
- DO 230 I = 1, IRC
- 230 W(I) = ZERO
- W(IRC) = ONE
- CALL DL7ITV(IRC, W, L, W)
- T1 = DV2NRM(IRC, W)
- LK = ALPHAK - T/T1/T1
- V(DST0) = -LK
- IF (UK .LT. LK) UK = LK
- IF (ALPHAK .LT. LK) GO TO 210
-C
-C *** NASTY CASE -- EXACT GERSCHGORIN BOUNDS. FUDGE LK, UK...
-C
- T = P001 * ALPHAK
- IF (T .LE. ZERO) T = P001
- LK = ALPHAK + T
- IF (UK .LE. LK) UK = LK + T
- GO TO 210
-C
-C *** ALPHAK MAKES (D**-1)*H*(D**-1) POSITIVE DEFINITE.
-C *** COMPUTE Q = -D*STEP, CHECK FOR CONVERGENCE. ***
-C
- 240 CALL DL7IVM(P, W(Q), L, DIG)
- GTSTA = DD7TPR(P, W(Q), W(Q))
- CALL DL7ITV(P, W(Q), L, W(Q))
- DST = DV2NRM(P, W(Q))
- PHI = DST - RAD
- IF (PHI .LE. PHIMAX .AND. PHI .GE. PHIMIN) GO TO 270
- IF (PHI .EQ. OLDPHI) GO TO 270
- OLDPHI = PHI
- IF (PHI .LT. ZERO) GO TO 330
-C
-C *** UNACCEPTABLE ALPHAK -- UPDATE LK, UK, ALPHAK ***
-C
- 250 IF (KA .GE. KALIM) GO TO 270
-C *** THE FOLLOWING DMIN1 IS NECESSARY BECAUSE OF RESTARTS ***
- IF (PHI .LT. ZERO) UK = DMIN1(UK, ALPHAK)
-C *** KAMIN = 0 ONLY IFF THE GRADIENT VANISHES ***
- IF (KAMIN .EQ. 0) GO TO 210
- CALL DL7IVM(P, W, L, W(Q))
-C *** THE FOLLOWING, COMMENTED CALCULATION OF ALPHAK IS SOMETIMES
-C *** SAFER BUT WORSE IN PERFORMANCE...
-C T1 = DST / DV2NRM(P, W)
-C ALPHAK = ALPHAK + T1 * (PHI/RAD) * T1
- T1 = DV2NRM(P, W)
- ALPHAK = ALPHAK + (PHI/T1) * (DST/T1) * (DST/RAD)
- LK = DMAX1(LK, ALPHAK)
- ALPHAK = LK
- GO TO 210
-C
-C *** ACCEPTABLE STEP ON FIRST TRY ***
-C
- 260 ALPHAK = ZERO
-C
-C *** SUCCESSFUL STEP IN GENERAL. COMPUTE STEP = -(D**-1)*Q ***
-C
- 270 DO 280 I = 1, P
- J = Q0 + I
- STEP(I) = -W(J)/D(I)
- 280 CONTINUE
- V(GTSTEP) = -GTSTA
- V(PREDUC) = HALF * (DABS(ALPHAK)*DST*DST + GTSTA)
- GO TO 410
-C
-C
-C *** RESTART WITH NEW RADIUS ***
-C
- 290 IF (V(DST0) .LE. ZERO .OR. V(DST0) - RAD .GT. PHIMAX) GO TO 310
-C
-C *** PREPARE TO RETURN NEWTON STEP ***
-C
- RESTRT = .TRUE.
- KA = KA + 1
- K = 0
- DO 300 I = 1, P
- K = K + I
- J = DIAG0 + I
- DIHDI(K) = W(J)
- 300 CONTINUE
- UK = NEGONE
- GO TO 30
-C
- 310 KAMIN = KA + 3
- IF (V(DGNORM) .EQ. ZERO) KAMIN = 0
- IF (KA .EQ. 0) GO TO 50
-C
- DST = W(DSTSAV)
- ALPHAK = DABS(V(STPPAR))
- PHI = DST - RAD
- T = V(DGNORM)/RAD
- UK = T - W(EMIN)
- IF (V(DGNORM) .EQ. ZERO) UK = UK + P001 + P001*UK
- IF (UK .LE. ZERO) UK = P001
- IF (RAD .GT. V(RAD0)) GO TO 320
-C
-C *** SMALLER RADIUS ***
- LK = ZERO
- IF (ALPHAK .GT. ZERO) LK = W(LK0)
- LK = DMAX1(LK, T - W(EMAX))
- IF (V(DST0) .GT. ZERO) LK = DMAX1(LK, (V(DST0)-RAD)*W(PHIPIN))
- GO TO 250
-C
-C *** BIGGER RADIUS ***
- 320 IF (ALPHAK .GT. ZERO) UK = DMIN1(UK, W(UK0))
- LK = DMAX1(ZERO, -V(DST0), T - W(EMAX))
- IF (V(DST0) .GT. ZERO) LK = DMAX1(LK, (V(DST0)-RAD)*W(PHIPIN))
- GO TO 250
-C
-C *** DECIDE WHETHER TO CHECK FOR SPECIAL CASE... IN PRACTICE (FROM
-C *** THE STANDPOINT OF THE CALLING OPTIMIZATION CODE) IT SEEMS BEST
-C *** NOT TO CHECK UNTIL A FEW ITERATIONS HAVE FAILED -- HENCE THE
-C *** TEST ON KAMIN BELOW.
-C
- 330 DELTA = ALPHAK + DMIN1(ZERO, V(DST0))
- TWOPSI = ALPHAK*DST*DST + GTSTA
- IF (KA .GE. KAMIN) GO TO 340
-C *** IF THE TEST IN REF. 2 IS SATISFIED, FALL THROUGH TO HANDLE
-C *** THE SPECIAL CASE (AS SOON AS THE MORE-SORENSEN TEST DETECTS
-C *** IT).
- IF (PSIFAC .GE. BIG) GO TO 340
- IF (DELTA .GE. PSIFAC*TWOPSI) GO TO 370
-C
-C *** CHECK FOR THE SPECIAL CASE OF H + ALPHA*D**2 (NEARLY)
-C *** SINGULAR. _USE_ ONE STEP OF INVERSE POWER METHOD WITH START
-C *** FROM DL7SVN TO OBTAIN APPROXIMATE EIGENVECTOR CORRESPONDING
-C *** TO SMALLEST EIGENVALUE OF (D**-1)*H*(D**-1). DL7SVN RETURNS
-C *** X AND W WITH L*W = X.
-C
- 340 T = DL7SVN(P, L, W(X), W)
-C
-C *** NORMALIZE W ***
- DO 350 I = 1, P
- 350 W(I) = T*W(I)
-C *** COMPLETE CURRENT INV. POWER ITER. -- REPLACE W BY (L**-T)*W.
- CALL DL7ITV(P, W, L, W)
- T2 = ONE/DV2NRM(P, W)
- DO 360 I = 1, P
- 360 W(I) = T2*W(I)
- T = T2 * T
-C
-C *** NOW W IS THE DESIRED APPROXIMATE (UNIT) EIGENVECTOR AND
-C *** T*X = ((D**-1)*H*(D**-1) + ALPHAK*I)*W.
-C
- SW = DD7TPR(P, W(Q), W)
- T1 = (RAD + DST) * (RAD - DST)
- ROOT = DSQRT(SW*SW + T1)
- IF (SW .LT. ZERO) ROOT = -ROOT
- SI = T1 / (SW + ROOT)
-C
-C *** THE ACTUAL TEST FOR THE SPECIAL CASE...
-C
- IF ((T2*SI)**2 .LE. EPS*(DST**2 + ALPHAK*RADSQ)) GO TO 380
-C
-C *** UPDATE UPPER BOUND ON SMALLEST EIGENVALUE (WHEN NOT POSITIVE)
-C *** (AS RECOMMENDED BY MORE AND SORENSEN) AND CONTINUE...
-C
- IF (V(DST0) .LE. ZERO) V(DST0) = DMIN1(V(DST0), T2**2 - ALPHAK)
- LK = DMAX1(LK, -V(DST0))
-C
-C *** CHECK WHETHER WE CAN HOPE TO DETECT THE SPECIAL CASE IN
-C *** THE AVAILABLE ARITHMETIC. ACCEPT STEP AS IT IS IF NOT.
-C
-C *** IF NOT YET AVAILABLE, OBTAIN MACHINE DEPENDENT VALUE DGXFAC.
- 370 IF (DGXFAC .EQ. ZERO) DGXFAC = EPSFAC * DR7MDC(3)
-C
- IF (DELTA .GT. DGXFAC*W(DGGDMX)) GO TO 250
- GO TO 270
-C
-C *** SPECIAL CASE DETECTED... NEGATE ALPHAK TO INDICATE SPECIAL CASE
-C
- 380 ALPHAK = -ALPHAK
- V(PREDUC) = HALF * TWOPSI
-C
-C *** ACCEPT CURRENT STEP IF ADDING SI*W WOULD LEAD TO A
-C *** FURTHER RELATIVE REDUCTION IN PSI OF LESS THAN V(EPSLON)/3.
-C
- T1 = ZERO
- T = SI*(ALPHAK*SW - HALF*SI*(ALPHAK + T*DD7TPR(P,W(X),W)))
- IF (T .LT. EPS*TWOPSI/SIX) GO TO 390
- V(PREDUC) = V(PREDUC) + T
- DST = RAD
- T1 = -SI
- 390 DO 400 I = 1, P
- J = Q0 + I
- W(J) = T1*W(I) - W(J)
- STEP(I) = W(J) / D(I)
- 400 CONTINUE
- V(GTSTEP) = DD7TPR(P, DIG, W(Q))
-C
-C *** SAVE VALUES FOR _USE_ IN A POSSIBLE RESTART ***
-C
- 410 V(DSTNRM) = DST
- V(STPPAR) = ALPHAK
- W(LK0) = LK
- W(UK0) = UK
- V(RAD0) = RAD
- W(DSTSAV) = DST
-C
-C *** RESTORE DIAGONAL OF DIHDI ***
-C
- J = 0
- DO 420 I = 1, P
- J = J + I
- K = DIAG0 + I
- DIHDI(J) = W(K)
- 420 CONTINUE
-C
- 999 RETURN
-C
-C *** LAST CARD OF DG7QTS FOLLOWS ***
- END
diff --git a/CEP/PyBDSM/src/port3/dh2rfa.f b/CEP/PyBDSM/src/port3/dh2rfa.f
deleted file mode 100644
index 5f499c998879903e74bd366998f460204924df60..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/dh2rfa.f
+++ /dev/null
@@ -1,17 +0,0 @@
- SUBROUTINE DH2RFA(N, A, B, X, Y, Z)
-C
-C *** APPLY 2X2 HOUSEHOLDER REFLECTION DETERMINED BY X, Y, Z TO
-C *** N-VECTORS A, B ***
-C
- INTEGER N
- DOUBLE PRECISION A(N), B(N), X, Y, Z
- INTEGER I
- DOUBLE PRECISION T
- DO 10 I = 1, N
- T = A(I)*X + B(I)*Y
- A(I) = A(I) + T
- B(I) = B(I) + T*Z
- 10 CONTINUE
- 999 RETURN
-C *** LAST LINE OF DH2RFA FOLLOWS ***
- END
diff --git a/CEP/PyBDSM/src/port3/dh2rfg.f b/CEP/PyBDSM/src/port3/dh2rfg.f
deleted file mode 100644
index 73a1f4f2b64c8ff73c848229a254ff3cd2a93605..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/dh2rfg.f
+++ /dev/null
@@ -1,37 +0,0 @@
- DOUBLE PRECISION FUNCTION DH2RFG(A, B, X, Y, Z)
-C
-C *** DETERMINE X, Y, Z SO I + (1,Z)**T * (X,Y) IS A 2X2
-C *** HOUSEHOLDER REFLECTION SENDING (A,B)**T INTO (C,0)**T,
-C *** WHERE C = -SIGN(A)*SQRT(A**2 + B**2) IS THE VALUE DH2RFG
-C *** RETURNS.
-C
- DOUBLE PRECISION A, B, X, Y, Z
-C
- DOUBLE PRECISION A1, B1, C, T
-C/+
- DOUBLE PRECISION DSQRT
-C/
- DOUBLE PRECISION ZERO
- DATA ZERO/0.D+0/
-C
-C *** BODY ***
-C
- IF (B .NE. ZERO) GO TO 10
- X = ZERO
- Y = ZERO
- Z = ZERO
- DH2RFG = A
- GO TO 999
- 10 T = DABS(A) + DABS(B)
- A1 = A / T
- B1 = B / T
- C = DSQRT(A1**2 + B1**2)
- IF (A1 .GT. ZERO) C = -C
- A1 = A1 - C
- Z = B1 / A1
- X = A1 / C
- Y = B1 / C
- DH2RFG = T * C
- 999 RETURN
-C *** LAST LINE OF DH2RFG FOLLOWS ***
- END
diff --git a/CEP/PyBDSM/src/port3/dhqr2.f b/CEP/PyBDSM/src/port3/dhqr2.f
deleted file mode 100644
index fa9bd680cfd61801f4b8666ff673822973c6e5c6..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/dhqr2.f
+++ /dev/null
@@ -1,476 +0,0 @@
- SUBROUTINE DHQR2(NM,N,LOW,IGH,H,WR,WI,Z,IERR)
-C
- INTEGER I,J,K,L,M,N,EN,II,JJ,LL,MM,NA,NM,NN,
- X IGH,ITN,ITS,LOW,MP2,ENM2,IERR
- DOUBLE PRECISION H(NM,N),WR(N),WI(N),Z(NM,N)
-C
- DOUBLE PRECISION CMPLXN(2),CMPLXD(2),CMPLXC(2)
-C THE ABOVE ARE TO BE USED WITH THE PORT CDDIV
-C ROUTINE NEEDED HERE FOR DOUBLE COMPLEX IN
-C PLACE OF THE RATIOS USED IN THE ORIGINAL HQR2.
-C THEY ARE, RESPECTIVELY, NUMERATOR, DENOMINATOR, AND COMPLEX ANSWER.
-C
- DOUBLE PRECISION P,Q,R,S,T,W,X,Y,RA,SA,VI,VR,ZZ,NORM,TST1,TST2
- LOGICAL NOTLAS
-C
-C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE HQR2,
-C NUM. MATH. 16, 181-204(1970) BY PETERS AND WILKINSON.
-C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 372-395(1971).
-C
-C THIS SUBROUTINE FINDS THE EIGENVALUES AND EIGENVECTORS
-C OF A REAL UPPER HESSENBERG MATRIX BY THE QR METHOD. THE
-C EIGENVECTORS OF A REAL GENERAL MATRIX CAN ALSO BE FOUND
-C IF ELMHES AND ELTRAN OR ORTHES AND ORTRAN HAVE
-C BEEN USED TO REDUCE THIS GENERAL MATRIX TO HESSENBERG FORM
-C AND TO ACCUMULATE THE SIMILARITY TRANSFORMATIONS.
-C
-C ON INPUT
-C
-C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
-C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
-C DIMENSION STATEMENT.
-C
-C N IS THE ORDER OF THE MATRIX.
-C
-C LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING
-C SUBROUTINE BALANC. IF BALANC HAS NOT BEEN USED,
-C SET LOW=1, IGH=N.
-C
-C H CONTAINS THE UPPER HESSENBERG MATRIX.
-C
-C Z CONTAINS THE TRANSFORMATION MATRIX PRODUCED BY ELTRAN
-C AFTER THE REDUCTION BY ELMHES, OR BY ORTRAN AFTER THE
-C REDUCTION BY ORTHES, IF PERFORMED. IF THE EIGENVECTORS
-C OF THE HESSENBERG MATRIX ARE DESIRED, Z MUST CONTAIN THE
-C IDENTITY MATRIX.
-C
-C ON OUTPUT
-C
-C H HAS BEEN DESTROYED.
-C
-C WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS,
-C RESPECTIVELY, OF THE EIGENVALUES. THE EIGENVALUES
-C ARE UNORDERED EXCEPT THAT COMPLEX CONJUGATE PAIRS
-C OF VALUES APPEAR CONSECUTIVELY WITH THE EIGENVALUE
-C HAVING THE POSITIVE IMAGINARY PART FIRST. IF AN
-C ERROR EXIT IS MADE, THE EIGENVALUES SHOULD BE CORRECT
-C FOR INDICES IERR+1,...,N.
-C
-C Z CONTAINS THE REAL AND IMAGINARY PARTS OF THE EIGENVECTORS.
-C IF THE I-TH EIGENVALUE IS REAL, THE I-TH COLUMN OF Z
-C CONTAINS ITS EIGENVECTOR. IF THE I-TH EIGENVALUE IS COMPLEX
-C WITH POSITIVE IMAGINARY PART, THE I-TH AND (I+1)-TH
-C COLUMNS OF Z CONTAIN THE REAL AND IMAGINARY PARTS OF ITS
-C EIGENVECTOR. THE EIGENVECTORS ARE UNNORMALIZED. IF AN
-C ERROR EXIT IS MADE, NONE OF THE EIGENVECTORS HAS BEEN FOUND.
-C
-C IERR IS SET TO
-C ZERO FOR NORMAL RETURN,
-C J IF THE LIMIT OF 30*N ITERATIONS IS EXHAUSTED
-C WHILE THE J-TH EIGENVALUE IS BEING SOUGHT.
-C
-C THIS ROUTINE IS FROM EISPACK (VERSION DATED AUGUST 1983), WITH
-C NAMES CHANGED IN ACCORDANCE WITH PORT CONVENTIONS FOR DOUBLE
-C PRECISION, AND WITH PROCEDURE CDIV REPLACED BY THE PORT DOUBLE-
-C PRECISION COMPLEX DIVISION ROUTINE, CDDIV.
-C
-C ------------------------------------------------------------------
-C
- IERR = 0
- NORM = 0.0D0
- K = 1
-C .......... STORE ROOTS ISOLATED BY BALANC
-C AND COMPUTE MATRIX NORM ..........
- DO 50 I = 1, N
-C
- DO 40 J = K, N
- 40 NORM = NORM + DABS(H(I,J))
-C
- K = I
- IF (I .GE. LOW .AND. I .LE. IGH) GO TO 50
- WR(I) = H(I,I)
- WI(I) = 0.0D0
- 50 CONTINUE
-C
- EN = IGH
- T = 0.0D0
- ITN = 30*N
-C .......... SEARCH FOR NEXT EIGENVALUES ..........
- 60 IF (EN .LT. LOW) GO TO 340
- ITS = 0
- NA = EN - 1
- ENM2 = NA - 1
-C .......... LOOK FOR SINGLE SMALL SUB-DIAGONAL ELEMENT
-C FOR L=EN STEP -1 UNTIL LOW DO -- ..........
- 70 DO 80 LL = LOW, EN
- L = EN + LOW - LL
- IF (L .EQ. LOW) GO TO 100
- S = DABS(H(L-1,L-1)) + DABS(H(L,L))
- IF (S .EQ. 0.0D0) S = NORM
- TST1 = S
- TST2 = TST1 + DABS(H(L,L-1))
- IF (TST2 .EQ. TST1) GO TO 100
- 80 CONTINUE
-C .......... FORM SHIFT ..........
- 100 X = H(EN,EN)
- IF (L .EQ. EN) GO TO 270
- Y = H(NA,NA)
- W = H(EN,NA) * H(NA,EN)
- IF (L .EQ. NA) GO TO 280
- IF (ITN .EQ. 0) GO TO 1000
- IF (ITS .NE. 10 .AND. ITS .NE. 20) GO TO 130
-C .......... FORM EXCEPTIONAL SHIFT ..........
- T = T + X
-C
- DO 120 I = LOW, EN
- 120 H(I,I) = H(I,I) - X
-C
- S = DABS(H(EN,NA)) + DABS(H(NA,ENM2))
- X = 0.75D0 * S
- Y = X
- W = -0.4375D0 * S * S
- 130 ITS = ITS + 1
- ITN = ITN - 1
-C .......... LOOK FOR TWO CONSECUTIVE SMALL
-C SUB-DIAGONAL ELEMENTS.
-C FOR M=EN-2 STEP -1 UNTIL L DO -- ..........
- DO 140 MM = L, ENM2
- M = ENM2 + L - MM
- ZZ = H(M,M)
- R = X - ZZ
- S = Y - ZZ
- P = (R * S - W) / H(M+1,M) + H(M,M+1)
- Q = H(M+1,M+1) - ZZ - R - S
- R = H(M+2,M+1)
- S = DABS(P) + DABS(Q) + DABS(R)
- P = P / S
- Q = Q / S
- R = R / S
- IF (M .EQ. L) GO TO 150
- TST1 = DABS(P)*(DABS(H(M-1,M-1)) + DABS(ZZ) + DABS(H(M+1,M+1)))
- TST2 = TST1 + DABS(H(M,M-1))*(DABS(Q) + DABS(R))
- IF (TST2 .EQ. TST1) GO TO 150
- 140 CONTINUE
-C
- 150 MP2 = M + 2
-C
- DO 160 I = MP2, EN
- H(I,I-2) = 0.0D0
- IF (I .EQ. MP2) GO TO 160
- H(I,I-3) = 0.0D0
- 160 CONTINUE
-C .......... DOUBLE QR STEP INVOLVING ROWS L TO EN AND
-C COLUMNS M TO EN ..........
- DO 260 K = M, NA
- NOTLAS = K .NE. NA
- IF (K .EQ. M) GO TO 170
- P = H(K,K-1)
- Q = H(K+1,K-1)
- R = 0.0D0
- IF (NOTLAS) R = H(K+2,K-1)
- X = DABS(P) + DABS(Q) + DABS(R)
- IF (X .EQ. 0.0D0) GO TO 260
- P = P / X
- Q = Q / X
- R = R / X
- 170 S = DSIGN(DSQRT(P*P+Q*Q+R*R),P)
- IF (K .EQ. M) GO TO 180
- H(K,K-1) = -S * X
- GO TO 190
- 180 IF (L .NE. M) H(K,K-1) = -H(K,K-1)
- 190 P = P + S
- X = P / S
- Y = Q / S
- ZZ = R / S
- Q = Q / P
- R = R / P
- IF (NOTLAS) GO TO 225
-C .......... ROW MODIFICATION ..........
- DO 200 J = K, N
- P = H(K,J) + Q * H(K+1,J)
- H(K,J) = H(K,J) - P * X
- H(K+1,J) = H(K+1,J) - P * Y
- 200 CONTINUE
-C
- J = MIN0(EN,K+3)
-C .......... COLUMN MODIFICATION ..........
- DO 210 I = 1, J
- P = X * H(I,K) + Y * H(I,K+1)
- H(I,K) = H(I,K) - P
- H(I,K+1) = H(I,K+1) - P * Q
- 210 CONTINUE
-C .......... ACCUMULATE TRANSFORMATIONS ..........
- DO 220 I = LOW, IGH
- P = X * Z(I,K) + Y * Z(I,K+1)
- Z(I,K) = Z(I,K) - P
- Z(I,K+1) = Z(I,K+1) - P * Q
- 220 CONTINUE
- GO TO 255
- 225 CONTINUE
-C .......... ROW MODIFICATION ..........
- DO 230 J = K, N
- P = H(K,J) + Q * H(K+1,J) + R * H(K+2,J)
- H(K,J) = H(K,J) - P * X
- H(K+1,J) = H(K+1,J) - P * Y
- H(K+2,J) = H(K+2,J) - P * ZZ
- 230 CONTINUE
-C
- J = MIN0(EN,K+3)
-C .......... COLUMN MODIFICATION ..........
- DO 240 I = 1, J
- P = X * H(I,K) + Y * H(I,K+1) + ZZ * H(I,K+2)
- H(I,K) = H(I,K) - P
- H(I,K+1) = H(I,K+1) - P * Q
- H(I,K+2) = H(I,K+2) - P * R
- 240 CONTINUE
-C .......... ACCUMULATE TRANSFORMATIONS ..........
- DO 250 I = LOW, IGH
- P = X * Z(I,K) + Y * Z(I,K+1) + ZZ * Z(I,K+2)
- Z(I,K) = Z(I,K) - P
- Z(I,K+1) = Z(I,K+1) - P * Q
- Z(I,K+2) = Z(I,K+2) - P * R
- 250 CONTINUE
- 255 CONTINUE
-C
- 260 CONTINUE
-C
- GO TO 70
-C .......... ONE ROOT FOUND ..........
- 270 H(EN,EN) = X + T
- WR(EN) = H(EN,EN)
- WI(EN) = 0.0D0
- EN = NA
- GO TO 60
-C .......... TWO ROOTS FOUND ..........
- 280 P = (Y - X) / 2.0D0
- Q = P * P + W
- ZZ = DSQRT(DABS(Q))
- H(EN,EN) = X + T
- X = H(EN,EN)
- H(NA,NA) = Y + T
- IF (Q .LT. 0.0D0) GO TO 320
-C .......... REAL PAIR ..........
- ZZ = P + DSIGN(ZZ,P)
- WR(NA) = X + ZZ
- WR(EN) = WR(NA)
- IF (ZZ .NE. 0.0D0) WR(EN) = X - W / ZZ
- WI(NA) = 0.0D0
- WI(EN) = 0.0D0
- X = H(EN,NA)
- S = DABS(X) + DABS(ZZ)
- P = X / S
- Q = ZZ / S
- R = DSQRT(P*P+Q*Q)
- P = P / R
- Q = Q / R
-C .......... ROW MODIFICATION ..........
- DO 290 J = NA, N
- ZZ = H(NA,J)
- H(NA,J) = Q * ZZ + P * H(EN,J)
- H(EN,J) = Q * H(EN,J) - P * ZZ
- 290 CONTINUE
-C .......... COLUMN MODIFICATION ..........
- DO 300 I = 1, EN
- ZZ = H(I,NA)
- H(I,NA) = Q * ZZ + P * H(I,EN)
- H(I,EN) = Q * H(I,EN) - P * ZZ
- 300 CONTINUE
-C .......... ACCUMULATE TRANSFORMATIONS ..........
- DO 310 I = LOW, IGH
- ZZ = Z(I,NA)
- Z(I,NA) = Q * ZZ + P * Z(I,EN)
- Z(I,EN) = Q * Z(I,EN) - P * ZZ
- 310 CONTINUE
-C
- GO TO 330
-C .......... COMPLEX PAIR ..........
- 320 WR(NA) = X + P
- WR(EN) = X + P
- WI(NA) = ZZ
- WI(EN) = -ZZ
- 330 EN = ENM2
- GO TO 60
-C .......... ALL ROOTS FOUND. BACKSUBSTITUTE TO FIND
-C VECTORS OF UPPER TRIANGULAR FORM ..........
- 340 IF (NORM .EQ. 0.0D0) GO TO 1001
-C .......... FOR EN=N STEP -1 UNTIL 1 DO -- ..........
- DO 800 NN = 1, N
- EN = N + 1 - NN
- P = WR(EN)
- Q = WI(EN)
- NA = EN - 1
- IF (Q) 710, 600, 800
-C .......... REAL VECTOR ..........
- 600 M = EN
- H(EN,EN) = 1.0D0
- IF (NA .EQ. 0) GO TO 800
-C .......... FOR I=EN-1 STEP -1 UNTIL 1 DO -- ..........
- DO 700 II = 1, NA
- I = EN - II
- W = H(I,I) - P
- R = 0.0D0
-C
- DO 610 J = M, EN
- 610 R = R + H(I,J) * H(J,EN)
-C
- IF (WI(I) .GE. 0.0D0) GO TO 630
- ZZ = W
- S = R
- GO TO 700
- 630 M = I
- IF (WI(I) .NE. 0.0D0) GO TO 640
- T = W
- IF (T .NE. 0.0D0) GO TO 635
- TST1 = NORM
- T = TST1
- 632 T = 0.01D0 * T
- TST2 = NORM + T
- IF (TST2 .GT. TST1) GO TO 632
- 635 H(I,EN) = -R / T
- GO TO 680
-C .......... SOLVE REAL EQUATIONS ..........
- 640 X = H(I,I+1)
- Y = H(I+1,I)
- Q = (WR(I) - P) * (WR(I) - P) + WI(I) * WI(I)
- T = (X * S - ZZ * R) / Q
- H(I,EN) = T
- IF (DABS(X) .LE. DABS(ZZ)) GO TO 650
- H(I+1,EN) = (-R - W * T) / X
- GO TO 680
- 650 H(I+1,EN) = (-S - Y * T) / ZZ
-C
-C .......... OVERFLOW CONTROL ..........
- 680 T = DABS(H(I,EN))
- IF (T .EQ. 0.0D0) GO TO 700
- TST1 = T
- TST2 = TST1 + 1.0D0/TST1
- IF (TST2 .GT. TST1) GO TO 700
- DO 690 J = I, EN
- H(J,EN) = H(J,EN)/T
- 690 CONTINUE
-C
- 700 CONTINUE
-C .......... END REAL VECTOR ..........
- GO TO 800
-C .......... COMPLEX VECTOR ..........
- 710 M = NA
-C .......... LAST VECTOR COMPONENT CHOSEN IMAGINARY SO THAT
-C EIGENVECTOR MATRIX IS TRIANGULAR ..........
- IF (DABS(H(EN,NA)) .LE. DABS(H(NA,EN))) GO TO 720
- H(NA,NA) = Q / H(EN,NA)
- H(NA,EN) = -(H(EN,EN) - P) / H(EN,NA)
- GO TO 730
- 720 CMPLXN(1) = 0.D0
- CMPLXN(2) = -H(NA,EN)
- CMPLXD(1) = H(NA,NA)-P
- CMPLXD(2) = Q
- CALL CDDIV(CMPLXN,CMPLXD,CMPLXC)
- H(NA,NA) = CMPLXC(1)
- H(NA,EN) = CMPLXC(2)
- 730 H(EN,NA) = 0.0D0
- H(EN,EN) = 1.0D0
- ENM2 = NA - 1
- IF (ENM2 .EQ. 0) GO TO 800
-C .......... FOR I=EN-2 STEP -1 UNTIL 1 DO -- ..........
- DO 795 II = 1, ENM2
- I = NA - II
- W = H(I,I) - P
- RA = 0.0D0
- SA = 0.0D0
-C
- DO 760 J = M, EN
- RA = RA + H(I,J) * H(J,NA)
- SA = SA + H(I,J) * H(J,EN)
- 760 CONTINUE
-C
- IF (WI(I) .GE. 0.0D0) GO TO 770
- ZZ = W
- R = RA
- S = SA
- GO TO 795
- 770 M = I
- IF (WI(I) .NE. 0.0D0) GO TO 780
- CMPLXN(1) = -RA
- CMPLXN(2) = -SA
- CMPLXD(1) = W
- CMPLXD(2) = Q
- CALL CDDIV(CMPLXN,CMPLXD,CMPLXC)
- H(I,NA) = CMPLXC(1)
- H(I,EN) = CMPLXC(2)
- GO TO 790
-C .......... SOLVE COMPLEX EQUATIONS ..........
- 780 X = H(I,I+1)
- Y = H(I+1,I)
- VR = (WR(I) - P) * (WR(I) - P) + WI(I) * WI(I) - Q * Q
- VI = (WR(I) - P) * 2.0D0 * Q
- IF (VR .NE. 0.0D0 .OR. VI .NE. 0.0D0) GO TO 784
- TST1 = NORM * (DABS(W) + DABS(Q) + DABS(X)
- X + DABS(Y) + DABS(ZZ))
- VR = TST1
- 783 VR = 0.01D0 * VR
- TST2 = TST1 + VR
- IF (TST2 .GT. TST1) GO TO 783
- 784 CMPLXN(1) = X*R-ZZ*RA+Q*SA
- CMPLXN(2) = X*S-ZZ*SA-Q*RA
- CMPLXD(1) = VR
- CMPLXD(2) = VI
- CALL CDDIV(CMPLXN,CMPLXD,CMPLXC)
- H(I,NA) = CMPLXC(1)
- H(I,EN) = CMPLXC(2)
- IF (DABS(X) .LE. DABS(ZZ) + DABS(Q)) GO TO 785
- H(I+1,NA) = (-RA - W * H(I,NA) + Q * H(I,EN)) / X
- H(I+1,EN) = (-SA - W * H(I,EN) - Q * H(I,NA)) / X
- GO TO 790
- 785 CMPLXN(1) = -R-Y*H(I,NA)
- CMPLXN(2) = -S-Y*H(I,EN)
- CMPLXD(1) = ZZ
- CMPLXD(2) = Q
- CALL CDDIV(CMPLXN,CMPLXD,CMPLXC)
- H(I+1,NA) = CMPLXC(1)
- H(I+1,EN) = CMPLXC(2)
-C
-C .......... OVERFLOW CONTROL ..........
- 790 T = DMAX1(DABS(H(I,NA)), DABS(H(I,EN)))
- IF (T .EQ. 0.0D0) GO TO 795
- TST1 = T
- TST2 = TST1 + 1.0D0/TST1
- IF (TST2 .GT. TST1) GO TO 795
- DO 792 J = I, EN
- H(J,NA) = H(J,NA)/T
- H(J,EN) = H(J,EN)/T
- 792 CONTINUE
-C
- 795 CONTINUE
-C .......... END COMPLEX VECTOR ..........
- 800 CONTINUE
-C .......... END BACK SUBSTITUTION.
-C VECTORS OF ISOLATED ROOTS ..........
- DO 840 I = 1, N
- IF (I .GE. LOW .AND. I .LE. IGH) GO TO 840
-C
- DO 820 J = I, N
- 820 Z(I,J) = H(I,J)
-C
- 840 CONTINUE
-C .......... MULTIPLY BY TRANSFORMATION MATRIX TO GIVE
-C VECTORS OF ORIGINAL FULL MATRIX.
-C FOR J=N STEP -1 UNTIL LOW DO -- ..........
- DO 880 JJ = LOW, N
- J = N + LOW - JJ
- M = MIN0(J,IGH)
-C
- DO 880 I = LOW, IGH
- ZZ = 0.0D0
-C
- DO 860 K = LOW, M
- 860 ZZ = ZZ + Z(I,K) * H(K,J)
-C
- Z(I,J) = ZZ
- 880 CONTINUE
-C
- GO TO 1001
-C .......... SET ERROR -- ALL EIGENVALUES HAVE NOT
-C CONVERGED AFTER 30*N ITERATIONS ..........
- 1000 IERR = EN
- 1001 RETURN
- END
diff --git a/CEP/PyBDSM/src/port3/ditsum.f b/CEP/PyBDSM/src/port3/ditsum.f
deleted file mode 100644
index 18ce0fa271625815f527c6804c8461b86ee730c1..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ditsum.f
+++ /dev/null
@@ -1,251 +0,0 @@
- SUBROUTINE DITSUM(D, G, IV, LIV, LV, P, V, X)
-C
-C *** PRINT ITERATION SUMMARY FOR ***SOL (VERSION 2.3) ***
-C
-C *** PARAMETER DECLARATIONS ***
-C
- INTEGER LIV, LV, P
- INTEGER IV(LIV)
- DOUBLE PRECISION D(P), G(P), V(LV), X(P)
-C
-C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
-C
-C *** LOCAL VARIABLES ***
-C
- INTEGER ALG, I, IV1, M, NF, NG, OL, PU
-C/6S
-C REAL MODEL1(6), MODEL2(6)
-C/7S
- CHARACTER*4 MODEL1(6), MODEL2(6)
-C/
- DOUBLE PRECISION NRELDF, OLDF, PRELDF, RELDF, ZERO
-C
-C *** NO EXTERNAL FUNCTIONS OR SUBROUTINES ***
-C
-C *** SUBSCRIPTS FOR IV AND V ***
-C
- INTEGER ALGSAV, DSTNRM, F, FDIF, F0, NEEDHD, NFCALL, NFCOV, NGCOV,
- 1 NGCALL, NITER, NREDUC, OUTLEV, PREDUC, PRNTIT, PRUNIT,
- 2 RELDX, SOLPRT, STATPR, STPPAR, SUSED, X0PRT
-C
-C *** IV SUBSCRIPT VALUES ***
-C
-C/6
-C DATA ALGSAV/51/, NEEDHD/36/, NFCALL/6/, NFCOV/52/, NGCALL/30/,
-C 1 NGCOV/53/, NITER/31/, OUTLEV/19/, PRNTIT/39/, PRUNIT/21/,
-C 2 SOLPRT/22/, STATPR/23/, SUSED/64/, X0PRT/24/
-C/7
- PARAMETER (ALGSAV=51, NEEDHD=36, NFCALL=6, NFCOV=52, NGCALL=30,
- 1 NGCOV=53, NITER=31, OUTLEV=19, PRNTIT=39, PRUNIT=21,
- 2 SOLPRT=22, STATPR=23, SUSED=64, X0PRT=24)
-C/
-C
-C *** V SUBSCRIPT VALUES ***
-C
-C/6
-C DATA DSTNRM/2/, F/10/, F0/13/, FDIF/11/, NREDUC/6/, PREDUC/7/,
-C 1 RELDX/17/, STPPAR/5/
-C/7
- PARAMETER (DSTNRM=2, F=10, F0=13, FDIF=11, NREDUC=6, PREDUC=7,
- 1 RELDX=17, STPPAR=5)
-C/
-C
-C/6
-C DATA ZERO/0.D+0/
-C/7
- PARAMETER (ZERO=0.D+0)
-C/
-C/6S
-C DATA MODEL1(1)/4H /, MODEL1(2)/4H /, MODEL1(3)/4H /,
-C 1 MODEL1(4)/4H /, MODEL1(5)/4H G /, MODEL1(6)/4H S /,
-C 2 MODEL2(1)/4H G /, MODEL2(2)/4H S /, MODEL2(3)/4HG-S /,
-C 3 MODEL2(4)/4HS-G /, MODEL2(5)/4H-S-G/, MODEL2(6)/4H-G-S/
-C/7S
- DATA MODEL1/' ',' ',' ',' ',' G ',' S '/,
- 1 MODEL2/' G ',' S ','G-S ','S-G ','-S-G','-G-S'/
-C/
-C
-C------------------------------- BODY --------------------------------
-C
- PU = IV(PRUNIT)
- IF (PU .EQ. 0) GO TO 999
- IV1 = IV(1)
- IF (IV1 .GT. 62) IV1 = IV1 - 51
- OL = IV(OUTLEV)
- ALG = MOD(IV(ALGSAV)-1,2) + 1
- IF (IV1 .LT. 2 .OR. IV1 .GT. 15) GO TO 370
- IF (IV1 .GE. 12) GO TO 120
- IF (IV1 .EQ. 2 .AND. IV(NITER) .EQ. 0) GO TO 390
- IF (OL .EQ. 0) GO TO 120
- IF (IV1 .GE. 10 .AND. IV(PRNTIT) .EQ. 0) GO TO 120
- IF (IV1 .GT. 2) GO TO 10
- IV(PRNTIT) = IV(PRNTIT) + 1
- IF (IV(PRNTIT) .LT. IABS(OL)) GO TO 999
- 10 NF = IV(NFCALL) - IABS(IV(NFCOV))
- IV(PRNTIT) = 0
- RELDF = ZERO
- PRELDF = ZERO
- OLDF = DMAX1(DABS(V(F0)), DABS(V(F)))
- IF (OLDF .LE. ZERO) GO TO 20
- RELDF = V(FDIF) / OLDF
- PRELDF = V(PREDUC) / OLDF
- 20 IF (OL .GT. 0) GO TO 60
-C
-C *** PRINT SHORT SUMMARY LINE ***
-C
- IF (IV(NEEDHD) .EQ. 1 .AND. ALG .EQ. 1) WRITE(PU,30)
- 30 FORMAT(/10H IT NF,6X,1HF,7X,5HRELDF,3X,6HPRELDF,3X,5HRELDX,
- 1 2X,13HMODEL STPPAR)
- IF (IV(NEEDHD) .EQ. 1 .AND. ALG .EQ. 2) WRITE(PU,40)
- 40 FORMAT(/11H IT NF,7X,1HF,8X,5HRELDF,4X,6HPRELDF,4X,5HRELDX,
- 1 3X,6HSTPPAR)
- IV(NEEDHD) = 0
- IF (ALG .EQ. 2) GO TO 50
- M = IV(SUSED)
- WRITE(PU,100) IV(NITER), NF, V(F), RELDF, PRELDF, V(RELDX),
- 1 MODEL1(M), MODEL2(M), V(STPPAR)
- GO TO 120
-C
- 50 WRITE(PU,110) IV(NITER), NF, V(F), RELDF, PRELDF, V(RELDX),
- 1 V(STPPAR)
- GO TO 120
-C
-C *** PRINT LONG SUMMARY LINE ***
-C
- 60 IF (IV(NEEDHD) .EQ. 1 .AND. ALG .EQ. 1) WRITE(PU,70)
- 70 FORMAT(/11H IT NF,6X,1HF,7X,5HRELDF,3X,6HPRELDF,3X,5HRELDX,
- 1 2X,13HMODEL STPPAR,2X,6HD*STEP,2X,7HNPRELDF)
- IF (IV(NEEDHD) .EQ. 1 .AND. ALG .EQ. 2) WRITE(PU,80)
- 80 FORMAT(/11H IT NF,7X,1HF,8X,5HRELDF,4X,6HPRELDF,4X,5HRELDX,
- 1 3X,6HSTPPAR,3X,6HD*STEP,3X,7HNPRELDF)
- IV(NEEDHD) = 0
- NRELDF = ZERO
- IF (OLDF .GT. ZERO) NRELDF = V(NREDUC) / OLDF
- IF (ALG .EQ. 2) GO TO 90
- M = IV(SUSED)
- WRITE(PU,100) IV(NITER), NF, V(F), RELDF, PRELDF, V(RELDX),
- 1 MODEL1(M), MODEL2(M), V(STPPAR), V(DSTNRM), NRELDF
- GO TO 120
-C
- 90 WRITE(PU,110) IV(NITER), NF, V(F), RELDF, PRELDF,
- 1 V(RELDX), V(STPPAR), V(DSTNRM), NRELDF
- 100 FORMAT(I6,I5,D10.3,2D9.2,D8.1,A3,A4,2D8.1,D9.2)
- 110 FORMAT(I6,I5,D11.3,2D10.2,3D9.1,D10.2)
-C
- 120 IF (IV1 .LE. 2) GO TO 999
- I = IV(STATPR)
- IF (I .EQ. (-1)) GO TO 460
- IF (I + IV1 .LT. 0) GO TO 460
- GO TO (999, 999, 130, 150, 170, 190, 210, 230, 250, 270, 290, 310,
- 1 330, 350, 500), IV1
-C
- 130 WRITE(PU,140)
- 140 FORMAT(/26H ***** X-CONVERGENCE *****)
- GO TO 430
-C
- 150 WRITE(PU,160)
- 160 FORMAT(/42H ***** RELATIVE FUNCTION CONVERGENCE *****)
- GO TO 430
-C
- 170 WRITE(PU,180)
- 180 FORMAT(/49H ***** X- AND RELATIVE FUNCTION CONVERGENCE *****)
- GO TO 430
-C
- 190 WRITE(PU,200)
- 200 FORMAT(/42H ***** ABSOLUTE FUNCTION CONVERGENCE *****)
- GO TO 430
-C
- 210 WRITE(PU,220)
- 220 FORMAT(/33H ***** SINGULAR CONVERGENCE *****)
- GO TO 430
-C
- 230 WRITE(PU,240)
- 240 FORMAT(/30H ***** FALSE CONVERGENCE *****)
- GO TO 430
-C
- 250 WRITE(PU,260)
- 260 FORMAT(/38H ***** FUNCTION EVALUATION LIMIT *****)
- GO TO 430
-C
- 270 WRITE(PU,280)
- 280 FORMAT(/28H ***** ITERATION LIMIT *****)
- GO TO 430
-C
- 290 WRITE(PU,300)
- 300 FORMAT(/18H ***** STOPX *****)
- GO TO 430
-C
- 310 WRITE(PU,320)
- 320 FORMAT(/44H ***** INITIAL F(X) CANNOT BE COMPUTED *****)
-C
- GO TO 390
-C
- 330 WRITE(PU,340)
- 340 FORMAT(/37H ***** BAD PARAMETERS TO ASSESS *****)
- GO TO 999
-C
- 350 WRITE(PU,360)
- 360 FORMAT(/43H ***** GRADIENT COULD NOT BE COMPUTED *****)
- IF (IV(NITER) .GT. 0) GO TO 460
- GO TO 390
-C
- 370 WRITE(PU,380) IV(1)
- 380 FORMAT(/14H ***** IV(1) =,I5,6H *****)
- GO TO 999
-C
-C *** INITIAL CALL ON DITSUM ***
-C
- 390 IF (IV(X0PRT) .NE. 0) WRITE(PU,400) (I, X(I), D(I), I = 1, P)
- 400 FORMAT(/23H I INITIAL X(I),8X,4HD(I)//(1X,I5,D17.6,D14.3))
-C *** THE FOLLOWING ARE TO AVOID UNDEFINED VARIABLES WHEN THE
-C *** FUNCTION EVALUATION LIMIT IS 1...
- V(DSTNRM) = ZERO
- V(FDIF) = ZERO
- V(NREDUC) = ZERO
- V(PREDUC) = ZERO
- V(RELDX) = ZERO
- IF (IV1 .GE. 12) GO TO 999
- IV(NEEDHD) = 0
- IV(PRNTIT) = 0
- IF (OL .EQ. 0) GO TO 999
- IF (OL .LT. 0 .AND. ALG .EQ. 1) WRITE(PU,30)
- IF (OL .LT. 0 .AND. ALG .EQ. 2) WRITE(PU,40)
- IF (OL .GT. 0 .AND. ALG .EQ. 1) WRITE(PU,70)
- IF (OL .GT. 0 .AND. ALG .EQ. 2) WRITE(PU,80)
- IF (ALG .EQ. 1) WRITE(PU,410) IV(NFCALL), V(F)
- IF (ALG .EQ. 2) WRITE(PU,420) IV(NFCALL), V(F)
- 410 FORMAT(/6H 0,I5,D10.3)
- 420 FORMAT(/6H 0,I5,D11.3)
- GO TO 999
-C
-C *** PRINT VARIOUS INFORMATION REQUESTED ON SOLUTION ***
-C
- 430 IV(NEEDHD) = 1
- IF (IV(STATPR) .LE. 0) GO TO 460
- OLDF = DMAX1(DABS(V(F0)), DABS(V(F)))
- PRELDF = ZERO
- NRELDF = ZERO
- IF (OLDF .LE. ZERO) GO TO 440
- PRELDF = V(PREDUC) / OLDF
- NRELDF = V(NREDUC) / OLDF
- 440 NF = IV(NFCALL) - IV(NFCOV)
- NG = IV(NGCALL) - IV(NGCOV)
- WRITE(PU,450) V(F), V(RELDX), NF, NG, PRELDF, NRELDF
- 450 FORMAT(/9H FUNCTION,D17.6,8H RELDX,D17.3/12H FUNC. EVALS,
- 1 I8,9X,11HGRAD. EVALS,I8/7H PRELDF,D16.3,6X,7HNPRELDF,D15.3)
-C
- 460 IF (IV(SOLPRT) .EQ. 0) GO TO 999
- IV(NEEDHD) = 1
- IF (IV(ALGSAV) .GT. 2) GO TO 999
- WRITE(PU,470)
- 470 FORMAT(/22H I FINAL X(I),8X,4HD(I),10X,4HG(I)/)
- DO 480 I = 1, P
- 480 WRITE(PU,490) I, X(I), D(I), G(I)
- 490 FORMAT(1X,I5,D16.6,2D14.3)
- GO TO 999
-C
- 500 WRITE(PU,510)
- 510 FORMAT(/24H INCONSISTENT DIMENSIONS)
- 999 RETURN
-C *** LAST CARD OF DITSUM FOLLOWS ***
- END
diff --git a/CEP/PyBDSM/src/port3/divset.f b/CEP/PyBDSM/src/port3/divset.f
deleted file mode 100644
index c1e58672aca8de4a000587955e05cb120a9ca52c..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/divset.f
+++ /dev/null
@@ -1,118 +0,0 @@
- SUBROUTINE DIVSET(ALG, IV, LIV, LV, V)
-C
-C *** SUPPLY ***SOL (VERSION 2.3) DEFAULT VALUES TO IV AND V ***
-C
-C *** ALG = 1 MEANS REGRESSION CONSTANTS.
-C *** ALG = 2 MEANS GENERAL UNCONSTRAINED OPTIMIZATION CONSTANTS.
-C
- INTEGER LIV, LV
- INTEGER ALG, IV(LIV)
- DOUBLE PRECISION V(LV)
-C
- INTEGER I7MDCN
- EXTERNAL I7MDCN,DV7DFL
-C I7MDCN... RETURNS MACHINE-DEPENDENT INTEGER CONSTANTS.
-C DV7DFL.... PROVIDES DEFAULT VALUES TO V.
-C
- INTEGER ALG1, MIV, MV
- INTEGER MINIV(4), MINV(4)
-C
-C *** SUBSCRIPTS FOR IV ***
-C
- INTEGER ALGSAV, COVPRT, COVREQ, DRADPR, DTYPE, HC, IERR, INITH,
- 1 INITS, IPIVOT, IVNEED, LASTIV, LASTV, LMAT, MXFCAL,
- 2 MXITER, NFCOV, NGCOV, NVDFLT, NVSAVE, OUTLEV, PARPRT,
- 3 PARSAV, PERM, PRUNIT, QRTYP, RDREQ, RMAT, SOLPRT, STATPR,
- 4 VNEED, VSAVE, X0PRT
-C
-C *** IV SUBSCRIPT VALUES ***
-C
-C/6
-C DATA ALGSAV/51/, COVPRT/14/, COVREQ/15/, DRADPR/101/, DTYPE/16/,
-C 1 HC/71/, IERR/75/, INITH/25/, INITS/25/, IPIVOT/76/,
-C 2 IVNEED/3/, LASTIV/44/, LASTV/45/, LMAT/42/, MXFCAL/17/,
-C 3 MXITER/18/, NFCOV/52/, NGCOV/53/, NVDFLT/50/, NVSAVE/9/,
-C 4 OUTLEV/19/, PARPRT/20/, PARSAV/49/, PERM/58/, PRUNIT/21/,
-C 5 QRTYP/80/, RDREQ/57/, RMAT/78/, SOLPRT/22/, STATPR/23/,
-C 6 VNEED/4/, VSAVE/60/, X0PRT/24/
-C/7
- PARAMETER (ALGSAV=51, COVPRT=14, COVREQ=15, DRADPR=101, DTYPE=16,
- 1 HC=71, IERR=75, INITH=25, INITS=25, IPIVOT=76,
- 2 IVNEED=3, LASTIV=44, LASTV=45, LMAT=42, MXFCAL=17,
- 3 MXITER=18, NFCOV=52, NGCOV=53, NVDFLT=50, NVSAVE=9,
- 4 OUTLEV=19, PARPRT=20, PARSAV=49, PERM=58, PRUNIT=21,
- 5 QRTYP=80, RDREQ=57, RMAT=78, SOLPRT=22, STATPR=23,
- 6 VNEED=4, VSAVE=60, X0PRT=24)
-C/
- DATA MINIV(1)/82/, MINIV(2)/59/, MINIV(3)/103/, MINIV(4)/103/,
- 1 MINV(1)/98/, MINV(2)/71/, MINV(3)/101/, MINV(4)/85/
-C
-C------------------------------- BODY --------------------------------
-C
- IF (PRUNIT .LE. LIV) IV(PRUNIT) = I7MDCN(1)
- IF (ALGSAV .LE. LIV) IV(ALGSAV) = ALG
- IF (ALG .LT. 1 .OR. ALG .GT. 4) GO TO 40
- MIV = MINIV(ALG)
- IF (LIV .LT. MIV) GO TO 20
- MV = MINV(ALG)
- IF (LV .LT. MV) GO TO 30
- ALG1 = MOD(ALG-1,2) + 1
- CALL DV7DFL(ALG1, LV, V)
- IV(1) = 12
- IF (ALG .GT. 2) IV(DRADPR) = 1
- IV(IVNEED) = 0
- IV(LASTIV) = MIV
- IV(LASTV) = MV
- IV(LMAT) = MV + 1
- IV(MXFCAL) = 200
- IV(MXITER) = 150
- IV(OUTLEV) = 1
- IV(PARPRT) = 1
- IV(PERM) = MIV + 1
- IV(SOLPRT) = 1
- IV(STATPR) = 1
- IV(VNEED) = 0
- IV(X0PRT) = 1
-C
- IF (ALG1 .GE. 2) GO TO 10
-C
-C *** REGRESSION VALUES
-C
- IV(COVPRT) = 3
- IV(COVREQ) = 1
- IV(DTYPE) = 1
- IV(HC) = 0
- IV(IERR) = 0
- IV(INITS) = 0
- IV(IPIVOT) = 0
- IV(NVDFLT) = 32
- IV(VSAVE) = 58
- IF (ALG .GT. 2) IV(VSAVE) = IV(VSAVE) + 3
- IV(PARSAV) = IV(VSAVE) + NVSAVE
- IV(QRTYP) = 1
- IV(RDREQ) = 3
- IV(RMAT) = 0
- GO TO 999
-C
-C *** GENERAL OPTIMIZATION VALUES
-C
- 10 IV(DTYPE) = 0
- IV(INITH) = 1
- IV(NFCOV) = 0
- IV(NGCOV) = 0
- IV(NVDFLT) = 25
- IV(PARSAV) = 47
- IF (ALG .GT. 2) IV(PARSAV) = 61
- GO TO 999
-C
- 20 IV(1) = 15
- GO TO 999
-C
- 30 IV(1) = 16
- GO TO 999
-C
- 40 IV(1) = 67
-C
- 999 RETURN
-C *** LAST CARD OF DIVSET FOLLOWS ***
- END
diff --git a/CEP/PyBDSM/src/port3/dl7itv.f b/CEP/PyBDSM/src/port3/dl7itv.f
deleted file mode 100644
index d419e670cdbe0e65fe3b38057aa322d382502eaa..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/dl7itv.f
+++ /dev/null
@@ -1,36 +0,0 @@
- SUBROUTINE DL7ITV(N, X, L, Y)
-C
-C *** SOLVE (L**T)*X = Y, WHERE L IS AN N X N LOWER TRIANGULAR
-C *** MATRIX STORED COMPACTLY BY ROWS. X AND Y MAY OCCUPY THE SAME
-C *** STORAGE. ***
-C
- INTEGER N
- DOUBLE PRECISION X(N), L(1), Y(N)
- INTEGER I, II, IJ, IM1, I0, J, NP1
- DOUBLE PRECISION XI, ZERO
-C/6
-C DATA ZERO/0.D+0/
-C/7
- PARAMETER (ZERO=0.D+0)
-C/
-C
- DO 10 I = 1, N
- 10 X(I) = Y(I)
- NP1 = N + 1
- I0 = N*(N+1)/2
- DO 30 II = 1, N
- I = NP1 - II
- XI = X(I)/L(I0)
- X(I) = XI
- IF (I .LE. 1) GO TO 999
- I0 = I0 - I
- IF (XI .EQ. ZERO) GO TO 30
- IM1 = I - 1
- DO 20 J = 1, IM1
- IJ = I0 + J
- X(J) = X(J) - XI*L(IJ)
- 20 CONTINUE
- 30 CONTINUE
- 999 RETURN
-C *** LAST CARD OF DL7ITV FOLLOWS ***
- END
diff --git a/CEP/PyBDSM/src/port3/dl7ivm.f b/CEP/PyBDSM/src/port3/dl7ivm.f
deleted file mode 100644
index 8df428e2e442a00b5dee3296d9daa20da0b985db..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/dl7ivm.f
+++ /dev/null
@@ -1,35 +0,0 @@
- SUBROUTINE DL7IVM(N, X, L, Y)
-C
-C *** SOLVE L*X = Y, WHERE L IS AN N X N LOWER TRIANGULAR
-C *** MATRIX STORED COMPACTLY BY ROWS. X AND Y MAY OCCUPY THE SAME
-C *** STORAGE. ***
-C
- INTEGER N
- DOUBLE PRECISION X(N), L(1), Y(N)
- DOUBLE PRECISION DD7TPR
- EXTERNAL DD7TPR
- INTEGER I, J, K
- DOUBLE PRECISION T, ZERO
-C/6
-C DATA ZERO/0.D+0/
-C/7
- PARAMETER (ZERO=0.D+0)
-C/
-C
- DO 10 K = 1, N
- IF (Y(K) .NE. ZERO) GO TO 20
- X(K) = ZERO
- 10 CONTINUE
- GO TO 999
- 20 J = K*(K+1)/2
- X(K) = Y(K) / L(J)
- IF (K .GE. N) GO TO 999
- K = K + 1
- DO 30 I = K, N
- T = DD7TPR(I-1, L(J+1), X)
- J = J + I
- X(I) = (Y(I) - T)/L(J)
- 30 CONTINUE
- 999 RETURN
-C *** LAST CARD OF DL7IVM FOLLOWS ***
- END
diff --git a/CEP/PyBDSM/src/port3/dl7msb.f b/CEP/PyBDSM/src/port3/dl7msb.f
deleted file mode 100644
index 7f845c5c70f894efc24c73ee874aa9d32b796739..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/dl7msb.f
+++ /dev/null
@@ -1,119 +0,0 @@
- SUBROUTINE DL7MSB(B, D, G, IERR, IPIV, IPIV1, IPIV2, KA, LMAT,
- 1 LV, P, P0, PC, QTR, RMAT, STEP, TD, TG, V,
- 2 W, WLM, X, X0)
-C
-C *** COMPUTE HEURISTIC BOUNDED NEWTON STEP ***
-C
- INTEGER IERR, KA, LV, P, P0, PC
- INTEGER IPIV(P), IPIV1(P), IPIV2(P)
- DOUBLE PRECISION B(2,P), D(P), G(P), LMAT(1), QTR(P), RMAT(1),
- 1 STEP(P,3), TD(P), TG(P), V(LV), W(P), WLM(1),
- 2 X0(P), X(P)
-C DIMENSION LMAT(P*(P+1)/2), RMAT(P*(P+1)/2), WLM(P*(P+5)/2 + 4)
-C
- DOUBLE PRECISION DD7TPR
- EXTERNAL DD7MLP, DD7TPR, DL7MST, DL7TVM, DQ7RSH, DS7BQN,
- 1 DV2AXY,DV7CPY, DV7IPR, DV7SCP, DV7VMP
-C
-C *** LOCAL VARIABLES ***
-C
- INTEGER I, J, K, K0, KB, KINIT, L, NS, P1, P10, P11
- DOUBLE PRECISION DS0, NRED, PRED, RAD
- DOUBLE PRECISION ONE, ZERO
-C
-C *** V SUBSCRIPTS ***
-C
- INTEGER DST0, DSTNRM, GTSTEP, NREDUC, PREDUC, RADIUS
-C
-C/6
-C DATA DST0/3/, DSTNRM/2/, GTSTEP/4/, NREDUC/6/, PREDUC/7/,
-C 1 RADIUS/8/
-C/7
- PARAMETER (DST0=3, DSTNRM=2, GTSTEP=4, NREDUC=6, PREDUC=7,
- 1 RADIUS=8)
-C/
- DATA ONE/1.D+0/, ZERO/0.D+0/
-C
-C+++++++++++++++++++++++++++++++ BODY ++++++++++++++++++++++++++++++++
-C
- P1 = PC
- IF (KA .LT. 0) GO TO 10
- NRED = V(NREDUC)
- DS0 = V(DST0)
- GO TO 20
- 10 P0 = 0
- KA = -1
-C
- 20 KINIT = -1
- IF (P0 .EQ. P1) KINIT = KA
- CALL DV7CPY(P, X, X0)
- CALL DV7CPY(P, TD, D)
-C *** _USE_ STEP(1,3) AS TEMP. COPY OF QTR ***
- CALL DV7CPY(P, STEP(1,3), QTR)
- CALL DV7IPR(P, IPIV, TD)
- PRED = ZERO
- RAD = V(RADIUS)
- KB = -1
- V(DSTNRM) = ZERO
- IF (P1 .GT. 0) GO TO 30
- NRED = ZERO
- DS0 = ZERO
- CALL DV7SCP(P, STEP, ZERO)
- GO TO 90
-C
- 30 CALL DV7VMP(P, TG, G, D, -1)
- CALL DV7IPR(P, IPIV, TG)
- P10 = P1
- 40 K = KINIT
- KINIT = -1
- V(RADIUS) = RAD - V(DSTNRM)
- CALL DV7VMP(P1, TG, TG, TD, 1)
- DO 50 I = 1, P1
- 50 IPIV1(I) = I
- K0 = MAX0(0, K)
- CALL DL7MST(TD, TG, IERR, IPIV1, K, P1, STEP(1,3), RMAT, STEP,
- 1 V, WLM)
- CALL DV7VMP(P1, TG, TG, TD, -1)
- P0 = P1
- IF (KA .GE. 0) GO TO 60
- NRED = V(NREDUC)
- DS0 = V(DST0)
-C
- 60 KA = K
- V(RADIUS) = RAD
- L = P1 + 5
- IF (K .LE. K0) CALL DD7MLP(P1, LMAT, TD, RMAT, -1)
- IF (K .GT. K0) CALL DD7MLP(P1, LMAT, TD, WLM(L), -1)
- CALL DS7BQN(B, D, STEP(1,2), IPIV, IPIV1, IPIV2, KB, LMAT,
- 1 LV, NS, P, P1, STEP, TD, TG, V, W, X, X0)
- PRED = PRED + V(PREDUC)
- IF (NS .EQ. 0) GO TO 80
- P0 = 0
-C
-C *** UPDATE RMAT AND QTR ***
-C
- P11 = P1 + 1
- L = P10 + P11
- DO 70 K = P11, P10
- J = L - K
- I = IPIV2(J)
- IF (I .LT. J) CALL DQ7RSH(I, J, .TRUE., QTR, RMAT, W)
- 70 CONTINUE
-C
- 80 IF (KB .GT. 0) GO TO 90
-C
-C *** UPDATE LOCAL COPY OF QTR ***
-C
- CALL DV7VMP(P10, W, STEP(1,2), TD, -1)
- CALL DL7TVM(P10, W, LMAT, W)
- CALL DV2AXY(P10, STEP(1,3), ONE, W, QTR)
- GO TO 40
-C
- 90 V(DST0) = DS0
- V(NREDUC) = NRED
- V(PREDUC) = PRED
- V(GTSTEP) = DD7TPR(P, G, STEP)
-C
- 999 RETURN
-C *** LAST LINE OF DL7MSB FOLLOWS ***
- END
diff --git a/CEP/PyBDSM/src/port3/dl7mst.f b/CEP/PyBDSM/src/port3/dl7mst.f
deleted file mode 100644
index 90d9e0e8c4177e88008b403ee837d9edfa698460..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/dl7mst.f
+++ /dev/null
@@ -1,497 +0,0 @@
- SUBROUTINE DL7MST(D, G, IERR, IPIVOT, KA, P, QTR, R, STEP, V, W)
-C
-C *** COMPUTE LEVENBERG-MARQUARDT STEP USING MORE-HEBDEN TECHNIQUE **
-C *** NL2SOL VERSION 2.2. ***
-C
-C *** PARAMETER DECLARATIONS ***
-C
- INTEGER IERR, KA, P
- INTEGER IPIVOT(P)
- DOUBLE PRECISION D(P), G(P), QTR(P), R(1), STEP(P), V(21), W(1)
-C DIMENSION W(P*(P+5)/2 + 4)
-C
-C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
-C
-C *** PURPOSE ***
-C
-C GIVEN THE R MATRIX FROM THE QR DECOMPOSITION OF A JACOBIAN
-C MATRIX, J, AS WELL AS Q-TRANSPOSE TIMES THE CORRESPONDING
-C RESIDUAL VECTOR, RESID, THIS SUBROUTINE COMPUTES A LEVENBERG-
-C MARQUARDT STEP OF APPROXIMATE LENGTH V(RADIUS) BY THE MORE-
-C TECHNIQUE.
-C
-C *** PARAMETER DESCRIPTION ***
-C
-C D (IN) = THE SCALE VECTOR.
-C G (IN) = THE GRADIENT VECTOR (J**T)*R.
-C IERR (I/O) = RETURN CODE FROM QRFACT OR DQ7RGS -- 0 MEANS R HAS
-C FULL RANK.
-C IPIVOT (I/O) = PERMUTATION ARRAY FROM QRFACT OR DQ7RGS, WHICH COMPUTE
-C QR DECOMPOSITIONS WITH COLUMN PIVOTING.
-C KA (I/O). KA .LT. 0 ON INPUT MEANS THIS IS THE FIRST CALL ON
-C DL7MST FOR THE CURRENT R AND QTR. ON OUTPUT KA CON-
-C TAINS THE NUMBER OF HEBDEN ITERATIONS NEEDED TO DETERMINE
-C STEP. KA = 0 MEANS A GAUSS-NEWTON STEP.
-C P (IN) = NUMBER OF PARAMETERS.
-C QTR (IN) = (Q**T)*RESID = Q-TRANSPOSE TIMES THE RESIDUAL VECTOR.
-C R (IN) = THE R MATRIX, STORED COMPACTLY BY COLUMNS.
-C STEP (OUT) = THE LEVENBERG-MARQUARDT STEP COMPUTED.
-C V (I/O) CONTAINS VARIOUS CONSTANTS AND VARIABLES DESCRIBED BELOW.
-C W (I/O) = WORKSPACE OF LENGTH P*(P+5)/2 + 4.
-C
-C *** ENTRIES IN V ***
-C
-C V(DGNORM) (I/O) = 2-NORM OF (D**-1)*G.
-C V(DSTNRM) (I/O) = 2-NORM OF D*STEP.
-C V(DST0) (I/O) = 2-NORM OF GAUSS-NEWTON STEP (FOR NONSING. J).
-C V(EPSLON) (IN) = MAX. REL. ERROR ALLOWED IN TWONORM(R)**2 MINUS
-C TWONORM(R - J*STEP)**2. (SEE ALGORITHM NOTES BELOW.)
-C V(GTSTEP) (OUT) = INNER PRODUCT BETWEEN G AND STEP.
-C V(NREDUC) (OUT) = HALF THE REDUCTION IN THE SUM OF SQUARES PREDICTED
-C FOR A GAUSS-NEWTON STEP.
-C V(PHMNFC) (IN) = TOL. (TOGETHER WITH V(PHMXFC)) FOR ACCEPTING STEP
-C (MORE*S SIGMA). THE ERROR V(DSTNRM) - V(RADIUS) MUST LIE
-C BETWEEN V(PHMNFC)*V(RADIUS) AND V(PHMXFC)*V(RADIUS).
-C V(PHMXFC) (IN) (SEE V(PHMNFC).)
-C V(PREDUC) (OUT) = HALF THE REDUCTION IN THE SUM OF SQUARES PREDICTED
-C BY THE STEP RETURNED.
-C V(RADIUS) (IN) = RADIUS OF CURRENT (SCALED) TRUST REGION.
-C V(RAD0) (I/O) = VALUE OF V(RADIUS) FROM PREVIOUS CALL.
-C V(STPPAR) (I/O) = MARQUARDT PARAMETER (OR ITS NEGATIVE IF THE SPECIAL
-C CASE MENTIONED BELOW IN THE ALGORITHM NOTES OCCURS).
-C
-C NOTE -- SEE DATA STATEMENT BELOW FOR VALUES OF ABOVE SUBSCRIPTS.
-C
-C *** USAGE NOTES ***
-C
-C IF IT IS DESIRED TO RECOMPUTE STEP USING A DIFFERENT VALUE OF
-C V(RADIUS), THEN THIS ROUTINE MAY BE RESTARTED BY CALLING IT
-C WITH ALL PARAMETERS UNCHANGED EXCEPT V(RADIUS). (THIS EXPLAINS
-C WHY MANY PARAMETERS ARE LISTED AS I/O). ON AN INTIIAL CALL (ONE
-C WITH KA = -1), THE CALLER NEED ONLY HAVE INITIALIZED D, G, KA, P,
-C QTR, R, V(EPSLON), V(PHMNFC), V(PHMXFC), V(RADIUS), AND V(RAD0).
-C
-C *** APPLICATION AND USAGE RESTRICTIONS ***
-C
-C THIS ROUTINE IS CALLED AS PART OF THE NL2SOL (NONLINEAR LEAST-
-C SQUARES) PACKAGE (REF. 1).
-C
-C *** ALGORITHM NOTES ***
-C
-C THIS CODE IMPLEMENTS THE STEP COMPUTATION SCHEME DESCRIBED IN
-C REFS. 2 AND 4. FAST GIVENS TRANSFORMATIONS (SEE REF. 3, PP. 60-
-C 62) ARE USED TO COMPUTE STEP WITH A NONZERO MARQUARDT PARAMETER.
-C A SPECIAL CASE OCCURS IF J IS (NEARLY) SINGULAR AND V(RADIUS)
-C IS SUFFICIENTLY LARGE. IN THIS CASE THE STEP RETURNED IS SUCH
-C THAT TWONORM(R)**2 - TWONORM(R - J*STEP)**2 DIFFERS FROM ITS
-C OPTIMAL VALUE BY LESS THAN V(EPSLON) TIMES THIS OPTIMAL VALUE,
-C WHERE J AND R DENOTE THE ORIGINAL JACOBIAN AND RESIDUAL. (SEE
-C REF. 2 FOR MORE DETAILS.)
-C
-C *** FUNCTIONS AND SUBROUTINES CALLED ***
-C
-C DD7TPR - RETURNS INNER PRODUCT OF TWO VECTORS.
-C DL7ITV - APPLY INVERSE-TRANSPOSE OF COMPACT LOWER TRIANG. MATRIX.
-C DL7IVM - APPLY INVERSE OF COMPACT LOWER TRIANG. MATRIX.
-C DV7CPY - COPIES ONE VECTOR TO ANOTHER.
-C DV2NRM - RETURNS 2-NORM OF A VECTOR.
-C
-C *** REFERENCES ***
-C
-C 1. DENNIS, J.E., GAY, D.M., AND WELSCH, R.E. (1981), AN ADAPTIVE
-C NONLINEAR LEAST-SQUARES ALGORITHM, ACM TRANS. MATH.
-C SOFTWARE, VOL. 7, NO. 3.
-C 2. GAY, D.M. (1981), COMPUTING OPTIMAL LOCALLY CONSTRAINED STEPS,
-C SIAM J. SCI. STATIST. COMPUTING, VOL. 2, NO. 2, PP.
-C 186-197.
-C 3. LAWSON, C.L., AND HANSON, R.J. (1974), SOLVING LEAST SQUARES
-C PROBLEMS, PRENTICE-HALL, ENGLEWOOD CLIFFS, N.J.
-C 4. MORE, J.J. (1978), THE LEVENBERG-MARQUARDT ALGORITHM, IMPLEMEN-
-C TATION AND THEORY, PP.105-116 OF SPRINGER LECTURE NOTES
-C IN MATHEMATICS NO. 630, EDITED BY G.A. WATSON, SPRINGER-
-C VERLAG, BERLIN AND NEW YORK.
-C
-C *** GENERAL ***
-C
-C CODED BY DAVID M. GAY.
-C THIS SUBROUTINE WAS WRITTEN IN CONNECTION WITH RESEARCH
-C SUPPORTED BY THE NATIONAL SCIENCE FOUNDATION UNDER GRANTS
-C MCS-7600324, DCR75-10143, 76-14311DSS, MCS76-11989, AND
-C MCS-7906671.
-C
-C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
-C
-C *** LOCAL VARIABLES ***
-C
- INTEGER DSTSAV, I, IP1, I1, J1, K, KALIM, L, LK0, PHIPIN,
- 1 PP1O2, RES, RES0, RMAT, RMAT0, UK0
- DOUBLE PRECISION A, ADI, ALPHAK, B, DFACSQ, DST, DTOL, D1, D2,
- 1 LK, OLDPHI, PHI, PHIMAX, PHIMIN, PSIFAC, RAD,
- 2 SI, SJ, SQRTAK, T, TWOPSI, UK, WL
-C
-C *** CONSTANTS ***
- DOUBLE PRECISION DFAC, EIGHT, HALF, NEGONE, ONE, P001, THREE,
- 1 TTOL, ZERO
- DOUBLE PRECISION BIG
-C
-C *** INTRINSIC FUNCTIONS ***
-C/+
- DOUBLE PRECISION DSQRT
-C/
-C *** EXTERNAL FUNCTIONS AND SUBROUTINES ***
-C
- DOUBLE PRECISION DD7TPR, DL7SVN, DR7MDC, DV2NRM
- EXTERNAL DD7TPR, DL7ITV, DL7IVM, DL7SVN, DR7MDC,DV7CPY, DV2NRM
-C
-C *** SUBSCRIPTS FOR V ***
-C
- INTEGER DGNORM, DSTNRM, DST0, EPSLON, GTSTEP, NREDUC, PHMNFC,
- 1 PHMXFC, PREDUC, RADIUS, RAD0, STPPAR
-C/6
-C DATA DGNORM/1/, DSTNRM/2/, DST0/3/, EPSLON/19/, GTSTEP/4/,
-C 1 NREDUC/6/, PHMNFC/20/, PHMXFC/21/, PREDUC/7/, RADIUS/8/,
-C 2 RAD0/9/, STPPAR/5/
-C/7
- PARAMETER (DGNORM=1, DSTNRM=2, DST0=3, EPSLON=19, GTSTEP=4,
- 1 NREDUC=6, PHMNFC=20, PHMXFC=21, PREDUC=7, RADIUS=8,
- 2 RAD0=9, STPPAR=5)
-C/
-C
-C/6
-C DATA DFAC/256.D+0/, EIGHT/8.D+0/, HALF/0.5D+0/, NEGONE/-1.D+0/,
-C 1 ONE/1.D+0/, P001/1.D-3/, THREE/3.D+0/, TTOL/2.5D+0/,
-C 2 ZERO/0.D+0/
-C/7
- PARAMETER (DFAC=256.D+0, EIGHT=8.D+0, HALF=0.5D+0, NEGONE=-1.D+0,
- 1 ONE=1.D+0, P001=1.D-3, THREE=3.D+0, TTOL=2.5D+0,
- 2 ZERO=0.D+0)
- SAVE BIG
-C/
- DATA BIG/0.D+0/
-C
-C *** BODY ***
-C
-C *** FOR _USE_ IN RECOMPUTING STEP, THE FINAL VALUES OF LK AND UK,
-C *** THE INVERSE DERIVATIVE OF MORE*S PHI AT 0 (FOR NONSING. J)
-C *** AND THE VALUE RETURNED AS V(DSTNRM) ARE STORED AT W(LK0),
-C *** W(UK0), W(PHIPIN), AND W(DSTSAV) RESPECTIVELY.
- LK0 = P + 1
- PHIPIN = LK0 + 1
- UK0 = PHIPIN + 1
- DSTSAV = UK0 + 1
- RMAT0 = DSTSAV
-C *** A COPY OF THE R-MATRIX FROM THE QR DECOMPOSITION OF J IS
-C *** STORED IN W STARTING AT W(RMAT), AND A COPY OF THE RESIDUAL
-C *** VECTOR IS STORED IN W STARTING AT W(RES). THE LOOPS BELOW
-C *** THAT UPDATE THE QR DECOMP. FOR A NONZERO MARQUARDT PARAMETER
-C *** WORK ON THESE COPIES.
- RMAT = RMAT0 + 1
- PP1O2 = P * (P + 1) / 2
- RES0 = PP1O2 + RMAT0
- RES = RES0 + 1
- RAD = V(RADIUS)
- IF (RAD .GT. ZERO)
- 1 PSIFAC = V(EPSLON)/((EIGHT*(V(PHMNFC) + ONE) + THREE) * RAD**2)
- IF (BIG .LE. ZERO) BIG = DR7MDC(6)
- PHIMAX = V(PHMXFC) * RAD
- PHIMIN = V(PHMNFC) * RAD
-C *** DTOL, DFAC, AND DFACSQ ARE USED IN RESCALING THE FAST GIVENS
-C *** REPRESENTATION OF THE UPDATED QR DECOMPOSITION.
- DTOL = ONE/DFAC
- DFACSQ = DFAC*DFAC
-C *** OLDPHI IS USED TO DETECT LIMITS OF NUMERICAL ACCURACY. IF
-C *** WE RECOMPUTE STEP AND IT DOES NOT CHANGE, THEN WE ACCEPT IT.
- OLDPHI = ZERO
- LK = ZERO
- UK = ZERO
- KALIM = KA + 12
-C
-C *** START OR RESTART, DEPENDING ON KA ***
-C
- IF (KA) 10, 20, 370
-C
-C *** FRESH START -- COMPUTE V(NREDUC) ***
-C
- 10 KA = 0
- KALIM = 12
- K = P
- IF (IERR .NE. 0) K = IABS(IERR) - 1
- V(NREDUC) = HALF*DD7TPR(K, QTR, QTR)
-C
-C *** SET UP TO TRY INITIAL GAUSS-NEWTON STEP ***
-C
- 20 V(DST0) = NEGONE
- IF (IERR .NE. 0) GO TO 90
- T = DL7SVN(P, R, STEP, W(RES))
- IF (T .GE. ONE) GO TO 30
- IF (DV2NRM(P, QTR) .GE. BIG*T) GO TO 90
-C
-C *** COMPUTE GAUSS-NEWTON STEP ***
-C
-C *** NOTE -- THE R-MATRIX IS STORED COMPACTLY BY COLUMNS IN
-C *** R(1), R(2), R(3), ... IT IS THE TRANSPOSE OF A
-C *** LOWER TRIANGULAR MATRIX STORED COMPACTLY BY ROWS, AND WE
-C *** TREAT IT AS SUCH WHEN USING DL7ITV AND DL7IVM.
- 30 CALL DL7ITV(P, W, R, QTR)
-C *** TEMPORARILY STORE PERMUTED -D*STEP IN STEP.
- DO 60 I = 1, P
- J1 = IPIVOT(I)
- STEP(I) = D(J1)*W(I)
- 60 CONTINUE
- DST = DV2NRM(P, STEP)
- V(DST0) = DST
- PHI = DST - RAD
- IF (PHI .LE. PHIMAX) GO TO 410
-C *** IF THIS IS A RESTART, GO TO 110 ***
- IF (KA .GT. 0) GO TO 110
-C
-C *** GAUSS-NEWTON STEP WAS UNACCEPTABLE. COMPUTE L0 ***
-C
- DO 70 I = 1, P
- J1 = IPIVOT(I)
- STEP(I) = D(J1)*(STEP(I)/DST)
- 70 CONTINUE
- CALL DL7IVM(P, STEP, R, STEP)
- T = ONE / DV2NRM(P, STEP)
- W(PHIPIN) = (T/RAD)*T
- LK = PHI*W(PHIPIN)
-C
-C *** COMPUTE U0 ***
-C
- 90 DO 100 I = 1, P
- 100 W(I) = G(I)/D(I)
- V(DGNORM) = DV2NRM(P, W)
- UK = V(DGNORM)/RAD
- IF (UK .LE. ZERO) GO TO 390
-C
-C *** ALPHAK WILL BE USED AS THE CURRENT MARQUARDT PARAMETER. WE
-C *** _USE_ MORE*S SCHEME FOR INITIALIZING IT.
-C
- ALPHAK = DABS(V(STPPAR)) * V(RAD0)/RAD
- ALPHAK = DMIN1(UK, DMAX1(ALPHAK, LK))
-C
-C
-C *** TOP OF LOOP -- INCREMENT KA, COPY R TO RMAT, QTR TO RES ***
-C
- 110 KA = KA + 1
- CALL DV7CPY(PP1O2, W(RMAT), R)
- CALL DV7CPY(P, W(RES), QTR)
-C
-C *** SAFEGUARD ALPHAK AND INITIALIZE FAST GIVENS SCALE VECTOR. ***
-C
- IF (ALPHAK .LE. ZERO .OR. ALPHAK .LT. LK .OR. ALPHAK .GE. UK)
- 1 ALPHAK = UK * DMAX1(P001, DSQRT(LK/UK))
- IF (ALPHAK .LE. ZERO) ALPHAK = HALF * UK
- SQRTAK = DSQRT(ALPHAK)
- DO 120 I = 1, P
- 120 W(I) = ONE
-C
-C *** ADD ALPHAK*D AND UPDATE QR DECOMP. USING FAST GIVENS TRANS. ***
-C
- DO 270 I = 1, P
-C *** GENERATE, APPLY 1ST GIVENS TRANS. FOR ROW I OF ALPHAK*D.
-C *** (USE STEP TO STORE TEMPORARY ROW) ***
- L = I*(I+1)/2 + RMAT0
- WL = W(L)
- D2 = ONE
- D1 = W(I)
- J1 = IPIVOT(I)
- ADI = SQRTAK*D(J1)
- IF (ADI .GE. DABS(WL)) GO TO 150
- 130 A = ADI/WL
- B = D2*A/D1
- T = A*B + ONE
- IF (T .GT. TTOL) GO TO 150
- W(I) = D1/T
- D2 = D2/T
- W(L) = T*WL
- A = -A
- DO 140 J1 = I, P
- L = L + J1
- STEP(J1) = A*W(L)
- 140 CONTINUE
- GO TO 170
-C
- 150 B = WL/ADI
- A = D1*B/D2
- T = A*B + ONE
- IF (T .GT. TTOL) GO TO 130
- W(I) = D2/T
- D2 = D1/T
- W(L) = T*ADI
- DO 160 J1 = I, P
- L = L + J1
- WL = W(L)
- STEP(J1) = -WL
- W(L) = A*WL
- 160 CONTINUE
-C
- 170 IF (I .EQ. P) GO TO 280
-C
-C *** NOW _USE_ GIVENS TRANS. TO ZERO ELEMENTS OF TEMP. ROW ***
-C
- IP1 = I + 1
- DO 260 I1 = IP1, P
- SI = STEP(I1-1)
- IF (SI .EQ. ZERO) GO TO 260
- L = I1*(I1+1)/2 + RMAT0
- WL = W(L)
- D1 = W(I1)
-C
-C *** RESCALE ROW I1 IF NECESSARY ***
-C
- IF (D1 .GE. DTOL) GO TO 190
- D1 = D1*DFACSQ
- WL = WL/DFAC
- K = L
- DO 180 J1 = I1, P
- K = K + J1
- W(K) = W(K)/DFAC
- 180 CONTINUE
-C
-C *** _USE_ GIVENS TRANS. TO ZERO NEXT ELEMENT OF TEMP. ROW
-C
- 190 IF (DABS(SI) .GT. DABS(WL)) GO TO 220
- 200 A = SI/WL
- B = D2*A/D1
- T = A*B + ONE
- IF (T .GT. TTOL) GO TO 220
- W(L) = T*WL
- W(I1) = D1/T
- D2 = D2/T
- DO 210 J1 = I1, P
- L = L + J1
- WL = W(L)
- SJ = STEP(J1)
- W(L) = WL + B*SJ
- STEP(J1) = SJ - A*WL
- 210 CONTINUE
- GO TO 240
-C
- 220 B = WL/SI
- A = D1*B/D2
- T = A*B + ONE
- IF (T .GT. TTOL) GO TO 200
- W(I1) = D2/T
- D2 = D1/T
- W(L) = T*SI
- DO 230 J1 = I1, P
- L = L + J1
- WL = W(L)
- SJ = STEP(J1)
- W(L) = A*WL + SJ
- STEP(J1) = B*SJ - WL
- 230 CONTINUE
-C
-C *** RESCALE TEMP. ROW IF NECESSARY ***
-C
- 240 IF (D2 .GE. DTOL) GO TO 260
- D2 = D2*DFACSQ
- DO 250 K = I1, P
- 250 STEP(K) = STEP(K)/DFAC
- 260 CONTINUE
- 270 CONTINUE
-C
-C *** COMPUTE STEP ***
-C
- 280 CALL DL7ITV(P, W(RES), W(RMAT), W(RES))
-C *** RECOVER STEP AND STORE PERMUTED -D*STEP AT W(RES) ***
- DO 290 I = 1, P
- J1 = IPIVOT(I)
- K = RES0 + I
- T = W(K)
- STEP(J1) = -T
- W(K) = T*D(J1)
- 290 CONTINUE
- DST = DV2NRM(P, W(RES))
- PHI = DST - RAD
- IF (PHI .LE. PHIMAX .AND. PHI .GE. PHIMIN) GO TO 430
- IF (OLDPHI .EQ. PHI) GO TO 430
- OLDPHI = PHI
-C
-C *** CHECK FOR (AND HANDLE) SPECIAL CASE ***
-C
- IF (PHI .GT. ZERO) GO TO 310
- IF (KA .GE. KALIM) GO TO 430
- TWOPSI = ALPHAK*DST*DST - DD7TPR(P, STEP, G)
- IF (ALPHAK .GE. TWOPSI*PSIFAC) GO TO 310
- V(STPPAR) = -ALPHAK
- GO TO 440
-C
-C *** UNACCEPTABLE STEP -- UPDATE LK, UK, ALPHAK, AND TRY AGAIN ***
-C
- 300 IF (PHI .LT. ZERO) UK = DMIN1(UK, ALPHAK)
- GO TO 320
- 310 IF (PHI .LT. ZERO) UK = ALPHAK
- 320 DO 330 I = 1, P
- J1 = IPIVOT(I)
- K = RES0 + I
- STEP(I) = D(J1) * (W(K)/DST)
- 330 CONTINUE
- CALL DL7IVM(P, STEP, W(RMAT), STEP)
- DO 340 I = 1, P
- 340 STEP(I) = STEP(I) / DSQRT(W(I))
- T = ONE / DV2NRM(P, STEP)
- ALPHAK = ALPHAK + T*PHI*T/RAD
- LK = DMAX1(LK, ALPHAK)
- ALPHAK = LK
- GO TO 110
-C
-C *** RESTART ***
-C
- 370 LK = W(LK0)
- UK = W(UK0)
- IF (V(DST0) .GT. ZERO .AND. V(DST0) - RAD .LE. PHIMAX) GO TO 20
- ALPHAK = DABS(V(STPPAR))
- DST = W(DSTSAV)
- PHI = DST - RAD
- T = V(DGNORM)/RAD
- IF (RAD .GT. V(RAD0)) GO TO 380
-C
-C *** SMALLER RADIUS ***
- UK = T
- IF (ALPHAK .LE. ZERO) LK = ZERO
- IF (V(DST0) .GT. ZERO) LK = DMAX1(LK, (V(DST0)-RAD)*W(PHIPIN))
- GO TO 300
-C
-C *** BIGGER RADIUS ***
- 380 IF (ALPHAK .LE. ZERO .OR. UK .GT. T) UK = T
- LK = ZERO
- IF (V(DST0) .GT. ZERO) LK = DMAX1(LK, (V(DST0)-RAD)*W(PHIPIN))
- GO TO 300
-C
-C *** SPECIAL CASE -- RAD .LE. 0 OR (G = 0 AND J IS SINGULAR) ***
-C
- 390 V(STPPAR) = ZERO
- DST = ZERO
- LK = ZERO
- UK = ZERO
- V(GTSTEP) = ZERO
- V(PREDUC) = ZERO
- DO 400 I = 1, P
- 400 STEP(I) = ZERO
- GO TO 450
-C
-C *** ACCEPTABLE GAUSS-NEWTON STEP -- RECOVER STEP FROM W ***
-C
- 410 ALPHAK = ZERO
- DO 420 I = 1, P
- J1 = IPIVOT(I)
- STEP(J1) = -W(I)
- 420 CONTINUE
-C
-C *** SAVE VALUES FOR _USE_ IN A POSSIBLE RESTART ***
-C
- 430 V(STPPAR) = ALPHAK
- 440 V(GTSTEP) = DMIN1(DD7TPR(P,STEP,G), ZERO)
- V(PREDUC) = HALF * (ALPHAK*DST*DST - V(GTSTEP))
- 450 V(DSTNRM) = DST
- W(DSTSAV) = DST
- W(LK0) = LK
- W(UK0) = UK
- V(RAD0) = RAD
-C
- 999 RETURN
-C
-C *** LAST CARD OF DL7MST FOLLOWS ***
- END
diff --git a/CEP/PyBDSM/src/port3/dl7nvr.f b/CEP/PyBDSM/src/port3/dl7nvr.f
deleted file mode 100644
index ee2e6b524e4d494161874564c230e32c3e9c7ab5..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/dl7nvr.f
+++ /dev/null
@@ -1,47 +0,0 @@
- SUBROUTINE DL7NVR(N, LIN, L)
-C
-C *** COMPUTE LIN = L**-1, BOTH N X N LOWER TRIANG. STORED ***
-C *** COMPACTLY BY ROWS. LIN AND L MAY SHARE THE SAME STORAGE. ***
-C
-C *** PARAMETERS ***
-C
- INTEGER N
- DOUBLE PRECISION L(1), LIN(1)
-C DIMENSION L(N*(N+1)/2), LIN(N*(N+1)/2)
-C
-C *** LOCAL VARIABLES ***
-C
- INTEGER I, II, IM1, JJ, J0, J1, K, K0, NP1
- DOUBLE PRECISION ONE, T, ZERO
-C/6
-C DATA ONE/1.D+0/, ZERO/0.D+0/
-C/7
- PARAMETER (ONE=1.D+0, ZERO=0.D+0)
-C/
-C
-C *** BODY ***
-C
- NP1 = N + 1
- J0 = N*(NP1)/2
- DO 30 II = 1, N
- I = NP1 - II
- LIN(J0) = ONE/L(J0)
- IF (I .LE. 1) GO TO 999
- J1 = J0
- IM1 = I - 1
- DO 20 JJ = 1, IM1
- T = ZERO
- J0 = J1
- K0 = J1 - JJ
- DO 10 K = 1, JJ
- T = T - L(K0)*LIN(J0)
- J0 = J0 - 1
- K0 = K0 + K - I
- 10 CONTINUE
- LIN(J0) = T/L(K0)
- 20 CONTINUE
- J0 = J0 - 1
- 30 CONTINUE
- 999 RETURN
-C *** LAST CARD OF DL7NVR FOLLOWS ***
- END
diff --git a/CEP/PyBDSM/src/port3/dl7sqr.f b/CEP/PyBDSM/src/port3/dl7sqr.f
deleted file mode 100644
index f15e5f48ff7cab2f066e20472aea38252e60fac4..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/dl7sqr.f
+++ /dev/null
@@ -1,39 +0,0 @@
- SUBROUTINE DL7SQR(N, A, L)
-C
-C *** COMPUTE A = LOWER TRIANGLE OF L*(L**T), WITH BOTH
-C *** L AND A STORED COMPACTLY BY ROWS. (BOTH MAY OCCUPY THE
-C *** SAME STORAGE.
-C
-C *** PARAMETERS ***
-C
- INTEGER N
- DOUBLE PRECISION A(1), L(1)
-C DIMENSION A(N*(N+1)/2), L(N*(N+1)/2)
-C
-C *** LOCAL VARIABLES ***
-C
- INTEGER I, II, IJ, IK, IP1, I0, J, JJ, JK, J0, K, NP1
- DOUBLE PRECISION T
-C
- NP1 = N + 1
- I0 = N*(N+1)/2
- DO 30 II = 1, N
- I = NP1 - II
- IP1 = I + 1
- I0 = I0 - I
- J0 = I*(I+1)/2
- DO 20 JJ = 1, I
- J = IP1 - JJ
- J0 = J0 - J
- T = 0.0D0
- DO 10 K = 1, J
- IK = I0 + K
- JK = J0 + K
- T = T + L(IK)*L(JK)
- 10 CONTINUE
- IJ = I0 + J
- A(IJ) = T
- 20 CONTINUE
- 30 CONTINUE
- 999 RETURN
- END
diff --git a/CEP/PyBDSM/src/port3/dl7srt.f b/CEP/PyBDSM/src/port3/dl7srt.f
deleted file mode 100644
index b8490941f2f30a07f1677a1bcecb08ffc538ed1e..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/dl7srt.f
+++ /dev/null
@@ -1,69 +0,0 @@
- SUBROUTINE DL7SRT(N1, N, L, A, IRC)
-C
-C *** COMPUTE ROWS N1 THROUGH N OF THE CHOLESKY FACTOR L OF
-C *** A = L*(L**T), WHERE L AND THE LOWER TRIANGLE OF A ARE BOTH
-C *** STORED COMPACTLY BY ROWS (AND MAY OCCUPY THE SAME STORAGE).
-C *** IRC = 0 MEANS ALL WENT WELL. IRC = J MEANS THE LEADING
-C *** PRINCIPAL J X J SUBMATRIX OF A IS NOT POSITIVE DEFINITE --
-C *** AND L(J*(J+1)/2) CONTAINS THE (NONPOS.) REDUCED J-TH DIAGONAL.
-C
-C *** PARAMETERS ***
-C
- INTEGER N1, N, IRC
- DOUBLE PRECISION L(1), A(1)
-C DIMENSION L(N*(N+1)/2), A(N*(N+1)/2)
-C
-C *** LOCAL VARIABLES ***
-C
- INTEGER I, IJ, IK, IM1, I0, J, JK, JM1, J0, K
- DOUBLE PRECISION T, TD, ZERO
-C
-C *** INTRINSIC FUNCTIONS ***
-C/+
- DOUBLE PRECISION DSQRT
-C/
-C/6
-C DATA ZERO/0.D+0/
-C/7
- PARAMETER (ZERO=0.D+0)
-C/
-C
-C *** BODY ***
-C
- I0 = N1 * (N1 - 1) / 2
- DO 50 I = N1, N
- TD = ZERO
- IF (I .EQ. 1) GO TO 40
- J0 = 0
- IM1 = I - 1
- DO 30 J = 1, IM1
- T = ZERO
- IF (J .EQ. 1) GO TO 20
- JM1 = J - 1
- DO 10 K = 1, JM1
- IK = I0 + K
- JK = J0 + K
- T = T + L(IK)*L(JK)
- 10 CONTINUE
- 20 IJ = I0 + J
- J0 = J0 + J
- T = (A(IJ) - T) / L(J0)
- L(IJ) = T
- TD = TD + T*T
- 30 CONTINUE
- 40 I0 = I0 + I
- T = A(I0) - TD
- IF (T .LE. ZERO) GO TO 60
- L(I0) = DSQRT(T)
- 50 CONTINUE
-C
- IRC = 0
- GO TO 999
-C
- 60 L(I0) = T
- IRC = I
-C
- 999 RETURN
-C
-C *** LAST CARD OF DL7SRT ***
- END
diff --git a/CEP/PyBDSM/src/port3/dl7svn.f b/CEP/PyBDSM/src/port3/dl7svn.f
deleted file mode 100644
index 54996c06338ea789473d3d6c847e96fcf92cd4bd..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/dl7svn.f
+++ /dev/null
@@ -1,175 +0,0 @@
- DOUBLE PRECISION FUNCTION DL7SVN(P, L, X, Y)
-C
-C *** ESTIMATE SMALLEST SING. VALUE OF PACKED LOWER TRIANG. MATRIX L
-C
-C *** PARAMETER DECLARATIONS ***
-C
- INTEGER P
- DOUBLE PRECISION L(1), X(P), Y(P)
-C DIMENSION L(P*(P+1)/2)
-C
-C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
-C
-C *** PURPOSE ***
-C
-C THIS FUNCTION RETURNS A GOOD OVER-ESTIMATE OF THE SMALLEST
-C SINGULAR VALUE OF THE PACKED LOWER TRIANGULAR MATRIX L.
-C
-C *** PARAMETER DESCRIPTION ***
-C
-C P (IN) = THE ORDER OF L. L IS A P X P LOWER TRIANGULAR MATRIX.
-C L (IN) = ARRAY HOLDING THE ELEMENTS OF L IN ROW ORDER, I.E.
-C L(1,1), L(2,1), L(2,2), L(3,1), L(3,2), L(3,3), ETC.
-C X (OUT) IF DL7SVN RETURNS A POSITIVE VALUE, THEN X IS A NORMALIZED
-C APPROXIMATE LEFT SINGULAR VECTOR CORRESPONDING TO THE
-C SMALLEST SINGULAR VALUE. THIS APPROXIMATION MAY BE VERY
-C CRUDE. IF DL7SVN RETURNS ZERO, THEN SOME COMPONENTS OF X
-C ARE ZERO AND THE REST RETAIN THEIR INPUT VALUES.
-C Y (OUT) IF DL7SVN RETURNS A POSITIVE VALUE, THEN Y = (L**-1)*X IS AN
-C UNNORMALIZED APPROXIMATE RIGHT SINGULAR VECTOR CORRESPOND-
-C ING TO THE SMALLEST SINGULAR VALUE. THIS APPROXIMATION
-C MAY BE CRUDE. IF DL7SVN RETURNS ZERO, THEN Y RETAINS ITS
-C INPUT VALUE. THE CALLER MAY PASS THE SAME VECTOR FOR X
-C AND Y (NONSTANDARD FORTRAN USAGE), IN WHICH CASE Y OVER-
-C WRITES X (FOR NONZERO DL7SVN RETURNS).
-C
-C *** ALGORITHM NOTES ***
-C
-C THE ALGORITHM IS BASED ON (1), WITH THE ADDITIONAL PROVISION THAT
-C DL7SVN = 0 IS RETURNED IF THE SMALLEST DIAGONAL ELEMENT OF L
-C (IN MAGNITUDE) IS NOT MORE THAN THE UNIT ROUNDOFF TIMES THE
-C LARGEST. THE ALGORITHM USES A RANDOM NUMBER GENERATOR PROPOSED
-C IN (4), WHICH PASSES THE SPECTRAL TEST WITH FLYING COLORS -- SEE
-C (2) AND (3).
-C
-C *** SUBROUTINES AND FUNCTIONS CALLED ***
-C
-C DV2NRM - FUNCTION, RETURNS THE 2-NORM OF A VECTOR.
-C
-C *** REFERENCES ***
-C
-C (1) CLINE, A., MOLER, C., STEWART, G., AND WILKINSON, J.H.(1977),
-C AN ESTIMATE FOR THE CONDITION NUMBER OF A MATRIX, REPORT
-C TM-310, APPLIED MATH. DIV., ARGONNE NATIONAL LABORATORY.
-C
-C (2) HOAGLIN, D.C. (1976), THEORETICAL PROPERTIES OF CONGRUENTIAL
-C RANDOM-NUMBER GENERATORS -- AN EMPIRICAL VIEW,
-C MEMORANDUM NS-340, DEPT. OF STATISTICS, HARVARD UNIV.
-C
-C (3) KNUTH, D.E. (1969), THE ART OF COMPUTER PROGRAMMING, VOL. 2
-C (SEMINUMERICAL ALGORITHMS), ADDISON-WESLEY, READING, MASS.
-C
-C (4) SMITH, C.S. (1971), MULTIPLICATIVE PSEUDO-RANDOM NUMBER
-C GENERATORS WITH PRIME MODULUS, J. ASSOC. COMPUT. MACH. 18,
-C PP. 586-593.
-C
-C *** HISTORY ***
-C
-C DESIGNED AND CODED BY DAVID M. GAY (WINTER 1977/SUMMER 1978).
-C
-C *** GENERAL ***
-C
-C THIS SUBROUTINE WAS WRITTEN IN CONNECTION WITH RESEARCH
-C SUPPORTED BY THE NATIONAL SCIENCE FOUNDATION UNDER GRANTS
-C MCS-7600324, DCR75-10143, 76-14311DSS, AND MCS76-11989.
-C
-C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
-C
-C *** LOCAL VARIABLES ***
-C
- INTEGER I, II, IX, J, JI, JJ, JJJ, JM1, J0, PM1
- DOUBLE PRECISION B, SMINUS, SPLUS, T, XMINUS, XPLUS
-C
-C *** CONSTANTS ***
-C
- DOUBLE PRECISION HALF, ONE, R9973, ZERO
-C
-C *** EXTERNAL FUNCTIONS AND SUBROUTINES ***
-C
- DOUBLE PRECISION DD7TPR, DV2NRM
- EXTERNAL DD7TPR, DV2NRM,DV2AXY
-C
-C/6
-C DATA HALF/0.5D+0/, ONE/1.D+0/, R9973/9973.D+0/, ZERO/0.D+0/
-C/7
- PARAMETER (HALF=0.5D+0, ONE=1.D+0, R9973=9973.D+0, ZERO=0.D+0)
-C/
-C
-C *** BODY ***
-C
- IX = 2
- PM1 = P - 1
-C
-C *** FIRST CHECK WHETHER TO RETURN DL7SVN = 0 AND INITIALIZE X ***
-C
- II = 0
- J0 = P*PM1/2
- JJ = J0 + P
- IF (L(JJ) .EQ. ZERO) GO TO 110
- IX = MOD(3432*IX, 9973)
- B = HALF*(ONE + FLOAT(IX)/R9973)
- XPLUS = B / L(JJ)
- X(P) = XPLUS
- IF (P .LE. 1) GO TO 60
- DO 10 I = 1, PM1
- II = II + I
- IF (L(II) .EQ. ZERO) GO TO 110
- JI = J0 + I
- X(I) = XPLUS * L(JI)
- 10 CONTINUE
-C
-C *** SOLVE (L**T)*X = B, WHERE THE COMPONENTS OF B HAVE RANDOMLY
-C *** CHOSEN MAGNITUDES IN (.5,1) WITH SIGNS CHOSEN TO MAKE X LARGE.
-C
-C DO J = P-1 TO 1 BY -1...
- DO 50 JJJ = 1, PM1
- J = P - JJJ
-C *** DETERMINE X(J) IN THIS ITERATION. NOTE FOR I = 1,2,...,J
-C *** THAT X(I) HOLDS THE CURRENT PARTIAL SUM FOR ROW I.
- IX = MOD(3432*IX, 9973)
- B = HALF*(ONE + FLOAT(IX)/R9973)
- XPLUS = (B - X(J))
- XMINUS = (-B - X(J))
- SPLUS = DABS(XPLUS)
- SMINUS = DABS(XMINUS)
- JM1 = J - 1
- J0 = J*JM1/2
- JJ = J0 + J
- XPLUS = XPLUS/L(JJ)
- XMINUS = XMINUS/L(JJ)
- IF (JM1 .EQ. 0) GO TO 30
- DO 20 I = 1, JM1
- JI = J0 + I
- SPLUS = SPLUS + DABS(X(I) + L(JI)*XPLUS)
- SMINUS = SMINUS + DABS(X(I) + L(JI)*XMINUS)
- 20 CONTINUE
- 30 IF (SMINUS .GT. SPLUS) XPLUS = XMINUS
- X(J) = XPLUS
-C *** UPDATE PARTIAL SUMS ***
- IF (JM1 .GT. 0) CALL DV2AXY(JM1, X, XPLUS, L(J0+1), X)
- 50 CONTINUE
-C
-C *** NORMALIZE X ***
-C
- 60 T = ONE/DV2NRM(P, X)
- DO 70 I = 1, P
- 70 X(I) = T*X(I)
-C
-C *** SOLVE L*Y = X AND RETURN DL7SVN = 1/TWONORM(Y) ***
-C
- DO 100 J = 1, P
- JM1 = J - 1
- J0 = J*JM1/2
- JJ = J0 + J
- T = ZERO
- IF (JM1 .GT. 0) T = DD7TPR(JM1, L(J0+1), Y)
- Y(J) = (X(J) - T) / L(JJ)
- 100 CONTINUE
-C
- DL7SVN = ONE/DV2NRM(P, Y)
- GO TO 999
-C
- 110 DL7SVN = ZERO
- 999 RETURN
-C *** LAST CARD OF DL7SVN FOLLOWS ***
- END
diff --git a/CEP/PyBDSM/src/port3/dl7svx.f b/CEP/PyBDSM/src/port3/dl7svx.f
deleted file mode 100644
index 731d4ba9424db903cb82bfe35c09fbb2db91c6c9..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/dl7svx.f
+++ /dev/null
@@ -1,171 +0,0 @@
- DOUBLE PRECISION FUNCTION DL7SVX(P, L, X, Y)
-C
-C *** ESTIMATE LARGEST SING. VALUE OF PACKED LOWER TRIANG. MATRIX L
-C
-C *** PARAMETER DECLARATIONS ***
-C
- INTEGER P
- DOUBLE PRECISION L(1), X(P), Y(P)
-C DIMENSION L(P*(P+1)/2)
-C
-C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
-C
-C *** PURPOSE ***
-C
-C THIS FUNCTION RETURNS A GOOD UNDER-ESTIMATE OF THE LARGEST
-C SINGULAR VALUE OF THE PACKED LOWER TRIANGULAR MATRIX L.
-C
-C *** PARAMETER DESCRIPTION ***
-C
-C P (IN) = THE ORDER OF L. L IS A P X P LOWER TRIANGULAR MATRIX.
-C L (IN) = ARRAY HOLDING THE ELEMENTS OF L IN ROW ORDER, I.E.
-C L(1,1), L(2,1), L(2,2), L(3,1), L(3,2), L(3,3), ETC.
-C X (OUT) IF DL7SVX RETURNS A POSITIVE VALUE, THEN X = (L**T)*Y IS AN
-C (UNNORMALIZED) APPROXIMATE RIGHT SINGULAR VECTOR
-C CORRESPONDING TO THE LARGEST SINGULAR VALUE. THIS
-C APPROXIMATION MAY BE CRUDE.
-C Y (OUT) IF DL7SVX RETURNS A POSITIVE VALUE, THEN Y = L*X IS A
-C NORMALIZED APPROXIMATE LEFT SINGULAR VECTOR CORRESPOND-
-C ING TO THE LARGEST SINGULAR VALUE. THIS APPROXIMATION
-C MAY BE VERY CRUDE. THE CALLER MAY PASS THE SAME VECTOR
-C FOR X AND Y (NONSTANDARD FORTRAN USAGE), IN WHICH CASE X
-C OVER-WRITES Y.
-C
-C *** ALGORITHM NOTES ***
-C
-C THE ALGORITHM IS BASED ON ANALOGY WITH (1). IT USES A
-C RANDOM NUMBER GENERATOR PROPOSED IN (4), WHICH PASSES THE
-C SPECTRAL TEST WITH FLYING COLORS -- SEE (2) AND (3).
-C
-C *** SUBROUTINES AND FUNCTIONS CALLED ***
-C
-C DV2NRM - FUNCTION, RETURNS THE 2-NORM OF A VECTOR.
-C
-C *** REFERENCES ***
-C
-C (1) CLINE, A., MOLER, C., STEWART, G., AND WILKINSON, J.H.(1977),
-C AN ESTIMATE FOR THE CONDITION NUMBER OF A MATRIX, REPORT
-C TM-310, APPLIED MATH. DIV., ARGONNE NATIONAL LABORATORY.
-C
-C (2) HOAGLIN, D.C. (1976), THEORETICAL PROPERTIES OF CONGRUENTIAL
-C RANDOM-NUMBER GENERATORS -- AN EMPIRICAL VIEW,
-C MEMORANDUM NS-340, DEPT. OF STATISTICS, HARVARD UNIV.
-C
-C (3) KNUTH, D.E. (1969), THE ART OF COMPUTER PROGRAMMING, VOL. 2
-C (SEMINUMERICAL ALGORITHMS), ADDISON-WESLEY, READING, MASS.
-C
-C (4) SMITH, C.S. (1971), MULTIPLICATIVE PSEUDO-RANDOM NUMBER
-C GENERATORS WITH PRIME MODULUS, J. ASSOC. COMPUT. MACH. 18,
-C PP. 586-593.
-C
-C *** HISTORY ***
-C
-C DESIGNED AND CODED BY DAVID M. GAY (WINTER 1977/SUMMER 1978).
-C
-C *** GENERAL ***
-C
-C THIS SUBROUTINE WAS WRITTEN IN CONNECTION WITH RESEARCH
-C SUPPORTED BY THE NATIONAL SCIENCE FOUNDATION UNDER GRANTS
-C MCS-7600324, DCR75-10143, 76-14311DSS, AND MCS76-11989.
-C
-C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
-C
-C *** LOCAL VARIABLES ***
-C
- INTEGER I, IX, J, JI, JJ, JJJ, JM1, J0, PM1, PPLUS1
- DOUBLE PRECISION B, BLJI, SMINUS, SPLUS, T, YI
-C
-C *** CONSTANTS ***
-C
- DOUBLE PRECISION HALF, ONE, R9973, ZERO
-C
-C *** EXTERNAL FUNCTIONS AND SUBROUTINES ***
-C
- DOUBLE PRECISION DD7TPR, DV2NRM
- EXTERNAL DD7TPR, DV2NRM,DV2AXY
-C
-C/6
-C DATA HALF/0.5D+0/, ONE/1.D+0/, R9973/9973.D+0/, ZERO/0.D+0/
-C/7
- PARAMETER (HALF=0.5D+0, ONE=1.D+0, R9973=9973.D+0, ZERO=0.D+0)
-C/
-C
-C *** BODY ***
-C
- IX = 2
- PPLUS1 = P + 1
- PM1 = P - 1
-C
-C *** FIRST INITIALIZE X TO PARTIAL SUMS ***
-C
- J0 = P*PM1/2
- JJ = J0 + P
- IX = MOD(3432*IX, 9973)
- B = HALF*(ONE + FLOAT(IX)/R9973)
- X(P) = B * L(JJ)
- IF (P .LE. 1) GO TO 40
- DO 10 I = 1, PM1
- JI = J0 + I
- X(I) = B * L(JI)
- 10 CONTINUE
-C
-C *** COMPUTE X = (L**T)*B, WHERE THE COMPONENTS OF B HAVE RANDOMLY
-C *** CHOSEN MAGNITUDES IN (.5,1) WITH SIGNS CHOSEN TO MAKE X LARGE.
-C
-C DO J = P-1 TO 1 BY -1...
- DO 30 JJJ = 1, PM1
- J = P - JJJ
-C *** DETERMINE X(J) IN THIS ITERATION. NOTE FOR I = 1,2,...,J
-C *** THAT X(I) HOLDS THE CURRENT PARTIAL SUM FOR ROW I.
- IX = MOD(3432*IX, 9973)
- B = HALF*(ONE + FLOAT(IX)/R9973)
- JM1 = J - 1
- J0 = J*JM1/2
- SPLUS = ZERO
- SMINUS = ZERO
- DO 20 I = 1, J
- JI = J0 + I
- BLJI = B * L(JI)
- SPLUS = SPLUS + DABS(BLJI + X(I))
- SMINUS = SMINUS + DABS(BLJI - X(I))
- 20 CONTINUE
- IF (SMINUS .GT. SPLUS) B = -B
- X(J) = ZERO
-C *** UPDATE PARTIAL SUMS ***
- CALL DV2AXY(J, X, B, L(J0+1), X)
- 30 CONTINUE
-C
-C *** NORMALIZE X ***
-C
- 40 T = DV2NRM(P, X)
- IF (T .LE. ZERO) GO TO 80
- T = ONE / T
- DO 50 I = 1, P
- 50 X(I) = T*X(I)
-C
-C *** COMPUTE L*X = Y AND RETURN SVMAX = TWONORM(Y) ***
-C
- DO 60 JJJ = 1, P
- J = PPLUS1 - JJJ
- JI = J*(J-1)/2 + 1
- Y(J) = DD7TPR(J, L(JI), X)
- 60 CONTINUE
-C
-C *** NORMALIZE Y AND SET X = (L**T)*Y ***
-C
- T = ONE / DV2NRM(P, Y)
- JI = 1
- DO 70 I = 1, P
- YI = T * Y(I)
- X(I) = ZERO
- CALL DV2AXY(I, X, YI, L(JI), X)
- JI = JI + I
- 70 CONTINUE
- DL7SVX = DV2NRM(P, X)
- GO TO 999
-C
- 80 DL7SVX = ZERO
-C
- 999 RETURN
-C *** LAST CARD OF DL7SVX FOLLOWS ***
- END
diff --git a/CEP/PyBDSM/src/port3/dl7tsq.f b/CEP/PyBDSM/src/port3/dl7tsq.f
deleted file mode 100644
index 2eaeac8268203e904a09169cd65d65c51cb17775..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/dl7tsq.f
+++ /dev/null
@@ -1,36 +0,0 @@
- SUBROUTINE DL7TSQ(N, A, L)
-C
-C *** SET A TO LOWER TRIANGLE OF (L**T) * L ***
-C
-C *** L = N X N LOWER TRIANG. MATRIX STORED ROWWISE. ***
-C *** A IS ALSO STORED ROWWISE AND MAY SHARE STORAGE WITH L. ***
-C
- INTEGER N
- DOUBLE PRECISION A(1), L(1)
-C DIMENSION A(N*(N+1)/2), L(N*(N+1)/2)
-C
- INTEGER I, II, IIM1, I1, J, K, M
- DOUBLE PRECISION LII, LJ
-C
- II = 0
- DO 50 I = 1, N
- I1 = II + 1
- II = II + I
- M = 1
- IF (I .EQ. 1) GO TO 30
- IIM1 = II - 1
- DO 20 J = I1, IIM1
- LJ = L(J)
- DO 10 K = I1, J
- A(M) = A(M) + LJ*L(K)
- M = M + 1
- 10 CONTINUE
- 20 CONTINUE
- 30 LII = L(II)
- DO 40 J = I1, II
- 40 A(J) = LII * L(J)
- 50 CONTINUE
-C
- 999 RETURN
-C *** LAST CARD OF DL7TSQ FOLLOWS ***
- END
diff --git a/CEP/PyBDSM/src/port3/dl7tvm.f b/CEP/PyBDSM/src/port3/dl7tvm.f
deleted file mode 100644
index 4d47c6e923a1a3ed01f6f744efa7a6297393c91a..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/dl7tvm.f
+++ /dev/null
@@ -1,30 +0,0 @@
- SUBROUTINE DL7TVM(N, X, L, Y)
-C
-C *** COMPUTE X = (L**T)*Y, WHERE L IS AN N X N LOWER
-C *** TRIANGULAR MATRIX STORED COMPACTLY BY ROWS. X AND Y MAY
-C *** OCCUPY THE SAME STORAGE. ***
-C
- INTEGER N
- DOUBLE PRECISION X(N), L(1), Y(N)
-C DIMENSION L(N*(N+1)/2)
- INTEGER I, IJ, I0, J
- DOUBLE PRECISION YI, ZERO
-C/6
-C DATA ZERO/0.D+0/
-C/7
- PARAMETER (ZERO=0.D+0)
-C/
-C
- I0 = 0
- DO 20 I = 1, N
- YI = Y(I)
- X(I) = ZERO
- DO 10 J = 1, I
- IJ = I0 + J
- X(J) = X(J) + YI*L(IJ)
- 10 CONTINUE
- I0 = I0 + I
- 20 CONTINUE
- 999 RETURN
-C *** LAST CARD OF DL7TVM FOLLOWS ***
- END
diff --git a/CEP/PyBDSM/src/port3/dl7upd.f b/CEP/PyBDSM/src/port3/dl7upd.f
deleted file mode 100644
index fd9b08128969b9c0b8ba65302746b3631cbc7815..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/dl7upd.f
+++ /dev/null
@@ -1,142 +0,0 @@
- SUBROUTINE DL7UPD(BETA, GAMMA, L, LAMBDA, LPLUS, N, W, Z)
-C
-C *** COMPUTE LPLUS = SECANT UPDATE OF L ***
-C
-C *** PARAMETER DECLARATIONS ***
-C
- INTEGER N
- DOUBLE PRECISION BETA(N), GAMMA(N), L(1), LAMBDA(N), LPLUS(1),
- 1 W(N), Z(N)
-C DIMENSION L(N*(N+1)/2), LPLUS(N*(N+1)/2)
-C
-C-------------------------- PARAMETER USAGE --------------------------
-C
-C BETA = SCRATCH VECTOR.
-C GAMMA = SCRATCH VECTOR.
-C L (INPUT) LOWER TRIANGULAR MATRIX, STORED ROWWISE.
-C LAMBDA = SCRATCH VECTOR.
-C LPLUS (OUTPUT) LOWER TRIANGULAR MATRIX, STORED ROWWISE, WHICH MAY
-C OCCUPY THE SAME STORAGE AS L.
-C N (INPUT) LENGTH OF VECTOR PARAMETERS AND ORDER OF MATRICES.
-C W (INPUT, DESTROYED ON OUTPUT) RIGHT SINGULAR VECTOR OF RANK 1
-C CORRECTION TO L.
-C Z (INPUT, DESTROYED ON OUTPUT) LEFT SINGULAR VECTOR OF RANK 1
-C CORRECTION TO L.
-C
-C------------------------------- NOTES -------------------------------
-C
-C *** APPLICATION AND USAGE RESTRICTIONS ***
-C
-C THIS ROUTINE UPDATES THE CHOLESKY FACTOR L OF A SYMMETRIC
-C POSITIVE DEFINITE MATRIX TO WHICH A SECANT UPDATE IS BEING
-C APPLIED -- IT COMPUTES A CHOLESKY FACTOR LPLUS OF
-C L * (I + Z*W**T) * (I + W*Z**T) * L**T. IT IS ASSUMED THAT W
-C AND Z HAVE BEEN CHOSEN SO THAT THE UPDATED MATRIX IS STRICTLY
-C POSITIVE DEFINITE.
-C
-C *** ALGORITHM NOTES ***
-C
-C THIS CODE USES RECURRENCE 3 OF REF. 1 (WITH D(J) = 1 FOR ALL J)
-C TO COMPUTE LPLUS OF THE FORM L * (I + Z*W**T) * Q, WHERE Q
-C IS AN ORTHOGONAL MATRIX THAT MAKES THE RESULT LOWER TRIANGULAR.
-C LPLUS MAY HAVE SOME NEGATIVE DIAGONAL ELEMENTS.
-C
-C *** REFERENCES ***
-C
-C 1. GOLDFARB, D. (1976), FACTORIZED VARIABLE METRIC METHODS FOR UNCON-
-C STRAINED OPTIMIZATION, MATH. COMPUT. 30, PP. 796-811.
-C
-C *** GENERAL ***
-C
-C CODED BY DAVID M. GAY (FALL 1979).
-C THIS SUBROUTINE WAS WRITTEN IN CONNECTION WITH RESEARCH SUPPORTED
-C BY THE NATIONAL SCIENCE FOUNDATION UNDER GRANTS MCS-7600324 AND
-C MCS-7906671.
-C
-C------------------------ EXTERNAL QUANTITIES ------------------------
-C
-C *** INTRINSIC FUNCTIONS ***
-C/+
- DOUBLE PRECISION DSQRT
-C/
-C-------------------------- LOCAL VARIABLES --------------------------
-C
- INTEGER I, IJ, J, JJ, JP1, K, NM1, NP1
- DOUBLE PRECISION A, B, BJ, ETA, GJ, LJ, LIJ, LJJ, NU, S, THETA,
- 1 WJ, ZJ
- DOUBLE PRECISION ONE, ZERO
-C
-C *** DATA INITIALIZATIONS ***
-C
-C/6
-C DATA ONE/1.D+0/, ZERO/0.D+0/
-C/7
- PARAMETER (ONE=1.D+0, ZERO=0.D+0)
-C/
-C
-C+++++++++++++++++++++++++++++++ BODY ++++++++++++++++++++++++++++++++
-C
- NU = ONE
- ETA = ZERO
- IF (N .LE. 1) GO TO 30
- NM1 = N - 1
-C
-C *** TEMPORARILY STORE S(J) = SUM OVER K = J+1 TO N OF W(K)**2 IN
-C *** LAMBDA(J).
-C
- S = ZERO
- DO 10 I = 1, NM1
- J = N - I
- S = S + W(J+1)**2
- LAMBDA(J) = S
- 10 CONTINUE
-C
-C *** COMPUTE LAMBDA, GAMMA, AND BETA BY GOLDFARB*S RECURRENCE 3.
-C
- DO 20 J = 1, NM1
- WJ = W(J)
- A = NU*Z(J) - ETA*WJ
- THETA = ONE + A*WJ
- S = A*LAMBDA(J)
- LJ = DSQRT(THETA**2 + A*S)
- IF (THETA .GT. ZERO) LJ = -LJ
- LAMBDA(J) = LJ
- B = THETA*WJ + S
- GAMMA(J) = B * NU / LJ
- BETA(J) = (A - B*ETA) / LJ
- NU = -NU / LJ
- ETA = -(ETA + (A**2)/(THETA - LJ)) / LJ
- 20 CONTINUE
- 30 LAMBDA(N) = ONE + (NU*Z(N) - ETA*W(N))*W(N)
-C
-C *** UPDATE L, GRADUALLY OVERWRITING W AND Z WITH L*W AND L*Z.
-C
- NP1 = N + 1
- JJ = N * (N + 1) / 2
- DO 60 K = 1, N
- J = NP1 - K
- LJ = LAMBDA(J)
- LJJ = L(JJ)
- LPLUS(JJ) = LJ * LJJ
- WJ = W(J)
- W(J) = LJJ * WJ
- ZJ = Z(J)
- Z(J) = LJJ * ZJ
- IF (K .EQ. 1) GO TO 50
- BJ = BETA(J)
- GJ = GAMMA(J)
- IJ = JJ + J
- JP1 = J + 1
- DO 40 I = JP1, N
- LIJ = L(IJ)
- LPLUS(IJ) = LJ*LIJ + BJ*W(I) + GJ*Z(I)
- W(I) = W(I) + LIJ*WJ
- Z(I) = Z(I) + LIJ*ZJ
- IJ = IJ + I
- 40 CONTINUE
- 50 JJ = JJ - J
- 60 CONTINUE
-C
- 999 RETURN
-C *** LAST CARD OF DL7UPD FOLLOWS ***
- END
diff --git a/CEP/PyBDSM/src/port3/dl7vml.f b/CEP/PyBDSM/src/port3/dl7vml.f
deleted file mode 100644
index e69f4bccb1aa2fadfd49322125e01b7ba4fabba5..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/dl7vml.f
+++ /dev/null
@@ -1,32 +0,0 @@
- SUBROUTINE DL7VML(N, X, L, Y)
-C
-C *** COMPUTE X = L*Y, WHERE L IS AN N X N LOWER TRIANGULAR
-C *** MATRIX STORED COMPACTLY BY ROWS. X AND Y MAY OCCUPY THE SAME
-C *** STORAGE. ***
-C
- INTEGER N
- DOUBLE PRECISION X(N), L(1), Y(N)
-C DIMENSION L(N*(N+1)/2)
- INTEGER I, II, IJ, I0, J, NP1
- DOUBLE PRECISION T, ZERO
-C/6
-C DATA ZERO/0.D+0/
-C/7
- PARAMETER (ZERO=0.D+0)
-C/
-C
- NP1 = N + 1
- I0 = N*(N+1)/2
- DO 20 II = 1, N
- I = NP1 - II
- I0 = I0 - I
- T = ZERO
- DO 10 J = 1, I
- IJ = I0 + J
- T = T + L(IJ)*Y(J)
- 10 CONTINUE
- X(I) = T
- 20 CONTINUE
- 999 RETURN
-C *** LAST CARD OF DL7VML FOLLOWS ***
- END
diff --git a/CEP/PyBDSM/src/port3/dmnf.f b/CEP/PyBDSM/src/port3/dmnf.f
deleted file mode 100644
index 6db89dc8a40606a592ad6132ff16beb9ce91cc4d..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/dmnf.f
+++ /dev/null
@@ -1,97 +0,0 @@
- SUBROUTINE DMNF(N, D, X, CALCF, IV, LIV, LV, V,
- 1 UIPARM, URPARM, UFPARM)
-C
-C *** MINIMIZE GENERAL UNCONSTRAINED OBJECTIVE FUNCTION USING
-C *** FINITE-DIFFERENCE GRADIENTS AND SECANT HESSIAN APPROXIMATIONS.
-C
- INTEGER N, LIV, LV
- INTEGER IV(LIV), UIPARM(1)
- DOUBLE PRECISION D(N), X(N), V(LV), URPARM(1)
-C DIMENSION V(77 + N*(N+17)/2), UIPARM(*), URPARM(*)
- EXTERNAL CALCF, UFPARM
-C
-C *** PURPOSE ***
-C
-C THIS ROUTINE INTERACTS WITH SUBROUTINE DRMNF IN AN ATTEMPT
-C TO FIND AN N-VECTOR X* THAT MINIMIZES THE (UNCONSTRAINED)
-C OBJECTIVE FUNCTION COMPUTED BY CALCF. (OFTEN THE X* FOUND IS
-C A LOCAL MINIMIZER RATHER THAN A GLOBAL ONE.)
-C
-C *** PARAMETERS ***
-C
-C THE PARAMETERS FOR DMNF ARE THE SAME AS THOSE FOR DMNG
-C (WHICH SEE), EXCEPT THAT CALCG IS OMITTED. INSTEAD OF CALLING
-C CALCG TO OBTAIN THE GRADIENT OF THE OBJECTIVE FUNCTION AT X,
-C DMNF CALLS DS7GRD, WHICH COMPUTES AN APPROXIMATION TO THE
-C GRADIENT BY FINITE (FORWARD AND CENTRAL) DIFFERENCES USING THE
-C METHOD OF REF. 1. THE FOLLOWING INPUT COMPONENT IS OF INTEREST
-C IN THIS REGARD (AND IS NOT DESCRIBED IN DMNG).
-C
-C V(ETA0)..... V(42) IS AN ESTIMATED BOUND ON THE RELATIVE ERROR IN THE
-C OBJECTIVE FUNCTION VALUE COMPUTED BY CALCF...
-C (TRUE VALUE) = (COMPUTED VALUE) * (1 + E),
-C WHERE ABS(E) .LE. V(ETA0). DEFAULT = MACHEP * 10**3,
-C WHERE MACHEP IS THE UNIT ROUNDOFF.
-C
-C THE OUTPUT VALUES IV(NFCALL) AND IV(NGCALL) HAVE DIFFERENT
-C MEANINGS FOR DMNF THAN FOR DMNG...
-C
-C IV(NFCALL)... IV(6) IS THE NUMBER OF CALLS SO FAR MADE ON CALCF (I.E.,
-C FUNCTION EVALUATIONS) EXCLUDING THOSE MADE ONLY FOR
-C COMPUTING GRADIENTS. THE INPUT VALUE IV(MXFCAL) IS A
-C LIMIT ON IV(NFCALL).
-C IV(NGCALL)... IV(30) IS THE NUMBER OF FUNCTION EVALUATIONS MADE ONLY
-C FOR COMPUTING GRADIENTS. THE TOTAL NUMBER OF FUNCTION
-C EVALUATIONS IS THUS IV(NFCALL) + IV(NGCALL).
-C
-C *** REFERENCE ***
-C
-C 1. STEWART, G.W. (1967), A MODIFICATION OF DAVIDON*S MINIMIZATION
-C METHOD TO ACCEPT DIFFERENCE APPROXIMATIONS OF DERIVATIVES,
-C J. ASSOC. COMPUT. MACH. 14, PP. 72-83.
-C.
-C *** GENERAL ***
-C
-C CODED BY DAVID M. GAY (WINTER 1980). REVISED SEPT. 1982.
-C THIS SUBROUTINE WAS WRITTEN IN CONNECTION WITH RESEARCH
-C SUPPORTED IN PART BY THE NATIONAL SCIENCE FOUNDATION UNDER
-C GRANTS MCS-7600324, DCR75-10143, 76-14311DSS, MCS76-11989,
-C AND MCS-7906671.
-C
-C
-C---------------------------- DECLARATIONS ---------------------------
-C
- EXTERNAL DRMNF
-C
-C DRMNF.... OVERSEES COMPUTATION OF FINITE-DIFFERENCE GRADIENT AND
-C CALLS DRMNG TO CARRY OUT DMNG ALGORITHM.
-C
- INTEGER NF
- DOUBLE PRECISION FX
-C
-C *** SUBSCRIPTS FOR IV ***
-C
- INTEGER NFCALL, TOOBIG
-C
-C/6
-C DATA NFCALL/6/, TOOBIG/2/
-C/7
- PARAMETER (NFCALL=6, TOOBIG=2)
-C/
-C
-C+++++++++++++++++++++++++++++++ BODY ++++++++++++++++++++++++++++++++
-C
- 10 CALL DRMNF(D, FX, IV, LIV, LV, N, V, X)
- IF (IV(1) .GT. 2) GO TO 999
-C
-C *** COMPUTE FUNCTION ***
-C
- NF = IV(NFCALL)
- CALL CALCF(N, X, NF, FX, UIPARM, URPARM, UFPARM)
- IF (NF .LE. 0) IV(TOOBIG) = 1
- GO TO 10
-C
-C
- 999 RETURN
-C *** LAST CARD OF DMNF FOLLOWS ***
- END
diff --git a/CEP/PyBDSM/src/port3/dmnfb.f b/CEP/PyBDSM/src/port3/dmnfb.f
deleted file mode 100644
index 307a56676ce7a70508a0c74266cc119a9b81e7f8..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/dmnfb.f
+++ /dev/null
@@ -1,102 +0,0 @@
- SUBROUTINE DMNFB(P, D, X, B, CALCF, IV, LIV, LV, V,
- 1 UIPARM, URPARM, UFPARM)
-C
-C *** MINIMIZE GENERAL UNCONSTRAINED OBJECTIVE FUNCTION USING
-C *** FINITE-DIFFERENCE GRADIENTS AND SECANT HESSIAN APPROXIMATIONS.
-C
- INTEGER P, LIV, LV
-C/6S
-C INTEGER IV(LIV), UIPARM(1)
-C DOUBLE PRECISION B(2,P), D(P), X(P), V(LV), URPARM(1)
-C/7S
- INTEGER IV(LIV), UIPARM(*)
- DOUBLE PRECISION B(2,P), D(P), X(P), V(LV), URPARM(*)
-C/
-C DIMENSION V(59 + P), V(77 + P*(P+23)/2), UIPARM(*), URPARM(*)
- EXTERNAL CALCF, UFPARM
-C
-C *** PURPOSE ***
-C
-C THIS ROUTINE INTERACTS WITH SUBROUTINE DRMNF IN AN ATTEMPT
-C TO FIND AN P-VECTOR X* THAT MINIMIZES THE (UNCONSTRAINED)
-C OBJECTIVE FUNCTION COMPUTED BY CALCF. (OFTEN THE X* FOUND IS
-C A LOCAL MINIMIZER RATHER THAN A GLOBAL ONE.)
-C
-C *** PARAMETERS ***
-C
-C THE PARAMETERS FOR DMNFB ARE THE SAME AS THOSE FOR DMNGB
-C (WHICH SEE), EXCEPT THAT CALCG IS OMITTED. INSTEAD OF CALLING
-C CALCG TO OBTAIN THE GRADIENT OF THE OBJECTIVE FUNCTION AT X,
-C DMNFB CALLS DS3GRD, WHICH COMPUTES AN APPROXIMATION TO THE
-C GRADIENT BY FINITE (FORWARD AND CENTRAL) DIFFERENCES USING THE
-C METHOD OF REF. 1. THE FOLLOWING INPUT COMPONENT IS OF INTEREST
-C IN THIS REGARD (AND IS NOT DESCRIBED IN DMNG OR DMNGB).
-C
-C V(ETA0)..... V(42) IS AN ESTIMATED BOUND ON THE RELATIVE ERROR IN THE
-C OBJECTIVE FUNCTION VALUE COMPUTED BY CALCF...
-C (TRUE VALUE) = (COMPUTED VALUE) * (1 + E),
-C WHERE ABS(E) .LE. V(ETA0). DEFAULT = MACHEP * 10**3,
-C WHERE MACHEP IS THE UNIT ROUNDOFF.
-C
-C THE OUTPUT VALUES IV(NFCALL) AND IV(NGCALL) HAVE DIFFERENT
-C MEANINGS FOR DMNFB THAN FOR DMNG...
-C
-C IV(NFCALL)... IV(6) IS THE NUMBER OF CALLS SO FAR MADE ON CALCF (I.E.,
-C FUNCTION EVALUATIONS) EXCLUDING THOSE MADE ONLY FOR
-C COMPUTING GRADIENTS. THE INPUT VALUE IV(MXFCAL) IS A
-C LIMIT ON IV(NFCALL).
-C IV(NGCALL)... IV(30) IS THE NUMBER OF FUNCTION EVALUATIONS MADE ONLY
-C FOR COMPUTING GRADIENTS. THE TOTAL NUMBER OF FUNCTION
-C EVALUATIONS IS THUS IV(NFCALL) + IV(NGCALL).
-C
-C *** REFERENCE ***
-C
-C 1. STEWART, G.W. (1967), A MODIFICATION OF DAVIDON*S MINIMIZATION
-C METHOD TO ACCEPT DIFFERENCE APPROXIMATIONS OF DERIVATIVES,
-C J. ASSOC. COMPUT. MACH. 14, PP. 72-83.
-C.
-C *** GENERAL ***
-C
-C CODED BY DAVID M. GAY (WINTER 1980). REVISED SEPT. 1982.
-C THIS SUBROUTINE WAS WRITTEN IN CONNECTION WITH RESEARCH
-C SUPPORTED IN PART BY THE NATIONAL SCIENCE FOUNDATION UNDER
-C GRANTS MCS-7600324, DCR75-10143, 76-14311DSS, MCS76-11989,
-C AND MCS-7906671.
-C
-C
-C---------------------------- DECLARATIONS ---------------------------
-C
- EXTERNAL DRMNFB
-C
-C DRMNFB... OVERSEES COMPUTATION OF FINITE-DIFFERENCE GRADIENT AND
-C CALLS DRMNG TO CARRY OUT DMNG ALGORITHM.
-C
- INTEGER NF
- DOUBLE PRECISION FX
-C
-C *** SUBSCRIPTS FOR IV ***
-C
- INTEGER NFCALL, TOOBIG
-C
-C/6
-C DATA NFCALL/6/, TOOBIG/2/
-C/7
- PARAMETER (NFCALL=6, TOOBIG=2)
-C/
-C
-C+++++++++++++++++++++++++++++++ BODY ++++++++++++++++++++++++++++++++
-C
- 10 CALL DRMNFB(B, D, FX, IV, LIV, LV, P, V, X)
- IF (IV(1) .GT. 2) GO TO 999
-C
-C *** COMPUTE FUNCTION ***
-C
- NF = IV(NFCALL)
- CALL CALCF(P, X, NF, FX, UIPARM, URPARM, UFPARM)
- IF (NF .LE. 0) IV(TOOBIG) = 1
- GO TO 10
-C
-C
- 999 RETURN
-C *** LAST CARD OF DMNFB FOLLOWS ***
- END
diff --git a/CEP/PyBDSM/src/port3/dmng.f b/CEP/PyBDSM/src/port3/dmng.f
deleted file mode 100644
index a0b80ea8c2600305b711c3bca65b46cc843731d1..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/dmng.f
+++ /dev/null
@@ -1,481 +0,0 @@
- SUBROUTINE DMNG(N, D, X, CALCF, CALCG, IV, LIV, LV, V,
- 1 UIPARM, URPARM, UFPARM)
-C
-C *** MINIMIZE GENERAL UNCONSTRAINED OBJECTIVE FUNCTION USING ***
-C *** ANALYTIC GRADIENT AND HESSIAN APPROX. FROM SECANT UPDATE ***
-C
- INTEGER N, LIV, LV
- INTEGER IV(LIV), UIPARM(1)
- DOUBLE PRECISION D(N), X(N), V(LV), URPARM(1)
-C DIMENSION V(71 + N*(N+15)/2), UIPARM(*), URPARM(*)
- EXTERNAL CALCF, CALCG, UFPARM
-C
-C *** PURPOSE ***
-C
-C THIS ROUTINE INTERACTS WITH SUBROUTINE DRMNG IN AN ATTEMPT
-C TO FIND AN N-VECTOR X* THAT MINIMIZES THE (UNCONSTRAINED)
-C OBJECTIVE FUNCTION COMPUTED BY CALCF. (OFTEN THE X* FOUND IS
-C A LOCAL MINIMIZER RATHER THAN A GLOBAL ONE.)
-C
-C-------------------------- PARAMETER USAGE --------------------------
-C
-C N........ (INPUT) THE NUMBER OF VARIABLES ON WHICH F DEPENDS, I.E.,
-C THE NUMBER OF COMPONENTS IN X.
-C D........ (INPUT/OUTPUT) A SCALE VECTOR SUCH THAT D(I)*X(I),
-C I = 1,2,...,N, ARE ALL IN COMPARABLE UNITS.
-C D CAN STRONGLY AFFECT THE BEHAVIOR OF DMNG.
-C FINDING THE BEST CHOICE OF D IS GENERALLY A TRIAL-
-C AND-ERROR PROCESS. CHOOSING D SO THAT D(I)*X(I)
-C HAS ABOUT THE SAME VALUE FOR ALL I OFTEN WORKS WELL.
-C THE DEFAULTS PROVIDED BY SUBROUTINE DIVSET (SEE IV
-C BELOW) REQUIRE THE CALLER TO SUPPLY D.
-C X........ (INPUT/OUTPUT) BEFORE (INITIALLY) CALLING DMNG, THE CALL-
-C ER SHOULD SET X TO AN INITIAL GUESS AT X*. WHEN
-C DMNG RETURNS, X CONTAINS THE BEST POINT SO FAR
-C FOUND, I.E., THE ONE THAT GIVES THE LEAST VALUE SO
-C FAR SEEN FOR F(X).
-C CALCF.... (INPUT) A SUBROUTINE THAT, GIVEN X, COMPUTES F(X). CALCF
-C MUST BE DECLARED EXTERNAL IN THE CALLING PROGRAM.
-C IT IS INVOKED BY
-C CALL CALCF(N, X, NF, F, UIPARM, URPARM, UFPARM)
-C WHEN CALCF IS CALLED, NF IS THE INVOCATION
-C COUNT FOR CALCF. NF IS INCLUDED FOR POSSIBLE USE
-C WITH CALCG. IF X IS OUT OF BOUNDS (E.G., IF IT
-C WOULD CAUSE OVERFLOW IN COMPUTING F(X)), THEN CALCF
-C SHOULD SET NF TO 0. THIS WILL CAUSE A SHORTER STEP
-C TO BE ATTEMPTED. (IF X IS IN BOUNDS, THEN CALCF
-C SHOULD NOT CHANGE NF.) THE OTHER PARAMETERS ARE AS
-C DESCRIBED ABOVE AND BELOW. CALCF SHOULD NOT CHANGE
-C N, P, OR X.
-C CALCG.... (INPUT) A SUBROUTINE THAT, GIVEN X, COMPUTES G(X), THE GRA-
-C DIENT OF F AT X. CALCG MUST BE DECLARED EXTERNAL IN
-C THE CALLING PROGRAM. IT IS INVOKED BY
-C CALL CALCG(N, X, NF, G, UIPARM, URPARM, UFAPRM)
-C WHEN CALCG IS CALLED, NF IS THE INVOCATION
-C COUNT FOR CALCF AT THE TIME F(X) WAS EVALUATED. THE
-C X PASSED TO CALCG IS USUALLY THE ONE PASSED TO CALCF
-C ON EITHER ITS MOST RECENT INVOCATION OR THE ONE
-C PRIOR TO IT. IF CALCF SAVES INTERMEDIATE RESULTS
-C FOR _USE_ BY CALCG, THEN IT IS POSSIBLE TO TELL FROM
-C NF WHETHER THEY ARE VALID FOR THE CURRENT X (OR
-C WHICH COPY IS VALID IF TWO COPIES ARE KEPT). IF G
-C CANNOT BE COMPUTED AT X, THEN CALCG SHOULD SET NF TO
-C 0. IN THIS CASE, DMNG WILL RETURN WITH IV(1) = 65.
-C (IF G CAN BE COMPUTED AT X, THEN CALCG SHOULD NOT
-C CHANGED NF.) THE OTHER PARAMETERS TO CALCG ARE AS
-C DESCRIBED ABOVE AND BELOW. CALCG SHOULD NOT CHANGE
-C N OR X.
-C IV....... (INPUT/OUTPUT) AN INTEGER VALUE ARRAY OF LENGTH LIV (SEE
-C BELOW) THAT HELPS CONTROL THE DMNG ALGORITHM AND
-C THAT IS USED TO STORE VARIOUS INTERMEDIATE QUANTI-
-C TIES. OF PARTICULAR INTEREST ARE THE INITIALIZATION/
-C RETURN CODE IV(1) AND THE ENTRIES IN IV THAT CONTROL
-C PRINTING AND LIMIT THE NUMBER OF ITERATIONS AND FUNC-
-C TION EVALUATIONS. SEE THE SECTION ON IV INPUT
-C VALUES BELOW.
-C LIV...... (INPUT) LENGTH OF IV ARRAY. MUST BE AT LEAST 60. IF LIV
-C IS TOO SMALL, THEN DMNG RETURNS WITH IV(1) = 15.
-C WHEN DMNG RETURNS, THE SMALLEST ALLOWED VALUE OF
-C LIV IS STORED IN IV(LASTIV) -- SEE THE SECTION ON
-C IV OUTPUT VALUES BELOW. (THIS IS INTENDED FOR USE
-C WITH EXTENSIONS OF DMNG THAT HANDLE CONSTRAINTS.)
-C LV....... (INPUT) LENGTH OF V ARRAY. MUST BE AT LEAST 71+N*(N+15)/2.
-C (AT LEAST 77+N*(N+17)/2 FOR DMNF, AT LEAST
-C 78+N*(N+12) FOR DMNH). IF LV IS TOO SMALL, THEN
-C DMNG RETURNS WITH IV(1) = 16. WHEN DMNG RETURNS,
-C THE SMALLEST ALLOWED VALUE OF LV IS STORED IN
-C IV(LASTV) -- SEE THE SECTION ON IV OUTPUT VALUES
-C BELOW.
-C V........ (INPUT/OUTPUT) A FLOATING-POINT VALUE ARRAY OF LENGTH LV
-C (SEE BELOW) THAT HELPS CONTROL THE DMNG ALGORITHM
-C AND THAT IS USED TO STORE VARIOUS INTERMEDIATE
-C QUANTITIES. OF PARTICULAR INTEREST ARE THE ENTRIES
-C IN V THAT LIMIT THE LENGTH OF THE FIRST STEP
-C ATTEMPTED (LMAX0) AND SPECIFY CONVERGENCE TOLERANCES
-C (AFCTOL, LMAXS, RFCTOL, SCTOL, XCTOL, XFTOL).
-C UIPARM... (INPUT) USER INTEGER PARAMETER ARRAY PASSED WITHOUT CHANGE
-C TO CALCF AND CALCG.
-C URPARM... (INPUT) USER FLOATING-POINT PARAMETER ARRAY PASSED WITHOUT
-C CHANGE TO CALCF AND CALCG.
-C UFPARM... (INPUT) USER EXTERNAL SUBROUTINE OR FUNCTION PASSED WITHOUT
-C CHANGE TO CALCF AND CALCG.
-C
-C *** IV INPUT VALUES (FROM SUBROUTINE DIVSET) ***
-C
-C IV(1)... ON INPUT, IV(1) SHOULD HAVE A VALUE BETWEEN 0 AND 14......
-C 0 AND 12 MEAN THIS IS A FRESH START. 0 MEANS THAT
-C DIVSET(2, IV, LIV, LV, V)
-C IS TO BE CALLED TO PROVIDE ALL DEFAULT VALUES TO IV AND
-C V. 12 (THE VALUE THAT DIVSET ASSIGNS TO IV(1)) MEANS THE
-C CALLER HAS ALREADY CALLED DIVSET AND HAS POSSIBLY CHANGED
-C SOME IV AND/OR V ENTRIES TO NON-DEFAULT VALUES.
-C 13 MEANS DIVSET HAS BEEN CALLED AND THAT DMNG (AND
-C DRMNG) SHOULD ONLY DO THEIR STORAGE ALLOCATION. THAT IS,
-C THEY SHOULD SET THE OUTPUT COMPONENTS OF IV THAT TELL
-C WHERE VARIOUS SUBARRAYS ARRAYS OF V BEGIN, SUCH AS IV(G)
-C (AND, FOR DMNH AND DRMNH ONLY, IV(DTOL)), AND RETURN.
-C 14 MEANS THAT A STORAGE HAS BEEN ALLOCATED (BY A CALL
-C WITH IV(1) = 13) AND THAT THE ALGORITHM SHOULD BE
-C STARTED. WHEN CALLED WITH IV(1) = 13, DMNG RETURNS
-C IV(1) = 14 UNLESS LIV OR LV IS TOO SMALL (OR N IS NOT
-C POSITIVE). DEFAULT = 12.
-C IV(INITH).... IV(25) TELLS WHETHER THE HESSIAN APPROXIMATION H SHOULD
-C BE INITIALIZED. 1 (THE DEFAULT) MEANS DRMNG SHOULD
-C INITIALIZE H TO THE DIAGONAL MATRIX WHOSE I-TH DIAGONAL
-C ELEMENT IS D(I)**2. 0 MEANS THE CALLER HAS SUPPLIED A
-C CHOLESKY FACTOR L OF THE INITIAL HESSIAN APPROXIMATION
-C H = L*(L**T) IN V, STARTING AT V(IV(LMAT)) = V(IV(42))
-C (AND STORED COMPACTLY BY ROWS). NOTE THAT IV(LMAT) MAY
-C BE INITIALIZED BY CALLING DMNG WITH IV(1) = 13 (SEE
-C THE IV(1) DISCUSSION ABOVE). DEFAULT = 1.
-C IV(MXFCAL)... IV(17) GIVES THE MAXIMUM NUMBER OF FUNCTION EVALUATIONS
-C (CALLS ON CALCF) ALLOWED. IF THIS NUMBER DOES NOT SUF-
-C FICE, THEN DMNG RETURNS WITH IV(1) = 9. DEFAULT = 200.
-C IV(MXITER)... IV(18) GIVES THE MAXIMUM NUMBER OF ITERATIONS ALLOWED.
-C IT ALSO INDIRECTLY LIMITS THE NUMBER OF GRADIENT EVALUA-
-C TIONS (CALLS ON CALCG) TO IV(MXITER) + 1. IF IV(MXITER)
-C ITERATIONS DO NOT SUFFICE, THEN DMNG RETURNS WITH
-C IV(1) = 10. DEFAULT = 150.
-C IV(OUTLEV)... IV(19) CONTROLS THE NUMBER AND LENGTH OF ITERATION SUM-
-C MARY LINES PRINTED (BY DITSUM). IV(OUTLEV) = 0 MEANS DO
-C NOT PRINT ANY SUMMARY LINES. OTHERWISE, PRINT A SUMMARY
-C LINE AFTER EACH ABS(IV(OUTLEV)) ITERATIONS. IF IV(OUTLEV)
-C IS POSITIVE, THEN SUMMARY LINES OF LENGTH 78 (PLUS CARRI-
-C AGE CONTROL) ARE PRINTED, INCLUDING THE FOLLOWING... THE
-C ITERATION AND FUNCTION EVALUATION COUNTS, F = THE CURRENT
-C FUNCTION VALUE, RELATIVE DIFFERENCE IN FUNCTION VALUES
-C ACHIEVED BY THE LATEST STEP (I.E., RELDF = (F0-V(F))/F01,
-C WHERE F01 IS THE MAXIMUM OF ABS(V(F)) AND ABS(V(F0)) AND
-C V(F0) IS THE FUNCTION VALUE FROM THE PREVIOUS ITERA-
-C TION), THE RELATIVE FUNCTION REDUCTION PREDICTED FOR THE
-C STEP JUST TAKEN (I.E., PRELDF = V(PREDUC) / F01, WHERE
-C V(PREDUC) IS DESCRIBED BELOW), THE SCALED RELATIVE CHANGE
-C IN X (SEE V(RELDX) BELOW), THE STEP PARAMETER FOR THE
-C STEP JUST TAKEN (STPPAR = 0 MEANS A FULL NEWTON STEP,
-C BETWEEN 0 AND 1 MEANS A RELAXED NEWTON STEP, BETWEEN 1
-C AND 2 MEANS A DOUBLE DOGLEG STEP, GREATER THAN 2 MEANS
-C A SCALED DOWN CAUCHY STEP -- SEE SUBROUTINE DBLDOG), THE
-C 2-NORM OF THE SCALE VECTOR D TIMES THE STEP JUST TAKEN
-C (SEE V(DSTNRM) BELOW), AND NPRELDF, I.E.,
-C V(NREDUC)/F01, WHERE V(NREDUC) IS DESCRIBED BELOW -- IF
-C NPRELDF IS POSITIVE, THEN IT IS THE RELATIVE FUNCTION
-C REDUCTION PREDICTED FOR A NEWTON STEP (ONE WITH
-C STPPAR = 0). IF NPRELDF IS NEGATIVE, THEN IT IS THE
-C NEGATIVE OF THE RELATIVE FUNCTION REDUCTION PREDICTED
-C FOR A STEP COMPUTED WITH STEP BOUND V(LMAXS) FOR _USE_ IN
-C TESTING FOR SINGULAR CONVERGENCE.
-C IF IV(OUTLEV) IS NEGATIVE, THEN LINES OF LENGTH 50
-C ARE PRINTED, INCLUDING ONLY THE FIRST 6 ITEMS LISTED
-C ABOVE (THROUGH RELDX).
-C DEFAULT = 1.
-C IV(PARPRT)... IV(20) = 1 MEANS PRINT ANY NONDEFAULT V VALUES ON A
-C FRESH START OR ANY CHANGED V VALUES ON A RESTART.
-C IV(PARPRT) = 0 MEANS SKIP THIS PRINTING. DEFAULT = 1.
-C IV(PRUNIT)... IV(21) IS THE OUTPUT UNIT NUMBER ON WHICH ALL PRINTING
-C IS DONE. IV(PRUNIT) = 0 MEANS SUPPRESS ALL PRINTING.
-C DEFAULT = STANDARD OUTPUT UNIT (UNIT 6 ON MOST SYSTEMS).
-C IV(SOLPRT)... IV(22) = 1 MEANS PRINT OUT THE VALUE OF X RETURNED (AS
-C WELL AS THE GRADIENT AND THE SCALE VECTOR D).
-C IV(SOLPRT) = 0 MEANS SKIP THIS PRINTING. DEFAULT = 1.
-C IV(STATPR)... IV(23) = 1 MEANS PRINT SUMMARY STATISTICS UPON RETURN-
-C ING. THESE CONSIST OF THE FUNCTION VALUE, THE SCALED
-C RELATIVE CHANGE IN X CAUSED BY THE MOST RECENT STEP (SEE
-C V(RELDX) BELOW), THE NUMBER OF FUNCTION AND GRADIENT
-C EVALUATIONS (CALLS ON CALCF AND CALCG), AND THE RELATIVE
-C FUNCTION REDUCTIONS PREDICTED FOR THE LAST STEP TAKEN AND
-C FOR A NEWTON STEP (OR PERHAPS A STEP BOUNDED BY V(LMAXS)
-C -- SEE THE DESCRIPTIONS OF PRELDF AND NPRELDF UNDER
-C IV(OUTLEV) ABOVE).
-C IV(STATPR) = 0 MEANS SKIP THIS PRINTING.
-C IV(STATPR) = -1 MEANS SKIP THIS PRINTING AS WELL AS THAT
-C OF THE ONE-LINE TERMINATION REASON MESSAGE. DEFAULT = 1.
-C IV(X0PRT).... IV(24) = 1 MEANS PRINT THE INITIAL X AND SCALE VECTOR D
-C (ON A FRESH START ONLY). IV(X0PRT) = 0 MEANS SKIP THIS
-C PRINTING. DEFAULT = 1.
-C
-C *** (SELECTED) IV OUTPUT VALUES ***
-C
-C IV(1)........ ON OUTPUT, IV(1) IS A RETURN CODE....
-C 3 = X-CONVERGENCE. THE SCALED RELATIVE DIFFERENCE (SEE
-C V(RELDX)) BETWEEN THE CURRENT PARAMETER VECTOR X AND
-C A LOCALLY OPTIMAL PARAMETER VECTOR IS VERY LIKELY AT
-C MOST V(XCTOL).
-C 4 = RELATIVE FUNCTION CONVERGENCE. THE RELATIVE DIFFER-
-C ENCE BETWEEN THE CURRENT FUNCTION VALUE AND ITS LO-
-C CALLY OPTIMAL VALUE IS VERY LIKELY AT MOST V(RFCTOL).
-C 5 = BOTH X- AND RELATIVE FUNCTION CONVERGENCE (I.E., THE
-C CONDITIONS FOR IV(1) = 3 AND IV(1) = 4 BOTH HOLD).
-C 6 = ABSOLUTE FUNCTION CONVERGENCE. THE CURRENT FUNCTION
-C VALUE IS AT MOST V(AFCTOL) IN ABSOLUTE VALUE.
-C 7 = SINGULAR CONVERGENCE. THE HESSIAN NEAR THE CURRENT
-C ITERATE APPEARS TO BE SINGULAR OR NEARLY SO, AND A
-C STEP OF LENGTH AT MOST V(LMAXS) IS UNLIKELY TO YIELD
-C A RELATIVE FUNCTION DECREASE OF MORE THAN V(SCTOL).
-C 8 = FALSE CONVERGENCE. THE ITERATES APPEAR TO BE CONVERG-
-C ING TO A NONCRITICAL POINT. THIS MAY MEAN THAT THE
-C CONVERGENCE TOLERANCES (V(AFCTOL), V(RFCTOL),
-C V(XCTOL)) ARE TOO SMALL FOR THE ACCURACY TO WHICH
-C THE FUNCTION AND GRADIENT ARE BEING COMPUTED, THAT
-C THERE IS AN ERROR IN COMPUTING THE GRADIENT, OR THAT
-C THE FUNCTION OR GRADIENT IS DISCONTINUOUS NEAR X.
-C 9 = FUNCTION EVALUATION LIMIT REACHED WITHOUT OTHER CON-
-C VERGENCE (SEE IV(MXFCAL)).
-C 10 = ITERATION LIMIT REACHED WITHOUT OTHER CONVERGENCE
-C (SEE IV(MXITER)).
-C 11 = STOPX RETURNED .TRUE. (EXTERNAL INTERRUPT). SEE THE
-C USAGE NOTES BELOW.
-C 14 = STORAGE HAS BEEN ALLOCATED (AFTER A CALL WITH
-C IV(1) = 13).
-C 17 = RESTART ATTEMPTED WITH N CHANGED.
-C 18 = D HAS A NEGATIVE COMPONENT AND IV(DTYPE) .LE. 0.
-C 19...43 = V(IV(1)) IS OUT OF RANGE.
-C 63 = F(X) CANNOT BE COMPUTED AT THE INITIAL X.
-C 64 = BAD PARAMETERS PASSED TO ASSESS (WHICH SHOULD NOT
-C OCCUR).
-C 65 = THE GRADIENT COULD NOT BE COMPUTED AT X (SEE CALCG
-C ABOVE).
-C 67 = BAD FIRST PARAMETER TO DIVSET.
-C 80 = IV(1) WAS OUT OF RANGE.
-C 81 = N IS NOT POSITIVE.
-C IV(G)........ IV(28) IS THE STARTING SUBSCRIPT IN V OF THE CURRENT
-C GRADIENT VECTOR (THE ONE CORRESPONDING TO X).
-C IV(LASTIV)... IV(44) IS THE LEAST ACCEPTABLE VALUE OF LIV. (IT IS
-C ONLY SET IF LIV IS AT LEAST 44.)
-C IV(LASTV).... IV(45) IS THE LEAST ACCEPTABLE VALUE OF LV. (IT IS
-C ONLY SET IF LIV IS LARGE ENOUGH, AT LEAST IV(LASTIV).)
-C IV(NFCALL)... IV(6) IS THE NUMBER OF CALLS SO FAR MADE ON CALCF (I.E.,
-C FUNCTION EVALUATIONS).
-C IV(NGCALL)... IV(30) IS THE NUMBER OF GRADIENT EVALUATIONS (CALLS ON
-C CALCG).
-C IV(NITER).... IV(31) IS THE NUMBER OF ITERATIONS PERFORMED.
-C
-C *** (SELECTED) V INPUT VALUES (FROM SUBROUTINE DIVSET) ***
-C
-C V(BIAS)..... V(43) IS THE BIAS PARAMETER USED IN SUBROUTINE DBLDOG --
-C SEE THAT SUBROUTINE FOR DETAILS. DEFAULT = 0.8.
-C V(AFCTOL)... V(31) IS THE ABSOLUTE FUNCTION CONVERGENCE TOLERANCE.
-C IF DMNG FINDS A POINT WHERE THE FUNCTION VALUE IS LESS
-C THAN V(AFCTOL) IN ABSOLUTE VALUE, AND IF DMNG DOES NOT
-C RETURN WITH IV(1) = 3, 4, OR 5, THEN IT RETURNS WITH
-C IV(1) = 6. THIS TEST CAN BE TURNED OFF BY SETTING
-C V(AFCTOL) TO ZERO. DEFAULT = MAX(10**-20, MACHEP**2),
-C WHERE MACHEP IS THE UNIT ROUNDOFF.
-C V(DINIT).... V(38), IF NONNEGATIVE, IS THE VALUE TO WHICH THE SCALE
-C VECTOR D IS INITIALIZED. DEFAULT = -1.
-C V(LMAX0).... V(35) GIVES THE MAXIMUM 2-NORM ALLOWED FOR D TIMES THE
-C VERY FIRST STEP THAT DMNG ATTEMPTS. THIS PARAMETER CAN
-C MARKEDLY AFFECT THE PERFORMANCE OF DMNG.
-C V(LMAXS).... V(36) IS USED IN TESTING FOR SINGULAR CONVERGENCE -- IF
-C THE FUNCTION REDUCTION PREDICTED FOR A STEP OF LENGTH
-C BOUNDED BY V(LMAXS) IS AT MOST V(SCTOL) * ABS(F0), WHERE
-C F0 IS THE FUNCTION VALUE AT THE START OF THE CURRENT
-C ITERATION, AND IF DMNG DOES NOT RETURN WITH IV(1) = 3,
-C 4, 5, OR 6, THEN IT RETURNS WITH IV(1) = 7. DEFAULT = 1.
-C V(RFCTOL)... V(32) IS THE RELATIVE FUNCTION CONVERGENCE TOLERANCE.
-C IF THE CURRENT MODEL PREDICTS A MAXIMUM POSSIBLE FUNCTION
-C REDUCTION (SEE V(NREDUC)) OF AT MOST V(RFCTOL)*ABS(F0)
-C AT THE START OF THE CURRENT ITERATION, WHERE F0 IS THE
-C THEN CURRENT FUNCTION VALUE, AND IF THE LAST STEP ATTEMPT-
-C ED ACHIEVED NO MORE THAN TWICE THE PREDICTED FUNCTION
-C DECREASE, THEN DMNG RETURNS WITH IV(1) = 4 (OR 5).
-C DEFAULT = MAX(10**-10, MACHEP**(2/3)), WHERE MACHEP IS
-C THE UNIT ROUNDOFF.
-C V(SCTOL).... V(37) IS THE SINGULAR CONVERGENCE TOLERANCE -- SEE THE
-C DESCRIPTION OF V(LMAXS) ABOVE.
-C V(TUNER1)... V(26) HELPS DECIDE WHEN TO CHECK FOR FALSE CONVERGENCE.
-C THIS IS DONE IF THE ACTUAL FUNCTION DECREASE FROM THE
-C CURRENT STEP IS NO MORE THAN V(TUNER1) TIMES ITS PREDICT-
-C ED VALUE. DEFAULT = 0.1.
-C V(XCTOL).... V(33) IS THE X-CONVERGENCE TOLERANCE. IF A NEWTON STEP
-C (SEE V(NREDUC)) IS TRIED THAT HAS V(RELDX) .LE. V(XCTOL)
-C AND IF THIS STEP YIELDS AT MOST TWICE THE PREDICTED FUNC-
-C TION DECREASE, THEN DMNG RETURNS WITH IV(1) = 3 (OR 5).
-C (SEE THE DESCRIPTION OF V(RELDX) BELOW.)
-C DEFAULT = MACHEP**0.5, WHERE MACHEP IS THE UNIT ROUNDOFF.
-C V(XFTOL).... V(34) IS THE FALSE CONVERGENCE TOLERANCE. IF A STEP IS
-C TRIED THAT GIVES NO MORE THAN V(TUNER1) TIMES THE PREDICT-
-C ED FUNCTION DECREASE AND THAT HAS V(RELDX) .LE. V(XFTOL),
-C AND IF DMNG DOES NOT RETURN WITH IV(1) = 3, 4, 5, 6, OR
-C 7, THEN IT RETURNS WITH IV(1) = 8. (SEE THE DESCRIPTION
-C OF V(RELDX) BELOW.) DEFAULT = 100*MACHEP, WHERE
-C MACHEP IS THE UNIT ROUNDOFF.
-C V(*)........DIVSET SUPPLIES TO V A NUMBER OF TUNING CONSTANTS, WITH
-C WHICH IT SHOULD ORDINARILY BE UNNECESSARY TO TINKER. SEE
-C SECTION 17 OF VERSION 2.2 OF THE NL2SOL USAGE SUMMARY
-C (I.E., THE APPENDIX TO REF. 1) FOR DETAILS ON V(I),
-C I = DECFAC, INCFAC, PHMNFC, PHMXFC, RDFCMN, RDFCMX,
-C TUNER2, TUNER3, TUNER4, TUNER5.
-C
-C *** (SELECTED) V OUTPUT VALUES ***
-C
-C V(DGNORM)... V(1) IS THE 2-NORM OF (DIAG(D)**-1)*G, WHERE G IS THE
-C MOST RECENTLY COMPUTED GRADIENT.
-C V(DSTNRM)... V(2) IS THE 2-NORM OF DIAG(D)*STEP, WHERE STEP IS THE
-C CURRENT STEP.
-C V(F)........ V(10) IS THE CURRENT FUNCTION VALUE.
-C V(F0)....... V(13) IS THE FUNCTION VALUE AT THE START OF THE CURRENT
-C ITERATION.
-C V(NREDUC)... V(6), IF POSITIVE, IS THE MAXIMUM FUNCTION REDUCTION
-C POSSIBLE ACCORDING TO THE CURRENT MODEL, I.E., THE FUNC-
-C TION REDUCTION PREDICTED FOR A NEWTON STEP (I.E.,
-C STEP = -H**-1 * G, WHERE G IS THE CURRENT GRADIENT AND
-C H IS THE CURRENT HESSIAN APPROXIMATION).
-C IF V(NREDUC) IS NEGATIVE, THEN IT IS THE NEGATIVE OF
-C THE FUNCTION REDUCTION PREDICTED FOR A STEP COMPUTED WITH
-C A STEP BOUND OF V(LMAXS) FOR _USE_ IN TESTING FOR SINGULAR
-C CONVERGENCE.
-C V(PREDUC)... V(7) IS THE FUNCTION REDUCTION PREDICTED (BY THE CURRENT
-C QUADRATIC MODEL) FOR THE CURRENT STEP. THIS (DIVIDED BY
-C V(F0)) IS USED IN TESTING FOR RELATIVE FUNCTION
-C CONVERGENCE.
-C V(RELDX).... V(17) IS THE SCALED RELATIVE CHANGE IN X CAUSED BY THE
-C CURRENT STEP, COMPUTED AS
-C MAX(ABS(D(I)*(X(I)-X0(I)), 1 .LE. I .LE. P) /
-C MAX(D(I)*(ABS(X(I))+ABS(X0(I))), 1 .LE. I .LE. P),
-C WHERE X = X0 + STEP.
-C
-C------------------------------- NOTES -------------------------------
-C
-C *** ALGORITHM NOTES ***
-C
-C THIS ROUTINE USES A HESSIAN APPROXIMATION COMPUTED FROM THE
-C BFGS UPDATE (SEE REF 3). ONLY A CHOLESKY FACTOR OF THE HESSIAN
-C APPROXIMATION IS STORED, AND THIS IS UPDATED USING IDEAS FROM
-C REF. 4. STEPS ARE COMPUTED BY THE DOUBLE DOGLEG SCHEME DESCRIBED
-C IN REF. 2. THE STEPS ARE ASSESSED AS IN REF. 1.
-C
-C *** USAGE NOTES ***
-C
-C AFTER A RETURN WITH IV(1) .LE. 11, IT IS POSSIBLE TO RESTART,
-C I.E., TO CHANGE SOME OF THE IV AND V INPUT VALUES DESCRIBED ABOVE
-C AND CONTINUE THE ALGORITHM FROM THE POINT WHERE IT WAS INTERRUPT-
-C ED. IV(1) SHOULD NOT BE CHANGED, NOR SHOULD ANY ENTRIES OF IV
-C AND V OTHER THAN THE INPUT VALUES (THOSE SUPPLIED BY DIVSET).
-C THOSE WHO DO NOT WISH TO WRITE A CALCG WHICH COMPUTES THE
-C GRADIENT ANALYTICALLY SHOULD CALL DMNF RATHER THAN DMNG.
-C DMNF USES FINITE DIFFERENCES TO COMPUTE AN APPROXIMATE GRADIENT.
-C THOSE WHO WOULD PREFER TO PROVIDE F AND G (THE FUNCTION AND
-C GRADIENT) BY REVERSE COMMUNICATION RATHER THAN BY WRITING SUBROU-
-C TINES CALCF AND CALCG MAY CALL ON DRMNG DIRECTLY. SEE THE COM-
-C MENTS AT THE BEGINNING OF DRMNG.
-C THOSE WHO _USE_ DMNG INTERACTIVELY MAY WISH TO SUPPLY THEIR
-C OWN STOPX FUNCTION, WHICH SHOULD RETURN .TRUE. IF THE BREAK KEY
-C HAS BEEN PRESSED SINCE STOPX WAS LAST INVOKED. THIS MAKES IT
-C POSSIBLE TO EXTERNALLY INTERRUPT DMNG (WHICH WILL RETURN WITH
-C IV(1) = 11 IF STOPX RETURNS .TRUE.).
-C STORAGE FOR G IS ALLOCATED AT THE END OF V. THUS THE CALLER
-C MAY MAKE V LONGER THAN SPECIFIED ABOVE AND MAY ALLOW CALCG TO USE
-C ELEMENTS OF G BEYOND THE FIRST N AS SCRATCH STORAGE.
-C
-C *** PORTABILITY NOTES ***
-C
-C THE DMNG DISTRIBUTION TAPE CONTAINS BOTH SINGLE- AND DOUBLE-
-C PRECISION VERSIONS OF THE DMNG SOURCE CODE, SO IT SHOULD BE UN-
-C NECESSARY TO CHANGE PRECISIONS.
-C ONLY THE FUNCTIONS I7MDCN AND DR7MDC CONTAIN MACHINE-DEPENDENT
-C CONSTANTS. TO CHANGE FROM ONE MACHINE TO ANOTHER, IT SHOULD
-C SUFFICE TO CHANGE THE (FEW) RELEVANT LINES IN THESE FUNCTIONS.
-C INTRINSIC FUNCTIONS ARE EXPLICITLY DECLARED. ON CERTAIN COM-
-C PUTERS (E.G. UNIVAC), IT MAY BE NECESSARY TO COMMENT OUT THESE
-C DECLARATIONS. SO THAT THIS MAY BE DONE AUTOMATICALLY BY A SIMPLE
-C PROGRAM, SUCH DECLARATIONS ARE PRECEDED BY A COMMENT HAVING C/+
-C IN COLUMNS 1-3 AND BLANKS IN COLUMNS 4-72 AND ARE FOLLOWED BY
-C A COMMENT HAVING C/ IN COLUMNS 1 AND 2 AND BLANKS IN COLUMNS 3-72.
-C THE DMNG SOURCE CODE IS EXPRESSED IN 1966 ANSI STANDARD
-C FORTRAN. IT MAY BE CONVERTED TO FORTRAN 77 BY COMMENTING OUT ALL
-C LINES THAT FALL BETWEEN A LINE HAVING C/6 IN COLUMNS 1-3 AND A
-C LINE HAVING C/7 IN COLUMNS 1-3 AND BY REMOVING (I.E., REPLACING
-C BY A BLANK) THE C IN COLUMN 1 OF THE LINES THAT FOLLOW THE C/7
-C LINE AND PRECEDE A LINE HAVING C/ IN COLUMNS 1-2 AND BLANKS IN
-C COLUMNS 3-72. THESE CHANGES CONVERT SOME DATA STATEMENTS INTO
-C PARAMETER STATEMENTS, CONVERT SOME VARIABLES FROM REAL TO
-C CHARACTER*4, AND MAKE THE DATA STATEMENTS THAT INITIALIZE THESE
-C VARIABLES _USE_ CHARACTER STRINGS DELIMITED BY PRIMES INSTEAD
-C OF HOLLERITH CONSTANTS. (SUCH VARIABLES AND DATA STATEMENTS
-C APPEAR ONLY IN MODULES DITSUM AND DPARCK. PARAMETER STATEMENTS
-C APPEAR NEARLY EVERYWHERE.) THESE CHANGES ALSO ADD SAVE STATE-
-C MENTS FOR VARIABLES GIVEN MACHINE-DEPENDENT CONSTANTS BY DR7MDC.
-C
-C *** REFERENCES ***
-C
-C 1. DENNIS, J.E., GAY, D.M., AND WELSCH, R.E. (1981), ALGORITHM 573 --
-C AN ADAPTIVE NONLINEAR LEAST-SQUARES ALGORITHM, ACM TRANS.
-C MATH. SOFTWARE 7, PP. 369-383.
-C
-C 2. DENNIS, J.E., AND MEI, H.H.W. (1979), TWO NEW UNCONSTRAINED OPTI-
-C MIZATION ALGORITHMS WHICH _USE_ FUNCTION AND GRADIENT
-C VALUES, J. OPTIM. THEORY APPLIC. 28, PP. 453-482.
-C
-C 3. DENNIS, J.E., AND MORE, J.J. (1977), QUASI-NEWTON METHODS, MOTIVA-
-C TION AND THEORY, SIAM REV. 19, PP. 46-89.
-C
-C 4. GOLDFARB, D. (1976), FACTORIZED VARIABLE METRIC METHODS FOR UNCON-
-C STRAINED OPTIMIZATION, MATH. COMPUT. 30, PP. 796-811.
-C
-C *** GENERAL ***
-C
-C CODED BY DAVID M. GAY (WINTER 1980). REVISED SUMMER 1982.
-C THIS SUBROUTINE WAS WRITTEN IN CONNECTION WITH RESEARCH
-C SUPPORTED IN PART BY THE NATIONAL SCIENCE FOUNDATION UNDER
-C GRANTS MCS-7600324, DCR75-10143, 76-14311DSS, MCS76-11989,
-C AND MCS-7906671.
-C.
-C
-C---------------------------- DECLARATIONS ---------------------------
-C
- EXTERNAL DIVSET, DRMNG
-C
-C DIVSET... SUPPLIES DEFAULT IV AND V INPUT COMPONENTS.
-C DRMNG... REVERSE-COMMUNICATION ROUTINE THAT CARRIES OUT DMNG ALGO-
-C RITHM.
-C
- INTEGER G1, IV1, NF
- DOUBLE PRECISION F
-C
-C *** SUBSCRIPTS FOR IV ***
-C
- INTEGER NEXTV, NFCALL, NFGCAL, G, TOOBIG, VNEED
-C
-C/6
-C DATA NEXTV/47/, NFCALL/6/, NFGCAL/7/, G/28/, TOOBIG/2/, VNEED/4/
-C/7
- PARAMETER (NEXTV=47, NFCALL=6, NFGCAL=7, G=28, TOOBIG=2, VNEED=4)
-C/
-C
-C+++++++++++++++++++++++++++++++ BODY ++++++++++++++++++++++++++++++++
-C
- IF (IV(1) .EQ. 0) CALL DIVSET(2, IV, LIV, LV, V)
- IV1 = IV(1)
- IF (IV1 .EQ. 12 .OR. IV1 .EQ. 13) IV(VNEED) = IV(VNEED) + N
- IF (IV1 .EQ. 14) GO TO 10
- IF (IV1 .GT. 2 .AND. IV1 .LT. 12) GO TO 10
- G1 = 1
- IF (IV1 .EQ. 12) IV(1) = 13
- GO TO 20
-C
- 10 G1 = IV(G)
-C
- 20 CALL DRMNG(D, F, V(G1), IV, LIV, LV, N, V, X)
- IF (IV(1) - 2) 30, 40, 50
-C
- 30 NF = IV(NFCALL)
- CALL CALCF(N, X, NF, F, UIPARM, URPARM, UFPARM)
- IF (NF .LE. 0) IV(TOOBIG) = 1
- GO TO 20
-C
- 40 NF = IV(NFGCAL)
- CALL CALCG(N, X, NF, V(G1), UIPARM, URPARM, UFPARM)
- IF (NF .LE. 0) IV(TOOBIG) = 1
- GO TO 20
-C
- 50 IF (IV(1) .NE. 14) GO TO 999
-C
-C *** STORAGE ALLOCATION
-C
- IV(G) = IV(NEXTV)
- IV(NEXTV) = IV(G) + N
- IF (IV1 .NE. 13) GO TO 10
-C
- 999 RETURN
-C *** LAST CARD OF DMNG FOLLOWS ***
- END
diff --git a/CEP/PyBDSM/src/port3/dmngb.f b/CEP/PyBDSM/src/port3/dmngb.f
deleted file mode 100644
index b56d2f1f4930eaaa5ec9d437f5388e7f1a37acf6..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/dmngb.f
+++ /dev/null
@@ -1,81 +0,0 @@
- SUBROUTINE DMNGB(N, D, X, B, CALCF, CALCG, IV, LIV, LV, V,
- 1 UIPARM, URPARM, UFPARM)
-C
-C *** MINIMIZE GENERAL SIMPLY BOUNDED OBJECTIVE FUNCTION USING ***
-C *** ANALYTIC GRADIENT AND HESSIAN APPROX. FROM SECANT UPDATE ***
-C
- INTEGER N, LIV, LV
-C/6S
-C INTEGER IV(LIV), UIPARM(1)
-C DOUBLE PRECISION D(N), X(N), B(2,N), V(LV), URPARM(1)
-C/7S
- INTEGER IV(LIV), UIPARM(*)
- DOUBLE PRECISION D(N), X(N), B(2,N), V(LV), URPARM(*)
-C/
-C DIMENSION IV(59 + N), V(71 + N*(N+21)/2), UIPARM(*), URPARM(*)
- EXTERNAL CALCF, CALCG, UFPARM
-C
-C *** DISCUSSION ***
-C
-C THIS ROUTINE IS LIKE DMNG, EXCEPT FOR THE EXTRA PARAMETER B,
-C AN ARRAY OF LOWER AND UPPER BOUNDS ON X... DMNGB ENFORCES THE
-C CONSTRAINTS THAT B(1,I) .LE. X(I) .LE. B(2,I), I = 1(1)N.
-C (INSTEAD OF CALLING DRMNG, DMNGB CALLS DRMNGB.)
-C.
-C
-C---------------------------- DECLARATIONS ---------------------------
-C
- EXTERNAL DIVSET, DRMNGB
-C
-C DIVSET.... SUPPLIES DEFAULT IV AND V INPUT COMPONENTS.
-C DRMNGB... REVERSE-COMMUNICATION ROUTINE THAT CARRIES OUT DMNG ALGO-
-C RITHM.
-C
- INTEGER G1, IV1, NF
- DOUBLE PRECISION F
-C
-C *** SUBSCRIPTS FOR IV ***
-C
- INTEGER NEXTV, NFCALL, NFGCAL, G, TOOBIG, VNEED
-C
-C/6
-C DATA NEXTV/47/, NFCALL/6/, NFGCAL/7/, G/28/, TOOBIG/2/, VNEED/4/
-C/7
- PARAMETER (NEXTV=47, NFCALL=6, NFGCAL=7, G=28, TOOBIG=2, VNEED=4)
-C/
-C
-C+++++++++++++++++++++++++++++++ BODY ++++++++++++++++++++++++++++++++
-C
- IF (IV(1) .EQ. 0) CALL DIVSET(2, IV, LIV, LV, V)
- IV1 = IV(1)
- IF (IV1 .EQ. 14) GO TO 10
- IF (IV1 .GT. 2 .AND. IV1 .LT. 12) GO TO 10
- IF (IV1 .EQ. 12) IV(1) = 13
- IF (IV(1) .EQ. 13) IV(VNEED) = IV(VNEED) + N
- CALL DRMNGB(B, D, F, V, IV, LIV, LV, N, V, X)
- IF (IV(1) .NE. 14) GO TO 999
-C
-C *** STORAGE ALLOCATION
-C
- IV(G) = IV(NEXTV)
- IV(NEXTV) = IV(G) + N
- IF (IV1 .EQ. 13) GO TO 999
-C
- 10 G1 = IV(G)
-C
- 20 CALL DRMNGB(B, D, F, V(G1), IV, LIV, LV, N, V, X)
- IF (IV(1) - 2) 30, 40, 999
-C
- 30 NF = IV(NFCALL)
- CALL CALCF(N, X, NF, F, UIPARM, URPARM, UFPARM)
- IF (NF .LE. 0) IV(TOOBIG) = 1
- GO TO 20
-C
- 40 NF = IV(NFGCAL)
- CALL CALCG(N, X, NF, V(G1), UIPARM, URPARM, UFPARM)
- IF (NF .LE. 0) IV(TOOBIG) = 1
- GO TO 20
-C
- 999 RETURN
-C *** LAST CARD OF DMNGB FOLLOWS ***
- END
diff --git a/CEP/PyBDSM/src/port3/dmnh.f b/CEP/PyBDSM/src/port3/dmnh.f
deleted file mode 100644
index 93fcf0a47e80692e484b50018a42ddad3709ba81..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/dmnh.f
+++ /dev/null
@@ -1,141 +0,0 @@
- SUBROUTINE DMNH(N, D, X, CALCF, CALCGH, IV, LIV, LV, V,
- 1 UIPARM, URPARM, UFPARM)
-C
-C *** MINIMIZE GENERAL UNCONSTRAINED OBJECTIVE FUNCTION USING ***
-C *** (ANALYTIC) GRADIENT AND HESSIAN PROVIDED BY THE CALLER. ***
-C
- INTEGER LIV, LV, N
- INTEGER IV(LIV), UIPARM(1)
- DOUBLE PRECISION D(N), X(N), V(LV), URPARM(1)
-C DIMENSION V(78 + N*(N+12)), UIPARM(*), URPARM(*)
- EXTERNAL CALCF, CALCGH, UFPARM
-C
-C------------------------------ DISCUSSION ---------------------------
-C
-C THIS ROUTINE IS LIKE DMNG, EXCEPT THAT THE SUBROUTINE PARA-
-C METER CALCG OF DMNG (WHICH COMPUTES THE GRADIENT OF THE OBJEC-
-C TIVE FUNCTION) IS REPLACED BY THE SUBROUTINE PARAMETER CALCGH,
-C WHICH COMPUTES BOTH THE GRADIENT AND (LOWER TRIANGLE OF THE)
-C HESSIAN OF THE OBJECTIVE FUNCTION. THE CALLING SEQUENCE IS...
-C CALL CALCGH(N, X, NF, G, H, UIPARM, URPARM, UFPARM)
-C PARAMETERS N, X, NF, G, UIPARM, URPARM, AND UFPARM ARE THE SAME
-C AS FOR DMNG, WHILE H IS AN ARRAY OF LENGTH N*(N+1)/2 IN WHICH
-C CALCGH MUST STORE THE LOWER TRIANGLE OF THE HESSIAN AT X. START-
-C ING AT H(1), CALCGH MUST STORE THE HESSIAN ENTRIES IN THE ORDER
-C (1,1), (2,1), (2,2), (3,1), (3,2), (3,3), ...
-C THE VALUE PRINTED (BY DITSUM) IN THE COLUMN LABELLED STPPAR
-C IS THE LEVENBERG-MARQUARDT USED IN COMPUTING THE CURRENT STEP.
-C ZERO MEANS A FULL NEWTON STEP. IF THE SPECIAL CASE DESCRIBED IN
-C REF. 1 IS DETECTED, THEN STPPAR IS NEGATED. THE VALUE PRINTED
-C IN THE COLUMN LABELLED NPRELDF IS ZERO IF THE CURRENT HESSIAN
-C IS NOT POSITIVE DEFINITE.
-C IT SOMETIMES PROVES WORTHWHILE TO LET D BE DETERMINED FROM THE
-C DIAGONAL OF THE HESSIAN MATRIX BY SETTING IV(DTYPE) = 1 AND
-C V(DINIT) = 0. THE FOLLOWING IV AND V COMPONENTS ARE RELEVANT...
-C
-C IV(DTOL)..... IV(59) GIVES THE STARTING SUBSCRIPT IN V OF THE DTOL
-C ARRAY USED WHEN D IS UPDATED. (IV(DTOL) CAN BE
-C INITIALIZED BY CALLING DMNH WITH IV(1) = 13.)
-C IV(DTYPE).... IV(16) TELLS HOW THE SCALE VECTOR D SHOULD BE CHOSEN.
-C IV(DTYPE) .LE. 0 MEANS THAT D SHOULD NOT BE UPDATED, AND
-C IV(DTYPE) .GE. 1 MEANS THAT D SHOULD BE UPDATED AS
-C DESCRIBED BELOW WITH V(DFAC). DEFAULT = 0.
-C V(DFAC)..... V(41) AND THE DTOL AND D0 ARRAYS (SEE V(DTINIT) AND
-C V(D0INIT)) ARE USED IN UPDATING THE SCALE VECTOR D WHEN
-C IV(DTYPE) .GT. 0. (D IS INITIALIZED ACCORDING TO
-C V(DINIT), DESCRIBED IN DMNG.) LET
-C D1(I) = MAX(SQRT(ABS(H(I,I))), V(DFAC)*D(I)),
-C WHERE H(I,I) IS THE I-TH DIAGONAL ELEMENT OF THE CURRENT
-C HESSIAN. IF IV(DTYPE) = 1, THEN D(I) IS SET TO D1(I)
-C UNLESS D1(I) .LT. DTOL(I), IN WHICH CASE D(I) IS SET TO
-C MAX(D0(I), DTOL(I)).
-C IF IV(DTYPE) .GE. 2, THEN D IS UPDATED DURING THE FIRST
-C ITERATION AS FOR IV(DTYPE) = 1 (AFTER ANY INITIALIZATION
-C DUE TO V(DINIT)) AND IS LEFT UNCHANGED THEREAFTER.
-C DEFAULT = 0.6.
-C V(DTINIT)... V(39), IF POSITIVE, IS THE VALUE TO WHICH ALL COMPONENTS
-C OF THE DTOL ARRAY (SEE V(DFAC)) ARE INITIALIZED. IF
-C V(DTINIT) = 0, THEN IT IS ASSUMED THAT THE CALLER HAS
-C STORED DTOL IN V STARTING AT V(IV(DTOL)).
-C DEFAULT = 10**-6.
-C V(D0INIT)... V(40), IF POSITIVE, IS THE VALUE TO WHICH ALL COMPONENTS
-C OF THE D0 VECTOR (SEE V(DFAC)) ARE INITIALIZED. IF
-C V(DFAC) = 0, THEN IT IS ASSUMED THAT THE CALLER HAS
-C STORED D0 IN V STARTING AT V(IV(DTOL)+N). DEFAULT = 1.0.
-C
-C *** REFERENCE ***
-C
-C 1. GAY, D.M. (1981), COMPUTING OPTIMAL LOCALLY CONSTRAINED STEPS,
-C SIAM J. SCI. STATIST. COMPUT. 2, PP. 186-197.
-C.
-C *** GENERAL ***
-C
-C CODED BY DAVID M. GAY (WINTER 1980). REVISED SEPT. 1982.
-C THIS SUBROUTINE WAS WRITTEN IN CONNECTION WITH RESEARCH SUPPORTED
-C IN PART BY THE NATIONAL SCIENCE FOUNDATION UNDER GRANTS
-C MCS-7600324 AND MCS-7906671.
-C
-C---------------------------- DECLARATIONS ---------------------------
-C
- EXTERNAL DIVSET, DRMNH
-C
-C DIVSET... PROVIDES DEFAULT INPUT VALUES FOR IV AND V.
-C DRMNH... REVERSE-COMMUNICATION ROUTINE THAT DOES DMNH ALGORITHM.
-C
- INTEGER G1, H1, IV1, LH, NF
- DOUBLE PRECISION F
-C
-C *** SUBSCRIPTS FOR IV ***
-C
- INTEGER G, H, NEXTV, NFCALL, NFGCAL, TOOBIG, VNEED
-C
-C/6
-C DATA NEXTV/47/, NFCALL/6/, NFGCAL/7/, G/28/, H/56/, TOOBIG/2/,
-C 1 VNEED/4/
-C/7
- PARAMETER (NEXTV=47, NFCALL=6, NFGCAL=7, G=28, H=56, TOOBIG=2,
- 1 VNEED=4)
-C/
-C
-C+++++++++++++++++++++++++++++++ BODY ++++++++++++++++++++++++++++++++
-C
- LH = N * (N + 1) / 2
- IF (IV(1) .EQ. 0) CALL DIVSET(2, IV, LIV, LV, V)
- IF (IV(1) .EQ. 12 .OR. IV(1) .EQ. 13)
- 1 IV(VNEED) = IV(VNEED) + N*(N+3)/2
- IV1 = IV(1)
- IF (IV1 .EQ. 14) GO TO 10
- IF (IV1 .GT. 2 .AND. IV1 .LT. 12) GO TO 10
- G1 = 1
- H1 = 1
- IF (IV1 .EQ. 12) IV(1) = 13
- GO TO 20
-C
- 10 G1 = IV(G)
- H1 = IV(H)
-C
- 20 CALL DRMNH(D, F, V(G1), V(H1), IV, LH, LIV, LV, N, V, X)
- IF (IV(1) - 2) 30, 40, 50
-C
- 30 NF = IV(NFCALL)
- CALL CALCF(N, X, NF, F, UIPARM, URPARM, UFPARM)
- IF (NF .LE. 0) IV(TOOBIG) = 1
- GO TO 20
-C
- 40 NF = IV(NFGCAL)
- CALL CALCGH(N, X, NF, V(G1), V(H1), UIPARM, URPARM, UFPARM)
- IF (NF .LE. 0) IV(TOOBIG) = 1
- GO TO 20
-C
- 50 IF (IV(1) .NE. 14) GO TO 999
-C
-C *** STORAGE ALLOCATION
-C
- IV(G) = IV(NEXTV)
- IV(H) = IV(G) + N
- IV(NEXTV) = IV(H) + N*(N+1)/2
- IF (IV1 .NE. 13) GO TO 10
-C
- 999 RETURN
-C *** LAST CARD OF DMNH FOLLOWS ***
- END
diff --git a/CEP/PyBDSM/src/port3/dmnhb.f b/CEP/PyBDSM/src/port3/dmnhb.f
deleted file mode 100644
index 93b7acf7d034270886359eb372e02e7b98d4a73a..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/dmnhb.f
+++ /dev/null
@@ -1,139 +0,0 @@
- SUBROUTINE DMNHB(N, D, X, B, CALCF, CALCGH, IV, LIV, LV, V,
- 1 UIPARM, URPARM, UFPARM)
-C
-C *** MINIMIZE GENERAL SIMPLY BOUNDED OBJECTIVE FUNCTION USING ***
-C *** (ANALYTIC) GRADIENT AND HESSIAN PROVIDED BY THE CALLER. ***
-C
- INTEGER LIV, LV, N
-C/6S
-C INTEGER IV(LIV), UIPARM(1)
-C DOUBLE PRECISION B(2,N), D(N), X(N), V(LV), URPARM(1)
-C/7S
- INTEGER IV(LIV), UIPARM(*)
- DOUBLE PRECISION B(2,N), D(N), X(N), V(LV), URPARM(*)
-C/
-C DIMENSION IV(59 + 3*N), V(78 + N*(N+15))
- EXTERNAL CALCF, CALCGH, UFPARM
-C
-C------------------------------ DISCUSSION ---------------------------
-C
-C THIS ROUTINE IS LIKE DMNGB, EXCEPT THAT THE SUBROUTINE PARA-
-C METER CALCG OF DMNGB (WHICH COMPUTES THE GRADIENT OF THE OBJEC-
-C TIVE FUNCTION) IS REPLACED BY THE SUBROUTINE PARAMETER CALCGH,
-C WHICH COMPUTES BOTH THE GRADIENT AND (LOWER TRIANGLE OF THE)
-C HESSIAN OF THE OBJECTIVE FUNCTION. THE CALLING SEQUENCE IS...
-C CALL CALCGH(N, X, NF, G, H, UIPARM, URPARM, UFPARM)
-C PARAMETERS N, X, NF, G, UIPARM, URPARM, AND UFPARM ARE THE SAME
-C AS FOR DMNGB, WHILE H IS AN ARRAY OF LENGTH N*(N+1)/2 IN WHICH
-C CALCGH MUST STORE THE LOWER TRIANGLE OF THE HESSIAN AT X. START-
-C ING AT H(1), CALCGH MUST STORE THE HESSIAN ENTRIES IN THE ORDER
-C (1,1), (2,1), (2,2), (3,1), (3,2), (3,3), ...
-C THE VALUE PRINTED (BY DITSUM) IN THE COLUMN LABELLED STPPAR
-C IS THE LEVENBERG-MARQUARDT USED IN COMPUTING THE CURRENT STEP.
-C ZERO MEANS A FULL NEWTON STEP. IF THE SPECIAL CASE DESCRIBED IN
-C REF. 1 IS DETECTED, THEN STPPAR IS NEGATED. THE VALUE PRINTED
-C IN THE COLUMN LABELLED NPRELDF IS ZERO IF THE CURRENT HESSIAN
-C IS NOT POSITIVE DEFINITE.
-C IT SOMETIMES PROVES WORTHWHILE TO LET D BE DETERMINED FROM THE
-C DIAGONAL OF THE HESSIAN MATRIX BY SETTING IV(DTYPE) = 1 AND
-C V(DINIT) = 0. THE FOLLOWING IV AND V COMPONENTS ARE RELEVANT...
-C
-C IV(DTOL)..... IV(59) GIVES THE STARTING SUBSCRIPT IN V OF THE DTOL
-C ARRAY USED WHEN D IS UPDATED. (IV(DTOL) CAN BE
-C INITIALIZED BY CALLING DMNHB WITH IV(1) = 13.)
-C IV(DTYPE).... IV(16) TELLS HOW THE SCALE VECTOR D SHOULD BE CHOSEN.
-C IV(DTYPE) .LE. 0 MEANS THAT D SHOULD NOT BE UPDATED, AND
-C IV(DTYPE) .GE. 1 MEANS THAT D SHOULD BE UPDATED AS
-C DESCRIBED BELOW WITH V(DFAC). DEFAULT = 0.
-C V(DFAC)..... V(41) AND THE DTOL AND D0 ARRAYS (SEE V(DTINIT) AND
-C V(D0INIT)) ARE USED IN UPDATING THE SCALE VECTOR D WHEN
-C IV(DTYPE) .GT. 0. (D IS INITIALIZED ACCORDING TO
-C V(DINIT), DESCRIBED IN DMNG.) LET
-C D1(I) = MAX(SQRT(ABS(H(I,I))), V(DFAC)*D(I)),
-C WHERE H(I,I) IS THE I-TH DIAGONAL ELEMENT OF THE CURRENT
-C HESSIAN. IF IV(DTYPE) = 1, THEN D(I) IS SET TO D1(I)
-C UNLESS D1(I) .LT. DTOL(I), IN WHICH CASE D(I) IS SET TO
-C MAX(D0(I), DTOL(I)).
-C IF IV(DTYPE) .GE. 2, THEN D IS UPDATED DURING THE FIRST
-C ITERATION AS FOR IV(DTYPE) = 1 (AFTER ANY INITIALIZATION
-C DUE TO V(DINIT)) AND IS LEFT UNCHANGED THEREAFTER.
-C DEFAULT = 0.6.
-C V(DTINIT)... V(39), IF POSITIVE, IS THE VALUE TO WHICH ALL COMPONENTS
-C OF THE DTOL ARRAY (SEE V(DFAC)) ARE INITIALIZED. IF
-C V(DTINIT) = 0, THEN IT IS ASSUMED THAT THE CALLER HAS
-C STORED DTOL IN V STARTING AT V(IV(DTOL)).
-C DEFAULT = 10**-6.
-C V(D0INIT)... V(40), IF POSITIVE, IS THE VALUE TO WHICH ALL COMPONENTS
-C OF THE D0 VECTOR (SEE V(DFAC)) ARE INITIALIZED. IF
-C V(DFAC) = 0, THEN IT IS ASSUMED THAT THE CALLER HAS
-C STORED D0 IN V STARTING AT V(IV(DTOL)+N). DEFAULT = 1.0.
-C
-C *** REFERENCE ***
-C
-C 1. GAY, D.M. (1981), COMPUTING OPTIMAL LOCALLY CONSTRAINED STEPS,
-C SIAM J. SCI. STATIST. COMPUT. 2, PP. 186-197.
-C.
-C *** GENERAL ***
-C
-C CODED BY DAVID M. GAY (WINTER, SPRING 1983).
-C
-C---------------------------- DECLARATIONS ---------------------------
-C
- EXTERNAL DIVSET, DRMNHB
-C
-C DIVSET.... PROVIDES DEFAULT INPUT VALUES FOR IV AND V.
-C DRMNHB... REVERSE-COMMUNICATION ROUTINE THAT DOES DMNHB ALGORITHM.
-C
- INTEGER G1, H1, IV1, LH, NF
- DOUBLE PRECISION F
-C
-C *** SUBSCRIPTS FOR IV ***
-C
- INTEGER G, H, NEXTV, NFCALL, NFGCAL, TOOBIG, VNEED
-C
-C/6
-C DATA NEXTV/47/, NFCALL/6/, NFGCAL/7/, G/28/, H/56/, TOOBIG/2/,
-C 1 VNEED/4/
-C/7
- PARAMETER (NEXTV=47, NFCALL=6, NFGCAL=7, G=28, H=56, TOOBIG=2,
- 1 VNEED=4)
-C/
-C
-C+++++++++++++++++++++++++++++++ BODY ++++++++++++++++++++++++++++++++
-C
- LH = N * (N + 1) / 2
- IF (IV(1) .EQ. 0) CALL DIVSET(2, IV, LIV, LV, V)
- IV1 = IV(1)
- IF (IV1 .EQ. 14) GO TO 10
- IF (IV1 .GT. 2 .AND. IV1 .LT. 12) GO TO 10
- IF (IV1 .EQ. 12) IV(1) = 13
- IF (IV(1) .EQ. 13) IV(VNEED) = IV(VNEED) + N*(N+3)/2
- CALL DRMNHB(B, D, F, V, V, IV, LH, LIV, LV, N, V, X)
- IF (IV(1) .NE. 14) GO TO 999
-C
-C *** STORAGE ALLOCATION
-C
- IV(G) = IV(NEXTV)
- IV(H) = IV(G) + N
- IV(NEXTV) = IV(H) + N*(N+1)/2
- IF (IV1 .EQ. 13) GO TO 999
-C
- 10 G1 = IV(G)
- H1 = IV(H)
-C
- 20 CALL DRMNHB(B, D, F, V(G1), V(H1), IV, LH, LIV, LV, N, V, X)
- IF (IV(1) - 2) 30, 40, 999
-C
- 30 NF = IV(NFCALL)
- CALL CALCF(N, X, NF, F, UIPARM, URPARM, UFPARM)
- IF (NF .LE. 0) IV(TOOBIG) = 1
- GO TO 20
-C
- 40 NF = IV(NFGCAL)
- CALL CALCGH(N, X, NF, V(G1), V(H1), UIPARM, URPARM, UFPARM)
- IF (NF .LE. 0) IV(TOOBIG) = 1
- GO TO 20
-C
- 999 RETURN
-C *** LAST CARD OF DMNHB FOLLOWS ***
- END
diff --git a/CEP/PyBDSM/src/port3/dn2cvp.f b/CEP/PyBDSM/src/port3/dn2cvp.f
deleted file mode 100644
index ff389fd62ad1584cad3ccbe7c4df24f818c72396..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/dn2cvp.f
+++ /dev/null
@@ -1,85 +0,0 @@
- SUBROUTINE DN2CVP(IV, LIV, LV, P, V)
-C
-C *** PRINT COVARIANCE MATRIX FOR DRN2G ***
-C
- INTEGER LIV, LV, P
- INTEGER IV(LIV)
- DOUBLE PRECISION V(LV)
-C
-C *** LOCAL VARIABLES ***
-C
- INTEGER COV1, I, II, I1, J, PU
- DOUBLE PRECISION T
-C
-C *** IV SUBSCRIPTS ***
-C
- INTEGER COVMAT, COVPRT, COVREQ, NEEDHD, NFCOV, NGCOV, PRUNIT,
- 1 RCOND, REGD, STATPR
-C
-C/6
-C DATA COVMAT/26/, COVPRT/14/, COVREQ/15/, NEEDHD/36/, NFCOV/52/,
-C 1 NGCOV/53/, PRUNIT/21/, RCOND/53/, REGD/67/, STATPR/23/
-C/7
- PARAMETER (COVMAT=26, COVPRT=14, COVREQ=15, NEEDHD=36, NFCOV=52,
- 1 NGCOV=53, PRUNIT=21, RCOND=53, REGD=67, STATPR=23)
-C/
-C *** BODY ***
-C
- IF (IV(1) .GT. 8) GO TO 999
- PU = IV(PRUNIT)
- IF (PU .EQ. 0) GO TO 999
- IF (IV(STATPR) .EQ. 0) GO TO 30
- IF (IV(NFCOV) .GT. 0) WRITE(PU,10) IV(NFCOV)
- 10 FORMAT(/1X,I4,50H EXTRA FUNC. EVALS FOR COVARIANCE AND DIAGNOST
- 1ICS.)
- IF (IV(NGCOV) .GT. 0) WRITE(PU,20) IV(NGCOV)
- 20 FORMAT(1X,I4,50H EXTRA GRAD. EVALS FOR COVARIANCE AND DIAGNOSTI
- 1CS.)
-C
- 30 IF (IV(COVPRT) .LE. 0) GO TO 999
- COV1 = IV(COVMAT)
- IF (IV(REGD) .LE. 0 .AND. COV1 .LE. 0) GO TO 70
- IV(NEEDHD) = 1
- T = V(RCOND)**2
- IF (IABS(IV(COVREQ)) .GT. 2) GO TO 50
-C
- WRITE(PU,40) T
- 40 FORMAT(/47H RECIPROCAL CONDITION OF F.D. HESSIAN = AT MOST,D10.2)
- GO TO 70
-C
- 50 WRITE(PU,60) T
- 60 FORMAT(/44H RECIPROCAL CONDITION OF (J**T)*J = AT LEAST,D10.2)
-C
- 70 IF (MOD(IV(COVPRT),2) .EQ. 0) GO TO 999
- IV(NEEDHD) = 1
- IF (COV1) 80,110,130
- 80 IF (-1 .EQ. COV1) WRITE(PU,90)
- 90 FORMAT(/43H ++++++ INDEFINITE COVARIANCE MATRIX ++++++)
- IF (-2 .EQ. COV1) WRITE(PU,100)
- 100 FORMAT(/52H ++++++ OVERSIZE STEPS IN COMPUTING COVARIANCE +++++)
- GO TO 999
-C
- 110 WRITE(PU,120)
- 120 FORMAT(/45H ++++++ COVARIANCE MATRIX NOT COMPUTED ++++++)
- GO TO 999
-C
- 130 I = IABS(IV(COVREQ))
- IF (I .LE. 1) WRITE(PU,140)
- 140 FORMAT(/48H COVARIANCE = SCALE * H**-1 * (J**T * J) * H**-1/
- 1 23H WHERE H = F.D. HESSIAN/)
- IF (I .EQ. 2) WRITE(PU,150)
- 150 FORMAT(/56H COVARIANCE = H**-1, WHERE H = FINITE-DIFFERENCE HESSIA
- 1N/)
- IF (I .GT. 2) WRITE(PU,160)
- 160 FORMAT(/30H COVARIANCE = SCALE * J**T * J/)
- II = COV1 - 1
- DO 170 I = 1, P
- I1 = II + 1
- II = II + I
- WRITE(PU,180) I, (V(J), J = I1, II)
- 170 CONTINUE
- 180 FORMAT(4H ROW,I3,2X,5D12.3/(9X,5D12.3))
-C
- 999 RETURN
-C *** LAST CARD OF DN2CVP FOLLOWS ***
- END
diff --git a/CEP/PyBDSM/src/port3/dn2f.f b/CEP/PyBDSM/src/port3/dn2f.f
deleted file mode 100644
index 3f26205c7db5b29cab536d0667699dda00af997d..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/dn2f.f
+++ /dev/null
@@ -1,168 +0,0 @@
- SUBROUTINE DN2F(N, P, X, CALCR, IV, LIV, LV, V,
- 1 UIPARM, URPARM, UFPARM)
-C
-C *** MINIMIZE A NONLINEAR SUM OF SQUARES USING RESIDUAL VALUES ONLY..
-C *** THIS AMOUNTS TO DN2G WITHOUT THE SUBROUTINE PARAMETER CALCJ.
-C
-C *** PARAMETERS ***
-C
- INTEGER N, P, LIV, LV
-C/6
-C INTEGER IV(LIV), UIPARM(1)
-C DOUBLE PRECISION X(P), V(LV), URPARM(1)
-C/7
- INTEGER IV(LIV), UIPARM(*)
- DOUBLE PRECISION X(P), V(LV), URPARM(*)
-C/
- EXTERNAL CALCR, UFPARM
-C
-C----------------------------- DISCUSSION ----------------------------
-C
-C THIS AMOUNTS TO SUBROUTINE NL2SNO (REF. 1) MODIFIED TO CALL
-C DRN2G.
-C THE PARAMETERS FOR DN2F ARE THE SAME AS THOSE FOR DN2G
-C (WHICH SEE), EXCEPT THAT CALCJ IS OMITTED. INSTEAD OF CALLING
-C CALCJ TO OBTAIN THE JACOBIAN MATRIX OF R AT X, DN2F COMPUTES
-C AN APPROXIMATION TO IT BY FINITE (FORWARD) DIFFERENCES -- SEE
-C V(DLTFDJ) BELOW. DN2F USES FUNCTION VALUES ONLY WHEN COMPUT-
-C THE COVARIANCE MATRIX (RATHER THAN THE FUNCTIONS AND GRADIENTS
-C THAT DN2G MAY USE). TO DO SO, DN2F SETS IV(COVREQ) TO MINUS
-C ITS ABSOLUTE VALUE. THUS V(DELTA0) IS NEVER REFERENCED AND ONLY
-C V(DLTFDC) MATTERS -- SEE NL2SOL FOR A DESCRIPTION OF V(DLTFDC).
-C THE NUMBER OF EXTRA CALLS ON CALCR USED IN COMPUTING THE JACO-
-C BIAN APPROXIMATION ARE NOT INCLUDED IN THE FUNCTION EVALUATION
-C COUNT IV(NFCALL), BUT ARE RECORDED IN IV(NGCALL) INSTEAD.
-C
-C V(DLTFDJ)... V(43) HELPS CHOOSE THE STEP SIZE USED WHEN COMPUTING THE
-C FINITE-DIFFERENCE JACOBIAN MATRIX. FOR DIFFERENCES IN-
-C VOLVING X(I), THE STEP SIZE FIRST TRIED IS
-C V(DLTFDJ) * MAX(ABS(X(I)), 1/D(I)),
-C WHERE D IS THE CURRENT SCALE VECTOR (SEE REF. 1). (IF
-C THIS STEP IS TOO BIG, I.E., IF CALCR SETS NF TO 0, THEN
-C SMALLER STEPS ARE TRIED UNTIL THE STEP SIZE IS SHRUNK BE-
-C LOW 1000 * MACHEP, WHERE MACHEP IS THE UNIT ROUNDOFF.
-C DEFAULT = MACHEP**0.5.
-C
-C *** REFERENCE ***
-C
-C 1. DENNIS, J.E., GAY, D.M., AND WELSCH, R.E. (1981), AN ADAPTIVE
-C NONLINEAR LEAST-SQUARES ALGORITHM, ACM TRANS. MATH.
-C SOFTWARE, VOL. 7, NO. 3.
-C
-C *** GENERAL ***
-C
-C CODED BY DAVID M. GAY.
-C
-C+++++++++++++++++++++++++++ DECLARATIONS +++++++++++++++++++++++++++
-C
-C *** EXTERNAL SUBROUTINES ***
-C
- EXTERNAL DIVSET, DRN2G, DN2RDP, DV7SCP
-C
-C DIVSET.... PROVIDES DEFAULT IV AND V INPUT COMPONENTS.
-C DRN2G... CARRIES OUT OPTIMIZATION ITERATIONS.
-C DN2RDP... PRINTS REGRESSION DIAGNOSTICS.
-C DV7SCP... SETS ALL COMPONENTS OF A VECTOR TO A SCALAR.
-C
-C *** LOCAL VARIABLES ***
-C
- INTEGER D1, DK, DR1, I, IV1, J1K, K, N1, N2, NF, NG, RD1, R1, RN
- DOUBLE PRECISION H, H0, HLIM, NEGPT5, ONE, XK, ZERO
-C
-C *** IV AND V COMPONENTS ***
-C
- INTEGER COVREQ, D, DINIT, DLTFDJ, J, MODE, NEXTV, NFCALL, NFGCAL,
- 1 NGCALL, NGCOV, R, REGD, REGD0, TOOBIG, VNEED
-C/6
-C DATA COVREQ/15/, D/27/, DINIT/38/, DLTFDJ/43/, J/70/, MODE/35/,
-C 1 NEXTV/47/, NFCALL/6/, NFGCAL/7/, NGCALL/30/, NGCOV/53/,
-C 2 R/61/, REGD/67/, REGD0/82/, TOOBIG/2/, VNEED/4/
-C/7
- PARAMETER (COVREQ=15, D=27, DINIT=38, DLTFDJ=43, J=70, MODE=35,
- 1 NEXTV=47, NFCALL=6, NFGCAL=7, NGCALL=30, NGCOV=53,
- 2 R=61, REGD=67, REGD0=82, TOOBIG=2, VNEED=4)
-C/
- DATA HLIM/0.1D+0/, NEGPT5/-0.5D+0/, ONE/1.D+0/, ZERO/0.D+0/
-C
-C--------------------------------- BODY ------------------------------
-C
- IF (IV(1) .EQ. 0) CALL DIVSET(1, IV, LIV, LV, V)
- IV(COVREQ) = -IABS(IV(COVREQ))
- IV1 = IV(1)
- IF (IV1 .EQ. 14) GO TO 10
- IF (IV1 .GT. 2 .AND. IV1 .LT. 12) GO TO 10
- IF (IV1 .EQ. 12) IV(1) = 13
- IF (IV(1) .EQ. 13) IV(VNEED) = IV(VNEED) + P + N*(P+2)
- CALL DRN2G(X, V, IV, LIV, LV, N, N, N1, N2, P, V, V, V, X)
- IF (IV(1) .NE. 14) GO TO 999
-C
-C *** STORAGE ALLOCATION ***
-C
- IV(D) = IV(NEXTV)
- IV(R) = IV(D) + P
- IV(REGD0) = IV(R) + N
- IV(J) = IV(REGD0) + N
- IV(NEXTV) = IV(J) + N*P
- IF (IV1 .EQ. 13) GO TO 999
-C
- 10 D1 = IV(D)
- DR1 = IV(J)
- R1 = IV(R)
- RN = R1 + N - 1
- RD1 = IV(REGD0)
-C
- 20 CALL DRN2G(V(D1), V(DR1), IV, LIV, LV, N, N, N1, N2, P, V(R1),
- 1 V(RD1), V, X)
- IF (IV(1)-2) 30, 50, 100
-C
-C *** NEW FUNCTION VALUE (R VALUE) NEEDED ***
-C
- 30 NF = IV(NFCALL)
- CALL CALCR(N, P, X, NF, V(R1), UIPARM, URPARM, UFPARM)
- IF (NF .GT. 0) GO TO 40
- IV(TOOBIG) = 1
- GO TO 20
- 40 IF (IV(1) .GT. 0) GO TO 20
-C
-C *** COMPUTE FINITE-DIFFERENCE APPROXIMATION TO DR = GRAD. OF R ***
-C
-C *** INITIALIZE D IF NECESSARY ***
-C
- 50 IF (IV(MODE) .LT. 0 .AND. V(DINIT) .EQ. ZERO)
- 1 CALL DV7SCP(P, V(D1), ONE)
-C
- J1K = DR1
- DK = D1
- NG = IV(NGCALL) - 1
- IF (IV(1) .EQ. (-1)) IV(NGCOV) = IV(NGCOV) - 1
- DO 90 K = 1, P
- XK = X(K)
- H = V(DLTFDJ) * DMAX1(DABS(XK), ONE/V(DK))
- H0 = H
- DK = DK + 1
- 60 X(K) = XK + H
- NF = IV(NFGCAL)
- CALL CALCR (N, P, X, NF, V(J1K), UIPARM, URPARM, UFPARM)
- NG = NG + 1
- IF (NF .GT. 0) GO TO 70
- H = NEGPT5 * H
- IF (DABS(H/H0) .GE. HLIM) GO TO 60
- IV(TOOBIG) = 1
- IV(NGCALL) = NG
- GO TO 20
- 70 X(K) = XK
- IV(NGCALL) = NG
- DO 80 I = R1, RN
- V(J1K) = (V(J1K) - V(I)) / H
- J1K = J1K + 1
- 80 CONTINUE
- 90 CONTINUE
- GO TO 20
-C
- 100 IF (IV(REGD) .GT. 0) IV(REGD) = RD1
- CALL DN2RDP(IV, LIV, LV, N, V(RD1), V)
-C
- 999 RETURN
-C
-C *** LAST LINE OF DN2F FOLLOWS ***
- END
diff --git a/CEP/PyBDSM/src/port3/dn2fb.f b/CEP/PyBDSM/src/port3/dn2fb.f
deleted file mode 100644
index aa2273fcebc2f746c1a01b9a0e37cb46604db9b6..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/dn2fb.f
+++ /dev/null
@@ -1,177 +0,0 @@
- SUBROUTINE DN2FB(N, P, X, B, CALCR, IV, LIV, LV, V, UI, UR, UF)
-C
-C *** MINIMIZE A NONLINEAR SUM OF SQUARES USING RESIDUAL VALUES ONLY..
-C *** THIS AMOUNTS TO DN2G WITHOUT THE SUBROUTINE PARAMETER CALCJ.
-C
-C *** PARAMETERS ***
-C
- INTEGER N, P, LIV, LV
-C/6
-C INTEGER IV(LIV), UI(1)
-C DOUBLE PRECISION X(P), B(2,P), V(LV), UR(1)
-C/7
- INTEGER IV(LIV), UI(*)
- DOUBLE PRECISION X(P), B(2,P), V(LV), UR(*)
-C/
- EXTERNAL CALCR, UF
-C
-C----------------------------- DISCUSSION ----------------------------
-C
-C THIS AMOUNTS TO SUBROUTINE NL2SNO (REF. 1) MODIFIED TO HANDLE
-C SIMPLE BOUNDS ON THE VARIABLES...
-C B(1,I) .LE. X(I) .LE. B(2,I), I = 1(1)P.
-C THE PARAMETERS FOR DN2FB ARE THE SAME AS THOSE FOR DN2GB
-C (WHICH SEE), EXCEPT THAT CALCJ IS OMITTED. INSTEAD OF CALLING
-C CALCJ TO OBTAIN THE JACOBIAN MATRIX OF R AT X, DN2FB COMPUTES
-C AN APPROXIMATION TO IT BY FINITE (FORWARD) DIFFERENCES -- SEE
-C V(DLTFDJ) BELOW. DN2FB DOES NOT COMPUTE A COVARIANCE MATRIX.
-C THE NUMBER OF EXTRA CALLS ON CALCR USED IN COMPUTING THE JACO-
-C BIAN APPROXIMATION ARE NOT INCLUDED IN THE FUNCTION EVALUATION
-C COUNT IV(NFCALL), BUT ARE RECORDED IN IV(NGCALL) INSTEAD.
-C
-C V(DLTFDJ)... V(43) HELPS CHOOSE THE STEP SIZE USED WHEN COMPUTING THE
-C FINITE-DIFFERENCE JACOBIAN MATRIX. FOR DIFFERENCES IN-
-C VOLVING X(I), THE STEP SIZE FIRST TRIED IS
-C V(DLTFDJ) * MAX(ABS(X(I)), 1/D(I)),
-C WHERE D IS THE CURRENT SCALE VECTOR (SEE REF. 1). (IF
-C THIS STEP IS TOO BIG, I.E., IF CALCR SETS NF TO 0, THEN
-C SMALLER STEPS ARE TRIED UNTIL THE STEP SIZE IS SHRUNK BE-
-C LOW 1000 * MACHEP, WHERE MACHEP IS THE UNIT ROUNDOFF.
-C DEFAULT = MACHEP**0.5.
-C
-C *** REFERENCE ***
-C
-C 1. DENNIS, J.E., GAY, D.M., AND WELSCH, R.E. (1981), AN ADAPTIVE
-C NONLINEAR LEAST-SQUARES ALGORITHM, ACM TRANS. MATH.
-C SOFTWARE, VOL. 7, NO. 3.
-C
-C *** GENERAL ***
-C
-C CODED BY DAVID M. GAY.
-C
-C+++++++++++++++++++++++++++ DECLARATIONS +++++++++++++++++++++++++++
-C
-C *** EXTERNAL SUBROUTINES ***
-C
- EXTERNAL DIVSET, DRN2GB, DV7SCP
-C
-C DIVSET.... PROVIDES DEFAULT IV AND V INPUT COMPONENTS.
-C DRN2GB... CARRIES OUT OPTIMIZATION ITERATIONS.
-C DN2RDP... PRINTS REGRESSION DIAGNOSTICS.
-C DV7SCP... SETS ALL ELEMENTS OF A VECTOR TO A SCALAR.
-C
-C *** LOCAL VARIABLES ***
-C
- INTEGER D1, DK, DR1, I, IV1, J1K, K, N1, N2, NF, NG, RD1, R1, RN
- DOUBLE PRECISION H, H0, HLIM, NEGPT5, ONE, T, XK, XK1, ZERO
-C
-C *** IV AND V COMPONENTS ***
-C
- INTEGER COVREQ, D, DINIT, DLTFDJ, J, MODE, NEXTV, NFCALL, NFGCAL,
- 1 NGCALL, NGCOV, R, REGD0, TOOBIG, VNEED
-C/6
-C DATA COVREQ/15/, D/27/, DINIT/38/, DLTFDJ/43/, J/70/, MODE/35/,
-C 1 NEXTV/47/, NFCALL/6/, NFGCAL/7/, NGCALL/30/, NGCOV/53/,
-C 2 R/61/, REGD0/82/, TOOBIG/2/, VNEED/4/
-C/7
- PARAMETER (COVREQ=15, D=27, DINIT=38, DLTFDJ=43, J=70, MODE=35,
- 1 NEXTV=47, NFCALL=6, NFGCAL=7, NGCALL=30, NGCOV=53,
- 2 R=61, REGD0=82, TOOBIG=2, VNEED=4)
-C/
- DATA HLIM/0.1D+0/, NEGPT5/-0.5D+0/, ONE/1.D+0/, ZERO/0.D+0/
-C
-C--------------------------------- BODY ------------------------------
-C
- IF (IV(1) .EQ. 0) CALL DIVSET(1, IV, LIV, LV, V)
- IV(COVREQ) = 0
- IV1 = IV(1)
- IF (IV1 .EQ. 14) GO TO 10
- IF (IV1 .GT. 2 .AND. IV1 .LT. 12) GO TO 10
- IF (IV1 .EQ. 12) IV(1) = 13
- IF (IV(1) .EQ. 13) IV(VNEED) = IV(VNEED) + P + N*(P+2)
- CALL DRN2GB(B, X, V, IV, LIV, LV, N, N, N1, N2, P, V, V, V, X)
- IF (IV(1) .NE. 14) GO TO 999
-C
-C *** STORAGE ALLOCATION ***
-C
- IV(D) = IV(NEXTV)
- IV(R) = IV(D) + P
- IV(REGD0) = IV(R) + N
- IV(J) = IV(REGD0) + N
- IV(NEXTV) = IV(J) + N*P
- IF (IV1 .EQ. 13) GO TO 999
-C
- 10 D1 = IV(D)
- DR1 = IV(J)
- R1 = IV(R)
- RN = R1 + N - 1
- RD1 = IV(REGD0)
-C
- 20 CALL DRN2GB(B, V(D1), V(DR1), IV, LIV, LV, N, N, N1, N2, P, V(R1),
- 1 V(RD1), V, X)
- IF (IV(1)-2) 30, 50, 999
-C
-C *** NEW FUNCTION VALUE (R VALUE) NEEDED ***
-C
- 30 NF = IV(NFCALL)
- CALL CALCR(N, P, X, NF, V(R1), UI, UR, UF)
- IF (NF .GT. 0) GO TO 40
- IV(TOOBIG) = 1
- GO TO 20
- 40 IF (IV(1) .GT. 0) GO TO 20
-C
-C *** COMPUTE FINITE-DIFFERENCE APPROXIMATION TO DR = GRAD. OF R ***
-C
-C *** INITIALIZE D IF NECESSARY ***
-C
- 50 IF (IV(MODE) .LT. 0 .AND. V(DINIT) .EQ. ZERO)
- 1 CALL DV7SCP(P, V(D1), ONE)
-C
- J1K = DR1
- DK = D1
- NG = IV(NGCALL) - 1
- IF (IV(1) .EQ. (-1)) IV(NGCOV) = IV(NGCOV) - 1
- DO 120 K = 1, P
- IF (B(1,K) .GE. B(2,K)) GO TO 110
- XK = X(K)
- H = V(DLTFDJ) * DMAX1(DABS(XK), ONE/V(DK))
- H0 = H
- DK = DK + 1
- T = NEGPT5
- XK1 = XK + H
- IF (XK - H .GE. B(1,K)) GO TO 60
- T = -T
- IF (XK1 .GT. B(2,K)) GO TO 80
- 60 IF (XK1 .LE. B(2,K)) GO TO 70
- T = -T
- H = -H
- XK1 = XK + H
- IF (XK1 .LT. B(1,K)) GO TO 80
- 70 X(K) = XK1
- NF = IV(NFGCAL)
- CALL CALCR (N, P, X, NF, V(J1K), UI, UR, UF)
- NG = NG + 1
- IF (NF .GT. 0) GO TO 90
- H = T * H
- XK1 = XK + H
- IF (DABS(H/H0) .GE. HLIM) GO TO 70
- 80 IV(TOOBIG) = 1
- IV(NGCALL) = NG
- GO TO 20
- 90 X(K) = XK
- IV(NGCALL) = NG
- DO 100 I = R1, RN
- V(J1K) = (V(J1K) - V(I)) / H
- J1K = J1K + 1
- 100 CONTINUE
- GO TO 120
-C *** SUPPLY A ZERO DERIVATIVE FOR CONSTANT COMPONENTS...
- 110 CALL DV7SCP(N, V(J1K), ZERO)
- J1K = J1K + N
- 120 CONTINUE
- GO TO 20
-C
- 999 RETURN
-C
-C *** LAST CARD OF DN2FB FOLLOWS ***
- END
diff --git a/CEP/PyBDSM/src/port3/dn2g.f b/CEP/PyBDSM/src/port3/dn2g.f
deleted file mode 100644
index ed5208b96ee8d59434b92440a436cc93717398a4..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/dn2g.f
+++ /dev/null
@@ -1,202 +0,0 @@
- SUBROUTINE DN2G(N, P, X, CALCR, CALCJ, IV, LIV, LV, V,
- 1 UI, UR, UF)
-C
-C *** VERSION OF NL2SOL THAT CALLS DRN2G ***
-C
-C *** PARAMETERS ***
-C
- INTEGER N, P, LIV, LV
-C/6
-C INTEGER IV(LIV), UI(1)
-C DOUBLE PRECISION X(P), V(LV), UR(1)
-C/7
- INTEGER IV(LIV), UI(*)
- DOUBLE PRECISION X(P), V(LV), UR(*)
-C/
- EXTERNAL CALCR, CALCJ, UF
-C
-C *** PARAMETER USAGE ***
-C
-C N....... TOTAL NUMBER OF RESIDUALS.
-C P....... NUMBER OF PARAMETERS (COMPONENTS OF X) BEING ESTIMATED.
-C X....... PARAMETER VECTOR BEING ESTIMATED (INPUT = INITIAL GUESS,
-C OUTPUT = BEST VALUE FOUND).
-C CALCR... SUBROUTINE FOR COMPUTING RESIDUAL VECTOR.
-C CALCJ... SUBROUTINE FOR COMPUTING JACOBIAN MATRIX = MATRIX OF FIRST
-C PARTIALS OF THE RESIDUAL VECTOR.
-C IV...... INTEGER VALUES ARRAY.
-C LIV..... LENGTH OF IV (SEE DISCUSSION BELOW).
-C LV...... LENGTH OF V (SEE DISCUSSION BELOW).
-C V....... FLOATING-POINT VALUES ARRAY.
-C UI...... PASSED UNCHANGED TO CALCR AND CALCJ.
-C UR...... PASSED UNCHANGED TO CALCR AND CALCJ.
-C UF...... PASSED UNCHANGED TO CALCR AND CALCJ.
-C
-C
-C *** DISCUSSION ***
-C
-C NOTE... NL2SOL (MENTIONED BELOW) IS A CODE FOR SOLVING
-C NONLINEAR LEAST-SQUARES PROBLEMS. IT IS DESCRIBED IN
-C ACM TRANS. MATH. SOFTWARE, VOL. 7 (1981), PP. 369-383
-C (AN ADAPTIVE NONLINEAR LEAST-SQUARES ALGORITHM, BY J.E. DENNIS,
-C D.M. GAY, AND R.E. WELSCH).
-C
-C LIV GIVES THE LENGTH OF IV. IT MUST BE AT LEAST 82+P. IF NOT,
-C THEN DN2G RETURNS WITH IV(1) = 15. WHEN DN2G RETURNS, THE
-C MINIMUM ACCEPTABLE VALUE OF LIV IS STORED IN IV(LASTIV) = IV(44),
-C (PROVIDED THAT LIV .GE. 44).
-C
-C LV GIVES THE LENGTH OF V. THE MINIMUM VALUE FOR LV IS
-C LV0 = 105 + P*(N + 2*P + 17) + 2*N. IF LV IS SMALLER THAN THIS,
-C THEN DN2G RETURNS WITH IV(1) = 16. WHEN DN2G RETURNS, THE
-C MINIMUM ACCEPTABLE VALUE OF LV IS STORED IN IV(LASTV) = IV(45)
-C (PROVIDED LIV .GE. 45).
-C
-C RETURN CODES AND CONVERGENCE TOLERANCES ARE THE SAME AS FOR
-C NL2SOL, WITH SOME SMALL EXTENSIONS... IV(1) = 15 MEANS LIV WAS
-C TOO SMALL. IV(1) = 16 MEANS LV WAS TOO SMALL.
-C
-C THERE ARE TWO NEW V INPUT COMPONENTS... V(LMAXS) = V(36) AND
-C V(SCTOL) = V(37) SERVE WHERE V(LMAX0) AND V(RFCTOL) FORMERLY DID
-C IN THE SINGULAR CONVERGENCE TEST -- SEE THE NL2SOL DOCUMENTATION.
-C
-C *** DEFAULT VALUES ***
-C
-C DEFAULT VALUES ARE PROVIDED BY SUBROUTINE DIVSET, RATHER THAN
-C DFAULT. THE CALLING SEQUENCE IS...
-C CALL DIVSET(1, IV, LIV, LV, V)
-C THE FIRST PARAMETER IS AN INTEGER 1. IF LIV AND LV ARE LARGE
-C ENOUGH FOR DIVSET, THEN DIVSET SETS IV(1) TO 12. OTHERWISE IT
-C SETS IV(1) TO 15 OR 16. CALLING DN2G WITH IV(1) = 0 CAUSES ALL
-C DEFAULT VALUES TO BE USED FOR THE INPUT COMPONENTS OF IV AND V.
-C IF YOU FIRST CALL DIVSET, THEN SET IV(1) TO 13 AND CALL DN2G,
-C THEN STORAGE ALLOCATION ONLY WILL BE PERFORMED. IN PARTICULAR,
-C IV(D) = IV(27), IV(J) = IV(70), AND IV(R) = IV(61) WILL BE SET
-C TO THE FIRST SUBSCRIPT IN V OF THE SCALE VECTOR, THE JACOBIAN
-C MATRIX, AND THE RESIDUAL VECTOR RESPECTIVELY, PROVIDED LIV AND LV
-C ARE LARGE ENOUGH. IF SO, THEN DN2G RETURNS WITH IV(1) = 14.
-C WHEN CALLED WITH IV(1) = 14, DN2G ASSUMES THAT STORAGE HAS
-C BEEN ALLOCATED, AND IT BEGINS THE MINIMIZATION ALGORITHM.
-C
-C *** SCALE VECTOR ***
-C
-C ONE DIFFERENCE WITH NL2SOL IS THAT THE SCALE VECTOR D IS
-C STORED IN V, STARTING AT A DIFFERENT SUBSCRIPT. THE STARTING
-C SUBSCRIPT VALUE IS STILL STORED IN IV(D) = IV(27). THE
-C DISCUSSION OF DEFAULT VALUES ABOVE TELLS HOW TO HAVE IV(D) SET
-C BEFORE THE ALGORITHM IS STARTED.
-C
-C *** REGRESSION DIAGNOSTICS ***
-C
-C IF IV(RDREQ) SO DICTATES, THEN ESTIMATES ARE COMPUTED OF THE
-C INFLUENCE EACH RESIDUAL COMPONENT HAS ON THE FINAL PARAMETER
-C ESTIMATE X. THE GENERAL IDEA IS THAT ONE MAY WISH TO EXAMINE
-C RESIDUAL COMPONENTS (AND THE DATA BEHIND THEM) FOR WHICH THE
-C INFLUENCE ESTIMATE IS SIGNIFICANTLY LARGER THAN MOST OF THE OTHER
-C INFLUENCE ESTIMATES. THESE ESTIMATES, HEREAFTER CALLED
-C REGRESSION DIAGNOSTICS, ARE ONLY COMPUTED IF IV(RDREQ) = 2 OR 3.
-C IN THIS CASE, FOR I = 1(1)N,
-C SQRT( G(I)**T * H(I)**-1 * G(I) )
-C IS COMPUTED AND STORED IN V, STARTING AT V(IV(REGD)), WHERE
-C RDREQ = 57 AND REGD = 67. HERE G(I) STANDS FOR THE GRADIENT
-C RESULTING WHEN THE I-TH OBSERVATION IS DELETED AND H(I) STANDS
-C FOR AN APPROXIMATION TO THE CORRESPONDING HESSIAN AT X, THE SOLU-
-C TION CORRESPONDING TO ALL OBSERVATIONS. (THIS APPROXIMATION IS
-C OBTAINED BY SUBTRACTING THE FIRST-ORDER CONTRIBUTION OF THE I-TH
-C OBSERVATION TO THE HESSIAN FROM A FINITE-DIFFERENCE HESSIAN
-C APPROXIMATION. IF H IS INDEFINITE, THEN IV(REGD) IS SET TO -1.
-C IF H(I) IS INDEFINITE, THEN -1 IS RETURNED AS THE DIAGNOSTIC FOR
-C OBSERVATION I. IF NO DIAGNOSTICS ARE COMPUTED, PERHAPS BECAUSE
-C OF A FAILURE TO CONVERGE, THEN IV(REGD) = 0 IS RETURNED.)
-C PRINTING OF THE REGRESSION DIAGNOSTICS IS CONTROLLED BY
-C IV(COVPRT) = IV(14)... IF IV(COVPRT) = 3, THEN BOTH THE
-C COVARIANCE MATRIX AND THE REGRESSION DIAGNOSTICS ARE PRINTED.
-C IV(COVPRT) = 2 CAUSES ONLY THE REGRESSION DIAGNOSTICS TO BE
-C PRINTED, IV(COVPRT) = 1 CAUSES ONLY THE COVARIANCE MATRIX TO BE
-C PRINTED, AND IV(COVPRT) = 0 CAUSES NEITHER TO BE PRINTED.
-C
-C RDREQ = 57 AND REGD = 67.
-C
-C *** GENERAL ***
-C
-C CODED BY DAVID M. GAY.
-C
-C+++++++++++++++++++++++++++ DECLARATIONS +++++++++++++++++++++++++++
-C
-C *** EXTERNAL SUBROUTINES ***
-C
- EXTERNAL DIVSET, DRN2G, DN2RDP
-C DIVSET.... PROVIDES DEFAULT IV AND V INPUT COMPONENTS.
-C DRN2G... CARRIES OUT OPTIMIZATION ITERATIONS.
-C DN2RDP... PRINTS REGRESSION DIAGNOSTICS.
-C
-C *** NO INTRINSIC FUNCTIONS ***
-C
-C *** LOCAL VARIABLES ***
-C
- INTEGER D1, DR1, IV1, N1, N2, NF, R1, RD1
-C
-C *** IV COMPONENTS ***
-C
- INTEGER D, J, NEXTV, NFCALL, NFGCAL, R, REGD, REGD0, TOOBIG, VNEED
-C/6
-C DATA D/27/, J/70/, NEXTV/47/, NFCALL/6/, NFGCAL/7/, R/61/,
-C 1 REGD/67/, REGD0/82/, TOOBIG/2/, VNEED/4/
-C/7
- PARAMETER (D=27, J=70, NEXTV=47, NFCALL=6, NFGCAL=7, R=61,
- 1 REGD=67, REGD0=82, TOOBIG=2, VNEED=4)
-C/
-C--------------------------------- BODY ------------------------------
-C
- IF (IV(1) .EQ. 0) CALL DIVSET(1, IV, LIV, LV, V)
- IV1 = IV(1)
- IF (IV1 .EQ. 14) GO TO 10
- IF (IV1 .GT. 2 .AND. IV1 .LT. 12) GO TO 10
- IF (IV1 .EQ. 12) IV(1) = 13
- IF (IV(1) .EQ. 13) IV(VNEED) = IV(VNEED) + P + N*(P+2)
- CALL DRN2G(X, V, IV, LIV, LV, N, N, N1, N2, P, V, V, V, X)
- IF (IV(1) .NE. 14) GO TO 999
-C
-C *** STORAGE ALLOCATION ***
-C
- IV(D) = IV(NEXTV)
- IV(R) = IV(D) + P
- IV(REGD0) = IV(R) + N
- IV(J) = IV(REGD0) + N
- IV(NEXTV) = IV(J) + N*P
- IF (IV1 .EQ. 13) GO TO 999
-C
- 10 D1 = IV(D)
- DR1 = IV(J)
- R1 = IV(R)
- RD1 = IV(REGD0)
-C
- 20 CALL DRN2G(V(D1), V(DR1), IV, LIV, LV, N, N, N1, N2, P, V(R1),
- 1 V(RD1), V, X)
- IF (IV(1)-2) 30, 50, 60
-C
-C *** NEW FUNCTION VALUE (R VALUE) NEEDED ***
-C
- 30 NF = IV(NFCALL)
- CALL CALCR(N, P, X, NF, V(R1), UI, UR, UF)
- IF (NF .GT. 0) GO TO 40
- IV(TOOBIG) = 1
- GO TO 20
- 40 IF (IV(1) .GT. 0) GO TO 20
-C
-C *** COMPUTE DR = GRADIENT OF R COMPONENTS ***
-C
- 50 CALL CALCJ(N, P, X, IV(NFGCAL), V(DR1), UI, UR, UF)
- IF (IV(NFGCAL) .EQ. 0) IV(TOOBIG) = 1
- GO TO 20
-C
-C *** INDICATE WHETHER THE REGRESSION DIAGNOSTIC ARRAY WAS COMPUTED
-C *** AND PRINT IT IF SO REQUESTED...
-C
- 60 IF (IV(REGD) .GT. 0) IV(REGD) = RD1
- CALL DN2RDP(IV, LIV, LV, N, V(RD1), V)
-C
- 999 RETURN
-C
-C *** LAST LINE OF DN2G FOLLOWS ***
- END
diff --git a/CEP/PyBDSM/src/port3/dn2gb.f b/CEP/PyBDSM/src/port3/dn2gb.f
deleted file mode 100644
index 87af73de7608a5f685807ed6aabd9bedc7031e2f..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/dn2gb.f
+++ /dev/null
@@ -1,146 +0,0 @@
- SUBROUTINE DN2GB(N, P, X, B, CALCR, CALCJ, IV, LIV, LV, V,
- 1 UIPARM, URPARM, UFPARM)
-C
-C *** VERSION OF NL2SOL THAT HANDLES SIMPLE BOUNDS ON X ***
-C
-C *** PARAMETERS ***
-C
- INTEGER N, P, LIV, LV
-C/6
-C INTEGER IV(LIV), UIPARM(1)
-C DOUBLE PRECISION X(P), B(2,P), V(LV), URPARM(1)
-C/7
- INTEGER IV(LIV), UIPARM(*)
- DOUBLE PRECISION X(P), B(2,P), V(LV), URPARM(*)
-C/
- EXTERNAL CALCR, CALCJ, UFPARM
-C
-C *** DISCUSSION ***
-C
-C NOTE... NL2SOL (MENTIONED BELOW) IS A CODE FOR SOLVING
-C NONLINEAR LEAST-SQUARES PROBLEMS. IT IS DESCRIBED IN
-C ACM TRANS. MATH. SOFTWARE, VOL. 7 (1981), PP. 369-383
-C (AN ADAPTIVE NONLINEAR LEAST-SQUARES ALGORITHM, BY J.E. DENNIS,
-C D.M. GAY, AND R.E. WELSCH).
-C
-C LIV GIVES THE LENGTH OF IV. IT MUST BE AT LEAST 82 + 4*P.
-C IF NOT, THEN DN2GB RETURNS WITH IV(1) = 15. WHEN DN2GB
-C RETURNS, THE MINIMUM ACCEPTABLE VALUE OF LIV IS STORED IN
-C IV(LASTIV) = IV(44), (PROVIDED THAT LIV .GE. 44).
-C
-C LV GIVES THE LENGTH OF V. THE MINIMUM VALUE FOR LV IS
-C LV0 = 105 + P*(N + 2*P + 21) + 2*N. IF LV IS SMALLER THAN THIS,
-C THEN DN2GB RETURNS WITH IV(1) = 16. WHEN DN2GB RETURNS, THE
-C MINIMUM ACCEPTABLE VALUE OF LV IS STORED IN IV(LASTV) = IV(45)
-C (PROVIDED LIV .GE. 45).
-C
-C RETURN CODES AND CONVERGENCE TOLERANCES ARE THE SAME AS FOR
-C NL2SOL, WITH SOME SMALL EXTENSIONS... IV(1) = 15 MEANS LIV WAS
-C TOO SMALL. IV(1) = 16 MEANS LV WAS TOO SMALL.
-C
-C THERE ARE TWO NEW V INPUT COMPONENTS... V(LMAXS) = V(36) AND
-C V(SCTOL) = V(37) SERVE WHERE V(LMAX0) AND V(RFCTOL) FORMERLY DID
-C IN THE SINGULAR CONVERGENCE TEST -- SEE THE NL2SOL DOCUMENTATION.
-C
-C *** BOUNDS ***
-C
-C THE BOUNDS B(1,I) .LE. X(I) .LE. B(2,I), I = 1(1)P, ARE ENFORCED.
-C
-C *** DEFAULT VALUES ***
-C
-C DEFAULT VALUES ARE PROVIDED BY SUBROUTINE DIVSET, RATHER THAN
-C DFAULT. THE CALLING SEQUENCE IS...
-C CALL DIVSET(1, IV, LIV, LV, V)
-C THE FIRST PARAMETER IS AN INTEGER 1. IF LIV AND LV ARE LARGE
-C ENOUGH FOR DIVSET, THEN DIVSET SETS IV(1) TO 12. OTHERWISE IT
-C SETS IV(1) TO 15 OR 16. CALLING DN2GB WITH IV(1) = 0 CAUSES ALL
-C DEFAULT VALUES TO BE USED FOR THE INPUT COMPONENTS OF IV AND V.
-C IF YOU FIRST CALL DIVSET, THEN SET IV(1) TO 13 AND CALL DN2GB,
-C THEN STORAGE ALLOCATION ONLY WILL BE PERFORMED. IN PARTICULAR,
-C IV(D) = IV(27), IV(J) = IV(70), AND IV(R) = IV(61) WILL BE SET
-C TO THE FIRST SUBSCRIPT IN V OF THE SCALE VECTOR, THE JACOBIAN
-C MATRIX, AND THE RESIDUAL VECTOR RESPECTIVELY, PROVIDED LIV AND LV
-C ARE LARGE ENOUGH. IF SO, THEN DN2GB RETURNS WITH IV(1) = 14.
-C WHEN CALLED WITH IV(1) = 14, DN2GB ASSUMES THAT STORAGE HAS
-C BEEN ALLOCATED, AND IT BEGINS THE MINIMIZATION ALGORITHM.
-C
-C *** SCALE VECTOR ***
-C
-C ONE DIFFERENCE WITH NL2SOL IS THAT THE SCALE VECTOR D IS
-C STORED IN V, STARTING AT A DIFFERENT SUBSCRIPT. THE STARTING
-C SUBSCRIPT VALUE IS STILL STORED IN IV(D) = IV(27). THE
-C DISCUSSION OF DEFAULT VALUES ABOVE TELLS HOW TO HAVE IV(D) SET
-C BEFORE THE ALGORITHM IS STARTED.
-C
-C *** GENERAL ***
-C
-C CODED BY DAVID M. GAY.
-C
-C *** EXTERNAL SUBROUTINES ***
-C
- EXTERNAL DIVSET, DRN2GB
-C DIVSET.... PROVIDES DEFAULT IV AND V INPUT COMPONENTS.
-C DRN2GB... CARRIES OUT OPTIMIZATION ITERATIONS.
-C
-C *** LOCAL VARIABLES ***
-C
- INTEGER D1, DR1, IV1, N1, N2, NF, R1, RD1
-C
-C *** IV COMPONENTS ***
-C
- INTEGER D, J, NEXTV, NFCALL, NFGCAL, R, REGD0, TOOBIG, VNEED
-C/6
-C DATA D/27/, J/70/, NEXTV/47/, NFCALL/6/, NFGCAL/7/, R/61/,
-C 1 REGD0/82/, TOOBIG/2/, VNEED/4/
-C/7
- PARAMETER (D=27, J=70, NEXTV=47, NFCALL=6, NFGCAL=7, R=61,
- 1 REGD0=82, TOOBIG=2, VNEED=4)
-C/
-C--------------------------------- BODY ------------------------------
-C
- IF (IV(1) .EQ. 0) CALL DIVSET(1, IV, LIV, LV, V)
- IV1 = IV(1)
- IF (IV1 .EQ. 14) GO TO 10
- IF (IV1 .GT. 2 .AND. IV1 .LT. 12) GO TO 10
- IF (IV1 .EQ. 12) IV(1) = 13
- IF (IV(1) .EQ. 13) IV(VNEED) = IV(VNEED) + P + N*(P+2)
- CALL DRN2GB(B, X, V, IV, LIV, LV, N, N, N1, N2, P, V, V, V, X)
- IF (IV(1) .NE. 14) GO TO 999
-C
-C *** STORAGE ALLOCATION ***
-C
- IV(D) = IV(NEXTV)
- IV(R) = IV(D) + P
- IV(REGD0) = IV(R) + N
- IV(J) = IV(REGD0) + N
- IV(NEXTV) = IV(J) + N*P
- IF (IV1 .EQ. 13) GO TO 999
-C
- 10 D1 = IV(D)
- DR1 = IV(J)
- R1 = IV(R)
- RD1 = IV(REGD0)
-C
- 20 CALL DRN2GB(B, V(D1), V(DR1), IV, LIV, LV, N, N, N1, N2, P, V(R1),
- 1 V(RD1), V, X)
- IF (IV(1)-2) 30, 50, 999
-C
-C *** NEW FUNCTION VALUE (R VALUE) NEEDED ***
-C
- 30 NF = IV(NFCALL)
- CALL CALCR(N, P, X, NF, V(R1), UIPARM, URPARM, UFPARM)
- IF (NF .GT. 0) GO TO 40
- IV(TOOBIG) = 1
- GO TO 20
- 40 IF (IV(1) .GT. 0) GO TO 20
-C
-C *** COMPUTE DR = GRADIENT OF R COMPONENTS ***
-C
- 50 CALL CALCJ(N, P, X, IV(NFGCAL), V(DR1), UIPARM, URPARM, UFPARM)
- IF (IV(NFGCAL) .EQ. 0) IV(TOOBIG) = 1
- GO TO 20
-C
- 999 RETURN
-C
-C *** LAST CARD OF DN2GB FOLLOWS ***
- END
diff --git a/CEP/PyBDSM/src/port3/dn2lrd.f b/CEP/PyBDSM/src/port3/dn2lrd.f
deleted file mode 100644
index b2a462d786edf506ed40b8708ef2b0453572ca44..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/dn2lrd.f
+++ /dev/null
@@ -1,90 +0,0 @@
- SUBROUTINE DN2LRD(DR, IV, L, LH, LIV, LV, ND, NN, P, R, RD, V)
-C
-C *** COMPUTE REGRESSION DIAGNOSTIC AND DEFAULT COVARIANCE MATRIX FOR
-C DRN2G ***
-C
-C *** PARAMETERS ***
-C
- INTEGER LH, LIV, LV, ND, NN, P
- INTEGER IV(LIV)
- DOUBLE PRECISION DR(ND,P), L(LH), R(NN), RD(NN), V(LV)
-C
-C *** CODED BY DAVID M. GAY (WINTER 1982, FALL 1983) ***
-C
-C *** EXTERNAL FUNCTIONS AND SUBROUTINES ***
-C
- DOUBLE PRECISION DD7TPR
- EXTERNAL DD7TPR, DL7ITV, DL7IVM,DO7PRD, DV7SCP
-C
-C *** LOCAL VARIABLES ***
-C
- INTEGER COV, I, J, M, STEP1
- DOUBLE PRECISION A, FF, S, T
-C
-C *** CONSTANTS ***
-C
- DOUBLE PRECISION NEGONE, ONE, ONEV(1), ZERO
-C
-C *** INTRINSIC FUNCTIONS ***
-C/+
- DOUBLE PRECISION DSQRT
-C/
-C
-C *** IV AND V SUBSCRIPTS ***
-C
- INTEGER F, H, MODE, RDREQ, STEP
-C/6
-C DATA F/10/, H/56/, MODE/35/, RDREQ/57/, STEP/40/
-C/7
- PARAMETER (F=10, H=56, MODE=35, RDREQ=57, STEP=40)
-C/
-C/6
-C DATA NEGONE/-1.D+0/, ONE/1.D+0/, ZERO/0.D+0/
-C/7
- PARAMETER (NEGONE=-1.D+0, ONE=1.D+0, ZERO=0.D+0)
-C/
- DATA ONEV(1)/1.D+0/
-C
-C++++++++++++++++++++++++++++++++ BODY +++++++++++++++++++++++++++++++
-C
- STEP1 = IV(STEP)
- I = IV(RDREQ)
- IF (I .LE. 0) GO TO 999
- IF (MOD(I,4) .LT. 2) GO TO 30
- FF = ONE
- IF (V(F) .NE. ZERO) FF = ONE / DSQRT(DABS(V(F)))
- CALL DV7SCP(NN, RD, NEGONE)
- DO 20 I = 1, NN
- A = R(I)**2
- M = STEP1
- DO 10 J = 1, P
- V(M) = DR(I,J)
- M = M + 1
- 10 CONTINUE
- CALL DL7IVM(P, V(STEP1), L, V(STEP1))
- S = DD7TPR(P, V(STEP1), V(STEP1))
- T = ONE - S
- IF (T .LE. ZERO) GO TO 20
- A = A * S / T
- RD(I) = DSQRT(A) * FF
- 20 CONTINUE
-C
- 30 IF (IV(MODE) - P .LT. 2) GO TO 999
-C
-C *** COMPUTE DEFAULT COVARIANCE MATRIX ***
-C
- COV = IABS(IV(H))
- DO 50 I = 1, NN
- M = STEP1
- DO 40 J = 1, P
- V(M) = DR(I,J)
- M = M + 1
- 40 CONTINUE
- CALL DL7IVM(P, V(STEP1), L, V(STEP1))
- CALL DL7ITV(P, V(STEP1), L, V(STEP1))
- CALL DO7PRD(1, LH, P, V(COV), ONEV, V(STEP1), V(STEP1))
- 50 CONTINUE
-C
- 999 RETURN
-C *** LAST LINE OF DN2LRD FOLLOWS ***
- END
diff --git a/CEP/PyBDSM/src/port3/dn2p.f b/CEP/PyBDSM/src/port3/dn2p.f
deleted file mode 100644
index 617574fbb2e6b6c501cb17bea8afed7212f446d9..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/dn2p.f
+++ /dev/null
@@ -1,177 +0,0 @@
- SUBROUTINE DN2P(N, ND, P, X, CALCR, CALCJ, IV, LIV, LV, V,
- 1 UI, UR, UF)
-C
-C *** VERSION OF NL2SOL THAT CALLS DRN2G AND HAS EXPANDED CALLING
-C *** SEQUENCES FOR CALCR, CALCJ, ALLOWING THEM TO PROVIDE R AND J
-C *** (RESIDUALS AND JACOBIAN) IN CHUNKS.
-C
-C *** PARAMETERS ***
-C
- INTEGER N, ND, P, LIV, LV
-C/6
-C INTEGER IV(LIV), UI(1)
-C DOUBLE PRECISION X(P), V(LV), UR(1)
-C/7
- INTEGER IV(LIV), UI(*)
- DOUBLE PRECISION X(P), V(LV), UR(*)
-C/
- EXTERNAL CALCR, CALCJ, UF
-C
-C
-C *** PARAMETER USAGE ***
-C
-C N....... TOTAL NUMBER OF RESIDUALS.
-C ND...... MAXIMUM NUMBER OF RESIDUAL COMPONENTS PROVIDED BY ANY CALL
-C ON CALCR.
-C P....... NUMBER OF PARAMETERS (COMPONENTS OF X) BEING ESTIMATED.
-C X....... PARAMETER VECTOR BEING ESTIMATED (INPUT = INITIAL GUESS,
-C OUTPUT = BEST VALUE FOUND).
-C CALCR... SUBROUTINE FOR COMPUTING RESIDUAL VECTOR.
-C CALCJ... SUBROUTINE FOR COMPUTING JACOBIAN MATRIX = MATRIX OF FIRST
-C PARTIALS OF THE RESIDUAL VECTOR.
-C IV...... INTEGER VALUES ARRAY.
-C LIV..... LENGTH OF IV (SEE DISCUSSION BELOW).
-C LV...... LENGTH OF V (SEE DISCUSSION BELOW).
-C V....... FLOATING-POINT VALUES ARRAY.
-C UI...... PASSED UNCHANGED TO CALCR AND CALCJ.
-C UR...... PASSED UNCHANGED TO CALCR AND CALCJ.
-C UF...... PASSED UNCHANGED TO CALCR AND CALCJ.
-C
-C
-C *** DISCUSSION ***
-C
-C THIS ROUTINE IS SIMILAR TO DN2G (WHICH SEE), EXCEPT THAT THE
-C CALLING SEQUENCE FOR CALCR AND CALCJ IS DIFFERENT -- IT ALLOWS
-C THE RESIDUAL VECTOR AND JACOBIAN MATRIX TO BE PASSED IN BLOCKS.
-C
-C FOR CALCR, THE CALLING SEQUENCE IS...
-C
-C CALCR(N, ND1, N1, N2, P, X, NF, R, UI, UR, UF)
-C
-C PARAMETERS N, P, X, NF, R, UI, UR, UF ARE AS FOR THE CALCR USED
-C BY NL2SOL OR DN2G.
-C PARAMETERS ND1, N1, AND N2 ARE INPUTS TO CALCR. CALCR SHOULD NOT
-C CHANGE ND1 OR N1 (BUT MAY CHANGE N2).
-C ND1 = MIN(N,ND) IS THE MAXIMUM NUMBER OF RESIDUAL COMPONENTS THAT
-C CALCR SHOULD SUPPLY ON ONE CALL.
-C N1 IS THE INDEX OF THE FIRST RESIDUAL COMPONENT THAT CALCR SHOULD
-C SUPPLY ON THIS CALL.
-C N2 HAS THE VALUE MIN(N, N1+ND1-1) WHEN CALCR IS CALLED. CALCR
-C MAY SET N2 TO A LOWER VALUE (AT LEAST 1) AND FOR N1 .LE. I .LE. N2
-C SHOULD RETURN RESIDUAL COMPONENT I IN R(I-N1+1), I.E., IN COMPONENTS
-C R(1), R(2), ..., R(N2-N1+1).
-C
-C FOR CALCJ, THE CALLING SEQUENCE IS...
-C
-C CALCJ(N, ND1, N1, N2, P, X, NF, J, UI, UR, UF)
-C
-C ALL PARAMETERS EXCEPT N2 AND J ARE AS FOR CALCR. N2 MAY NOT BE
-C CHANGED, BUT OTHERWISE IS AS FOR CALCR. (WHENEVER CALCJ IS CALLED,
-C CALCR WILL JUST HAVE BEEN CALLED WITH THE SAME VALUE OF N1 BUT
-C POSSIBLY A DIFFERENT X -- NF IDENTIFIES THE X PASSED. IF CALCR
-C CHANGES N2, THEN THIS CHANGED VALUE IS PASSED TO CALCJ.)
-C J IS A FLOATING-POINT ARRAY DIMENSIONED J(ND1,P). FOR I = N1(1)N2
-C AND K = 1(1)P, CALCJ MUST STORE THE PARTIAL DERIVATIVE AT X OF
-C RESIDUAL COMPONENT I WITH RESPECT TO X(K) IN J(I-N1+1,K).
-C
-C LIV MUST BE AT LEAST 82 + P. LV MUST BE AT LEAST
-C 105 + P*(17 + 2*P) + (P+1)*MIN(ND,N) + N
-C IF ND .LT. N AND NO REGRESSION DIAGNOSTIC ARRAY IS REQUESTED
-C (I.E., IV(RDREQ) = 0 OR 1), THEN LV CAN BE N LESS THAN THIS.
-C
-C+++++++++++++++++++++++++++ DECLARATIONS +++++++++++++++++++++++++++
-C
-C *** EXTERNAL SUBROUTINES ***
-C
- EXTERNAL DIVSET, DN2RDP, DRN2G
-C DIVSET.... PROVIDES DEFAULT IV AND V INPUT COMPONENTS.
-C DN2RDP... PRINTS REGRESSION DIAGNOSTICS.
-C DRN2G... CARRIES OUT OPTIMIZATION ITERATIONS.
-C
-C *** LOCAL VARIABLES ***
-C
- LOGICAL ONERD
- INTEGER D1, DR1, I, IV1, N1, N2, ND1, NF, R1, RD0, RD1, X01
-C
-C *** IV COMPONENTS ***
-C
- INTEGER D, J, NEXTV, NF00, NFCALL, NFGCAL, R, RDREQ, REGD,
- 1 REGD0, TOOBIG, VNEED, X0
-C/6
-C DATA D/27/, J/70/, NEXTV/47/, NF00/81/, NFCALL/6/, NFGCAL/7/,
-C 1 R/61/, RDREQ/57/, REGD/67/, REGD0/82/, TOOBIG/2/, VNEED/4/,
-C 2 X0/43/
-C/7
- PARAMETER (D=27, J=70, NEXTV=47, NF00=81, NFCALL=6, NFGCAL=7,
- 1 R=61, RDREQ=57, REGD=67, REGD0=82, TOOBIG=2, VNEED=4,
- 2 X0=43)
-C/
-C--------------------------------- BODY ------------------------------
-C
- IF (IV(1) .EQ. 0) CALL DIVSET(1, IV, LIV, LV, V)
- ND1 = MIN0(ND, N)
- IV1 = IV(1)
- IF (IV1 .EQ. 14) GO TO 10
- IF (IV1 .GT. 2 .AND. IV1 .LT. 12) GO TO 10
- IF (IV1 .EQ. 12) IV(1) = 13
- I = IV(VNEED) + P + ND1*(P+1)
- ONERD = IV(RDREQ) .GE. 2 .OR. ND .GE. N
- IF (ONERD) I = I + N
- IF (IV(1) .EQ. 13) IV(VNEED) = I
- CALL DRN2G(V, V, IV, LIV, LV, N, ND1, N1, N2, P, V, V, V, X)
- IF (IV(1) .NE. 14) GO TO 999
-C
-C *** STORAGE ALLOCATION ***
-C
- IV(D) = IV(NEXTV)
- IV(R) = IV(D) + P
- I = IV(R) + ND1
- IV(REGD0) = I
- IF (ONERD) I = I + N
- IV(J) = I
- IV(NEXTV) = I + ND1*P
- IF (IV1 .EQ. 13) GO TO 999
-C
- 10 D1 = IV(D)
- DR1 = IV(J)
- R1 = IV(R)
- RD1 = IV(REGD0)
- RD0 = RD1 - 1
-C
- 20 CALL DRN2G(V(D1), V(DR1), IV, LIV, LV, N, ND1, N1, N2, P, V(R1),
- 1 V(RD1), V, X)
- IV1 = IV(1)
- IF (IV1-2) 40, 30, 80
- 30 IF (ND .GE. N) GO TO 70
-C
-C *** FIRST COMPUTE RELEVANT PORTION OF R ***
-C
- 40 NF = IV(NFCALL)
- IF (IABS(IV1) .GE. 2) NF = IV(NFGCAL)
- CALL CALCR(N, ND1, N1, N2, P, X, NF, V(R1), UI, UR, UF)
- IF (NF .GT. 0) GO TO 50
- IV(TOOBIG) = 1
- GO TO 20
- 50 I = IV1 + 4
- GO TO (70, 60, 70, 20, 20, 70), I
- 60 X01 = IV(X0)
- CALL CALCJ(N, ND1, N1, N2, P, V(X01), IV(NF00), V(DR1), UI,
- 1 UR, UF)
- IF (IV(NF00) .LE. 0) IV(TOOBIG) = 1
- GO TO 20
-C
-C *** COMPUTE DR = GRADIENT OF R COMPONENTS ***
-C
- 70 CALL CALCJ(N, ND1, N1, N2, P, X, IV(NFGCAL), V(DR1), UI, UR, UF)
- IF (IV(NFGCAL) .EQ. 0) IV(TOOBIG) = 1
- RD1 = RD0 + N1
- GO TO 20
-C
- 80 RD1 = RD0 + 1
- IF (IV(REGD) .GT. 0) IV(REGD) = RD1
- IF (IV(1) .LE. 8) CALL DN2RDP(IV, LIV, LV, N, V(RD1), V)
-C
- 999 RETURN
-C
-C *** LAST LINE OF DN2P FOLLOWS ***
- END
diff --git a/CEP/PyBDSM/src/port3/dn2pb.f b/CEP/PyBDSM/src/port3/dn2pb.f
deleted file mode 100644
index 4b6ae328a975254dc84f61faf18d845141d91af3..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/dn2pb.f
+++ /dev/null
@@ -1,168 +0,0 @@
- SUBROUTINE DN2PB(N, ND, P, X, B, CALCR, CALCJ, IV, LIV, LV, V,
- 1 UI, UR, UF)
-C
-C *** SIMPLY BOUNDED VERSION OF NL2SOL THAT HAS EXPANDED CALLING
-C *** SEQUENCES FOR CALCR, CALCJ, ALLOWING THEM TO PROVIDE R AND J
-C *** (RESIDUALS AND JACOBIAN) IN CHUNKS.
-C
-C *** PARAMETERS ***
-C
- INTEGER N, ND, P, LIV, LV
-C/6
-C INTEGER IV(LIV), UI(1)
-C DOUBLE PRECISION B(2,P), X(P), V(LV), UR(1)
-C/7
- INTEGER IV(LIV), UI(*)
- DOUBLE PRECISION B(2,P), X(P), V(LV), UR(*)
-C/
- EXTERNAL CALCR, CALCJ, UF
-C
-C
-C *** PARAMETER USAGE ***
-C
-C N....... TOTAL NUMBER OF RESIDUALS.
-C ND...... MAXIMUM NUMBER OF RESIDUAL COMPONENTS PROVIDED BY ANY CALL
-C ON CALCR.
-C P....... NUMBER OF PARAMETERS (COMPONENTS OF X) BEING ESTIMATED.
-C X....... PARAMETER VECTOR BEING ESTIMATED (INPUT = INITIAL GUESS,
-C OUTPUT = BEST VALUE FOUND).
-C CALCR... SUBROUTINE FOR COMPUTING RESIDUAL VECTOR.
-C CALCJ... SUBROUTINE FOR COMPUTING JACOBIAN MATRIX = MATRIX OF FIRST
-C PARTIALS OF THE RESIDUAL VECTOR.
-C IV...... INTEGER VALUES ARRAY.
-C LIV..... LENGTH OF IV (SEE DISCUSSION BELOW).
-C LV...... LENGTH OF V (SEE DISCUSSION BELOW).
-C V....... FLOATING-POINT VALUES ARRAY.
-C UI...... PASSED UNCHANGED TO CALCR AND CALCJ.
-C UR...... PASSED UNCHANGED TO CALCR AND CALCJ.
-C UF...... PASSED UNCHANGED TO CALCR AND CALCJ.
-C
-C
-C *** DISCUSSION ***
-C
-C THIS ROUTINE IS SIMILAR TO DN2G (WHICH SEE), EXCEPT THAT THE
-C CALLING SEQUENCE FOR CALCR AND CALCJ IS DIFFERENT -- IT ALLOWS
-C THE RESIDUAL VECTOR AND JACOBIAN MATRIX TO BE PASSED IN BLOCKS.
-C
-C FOR CALCR, THE CALLING SEQUENCE IS...
-C
-C CALCR(N, ND1, N1, N2, P, X, NF, R, UI, UR, UF)
-C
-C PARAMETERS N, P, X, NF, R, UI, UR, UF ARE AS FOR THE CALCR USED
-C BY NL2SOL OR DN2G.
-C PARAMETERS ND1, N1, AND N2 ARE INPUTS TO CALCR. CALCR SHOULD NOT
-C CHANGE ND1 OR N1 (BUT MAY CHANGE N2).
-C ND1 = MIN(N,ND) IS THE MAXIMUM NUMBER OF RESIDUAL COMPONENTS THAT
-C CALCR SHOULD SUPPLY ON ONE CALL.
-C N1 IS THE INDEX OF THE FIRST RESIDUAL COMPONENT THAT CALCR SHOULD
-C SUPPLY ON THIS CALL.
-C N2 HAS THE VALUE MIN(N, N1+ND1-1) WHEN CALCR IS CALLED. CALCR
-C MAY SET N2 TO A LOWER VALUE (AT LEAST 1) AND FOR N1 .LE. I .LE. N2
-C SHOULD RETURN RESIDUAL COMPONENT I IN R(I-N1+1), I.E., IN COMPONENTS
-C R(1), R(2), ..., R(N2-N1+1).
-C
-C FOR CALCJ, THE CALLING SEQUENCE IS...
-C
-C CALCJ(N, ND1, N1, N2, P, X, NF, J, UI, UR, UF)
-C
-C ALL PARAMETERS EXCEPT N2 AND J ARE AS FOR CALCR. N2 MAY NOT BE
-C CHANGED, BUT OTHERWISE IS AS FOR CALCR. (WHENEVER CALCJ IS CALLED,
-C CALCR WILL JUST HAVE BEEN CALLED WITH THE SAME VALUE OF N1 BUT
-C POSSIBLY A DIFFERENT X -- NF IDENTIFIES THE X PASSED. IF CALCR
-C CHANGES N2, THEN THIS CHANGED VALUE IS PASSED TO CALCJ.)
-C J IS A FLOATING-POINT ARRAY DIMENSIONED J(ND1,P). FOR I = N1(1)N2
-C AND K = 1(1)P, CALCJ MUST STORE THE PARTIAL DERIVATIVE AT X OF
-C RESIDUAL COMPONENT I WITH RESPECT TO X(K) IN J(I-N1+1,K).
-C
-C LIV MUST BE AT LEAST 82 + P. LV MUST BE AT LEAST
-C 105 + P*(17 + 2*P) + (P+1)*MIN(ND,N) + N
-C IF ND .LT. N AND NO REGRESSION DIAGNOSTIC ARRAY IS REQUESTED
-C (I.E., IV(RDREQ) = 0 OR 1), THEN LV CAN BE N LESS THAN THIS.
-C
-C+++++++++++++++++++++++++++ DECLARATIONS +++++++++++++++++++++++++++
-C
-C *** EXTERNAL SUBROUTINES ***
-C
- EXTERNAL DIVSET, DRN2GB
-C DIVSET.... PROVIDES DEFAULT IV AND V INPUT COMPONENTS.
-C DRN2GB... CARRIES OUT OPTIMIZATION ITERATIONS.
-C
-C *** LOCAL VARIABLES ***
-C
- LOGICAL ONERD
- INTEGER D1, DR1, I, IV1, N1, N2, ND1, NF, R1, RD1, X01
-C
-C *** IV COMPONENTS ***
-C
- INTEGER D, J, NEXTV, NF00, NFCALL, NFGCAL, R,
- 1 REGD0, TOOBIG, VNEED, X0
-C/6
-C DATA D/27/, J/70/, NEXTV/47/, NF00/81/, NFCALL/6/, NFGCAL/7/,
-C 1 R/61/, REGD0/82/, TOOBIG/2/, VNEED/4/, X0/43/
-C/7
- PARAMETER (D=27, J=70, NEXTV=47, NF00=81, NFCALL=6, NFGCAL=7,
- 1 R=61, REGD0=82, TOOBIG=2, VNEED=4, X0=43)
-C/
-C--------------------------------- BODY ------------------------------
-C
- IF (IV(1) .EQ. 0) CALL DIVSET(1, IV, LIV, LV, V)
- ND1 = MIN0(ND, N)
- IV1 = IV(1)
- IF (IV1 .EQ. 14) GO TO 10
- IF (IV1 .GT. 2 .AND. IV1 .LT. 12) GO TO 10
- IF (IV1 .EQ. 12) IV(1) = 13
- I = IV(VNEED) + P + ND1*(P+1)
- ONERD = ND .GE. N
- IF (ONERD) I = I + N
- IF (IV(1) .EQ. 13) IV(VNEED) = I
- CALL DRN2GB(B, V, V, IV, LIV, LV, N, ND1, N1, N2, P, V, V, V, X)
- IF (IV(1) .NE. 14) GO TO 999
-C
-C *** STORAGE ALLOCATION ***
-C
- IV(D) = IV(NEXTV)
- IV(R) = IV(D) + P
- I = IV(R) + ND1
- IV(REGD0) = I
- IF (ONERD) I = I + N
- IV(J) = I
- IV(NEXTV) = I + ND1*P
- IF (IV1 .EQ. 13) GO TO 999
-C
- 10 D1 = IV(D)
- DR1 = IV(J)
- R1 = IV(R)
- RD1 = IV(REGD0)
-C
- 20 CALL DRN2GB(B, V(D1), V(DR1), IV, LIV, LV, N, ND1, N1, N2, P,
- 1 V(R1), V(RD1), V, X)
- IV1 = IV(1)
- IF (IV1-2) 40, 30, 999
- 30 IF (ND .GE. N) GO TO 70
-C
-C *** FIRST COMPUTE RELEVANT PORTION OF R ***
-C
- 40 NF = IV(NFCALL)
- IF (IABS(IV1) .GE. 2) NF = IV(NFGCAL)
- CALL CALCR(N, ND1, N1, N2, P, X, NF, V(R1), UI, UR, UF)
- IF (NF .GT. 0) GO TO 50
- IV(TOOBIG) = 1
- GO TO 20
- 50 I = IV1 + 4
- GO TO (70, 60, 70, 20, 20, 70), I
- 60 X01 = IV(X0)
- CALL CALCJ(N, ND1, N1, N2, P, V(X01), IV(NF00), V(DR1), UI,
- 1 UR, UF)
- IF (IV(NF00) .LE. 0) IV(TOOBIG) = 1
- GO TO 20
-C
-C *** COMPUTE DR = GRADIENT OF R COMPONENTS ***
-C
- 70 CALL CALCJ(N, ND1, N1, N2, P, X, IV(NFGCAL), V(DR1), UI, UR, UF)
- IF (IV(NFGCAL) .EQ. 0) IV(TOOBIG) = 1
- GO TO 20
-C
- 999 RETURN
-C
-C *** LAST LINE OF DN2PB FOLLOWS ***
- END
diff --git a/CEP/PyBDSM/src/port3/dn2rdp.f b/CEP/PyBDSM/src/port3/dn2rdp.f
deleted file mode 100644
index 3f81175b24b66511598ca8bf6fd0c68e517d7b3d..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/dn2rdp.f
+++ /dev/null
@@ -1,42 +0,0 @@
- SUBROUTINE DN2RDP(IV, LIV, LV, N, RD, V)
-C
-C *** PRINT REGRESSION DIAGNOSTICS FOR MLPSL AND NL2S1 ***
-C
- INTEGER LIV, LV, N
- INTEGER IV(LIV)
- DOUBLE PRECISION RD(N), V(LV)
-C
-C *** NOTE -- V IS PASSED FOR POSSIBLE _USE_ BY REVISED VERSIONS OF
-C *** THIS ROUTINE.
-C
- INTEGER PU
-C
-C *** IV AND V SUBSCRIPTS ***
-C
- INTEGER COVPRT, F, NEEDHD, PRUNIT, REGD
-C
-C/6
-C DATA COVPRT/14/, F/10/, NEEDHD/36/, PRUNIT/21/, REGD/67/
-C/7
- PARAMETER (COVPRT=14, F=10, NEEDHD=36, PRUNIT=21, REGD=67)
-C/
-C
-C+++++++++++++++++++++++++++++++ BODY ++++++++++++++++++++++++++++++++
-C
- PU = IV(PRUNIT)
- IF (PU .EQ. 0) GO TO 999
- IF (IV(COVPRT) .LT. 2) GO TO 999
- IF (IV(REGD) .LE. 0) GO TO 999
- IV(NEEDHD) = 1
- IF (V(F)) 10, 30, 10
- 10 WRITE(PU,20) RD
- 20 FORMAT(/70H REGRESSION DIAGNOSTIC = SQRT( G(I)**T * H(I)**-1 * G(I
- 1) / ABS(F) ).../(6D12.3))
- GO TO 999
- 30 WRITE(PU,40) RD
- 40 FORMAT(/61H REGRESSION DIAGNOSTIC = SQRT( G(I)**T * H(I)**-1 * G(I
- 1) ).../(6D12.3))
-C
- 999 RETURN
-C *** LAST LINE OF DN2RDP FOLLOWS ***
- END
diff --git a/CEP/PyBDSM/src/port3/dnsf.f b/CEP/PyBDSM/src/port3/dnsf.f
deleted file mode 100644
index 21ea88b9a12b612e49a56734bbc8fe92ea235c00..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/dnsf.f
+++ /dev/null
@@ -1,308 +0,0 @@
- SUBROUTINE DNSF(N, P, L, ALF, C, Y, CALCA, INC, IINC, IV,
- 1 LIV, LV, V, UIPARM, URPARM, UFPARM)
-C
-C *** SOLVE SEPARABLE NONLINEAR LEAST SQUARES USING
-C *** FINITE-DIFFERENCE DERIVATIVES.
-C
-C *** PARAMETER DECLARATIONS ***
-C
- INTEGER IINC, L, LIV, LV, N, P
-C/6
-C INTEGER INC(IINC,P), IV(LIV), UIPARM(1)
-C DOUBLE PRECISION ALF(P), C(L), URPARM(1), V(LV), Y(N)
-C/7
- INTEGER INC(IINC,P), IV(LIV), UIPARM(*)
- DOUBLE PRECISION ALF(P), C(L), URPARM(*), V(LV), Y(N)
-C/
- EXTERNAL CALCA, UFPARM
-C
-C *** PARAMETERS ***
-C
-C N (IN) NUMBER OF OBSERVATIONS.
-C P (IN) NUMBER OF NONLINEAR PARAMETERS TO BE ESTIMATED.
-C L (IN) NUMBER OF LINEAR PARAMETERS TO BE ESTIMATED.
-C ALF (I/O) NONLINEAR PARAMETERS.
-C INPUT = INITIAL GUESS,
-C OUTPUT = BEST ESTIMATE FOUND.
-C C (OUT) LINEAR PARAMETERS (ESTIMATED).
-C Y (IN) RIGHT-HAND SIDE VECTOR.
-C CALCA (IN) SUBROUTINE TO COMPUTE A MATRIX.
-C INC (IN) INCIDENCE MATRIX OF DEPENDENCIES OF COLUMNS OF A ON
-C COMPONENTS OF ALF -- INC(I,J) = 1 MEANS COLUMN I
-C OF A DEPENDS ON ALF(J).
-C IINC (IN) DECLARED LEAD DIMENSION OF INC. MUST BE AT LEAST L+1.
-C IV (I/O) INTEGER PARAMETER AND SCRATCH VECTOR.
-C LIV (IN) LENGTH OF IV. MUST BE AT LEAST
-C 122 + 2*M + 4*P + 2*L + MAX(L+1,6*P), WHERE M IS
-C THE NUMBER OF ONES IN INC.
-C LV (IN) LENGTH OF V. MUST BE AT LEAST
-C 105 + 2*N*(L+3) + JLEN + L*(L+3)/2 + P*(2*P + 18),
-C WHERE JLEN = (L+P)*(N+L+P+1), UNLESS NEITHER A
-C COVARIANCE MATRIX NOR REGRESSION DIAGNOSTICS ARE
-C REQUESTED, IN WHICH CASE JLEN = N*P. IF THE LAST
-C ROW OF INC CONTAINS ONLY ZEROS, THEN LV CAN BE 4*N
-C LESS THAN JUST DESCRIBED.
-C V (I/O) FLOATING-POINT PARAMETER AND SCRATCH VECTOR.
-C IF A COVARIANCE ESTIMATE IS REQUESTED, IT IS FOR
-C (ALF,C) -- NONLINEAR PARAMETERS ORDERED FIRST,
-C FOLLOWED BY LINEAR PARAMETERS.
-C UIPARM (I/O) INTEGER VECTOR PASSED WITHOUT CHANGE TO CALCA.
-C URPARM (I/O) FLOATING-POINT VECTOR PASSED WITHOUT CHANGE TO CALCA.
-C UFPARM (I/O) SUBROUTINE PASSED (WITHOUT HAVING BEEN CALLED) TO CALCA.
-C
-C
-C-------------------------- DECLARATIONS ----------------------------
-C
-C
-C *** EXTERNAL SUBROUTINES ***
-C
- EXTERNAL DIVSET, DSM, DRNSG,DV2AXY,DV7CPY, DV7SCL
-C
-C DIVSET.... PROVIDES DEFAULT IV AND V VALUES.
-C DSM...... DETERMINES EFFICIENT ORDER FOR FINITE DIFFERENCES.
-C DRNSG... CARRIES OUT NL2SOL ALGORITHM.
-C DV2AXY.... ADDS A MULTIPLE OF ONE VECTOR TO ANOTHER.
-C DV7CPY.... COPIES ONE VECTOR TO ANOTHER.
-C DV7SCL... SCALES AND COPIES ONE VECTOR TO ANOTHER.
-C
-C *** LOCAL VARIABLES ***
-C
- LOGICAL PARTJ
- INTEGER A0, A1, AJ, ALP1, BWA1, D0, DA0, DA1, DAJ, GPTR1, GRP1,
- 1 GRP2, I, I1, IN0, IN1, IN2, INI, INLEN, IPNTR1, IV1, IWA1,
- 2 IWALEN, J1, JN1, JPNTR1, K, L1, LP1, M, M0, NF, NG, NGRP0,
- 3 NGRP1, NGRP2, RSAVE0, RSAVE1, RSVLEN, X0I, XSAVE0, XSAVE1
- DOUBLE PRECISION DELTA, DI, H, XI
- DOUBLE PRECISION NEGONE, ONE, ZERO
-C
-C *** SUBSCRIPTS FOR IV AND V ***
-C
- INTEGER AMAT, COVREQ, D, DAMAT, DLTFDJ, GPTR, GRP, IN, IVNEED,
- 1 L1SAV, MAXGRP, MODE, MSAVE, NEXTIV, NEXTV, NFCALL, NFGCAL,
- 2 PERM, RESTOR, TOOBIG, VNEED, XSAVE
-C
-C *** IV SUBSCRIPT VALUES ***
-C
-C/6
-C DATA AMAT/113/, COVREQ/15/, D/27/, DAMAT/114/, DLTFDJ/43/,
-C 1 GPTR/117/, GRP/118/, IN/112/, IVNEED/3/, L1SAV/111/,
-C 2 MAXGRP/116/, MODE/35/, MSAVE/115/, NEXTIV/46/, NEXTV/47/,
-C 3 NFCALL/6/, NFGCAL/7/, PERM/58/, RESTOR/9/, TOOBIG/2/,
-C 4 VNEED/4/, XSAVE/119/
-C/7
- PARAMETER (AMAT=113, COVREQ=15, D=27, DAMAT=114, DLTFDJ=43,
- 1 GPTR=117, GRP=118, IN=112, IVNEED=3, L1SAV=111,
- 2 MAXGRP=116, MODE=35, MSAVE=115, NEXTIV=46, NEXTV=47,
- 3 NFCALL=6, NFGCAL=7, PERM=58, RESTOR=9, TOOBIG=2,
- 4 VNEED=4, XSAVE=119)
-C/
- DATA NEGONE/-1.D+0/, ONE/1.D+0/, ZERO/0.D+0/
-C
-C++++++++++++++++++++++++++++++++ BODY ++++++++++++++++++++++++++++++
-C
- LP1 = L + 1
- IF (IV(1) .EQ. 0) CALL DIVSET(1, IV, LIV, LV, V)
- IF (P .LE. 0 .OR. L .LT. 0 .OR. IINC .LE. L) GO TO 80
- IV1 = IV(1)
- IF (IV1 .EQ. 14) GO TO 120
- IF (IV1 .GT. 2 .AND. IV1 .LT. 12) GO TO 120
- IF (IV1 .EQ. 12) IV(1) = 13
- IF (IV(1) .NE. 13) GO TO 50
-C
-C *** FRESH START ***
-C
- IF (IV(PERM) .LE. XSAVE) IV(PERM) = XSAVE + 1
-C
-C *** CHECK INC, COUNT ITS NONZEROS
-C
- L1 = 0
- M = 0
- DO 40 I = 1, P
- M0 = M
- IF (L .EQ. 0) GO TO 20
- DO 10 K = 1, L
- IF (INC(K,I) .LT. 0 .OR. INC(K,I) .GT. 1) GO TO 80
- IF (INC(K,I) .EQ. 1) M = M + 1
- 10 CONTINUE
- 20 IF (INC(LP1,I) .NE. 1) GO TO 30
- M = M + 1
- L1 = 1
- 30 IF (M .EQ. M0 .OR. INC(LP1,I) .LT. 0
- 1 .OR. INC(LP1,I) .GT. 1) GO TO 80
- 40 CONTINUE
-C
-C *** NOW L1 = 1 MEANS A HAS COLUMN L+1 ***
-C
-C *** COMPUTE STORAGE REQUIREMENTS ***
-C
- IWALEN = MAX0(LP1, 6*P)
- INLEN = 2 * M
- IV(IVNEED) = IV(IVNEED) + INLEN + 3*P + L + IWALEN + 3
- RSVLEN = 2 * L1 * N
- L1 = L + L1
- IV(VNEED) = IV(VNEED) + 2*N*L1 + RSVLEN + P
-C
- 50 CALL DRNSG(V, ALF, C, V, IV, IV, L, 1, N, LIV, LV, N, M, P, V, Y)
- IF (IV(1) .NE. 14) GO TO 999
-C
-C *** STORAGE ALLOCATION ***
-C
- IV(IN) = IV(NEXTIV)
- IV(AMAT) = IV(NEXTV)
- IV(DAMAT) = IV(AMAT) + N*L1
- IV(XSAVE) = IV(DAMAT) + N*L1
- IV(NEXTV) = IV(XSAVE) + P + RSVLEN
- IV(L1SAV) = L1
- IV(MSAVE) = M
-C
-C *** DETERMINE HOW MANY GROUPS FOR FINITE DIFFERENCES
-C *** (SET UP TO CALL DSM)
-C
- IN1 = IV(IN)
- JN1 = IN1 + M
- DO 70 K = 1, P
- DO 60 I = 1, LP1
- IF (INC(I,K) .EQ. 0) GO TO 60
- IV(IN1) = I
- IN1 = IN1 + 1
- IV(JN1) = K
- JN1 = JN1 + 1
- 60 CONTINUE
- 70 CONTINUE
- IN1 = IV(IN)
- JN1 = IN1 + M
- IWA1 = IN1 + INLEN
- NGRP1 = IWA1 + IWALEN
- BWA1 = NGRP1 + P
- IPNTR1 = BWA1 + P
- JPNTR1 = IPNTR1 + L + 2
- CALL DSM(LP1, P, M, IV(IN1), IV(JN1), IV(NGRP1), NG, K, I,
- 1 IV(IPNTR1), IV(JPNTR1), IV(IWA1), IWALEN, IV(BWA1))
- IF (I .EQ. 1) GO TO 90
- IV(1) = 69
- GO TO 50
- 80 IV(1) = 66
- GO TO 50
-C
-C *** SET UP GRP AND GPTR ARRAYS FOR COMPUTING FINITE DIFFERENCES
-C
-C *** THERE ARE NG GROUPS. GROUP I CONTAINS ALF(GRP(J)) FOR
-C *** GPTR(I) .LE. J .LE. GPTR(I+1)-1.
-C
- 90 IV(MAXGRP) = NG
- IV(GPTR) = IN1 + 2*L1
- GPTR1 = IV(GPTR)
- IV(GRP) = GPTR1 + NG + 1
- IV(NEXTIV) = IV(GRP) + P
- GRP1 = IV(GRP)
- NGRP0 = NGRP1 - 1
- NGRP2 = NGRP0 + P
- DO 110 I = 1, NG
- IV(GPTR1) = GRP1
- GPTR1 = GPTR1 + 1
- DO 100 I1 = NGRP1, NGRP2
- IF (IV(I1) .NE. I) GO TO 100
- IV(GRP1) = I1 - NGRP0
- GRP1 = GRP1 + 1
- 100 CONTINUE
- 110 CONTINUE
- IV(GPTR1) = GRP1
- IF (IV1 .EQ. 13) GO TO 999
-C
-C *** INITIALIZE POINTERS ***
-C
- 120 A1 = IV(AMAT)
- A0 = A1 - N
- DA1 = IV(DAMAT)
- DA0 = DA1 - N
- IN1 = IV(IN)
- IN0 = IN1 - 2
- L1 = IV(L1SAV)
- IN2 = IN1 + 2*L1 - 1
- D0 = IV(D) - 1
- NG = IV(MAXGRP)
- XSAVE1 = IV(XSAVE)
- XSAVE0 = XSAVE1 - 1
- RSAVE1 = XSAVE1 + P
- RSAVE0 = RSAVE1 + N
- ALP1 = A1 + L*N
- DELTA = V(DLTFDJ)
- IV(COVREQ) = -IABS(IV(COVREQ))
-C
- 130 CALL DRNSG(V(A1), ALF, C, V(DA1), IV(IN1), IV, L, L1, N, LIV, LV,
- 1 N, L1, P, V, Y)
- IF (IV(1)-2) 140, 150, 999
-C
-C *** NEW FUNCTION VALUE (R VALUE) NEEDED ***
-C
- 140 NF = IV(NFCALL)
- CALL CALCA(N, P, L, ALF, NF, V(A1), UIPARM, URPARM, UFPARM)
- IF (NF .LE. 0) IV(TOOBIG) = 1
- IF (L1 .LE. L) GO TO 130
- IF (IV(RESTOR) .EQ. 2) CALL DV7CPY(N, V(RSAVE0), V(RSAVE1))
- CALL DV7CPY(N, V(RSAVE1), V(ALP1))
- GO TO 130
-C
-C *** COMPUTE DR = GRADIENT OF R COMPONENTS ***
-C
- 150 IF (L1 .GT. L .AND. IV(NFGCAL) .EQ. IV(NFCALL))
- 1 CALL DV7CPY(N, V(RSAVE0), V(RSAVE1))
- GPTR1 = IV(GPTR)
- DO 230 K = 1, NG
- CALL DV7CPY(P, V(XSAVE1), ALF)
- GRP1 = IV(GPTR1)
- GRP2 = IV(GPTR1+1) - 1
- GPTR1 = GPTR1 + 1
- DO 160 I1 = GRP1, GRP2
- I = IV(I1)
- XI = ALF(I)
- J1 = D0 + I
- DI = V(J1)
- IF (DI .LE. ZERO) DI = ONE
- H = DELTA * DMAX1(DABS(XI), ONE/DI)
- IF (XI .LT. ZERO) H = -H
- X0I = XSAVE0 + I
- V(X0I) = XI + H
- 160 CONTINUE
- CALL CALCA(N, P, L, V(XSAVE1), IV(NFGCAL), V(DA1),
- 1 UIPARM, URPARM, UFPARM)
- IF (IV(NFGCAL) .GT. 0) GO TO 170
- IV(TOOBIG) = 1
- GO TO 130
- 170 JN1 = IN1
- DO 180 I = IN1, IN2
- 180 IV(I) = 0
- PARTJ = IV(MODE) .LE. P
- DO 220 I1 = GRP1, GRP2
- I = IV(I1)
- DO 210 J1 = 1, L1
- IF (INC(J1,I) .EQ. 0) GO TO 210
- INI = IN0 + 2*J1
- IV(INI) = I
- IV(INI+1) = J1
- X0I = XSAVE0 + I
- H = ONE / (V(X0I) - ALF(I))
- DAJ = DA0 + J1*N
- IF (PARTJ) GO TO 190
-C *** FULL FINITE DIFFERENCE FOR COV. AND REG. DIAG. ***
- AJ = A0 + J1*N
- CALL DV2AXY(N, V(DAJ), NEGONE, V(AJ), V(DAJ))
- GO TO 200
- 190 IF (J1 .GT. L)
- 1 CALL DV2AXY(N, V(DAJ), NEGONE, V(RSAVE0), V(DAJ))
- 200 CALL DV7SCL(N, V(DAJ), H, V(DAJ))
- 210 CONTINUE
- 220 CONTINUE
- IF (K .GE. NG) GO TO 240
- IV(1) = -2
- CALL DRNSG(V(A1), ALF, C, V(DA1), IV(IN1), IV, L, L1, N, LIV,
- 1 LV, N, L1, P, V, Y)
- IF (-2 .NE. IV(1)) GO TO 999
- 230 CONTINUE
- 240 IV(1) = 2
- GO TO 130
-C
- 999 RETURN
-C
-C *** LAST CARD OF DNSF FOLLOWS ***
- END
diff --git a/CEP/PyBDSM/src/port3/dnsfb.f b/CEP/PyBDSM/src/port3/dnsfb.f
deleted file mode 100644
index 57ce78a4c2ae57a394ed50895b2c8d4d2166cc57..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/dnsfb.f
+++ /dev/null
@@ -1,319 +0,0 @@
- SUBROUTINE DNSFB(N, P, L, ALF, B, C, Y, CALCA, INC, IINC, IV,
- 1 LIV, LV, V, UIPARM, URPARM, UFPARM)
-C
-C *** SOLVE SEPARABLE NONLINEAR LEAST SQUARES USING
-C *** FINITE-DIFFERENCE DERIVATIVES.
-C
-C *** PARAMETER DECLARATIONS ***
-C
- INTEGER IINC, L, LIV, LV, N, P
-C/6
-C INTEGER INC(IINC,P), IV(LIV), UIPARM(1)
-C DOUBLE PRECISION ALF(P), C(L), B(2,P), URPARM(1), V(LV), Y(N)
-C/7
- INTEGER INC(IINC,P), IV(LIV), UIPARM(*)
- DOUBLE PRECISION ALF(P), C(L), B(2,P), URPARM(*), V(LV), Y(N)
-C/
- EXTERNAL CALCA, UFPARM
-C
-C *** PARAMETERS ***
-C
-C N (IN) NUMBER OF OBSERVATIONS.
-C P (IN) NUMBER OF NONLINEAR PARAMETERS TO BE ESTIMATED.
-C L (IN) NUMBER OF LINEAR PARAMETERS TO BE ESTIMATED.
-C ALF (I/O) NONLINEAR PARAMETERS.
-C INPUT = INITIAL GUESS,
-C OUTPUT = BEST ESTIMATE FOUND.
-C B (IN) SIMBLE BOUNDS ON ALF.. B(1,I) .LE. ALF(I) .LE. B(2,I).
-C C (OUT) LINEAR PARAMETERS (ESTIMATED).
-C Y (IN) RIGHT-HAND SIDE VECTOR.
-C CALCA (IN) SUBROUTINE TO COMPUTE A MATRIX.
-C INC (IN) INCIDENCE MATRIX OF DEPENDENCIES OF COLUMNS OF A ON
-C COMPONENTS OF ALF -- INC(I,J) = 1 MEANS COLUMN I
-C OF A DEPENDS ON ALF(J).
-C IINC (IN) DECLARED LEAD DIMENSION OF INC. MUST BE AT LEAST L+1.
-C IV (I/O) INTEGER PARAMETER AND SCRATCH VECTOR.
-C LIV (IN) LENGTH OF IV. MUST BE AT LEAST
-C 122 + 2*M + 7*P + 2*L + MAX(L+1,6*P), WHERE M IS
-C THE NUMBER OF ONES IN INC.
-C LV (IN) LENGTH OF V. MUST BE AT LEAST
-C 105 + N*(2*L+6+P) + L*(L+3)/2 + P*(2*P + 22).
-C IF THE LAST ROW OF INC CONTAINS ONLY ZEROS, THEN LV
-C CAN BE 4*N LESS THAN JUST DESCRIBED.
-C V (I/O) FLOATING-POINT PARAMETER AND SCRATCH VECTOR.
-C UIPARM (I/O) INTEGER VECTOR PASSED WITHOUT CHANGE TO CALCA.
-C URPARM (I/O) FLOATING-POINT VECTOR PASSED WITHOUT CHANGE TO CALCA.
-C UFPARM (I/O) SUBROUTINE PASSED (WITHOUT HAVING BEEN CALLED) TO CALCA.
-C
-C
-C-------------------------- DECLARATIONS ----------------------------
-C
-C
-C *** EXTERNAL SUBROUTINES ***
-C
- EXTERNAL DIVSET, DSM, DRNSGB,DV2AXY,DV7CPY, DV7SCL
-C
-C DIVSET.... PROVIDES DEFAULT IV AND V VALUES.
-C DSM...... DETERMINES EFFICIENT ORDER FOR FINITE DIFFERENCES.
-C DRNSGB... CARRIES OUT NL2SOL ALGORITHM.
-C DV2AXY.... ADDS A MULTIPLE OF ONE VECTOR TO ANOTHER.
-C DV7CPY.... COPIES ONE VECTOR TO ANOTHER.
-C DV7SCL... SCALES AND COPIES ONE VECTOR TO ANOTHER.
-C
-C *** LOCAL VARIABLES ***
-C
- LOGICAL PARTJ
- INTEGER A0, A1, AJ, ALP1, BWA1, D0, DA0, DA1, DAJ, GPTR1, GRP1,
- 1 GRP2, I, I1, IN0, IN1, IN2, INI, INLEN, IPNTR1, IV1, IWA1,
- 2 IWALEN, J1, JN1, JPNTR1, K, L1, LP1, M, M0, NF, NG, NGRP0,
- 3 NGRP1, NGRP2, RSAVE0, RSAVE1, RSVLEN, X0I, XSAVE0, XSAVE1
- DOUBLE PRECISION DELTA, DI, H, XI, XI1
- DOUBLE PRECISION NEGONE, ONE, ZERO
-C
-C *** SUBSCRIPTS FOR IV AND V ***
-C
- INTEGER AMAT, COVREQ, D, DAMAT, DLTFDJ, GPTR, GRP, IN, IVNEED,
- 1 L1SAV, MAXGRP, MODE, MSAVE, NEXTIV, NEXTV, NFCALL, NFGCAL,
- 2 PERM, RESTOR, TOOBIG, VNEED, XSAVE
-C
-C *** IV SUBSCRIPT VALUES ***
-C
-C/6
-C DATA AMAT/113/, COVREQ/15/, D/27/, DAMAT/114/, DLTFDJ/43/,
-C 1 GPTR/117/, GRP/118/, IN/112/, IVNEED/3/, L1SAV/111/,
-C 2 MAXGRP/116/, MODE/35/, MSAVE/115/, NEXTIV/46/, NEXTV/47/,
-C 3 NFCALL/6/, NFGCAL/7/, PERM/58/, RESTOR/9/, TOOBIG/2/,
-C 4 VNEED/4/, XSAVE/119/
-C/7
- PARAMETER (AMAT=113, COVREQ=15, D=27, DAMAT=114, DLTFDJ=43,
- 1 GPTR=117, GRP=118, IN=112, IVNEED=3, L1SAV=111,
- 2 MAXGRP=116, MODE=35, MSAVE=115, NEXTIV=46, NEXTV=47,
- 3 NFCALL=6, NFGCAL=7, PERM=58, RESTOR=9, TOOBIG=2,
- 4 VNEED=4, XSAVE=119)
-C/
- DATA NEGONE/-1.D+0/, ONE/1.D+0/, ZERO/0.D+0/
-C
-C++++++++++++++++++++++++++++++++ BODY ++++++++++++++++++++++++++++++
-C
- LP1 = L + 1
- IF (IV(1) .EQ. 0) CALL DIVSET(1, IV, LIV, LV, V)
- IF (P .LE. 0 .OR. L .LT. 0 .OR. IINC .LE. L) GO TO 80
- IV1 = IV(1)
- IF (IV1 .EQ. 14) GO TO 120
- IF (IV1 .GT. 2 .AND. IV1 .LT. 12) GO TO 120
- IF (IV1 .EQ. 12) IV(1) = 13
- IF (IV(1) .NE. 13) GO TO 50
-C
-C *** FRESH START ***
-C
- IF (IV(PERM) .LE. XSAVE) IV(PERM) = XSAVE + 1
-C
-C *** CHECK INC, COUNT ITS NONZEROS
-C
- L1 = 0
- M = 0
- DO 40 I = 1, P
- IF (B(1,I) .GE. B(2,I)) GO TO 40
- M0 = M
- IF (L .EQ. 0) GO TO 20
- DO 10 K = 1, L
- IF (INC(K,I) .LT. 0 .OR. INC(K,I) .GT. 1) GO TO 80
- IF (INC(K,I) .EQ. 1) M = M + 1
- 10 CONTINUE
- 20 IF (INC(LP1,I) .NE. 1) GO TO 30
- M = M + 1
- L1 = 1
- GO TO 40
- 30 IF (M .EQ. M0 .OR. INC(LP1,I) .LT. 0
- 1 .OR. INC(LP1,I) .GT. 1) GO TO 80
- 40 CONTINUE
-C
-C *** NOW L1 = 1 MEANS A HAS COLUMN L+1 ***
-C
-C *** COMPUTE STORAGE REQUIREMENTS ***
-C
- IWALEN = MAX0(LP1, 6*P)
- INLEN = 2 * M
- IV(IVNEED) = IV(IVNEED) + INLEN + 3*P + L + IWALEN + 3
- RSVLEN = 2 * L1 * N
- L1 = L + L1
- IV(VNEED) = IV(VNEED) + 2*N*L1 + RSVLEN + P
-C
- 50 CALL DRNSGB(V, ALF, B, C, V, IV, IV, L, 1, N, LIV, LV, N, M, P, V,
- 1 Y)
- IF (IV(1) .NE. 14) GO TO 999
-C
-C *** STORAGE ALLOCATION ***
-C
- IV(IN) = IV(NEXTIV)
- IV(AMAT) = IV(NEXTV)
- IV(DAMAT) = IV(AMAT) + N*L1
- IV(XSAVE) = IV(DAMAT) + N*L1
- IV(NEXTV) = IV(XSAVE) + P + RSVLEN
- IV(L1SAV) = L1
- IV(MSAVE) = M
-C
-C *** DETERMINE HOW MANY GROUPS FOR FINITE DIFFERENCES
-C *** (SET UP TO CALL DSM)
-C
- IN1 = IV(IN)
- JN1 = IN1 + M
- DO 70 K = 1, P
- IF (B(1,K) .GE. B(2,K)) GO TO 70
- DO 60 I = 1, LP1
- IF (INC(I,K) .EQ. 0) GO TO 60
- IV(IN1) = I
- IN1 = IN1 + 1
- IV(JN1) = K
- JN1 = JN1 + 1
- 60 CONTINUE
- 70 CONTINUE
- IN1 = IV(IN)
- JN1 = IN1 + M
- IWA1 = IN1 + INLEN
- NGRP1 = IWA1 + IWALEN
- BWA1 = NGRP1 + P
- IPNTR1 = BWA1 + P
- JPNTR1 = IPNTR1 + L + 2
- CALL DSM(LP1, P, M, IV(IN1), IV(JN1), IV(NGRP1), NG, K, I,
- 1 IV(IPNTR1), IV(JPNTR1), IV(IWA1), IWALEN, IV(BWA1))
- IF (I .EQ. 1) GO TO 90
- IV(1) = 69
- GO TO 50
- 80 IV(1) = 66
- GO TO 50
-C
-C *** SET UP GRP AND GPTR ARRAYS FOR COMPUTING FINITE DIFFERENCES
-C
-C *** THERE ARE NG GROUPS. GROUP I CONTAINS ALF(GRP(J)) FOR
-C *** GPTR(I) .LE. J .LE. GPTR(I+1)-1.
-C
- 90 IV(MAXGRP) = NG
- IV(GPTR) = IN1 + 2*L1
- GPTR1 = IV(GPTR)
- IV(GRP) = GPTR1 + NG + 1
- IV(NEXTIV) = IV(GRP) + P
- GRP1 = IV(GRP)
- NGRP0 = NGRP1 - 1
- NGRP2 = NGRP0 + P
- DO 110 I = 1, NG
- IV(GPTR1) = GRP1
- GPTR1 = GPTR1 + 1
- DO 100 I1 = NGRP1, NGRP2
- IF (IV(I1) .NE. I) GO TO 100
- K = I1 - NGRP0
- IF (B(1,K) .GE. B(2,K)) GO TO 100
- IV(GRP1) = K
- GRP1 = GRP1 + 1
- 100 CONTINUE
- 110 CONTINUE
- IV(GPTR1) = GRP1
- IF (IV1 .EQ. 13) GO TO 999
-C
-C *** INITIALIZE POINTERS ***
-C
- 120 A1 = IV(AMAT)
- A0 = A1 - N
- DA1 = IV(DAMAT)
- DA0 = DA1 - N
- IN1 = IV(IN)
- IN0 = IN1 - 2
- L1 = IV(L1SAV)
- IN2 = IN1 + 2*L1 - 1
- D0 = IV(D) - 1
- NG = IV(MAXGRP)
- XSAVE1 = IV(XSAVE)
- XSAVE0 = XSAVE1 - 1
- RSAVE1 = XSAVE1 + P
- RSAVE0 = RSAVE1 + N
- ALP1 = A1 + L*N
- DELTA = V(DLTFDJ)
- IV(COVREQ) = -IABS(IV(COVREQ))
-C
- 130 CALL DRNSGB(V(A1), ALF, B, C, V(DA1), IV(IN1), IV, L, L1, N, LIV,
- 1 LV, N, L1, P, V, Y)
- IF (IV(1)-2) 140, 150, 999
-C
-C *** NEW FUNCTION VALUE (R VALUE) NEEDED ***
-C
- 140 NF = IV(NFCALL)
- CALL CALCA(N, P, L, ALF, NF, V(A1), UIPARM, URPARM, UFPARM)
- IF (NF .LE. 0) IV(TOOBIG) = 1
- IF (L1 .LE. L) GO TO 130
- IF (IV(RESTOR) .EQ. 2) CALL DV7CPY(N, V(RSAVE0), V(RSAVE1))
- CALL DV7CPY(N, V(RSAVE1), V(ALP1))
- GO TO 130
-C
-C *** COMPUTE DR = GRADIENT OF R COMPONENTS ***
-C
- 150 IF (L1 .GT. L .AND. IV(NFGCAL) .EQ. IV(NFCALL))
- 1 CALL DV7CPY(N, V(RSAVE0), V(RSAVE1))
- GPTR1 = IV(GPTR)
- DO 260 K = 1, NG
- CALL DV7CPY(P, V(XSAVE1), ALF)
- GRP1 = IV(GPTR1)
- GRP2 = IV(GPTR1+1) - 1
- GPTR1 = GPTR1 + 1
- DO 180 I1 = GRP1, GRP2
- I = IV(I1)
- XI = ALF(I)
- J1 = D0 + I
- DI = V(J1)
- IF (DI .LE. ZERO) DI = ONE
- H = DELTA * DMAX1(DABS(XI), ONE/DI)
- IF (XI .LT. ZERO) GO TO 160
- XI1 = XI + H
- IF (XI1 .LE. B(2,I)) GO TO 170
- XI1 = XI - H
- IF (XI1 .GE. B(1,I)) GO TO 170
- GO TO 190
- 160 XI1 = XI - H
- IF (XI1 .GE. B(1,I)) GO TO 170
- XI1 = XI + H
- IF (XI1 .LE. B(2,I)) GO TO 170
- GO TO 190
- 170 X0I = XSAVE0 + I
- V(X0I) = XI1
- 180 CONTINUE
- CALL CALCA(N, P, L, V(XSAVE1), NF, V(DA1), UIPARM, URPARM,
- 1 UFPARM)
- IF (IV(NFGCAL) .GT. 0) GO TO 200
- 190 IV(TOOBIG) = 1
- GO TO 130
- 200 JN1 = IN1
- DO 210 I = IN1, IN2
- 210 IV(I) = 0
- PARTJ = IV(MODE) .LE. P
- DO 250 I1 = GRP1, GRP2
- I = IV(I1)
- DO 240 J1 = 1, L1
- IF (INC(J1,I) .EQ. 0) GO TO 240
- INI = IN0 + 2*J1
- IV(INI) = I
- IV(INI+1) = J1
- X0I = XSAVE0 + I
- H = ONE / (V(X0I) - ALF(I))
- DAJ = DA0 + J1*N
- IF (PARTJ) GO TO 220
-C *** FULL FINITE DIFFERENCE FOR COV. AND REG. DIAG. ***
- AJ = A0 + J1*N
- CALL DV2AXY(N, V(DAJ), NEGONE, V(AJ), V(DAJ))
- GO TO 230
- 220 IF (J1 .GT. L)
- 1 CALL DV2AXY(N, V(DAJ), NEGONE, V(RSAVE0), V(DAJ))
- 230 CALL DV7SCL(N, V(DAJ), H, V(DAJ))
- 240 CONTINUE
- 250 CONTINUE
- IF (K .GE. NG) GO TO 270
- IV(1) = -2
- CALL DRNSGB(V(A1), ALF, B, C, V(DA1), IV(IN1), IV, L, L1, N,
- 1 LIV, LV, N, L1, P, V, Y)
- IF (-2 .NE. IV(1)) GO TO 999
- 260 CONTINUE
- 270 IV(1) = 2
- GO TO 130
-C
- 999 RETURN
-C
-C *** LAST CARD OF DNSFB FOLLOWS ***
- END
diff --git a/CEP/PyBDSM/src/port3/dnsg.f b/CEP/PyBDSM/src/port3/dnsg.f
deleted file mode 100644
index 87f7ca95ea9a8f36986295bda68bbda83d4ccdc7..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/dnsg.f
+++ /dev/null
@@ -1,327 +0,0 @@
- SUBROUTINE DNSG(N, P, L, ALF, C, Y, CALCA, CALCB, INC, IINC, IV,
- 1 LIV, LV, V, UIPARM, URPARM, UFPARM)
-C
-C *** SOLVE SEPARABLE NONLINEAR LEAST SQUARES USING ***
-C *** ANALYTICALLY COMPUTED DERIVATIVES. ***
-C
-C *** PARAMETER DECLARATIONS ***
-C
- INTEGER IINC, L, LIV, LV, N, P
-C/6
-C INTEGER INC(IINC,P), IV(LIV), UIPARM(1)
-C DOUBLE PRECISION ALF(P), C(L), URPARM(1), V(LV), Y(N)
-C/7
- INTEGER INC(IINC,P), IV(LIV), UIPARM(*)
- DOUBLE PRECISION ALF(P), C(L), URPARM(*), V(LV), Y(N)
-C/
- EXTERNAL CALCA, CALCB, UFPARM
-C
-C *** PURPOSE ***
-C
-C GIVEN A SET OF N OBSERVATIONS Y(1)....Y(N) OF A DEPENDENT VARIABLE
-C T(1)...T(N), DNSG ATTEMPTS TO COMPUTE A LEAST SQUARES FIT
-C TO A FUNCTION ETA (THE MODEL) WHICH IS A LINEAR COMBINATION
-C
-C L
-C ETA(C,ALF,T) = SUM C * PHI(ALF,T) +PHI (ALF,T)
-C J=1 J J L+1
-C
-C OF NONLINEAR FUNCTIONS PHI(J) DEPENDENT ON T AND ALF(1),...,ALF(P)
-C (.E.G. A SUM OF EXPONENTIALS OR GAUSSIANS). THAT IS, IT DETERMINES
-C NONLINEAR PARAMETERS ALF WHICH MINIMIZE
-C
-C 2 N 2
-C NORM(RESIDUAL) = SUM (Y - ETA(C,ALF,T )).
-C I=1 I I
-C
-C THE (L+1)ST TERM IS OPTIONAL.
-C
-C-------------------------- PARAMETER USAGE -------------------------
-C
-C INPUT PARAMETERS
-C
-C N INTEGER NUMBER OF OBSERVATIONS (MUST BE .GE. MAX(L,P)).
-C
-C P INTEGER NUMBER OF NONLINEAR PARAMETERS (MUST BE .GE. 1).
-C
-C L INTEGER NUMBER OF LINEAR PARAMETERS (MUST BE .GE. 0).
-C
-C ALF D.P. ARRAY P VECTOR = INITIAL ESTIMATE OF THE NONLINEAR
-C PARAMETERS.
-C
-C CALCA SUBROUTINE USER PROVIDED FUNCTION TO CALCULATE THE MODEL
-C (I.E., TO CALCULATE PHI) -- SEE THE NOTE BELOW
-C ON THE CALLING SEQUENCE FOR CALCA.
-C CALCA MUST BE DECLARED EXTERNAL IN THE CALLING
-C PROGRAM.
-C
-C CALCB SUBROUTINE USER PROVIDED FUNCTION TO CALCULATE THE DERIVA-
-C TIVE OF THE MODEL (I.E., OF PHI) WITH RESPECT TO
-C ALF -- SEE THE NOTE BELOW ON THE CALLING
-C SEQUENCE FOR CALCB. CALCB MUST BE DECLARED
-C EXTERNAL IN THE CALLING PROGRAM.
-C
-C Y D.P. ARRAY VECTOR OF OBSERVATIONS.
-C
-C INC INTEGER ARRAY A 2 DIM. ARRAY OF DIMENSION AT LEAST (L+1,P)
-C INDICATING THE POSITION OF THE NONLINEAR PARA-
-C METERS IN THE MODEL. SET INC(J,K) = 1 IF ALF(K)
-C APPEARS IN PHI(J). OTHERWISE SET INC(J,K) = 0.
-C IF PHI((L+1)) IS NOT IN THE MODEL, SET THE L+1ST
-C ROW OF INC TO ALL ZEROS. EVERY COLUMN OF INC
-C MUST CONTAIN AT LEAST ONE 1.
-C
-C IINC INTEGER DECLARED ROW DIMENSION OF INC, WHICH MUST BE AT
-C LEAST L+1.
-C
-C IV INTEGER ARRAY OF LENGTH AT LEAST LIV THAT CONTAINS
-C VARIOUS PARAMETERS FOR THE SUBROUTINE, SUCH AS
-C THE ITERATION AND FUNCTION EVALUATION LIMITS AND
-C SWITCHES THAT CONTROL PRINTING. THE INPUT COM-
-C PONENTS OF IV ARE DESCRIBED IN DETAIL IN THE
-C PORT OPTIMIZATION DOCUMENTATION.
-C IF IV(1)=0 ON INPUT, THEN DEFAULT PARAMETERS
-C ARE SUPPLIED TO IV AND V. THE CALLER MAY SUPPLY
-C NONDEFAULT PARAMETERS TO IV AND V BY EXECUTING A
-C CALL DIVSET(1,IV,LIV,LV,V) AND THEN ASSIGNING
-C NONDEFAULT VALUES TO THE APPROPRIATE COMPONENTS
-C OF IV AND V BEFORE CALLING DNSG.
-C
-C LIV INTEGER LENGTH OF IV. MUST BE AT LEAST 115+P+L + 2*M,
-C WHERE M IS THE NUMBER OF ONES IN INC.
-C
-C LV INTEGER LENGTH OF V. MUST BE AT LEAST
-C 105 + N*(L+M+3) + JLEN + L*(L+3)/2 + P*(2*P+17),
-C WHERE M IS AS FOR LIV (SEE ABOVE) AND
-C JLEN = (L+P)*(N+L+P+1), UNLESS NEITHER A
-C COVARIANCE MATRIX NOR REGRESSION DIAGNOSTICS ARE
-C REQUESTED, IN WHICH CASE JLEN = N*P. IF THE
-C LAST ROW OF INC CONTAINS ONLY ZEROS, THEN LV
-C CAN BE N LESS THAN JUST DESCRIBED.
-C
-C V D.P. ARRAY WORK AND PARAMETER ARRAY OF LENGTH AT LEAST LV
-C THAT CONTAINS SUCH INPUT COMPONENTS AS THE
-C CONVERGENCE TOLERANCES. THE INPUT COMPONENTS OF
-C V MAY BE SUPPLIED AS FOR IV (SEE ABOVE). NOTE
-C THAT V(35) CONTAINS THE INITIAL STEP BOUND,
-C WHICH, IF TOO LARGE, MAY LEAD TO OVERFLOW.
-C
-C UIPARM INTEGER ARRAY SCRATCH SPACE FOR USER TO SEND INFORMATION
-C TO CALCA AND CALCB.
-C
-C URPARM D.P. ARRAY SCRATCH SPACE FOR USER TO SEND INFORMATION
-C TO CALCA AND CALCB.
-C
-C UFPARM EXTERNAL SUBROUTINE SENT TO CALCA AND CALCB FOR THEIR
-C USE. NOTE THAT THE SUBROUTINE PASSED FOR UFPARM
-C MUST BE DECLARED EXTERNAL IN THE CALLING PROGRAM.
-C
-C
-C OUTPUT PARAMETERS
-C
-C ALF D.P. ARRAY FINAL NONLINEAR PARAMETERS.
-C
-C C D.P. ARRAY L VECTOR OF LINEAR PARAMETERS -- NOTE THAT NO
-C INITIAL GUESS FOR C IS REQUIRED.
-C
-C IV IV(1) CONTAINS A RETURN CODE DESCRIBED IN THE
-C PORT OPTIMIZATION DOCUMENTATION. IF IV(1) LIES
-C BETWEEN 3 AND 7, THEN THE ALGORITHM HAS
-C CONVERGED (BUT IV(1) = 7 INDICATES POSSIBLE
-C TROUBLE WITH THE MODEL). IV(1) = 9 OR 10 MEANS
-C FUNCTION EVALUATION OR ITERATION LIMIT REACHED.
-C IV(1) = 66 MEANS BAD PARAMETERS (INCLUDING A
-C COLUMN OF ZEROS IN INC). NOTE THAT THE
-C ALGORITHM CAN BE RESTARTED AFTER ANY RETURN WITH
-C IV(1) .LT. 12 -- SEE THE PORT DOCUMENTATION.
-C
-C V VARIOUS ITEMS OF INTEREST, INCLUDING THE NORM OF
-C THE GRADIENT(1) AND THE FUNCTION VALUE(10). SEE
-C THE PORT DOCUMENTATION FOR A COMPLETE LIST. IF
-C A COVARIANCE ESTIMATE IS REQUESTED, IT IS FOR
-C (ALF,C) -- NONLINEAR PARAMETERS ORDERED FIRST,
-C FOLLOWED BY LINEAR PARAMETERS.
-C
-C
-C
-C PARAMETERS FOR CALCA(N,P,L,ALF,NF,PHI, UIPARM,URPARM,UFPARM)
-C
-C N,L,P,ALF ARE INPUT PARAMETERS AS DESCRIBED ABOVE
-C
-C PHI D.P. ARRAY N*(L+1) ARRAY WHOSE COLUMNS CONTAIN THE TERMS OF
-C THE MODEL. CALCA MUST EVALUATE PHI(ALF) AND STORE
-C THE RESULT IN PHI. IF THE (L+1)ST TERM IS NOT IN
-C THE MODEL, THEN NOTHING SHOULD BE STORED IN THE
-C (L+1)ST COLUMN OF PHI.
-C
-C NF INTEGER CURRENT INVOCATION COUNT FOR CALCA. IF PHI CANNOT
-C BE EVALUATED AT ALF (E.G. BECAUSE AN ARGUMENT TO
-C AN INTRINSIC FUNCTION IS OUT OF RANGE), THEN CALCA
-C SHOULD SIMPLY SET NF TO 0 AND RETURN. THIS
-C TELLS THE ALGORITHM TO TRY A SMALLER STEP.
-C
-C UIPARM,URPARM,UFPARM ARE AS DESCRIBED ABOVE
-C
-C N.B. THE DEPENDENT VARIABLE T IS NOT EXPLICITLY PASSED. IF REQUIRED,
-C IT MAY BE PASSED IN UIPARM OR URPARM OR STORED IN NAMED COMMON.
-C
-C
-C PARAMETERS FOR CALCB(N,P,L,ALF,NF,DER, UIPARM,URPARM,UFPARM)
-C
-C N,P,L,ALF,NF,UIPARM,URPARM,UFPARM ARE AS FOR CALCA
-C
-C DER D.P. ARRAY N*M ARRAY, WHERE M IS THE NUMBER OF ONES IN INC.
-C CALCB MUST SET DER TO THE DERIVATIVES OF THE MODEL
-C WITH RESPECT TO ALF. IF THE MODEL HAS K TERMS THAT
-C DEPEND ON ALF(I), THEN DER WILL HAVE K CONSECUTIVE
-C COLUMNS OF DERIVATIVES WITH RESPECT TO ALF(I). THE
-C COLUMNS OF DER CORRESPOND TO THE ONES IN INC WHEN
-C ONE TRAVELS THROUGH INC BY COLUMNS. FOR EXAMPLE,
-C IF INC HAS THE FORM...
-C 1 1 0
-C 0 1 0
-C 1 0 0
-C 0 0 1
-C THEN THE FIRST TWO COLUMNS OF DER ARE FOR THE
-C DERIVATIVES OF COLUMNS 1 AND 3 OF PHI WITH RESPECT
-C TO ALF(1), COLUMNS 3 AND 4 OF DER ARE FOR THE
-C DERIVATIVES OF COLUMNS 1 AND 2 OF PHI WITH RESPECT
-C TO ALF(2), AND COLUMN 5 OF DER IS FOR THE DERIVA-
-C TIVE OF COLUMN 4 OF PHI WITH RESPECT TO ALF(3).
-C MORE SPECIFICALLY, DER(I,2) IS FOR THE DERIVATIVE
-C OF PHI(I,3) WITH RESPECT TO ALF(1) AND DER(I,5) IS
-C FOR THE DERIVATIVE OF PHI(I,4) WITH RESPECT TO
-C ALF(3) (FOR I = 1,2,...,N).
-C THE VALUE OF ALF PASSED TO CALCB IS THE SAME AS
-C THAT PASSED TO CALCA THE LAST TIME IT WAS CALLED.
-C (IF DER CANNOT BE EVALUATED, THEN CALCB SHOULD SET
-C NF TO 0. THIS WILL CAUSE AN ERROR RETURN.)
-C
-C N.B. DER IS FOR DERIVATIVES WITH RESPECT TO ALF, NOT T.
-C
-C------------------------------ NOTES -------------------------------
-C
-C THIS PROGRAM WAS WRITTEN BY LINDA KAUFMAN AT BELL LABS, MURRAY
-C HILL, N.J. IN 1977 AND EXTENSIVELY REVISED BY HER AND DAVID GAY IN
-C 1980, 1981, 1983, 1984. THE WORK OF DAVID GAY WAS SUPPORTED IN PART
-C BY NATIONAL SCIENCE FOUNDATION GRANT MCS-7906671.
-C
-C-------------------------- DECLARATIONS ----------------------------
-C
-C
-C *** EXTERNAL SUBROUTINES ***
-C
- EXTERNAL DIVSET, DRNSG
-C
-C DIVSET.... PROVIDES DEFAULT IV AND V VALUES.
-C DRNSG... CARRIES OUT NL2SOL ALGORITHM.
-C
-C *** LOCAL VARIABLES ***
-C
- INTEGER A1, DA1, I, IN1, IV1, K, L1, LP1, M, M0, NF
-C
-C *** SUBSCRIPTS FOR IV AND V ***
-C
- INTEGER AMAT, DAMAT, IN, IVNEED, L1SAV, MSAVE, NEXTIV,
- 1 NEXTV, NFCALL, NFGCAL, PERM, TOOBIG, VNEED
-C
-C *** IV SUBSCRIPT VALUES ***
-C
-C/6
-C DATA AMAT/113/, DAMAT/114/, IN/112/, IVNEED/3/, L1SAV/111/,
-C 1 MSAVE/115/, NEXTIV/46/, NEXTV/47/, NFCALL/6/, NFGCAL/7/,
-C 2 PERM/58/, TOOBIG/2/, VNEED/4/
-C/7
- PARAMETER (AMAT=113, DAMAT=114, IN=112, IVNEED=3, L1SAV=111,
- 1 MSAVE=115, NEXTIV=46, NEXTV=47, NFCALL=6, NFGCAL=7,
- 2 PERM=58, TOOBIG=2, VNEED=4)
-C/
-C
-C++++++++++++++++++++++++++++++++ BODY ++++++++++++++++++++++++++++++
-C
- IF (IV(1) .EQ. 0) CALL DIVSET(1, IV, LIV, LV, V)
- IF (P .LE. 0 .OR. L .LT. 0 .OR. IINC .LE. L) GO TO 50
- IV1 = IV(1)
- IF (IV1 .EQ. 14) GO TO 90
- IF (IV1 .GT. 2 .AND. IV1 .LT. 12) GO TO 90
- IF (IV1 .EQ. 12) IV(1) = 13
- IF (IV(1) .NE. 13) GO TO 60
- IF (IV(PERM) .LE. MSAVE) IV(PERM) = MSAVE + 1
- LP1 = L + 1
- L1 = 0
- M = 0
- DO 40 I = 1, P
- M0 = M
- IF (L .EQ. 0) GO TO 20
- DO 10 K = 1, L
- IF (INC(K,I) .LT. 0 .OR. INC(K,I) .GT. 1) GO TO 50
- IF (INC(K,I) .EQ. 1) M = M + 1
- 10 CONTINUE
- 20 IF (INC(LP1,I) .NE. 1) GO TO 30
- M = M + 1
- L1 = 1
- 30 IF (M .EQ. M0 .OR. INC(LP1,I) .LT. 0
- 1 .OR. INC(LP1,I) .GT. 1) GO TO 50
- 40 CONTINUE
-C
- IV(IVNEED) = IV(IVNEED) + 2*M
- L1 = L + L1
- IV(VNEED) = IV(VNEED) + N*(L1+M)
- GO TO 60
-C
- 50 IV(1) = 66
-C
- 60 CALL DRNSG(V, ALF, C, V, IV, IV, L, 1, N, LIV, LV, N, M, P, V, Y)
- IF (IV(1) .NE. 14) GO TO 999
-C
-C *** STORAGE ALLOCATION ***
-C
- IV(IN) = IV(NEXTIV)
- IV(NEXTIV) = IV(IN) + 2*M
- IV(AMAT) = IV(NEXTV)
- IV(DAMAT) = IV(AMAT) + N*L1
- IV(NEXTV) = IV(DAMAT) + N*M
- IV(L1SAV) = L1
- IV(MSAVE) = M
-C
-C *** SET UP IN ARRAY ***
-C
- IN1 = IV(IN)
- DO 80 I = 1, P
- DO 70 K = 1, LP1
- IF (INC(K,I) .EQ. 0) GO TO 70
- IV(IN1) = I
- IV(IN1+1) = K
- IN1 = IN1 + 2
- 70 CONTINUE
- 80 CONTINUE
- IF (IV1 .EQ. 13) GO TO 999
-C
- 90 A1 = IV(AMAT)
- DA1 = IV(DAMAT)
- IN1 = IV(IN)
- L1 = IV(L1SAV)
- M = IV(MSAVE)
-C
- 100 CALL DRNSG(V(A1), ALF, C, V(DA1), IV(IN1), IV, L, L1, N, LIV, LV,
- 1 N, M, P, V, Y)
- IF (IV(1)-2) 110, 120, 999
-C
-C *** NEW FUNCTION VALUE (R VALUE) NEEDED ***
-C
- 110 NF = IV(NFCALL)
- CALL CALCA(N, P, L, ALF, NF, V(A1), UIPARM, URPARM, UFPARM)
- IF (NF .LE. 0) IV(TOOBIG) = 1
- GO TO 100
-C
-C *** COMPUTE DR = GRADIENT OF R COMPONENTS ***
-C
- 120 CALL CALCB(N, P, L, ALF, IV(NFGCAL), V(DA1), UIPARM, URPARM,
- 1 UFPARM)
- IF (IV(NFGCAL) .EQ. 0) IV(TOOBIG) = 1
- GO TO 100
-C
- 999 RETURN
-C
-C *** LAST CARD OF DNSG FOLLOWS ***
- END
diff --git a/CEP/PyBDSM/src/port3/dnsgb.f b/CEP/PyBDSM/src/port3/dnsgb.f
deleted file mode 100644
index a3178acb11e8ea7e628dd007afcfccbd348382fa..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/dnsgb.f
+++ /dev/null
@@ -1,326 +0,0 @@
- SUBROUTINE DNSGB(N, P, L, ALF, B, C, Y, CALCA, CALCB, INC, IINC,
- 1 IV, LIV, LV, V, UIPARM, URPARM, UFPARM)
-C
-C *** SOLVE SEPARABLE NONLINEAR LEAST SQUARES USING ***
-C *** ANALYTICALLY COMPUTED DERIVATIVES. ***
-C
-C *** PARAMETER DECLARATIONS ***
-C
- INTEGER IINC, L, LIV, LV, N, P
-C/6
-C INTEGER INC(IINC,P), IV(LIV), UIPARM(1)
-C DOUBLE PRECISION ALF(P), B(2,P), C(L), URPARM(1), V(LV), Y(N)
-C/7
- INTEGER INC(IINC,P), IV(LIV), UIPARM(*)
- DOUBLE PRECISION ALF(P), B(2,P), C(L), URPARM(*), V(LV), Y(N)
-C/
- EXTERNAL CALCA, CALCB, UFPARM
-C
-C *** PURPOSE ***
-C
-C GIVEN A SET OF N OBSERVATIONS Y(1)....Y(N) OF A DEPENDENT VARIABLE
-C T(1)...T(N), DNSGB ATTEMPTS TO COMPUTE A LEAST SQUARES FIT
-C TO A FUNCTION ETA (THE MODEL) WHICH IS A LINEAR COMBINATION
-C
-C L
-C ETA(C,ALF,T) = SUM C * PHI(ALF,T) +PHI (ALF,T)
-C J=1 J J L+1
-C
-C OF NONLINEAR FUNCTIONS PHI(J) DEPENDENT ON T AND ALF(1),...,ALF(P)
-C (.E.G. A SUM OF EXPONENTIALS OR GAUSSIANS). THAT IS, IT DETERMINES
-C NONLINEAR PARAMETERS ALF WHICH MINIMIZE
-C
-C 2 N 2
-C NORM(RESIDUAL) = SUM (Y - ETA(C,ALF,T )) ,
-C I=1 I I
-C
-C SUBJECT TO THE SIMPLE BOUND CONSTRAINTS
-C B(1,I) .LE. ALF(I) .LE. B(2,I), C I = 1(1)P.
-C
-C THE (L+1)ST TERM IS OPTIONAL.
-C
-C-------------------------- PARAMETER USAGE -------------------------
-C
-C INPUT PARAMETERS
-C
-C N INTEGER NUMBER OF OBSERVATIONS (MUST BE .GE. MAX(L,P)).
-C
-C P INTEGER NUMBER OF NONLINEAR PARAMETERS (MUST BE .GE. 1).
-C
-C L INTEGER NUMBER OF LINEAR PARAMETERS (MUST BE .GE. 0).
-C
-C ALF D.P. ARRAY P VECTOR = INITIAL ESTIMATE OF THE NONLINEAR
-C PARAMETERS.
-C
-C CALCA SUBROUTINE USER PROVIDED FUNCTION TO CALCULATE THE MODEL
-C (I.E., TO CALCULATE PHI) -- SEE THE NOTE BELOW
-C ON THE CALLING SEQUENCE FOR CALCA.
-C CALCA MUST BE DECLARED EXTERNAL IN THE CALLING
-C PROGRAM.
-C
-C CALCB SUBROUTINE USER PROVIDED FUNCTION TO CALCULATE THE DERIVA-
-C TIVE OF THE MODEL (I.E., OF PHI) WITH RESPECT TO
-C ALF -- SEE THE NOTE BELOW ON THE CALLING
-C SEQUENCE FOR CALCB. CALCB MUST BE DECLARED
-C EXTERNAL IN THE CALLING PROGRAM.
-C
-C Y D.P. ARRAY VECTOR OF OBSERVATIONS.
-C
-C INC INTEGER ARRAY A 2 DIM. ARRAY OF DIMENSION AT LEAST (L+1,P)
-C INDICATING THE POSITION OF THE NONLINEAR PARA-
-C METERS IN THE MODEL. SET INC(J,K) = 1 IF ALF(K)
-C APPEARS IN PHI(J). OTHERWISE SET INC(J,K) = 0.
-C IF PHI((L+1)) IS NOT IN THE MODEL, SET THE L+1ST
-C ROW OF INC TO ALL ZEROS. EVERY COLUMN OF INC
-C MUST CONTAIN AT LEAST ONE 1.
-C
-C IINC INTEGER DECLARED ROW DIMENSION OF INC, WHICH MUST BE AT
-C LEAST L+1.
-C
-C IV INTEGER ARRAY OF LENGTH AT LEAST LIV THAT CONTAINS
-C VARIOUS PARAMETERS FOR THE SUBROUTINE, SUCH AS
-C THE ITERATION AND FUNCTION EVALUATION LIMITS AND
-C SWITCHES THAT CONTROL PRINTING. THE INPUT COM-
-C PONENTS OF IV ARE DESCRIBED IN DETAIL IN THE
-C PORT OPTIMIZATION DOCUMENTATION.
-C IF IV(1)=0 ON INPUT, THEN DEFAULT PARAMETERS
-C ARE SUPPLIED TO IV AND V. THE CALLER MAY SUPPLY
-C NONDEFAULT PARAMETERS TO IV AND V BY EXECUTING A
-C CALL DIVSET(1,IV,LIV,LV,V) AND THEN ASSIGNING
-C NONDEFAULT VALUES TO THE APPROPRIATE COMPONENTS
-C OF IV AND V BEFORE CALLING DNSGB.
-C
-C LIV INTEGER LENGTH OF IV. MUST BE AT LEAST
-C 115 + 4*P + L + 2*M,
-C WHERE M IS THE NUMBER OF ONES IN INC.
-C
-C LV INTEGER LENGTH OF V. MUST BE AT LEAST
-C 105 + N*(L+M+P+3) + L*(L+3)/2 + P*(2*P+21),
-C WHERE M IS AS FOR LIV (SEE ABOVE). IF THE
-C LAST ROW OF INC CONTAINS ONLY ZEROS, THEN LV
-C CAN BE N LESS THAN JUST DESCRIBED.
-C
-C V D.P. ARRAY WORK AND PARAMETER ARRAY OF LENGTH AT LEAST LV
-C THAT CONTAINS SUCH INPUT COMPONENTS AS THE
-C CONVERGENCE TOLERANCES. THE INPUT COMPONENTS OF
-C V MAY BE SUPPLIED AS FOR IV (SEE ABOVE). NOTE
-C THAT V(35) CONTAINS THE INITIAL STEP BOUND,
-C WHICH, IF TOO LARGE, MAY LEAD TO OVERFLOW.
-C
-C UIPARM INTEGER ARRAY SCRATCH SPACE FOR USER TO SEND INFORMATION
-C TO CALCA AND CALCB.
-C
-C URPARM D.P. ARRAY SCRATCH SPACE FOR USER TO SEND INFORMATION
-C TO CALCA AND CALCB.
-C
-C UFPARM EXTERNAL SUBROUTINE SENT TO CALCA AND CALCB FOR THEIR
-C USE. NOTE THAT THE SUBROUTINE PASSED FOR UFPARM
-C MUST BE DECLARED EXTERNAL IN THE CALLING PROGRAM.
-C
-C
-C OUTPUT PARAMETERS
-C
-C ALF D.P. ARRAY FINAL NONLINEAR PARAMETERS.
-C
-C C D.P. ARRAY L VECTOR OF LINEAR PARAMETERS -- NOTE THAT NO
-C INITIAL GUESS FOR C IS REQUIRED.
-C
-C IV IV(1) CONTAINS A RETURN CODE DESCRIBED IN THE
-C PORT OPTIMIZATION DOCUMENTATION. IF IV(1) LIES
-C BETWEEN 3 AND 7, THEN THE ALGORITHM HAS
-C CONVERGED (BUT IV(1) = 7 INDICATES POSSIBLE
-C TROUBLE WITH THE MODEL). IV(1) = 9 OR 10 MEANS
-C FUNCTION EVALUATION OR ITERATION LIMIT REACHED.
-C IV(1) = 66 MEANS BAD PARAMETERS (INCLUDING A
-C COLUMN OF ZEROS IN INC). NOTE THAT THE
-C ALGORITHM CAN BE RESTARTED AFTER ANY RETURN WITH
-C IV(1) .LT. 12 -- SEE THE PORT DOCUMENTATION.
-C
-C V VARIOUS ITEMS OF INTEREST, INCLUDING THE NORM OF
-C THE GRADIENT(1) AND THE FUNCTION VALUE(10). SEE
-C THE PORT DOCUMENTATION FOR A COMPLETE LIST.
-C
-C
-C
-C PARAMETERS FOR CALCA(N,P,L,ALF,NF,PHI, UIPARM,URPARM,UFPARM)
-C
-C N,L,P,ALF ARE INPUT PARAMETERS AS DESCRIBED ABOVE
-C
-C PHI D.P. ARRAY N*(L+1) ARRAY WHOSE COLUMNS CONTAIN THE TERMS OF
-C THE MODEL. CALCA MUST EVALUATE PHI(ALF) AND STORE
-C THE RESULT IN PHI. IF THE (L+1)ST TERM IS NOT IN
-C THE MODEL, THEN NOTHING SHOULD BE STORED IN THE
-C (L+1)ST COLUMN OF PHI.
-C
-C NF INTEGER CURRENT INVOCATION COUNT FOR CALCA. IF PHI CANNOT
-C BE EVALUATED AT ALF (E.G. BECAUSE AN ARGUMENT TO
-C AN INTRINSIC FUNCTION IS OUT OF RANGE), THEN CALCA
-C SHOULD SIMPLY SET NF TO 0 AND RETURN. THIS
-C TELLS THE ALGORITHM TO TRY A SMALLER STEP.
-C
-C UIPARM,URPARM,UFPARM ARE AS DESCRIBED ABOVE
-C
-C N.B. THE DEPENDENT VARIABLE T IS NOT EXPLICITLY PASSED. IF REQUIRED,
-C IT MAY BE PASSED IN UIPARM OR URPARM OR STORED IN NAMED COMMON.
-C
-C
-C PARAMETERS FOR CALCB(N,P,L,ALF,NF,DER, UIPARM,URPARM,UFPARM)
-C
-C N,P,L,ALF,NF,UIPARM,URPARM,UFPARM ARE AS FOR CALCA
-C
-C DER D.P. ARRAY N*M ARRAY, WHERE M IS THE NUMBER OF ONES IN INC.
-C CALCB MUST SET DER TO THE DERIVATIVES OF THE MODEL
-C WITH RESPECT TO ALF. IF THE MODEL HAS K TERMS THAT
-C DEPEND ON ALF(I), THEN DER WILL HAVE K CONSECUTIVE
-C COLUMNS OF DERIVATIVES WITH RESPECT TO ALF(I). THE
-C COLUMNS OF DER CORRESPOND TO THE ONES IN INC WHEN
-C ONE TRAVELS THROUGH INC BY COLUMNS. FOR EXAMPLE,
-C IF INC HAS THE FORM...
-C 1 1 0
-C 0 1 0
-C 1 0 0
-C 0 0 1
-C THEN THE FIRST TWO COLUMNS OF DER ARE FOR THE
-C DERIVATIVES OF COLUMNS 1 AND 3 OF PHI WITH RESPECT
-C TO ALF(1), COLUMNS 3 AND 4 OF DER ARE FOR THE
-C DERIVATIVES OF COLUMNS 1 AND 2 OF PHI WITH RESPECT
-C TO ALF(2), AND COLUMN 5 OF DER IS FOR THE DERIVA-
-C TIVE OF COLUMN 4 OF PHI WITH RESPECT TO ALF(3).
-C MORE SPECIFICALLY, DER(I,2) IS FOR THE DERIVATIVE
-C OF PHI(I,3) WITH RESPECT TO ALF(1) AND DER(I,5) IS
-C FOR THE DERIVATIVE OF PHI(I,4) WITH RESPECT TO
-C ALF(3) (FOR I = 1,2,...,N).
-C THE VALUE OF ALF PASSED TO CALCB IS THE SAME AS
-C THAT PASSED TO CALCA THE LAST TIME IT WAS CALLED.
-C (IF DER CANNOT BE EVALUATED, THEN CALCB SHOULD SET
-C NF TO 0. THIS WILL CAUSE AN ERROR RETURN.)
-C
-C N.B. DER IS FOR DERIVATIVES WITH RESPECT TO ALF, NOT T.
-C
-C------------------------------ NOTES -------------------------------
-C
-C THIS PROGRAM WAS WRITTEN BY LINDA KAUFMAN AT BELL LABS, MURRAY
-C HILL, N.J. IN 1977 AND EXTENSIVELY REVISED BY HER AND DAVID GAY IN
-C 1980, 1981, 1983, 1984. THE WORK OF DAVID GAY WAS SUPPORTED IN PART
-C BY NATIONAL SCIENCE FOUNDATION GRANT MCS-7906671.
-C
-C-------------------------- DECLARATIONS ----------------------------
-C
-C
-C *** EXTERNAL SUBROUTINES ***
-C
- EXTERNAL DIVSET, DRNSGB
-C
-C DIVSET.... PROVIDES DEFAULT IV AND V VALUES.
-C DRNSGB... CARRIES OUT NL2SOL ALGORITHM.
-C
-C *** LOCAL VARIABLES ***
-C
- INTEGER A1, DA1, I, IN1, IV1, K, L1, LP1, M, M0, NF
-C
-C *** SUBSCRIPTS FOR IV AND V ***
-C
- INTEGER AMAT, DAMAT, IN, IVNEED, L1SAV, MSAVE, NEXTIV,
- 1 NEXTV, NFCALL, NFGCAL, PERM, TOOBIG, VNEED
-C
-C *** IV SUBSCRIPT VALUES ***
-C
-C/6
-C DATA AMAT/113/, DAMAT/114/, IN/112/, IVNEED/3/, L1SAV/111/,
-C 1 MSAVE/115/, NEXTIV/46/, NEXTV/47/, NFCALL/6/, NFGCAL/7/,
-C 2 PERM/58/, TOOBIG/2/, VNEED/4/
-C/7
- PARAMETER (AMAT=113, DAMAT=114, IN=112, IVNEED=3, L1SAV=111,
- 1 MSAVE=115, NEXTIV=46, NEXTV=47, NFCALL=6, NFGCAL=7,
- 2 PERM=58, TOOBIG=2, VNEED=4)
-C/
-C
-C++++++++++++++++++++++++++++++++ BODY ++++++++++++++++++++++++++++++
-C
- IF (IV(1) .EQ. 0) CALL DIVSET(1, IV, LIV, LV, V)
- IF (P .LE. 0 .OR. L .LT. 0 .OR. IINC .LE. L) GO TO 50
- IV1 = IV(1)
- IF (IV1 .EQ. 14) GO TO 90
- IF (IV1 .GT. 2 .AND. IV1 .LT. 12) GO TO 90
- IF (IV1 .EQ. 12) IV(1) = 13
- IF (IV(1) .NE. 13) GO TO 60
- IF (IV(PERM) .LE. MSAVE) IV(PERM) = MSAVE + 1
- LP1 = L + 1
- L1 = 0
- M = 0
- DO 40 I = 1, P
- M0 = M
- IF (L .EQ. 0) GO TO 20
- DO 10 K = 1, L
- IF (INC(K,I) .LT. 0 .OR. INC(K,I) .GT. 1) GO TO 50
- IF (INC(K,I) .EQ. 1) M = M + 1
- 10 CONTINUE
- 20 IF (INC(LP1,I) .NE. 1) GO TO 30
- M = M + 1
- L1 = 1
- 30 IF (M .EQ. M0 .OR. INC(LP1,I) .LT. 0
- 1 .OR. INC(LP1,I) .GT. 1) GO TO 50
- 40 CONTINUE
-C
- IV(IVNEED) = IV(IVNEED) + 2*M
- L1 = L + L1
- IV(VNEED) = IV(VNEED) + N*(L1+M)
- GO TO 60
-C
- 50 IV(1) = 66
-C
- 60 CALL DRNSGB(V, ALF, B, C, V, IV, IV, L, 1, N, LIV, LV, N, M, P, V,
- 1 Y)
- IF (IV(1) .NE. 14) GO TO 999
-C
-C *** STORAGE ALLOCATION ***
-C
- IV(IN) = IV(NEXTIV)
- IV(NEXTIV) = IV(IN) + 2*M
- IV(AMAT) = IV(NEXTV)
- IV(DAMAT) = IV(AMAT) + N*L1
- IV(NEXTV) = IV(DAMAT) + N*M
- IV(L1SAV) = L1
- IV(MSAVE) = M
-C
-C *** SET UP IN ARRAY ***
-C
- IN1 = IV(IN)
- DO 80 I = 1, P
- DO 70 K = 1, LP1
- IF (INC(K,I) .EQ. 0) GO TO 70
- IV(IN1) = I
- IV(IN1+1) = K
- IN1 = IN1 + 2
- 70 CONTINUE
- 80 CONTINUE
- IF (IV1 .EQ. 13) GO TO 999
-C
- 90 A1 = IV(AMAT)
- DA1 = IV(DAMAT)
- IN1 = IV(IN)
- L1 = IV(L1SAV)
- M = IV(MSAVE)
-C
- 100 CALL DRNSGB(V(A1), ALF, B, C, V(DA1), IV(IN1), IV, L, L1, N, LIV,
- 1 LV, N, M, P, V, Y)
- IF (IV(1)-2) 110, 120, 999
-C
-C *** NEW FUNCTION VALUE (R VALUE) NEEDED ***
-C
- 110 NF = IV(NFCALL)
- CALL CALCA(N, P, L, ALF, NF, V(A1), UIPARM, URPARM, UFPARM)
- IF (NF .LE. 0) IV(TOOBIG) = 1
- GO TO 100
-C
-C *** COMPUTE DR = GRADIENT OF R COMPONENTS ***
-C
- 120 CALL CALCB(N, P, L, ALF, IV(NFGCAL), V(DA1), UIPARM, URPARM,
- 1 UFPARM)
- IF (IV(NFGCAL) .EQ. 0) IV(TOOBIG) = 1
- GO TO 100
-C
- 999 RETURN
-C
-C *** LAST CARD OF DNSGB FOLLOWS ***
- END
diff --git a/CEP/PyBDSM/src/port3/do7prd.f b/CEP/PyBDSM/src/port3/do7prd.f
deleted file mode 100644
index 73a11dc8bab43a4bdeb75d3d26d2cac50d32b27e..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/do7prd.f
+++ /dev/null
@@ -1,29 +0,0 @@
- SUBROUTINE DO7PRD(L, LS, P, S, W, Y, Z)
-C
-C *** FOR I = 1..L, SET S = S + W(I)*Y(.,I)*(Z(.,I)**T), I.E.,
-C *** ADD W(I) TIMES THE OUTER PRODUCT OF Y(.,I) AND Z(.,I).
-C
- INTEGER L, LS, P
- DOUBLE PRECISION S(LS), W(L), Y(P,L), Z(P,L)
-C DIMENSION S(P*(P+1)/2)
-C
- INTEGER I, J, K, M
- DOUBLE PRECISION WK, YI, ZERO
- DATA ZERO/0.D+0/
-C
- DO 30 K = 1, L
- WK = W(K)
- IF (WK .EQ. ZERO) GO TO 30
- M = 1
- DO 20 I = 1, P
- YI = WK * Y(I,K)
- DO 10 J = 1, I
- S(M) = S(M) + YI*Z(J,K)
- M = M + 1
- 10 CONTINUE
- 20 CONTINUE
- 30 CONTINUE
-C
- 999 RETURN
-C *** LAST CARD OF DO7PRD FOLLOWS ***
- END
diff --git a/CEP/PyBDSM/src/port3/dorthe.f b/CEP/PyBDSM/src/port3/dorthe.f
deleted file mode 100644
index 76e077eff797ed2b2a76571e3f31336836d43f7b..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/dorthe.f
+++ /dev/null
@@ -1,109 +0,0 @@
- SUBROUTINE DORTHE(NM,N,LOW,IGH,A,ORT)
-C
- INTEGER I,J,M,N,II,JJ,LA,MP,NM,IGH,KP1,LOW
- DOUBLE PRECISION A(NM,N),ORT(IGH)
- DOUBLE PRECISION F,G,H,SCALE
- DOUBLE PRECISION DSQRT
-C
-C THIS IS A DOUBLE-PRECISION VERSION OF THE
-C EISPACK SINGLE-PRECISION ROUTINE ORTHES.
-C IT WAS ADAPTED BY PHYLLIS FOX, MAY 28, 1975.
-C
-C ORTHES IS A TRANSLATION OF THE ALGOL PROCEDURE ORTHES,
-C NUM. MATH. 12, 349-368(1968) BY MARTIN AND WILKINSON.
-C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 339-358(1971).
-C
-C GIVEN A REAL (DOUBLE PRECISION) GENERAL MATRIX, THIS SUBROUTINE
-C REDUCES A SUBMATRIX SITUATED IN ROWS AND COLUMNS
-C LOW THROUGH IGH TO UPPER HESSENBERG FORM BY
-C ORTHOGONAL SIMILARITY TRANSFORMATIONS.
-C
-C ON INPUT-
-C
-C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
-C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
-C DIMENSION STATEMENT,
-C
-C N IS THE ORDER OF THE MATRIX,
-C
-C LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING
-C SUBROUTINE BALANC. IF BALANC HAS NOT BEEN USED,
-C SET LOW=1, IGH=N,
-C
-C A CONTAINS THE INPUT MATRIX.
-C
-C ON OUTPUT-
-C
-C A CONTAINS THE HESSENBERG MATRIX. INFORMATION ABOUT
-C THE ORTHOGONAL TRANSFORMATIONS USED IN THE REDUCTION
-C IS STORED IN THE REMAINING TRIANGLE UNDER THE
-C HESSENBERG MATRIX,
-C
-C ORT CONTAINS FURTHER INFORMATION ABOUT THE TRANSFORMATIONS.
-C ONLY ELEMENTS LOW THROUGH IGH ARE USED.
-C
-C
-C ------------------------------------------------------------------
-C
- LA = IGH - 1
- KP1 = LOW + 1
- IF (LA .LT. KP1) GO TO 200
-C
- DO 180 M = KP1, LA
- H = 0.0D0
- ORT(M) = 0.0D0
- SCALE = 0.0D0
-C ********** SCALE COLUMN (ALGOL TOL THEN NOT NEEDED) **********
- DO 90 I = M, IGH
- 90 SCALE = SCALE + DABS(A(I,M-1))
-C
- IF (SCALE .EQ. 0.0D0) GO TO 180
- MP = M + IGH
-C ********** FOR I=IGH STEP -1 UNTIL M DO -- **********
- DO 100 II = M, IGH
- I = MP - II
- ORT(I) = A(I,M-1) / SCALE
- H = H + ORT(I) * ORT(I)
- 100 CONTINUE
-C
- G = -DSIGN(DSQRT(H),ORT(M))
- H = H - ORT(M) * G
- ORT(M) = ORT(M) - G
-C ********** FORM (I-(U*UT)/H) * A **********
- DO 130 J = M, N
- F = 0.0D0
-C ********** FOR I=IGH STEP -1 UNTIL M DO -- **********
- DO 110 II = M, IGH
- I = MP - II
- F = F + ORT(I) * A(I,J)
- 110 CONTINUE
-C
- F = F / H
-C
- DO 120 I = M, IGH
- 120 A(I,J) = A(I,J) - F * ORT(I)
-C
- 130 CONTINUE
-C ********** FORM (I-(U*UT)/H)*A*(I-(U*UT)/H) **********
- DO 160 I = 1, IGH
- F = 0.0D0
-C ********** FOR J=IGH STEP -1 UNTIL M DO -- **********
- DO 140 JJ = M, IGH
- J = MP - JJ
- F = F + ORT(J) * A(I,J)
- 140 CONTINUE
-C
- F = F / H
-C
- DO 150 J = M, IGH
- 150 A(I,J) = A(I,J) - F * ORT(J)
-C
- 160 CONTINUE
-C
- ORT(M) = SCALE * ORT(M)
- A(M,M-1) = SCALE * G
- 180 CONTINUE
-C
- 200 RETURN
-C ********** LAST CARD OF DORTHE **********
- END
diff --git a/CEP/PyBDSM/src/port3/dortra.f b/CEP/PyBDSM/src/port3/dortra.f
deleted file mode 100644
index 93b8a1d025fe78238141e22ce70adf9dbf56d7c2..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/dortra.f
+++ /dev/null
@@ -1,87 +0,0 @@
- SUBROUTINE DORTRA(NM,N,LOW,IGH,A,ORT,Z)
-C
- INTEGER I,J,N,KL,MM,MP,NM,IGH,LOW,MP1
- DOUBLE PRECISION A(NM,IGH),ORT(IGH),Z(NM,N)
- DOUBLE PRECISION G
-C
-C THIS IS A DOUBLE-PRECISION VERSION OF THE
-C EISPACK SINGLE-PRECISION ROUTINE ORTRAN.
-C IT WAS ADAPTED BY PHYLLIS FOX, MAY 28, 1975.
-C
-C ORTRAN IS A TRANSLATION OF THE ALGOL PROCEDURE ORTRANS,
-C NUM. MATH. 16, 181-204(1970) BY PETERS AND WILKINSON.
-C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 372-395(1971).
-C
-C THIS SUBROUTINE ACCUMULATES THE ORTHOGONAL SIMILARITY
-C TRANSFORMATIONS USED IN THE REDUCTION OF A REAL GENERAL
-C MATRIX TO UPPER HESSENBERG FORM BY DORTHE.
-C
-C ON INPUT-
-C
-C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
-C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
-C DIMENSION STATEMENT,
-C
-C N IS THE ORDER OF THE MATRIX,
-C
-C LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING
-C SUBROUTINE BALANC. IF BALANC HAS NOT BEEN USED,
-C SET LOW=1, IGH=N,
-C
-C A CONTAINS INFORMATION ABOUT THE ORTHOGONAL TRANS-
-C FORMATIONS USED IN THE REDUCTION BY DORTHE
-C IN ITS STRICT LOWER TRIANGLE,
-C
-C ORT CONTAINS FURTHER INFORMATION ABOUT THE TRANS-
-C FORMATIONS USED IN THE REDUCTION BY DORTHE.
-C ONLY ELEMENTS LOW THROUGH IGH ARE USED.
-C
-C ON OUTPUT-
-C
-C Z CONTAINS THE TRANSFORMATION MATRIX PRODUCED IN THE
-C REDUCTION BY DORTHE,
-C
-C ORT HAS BEEN ALTERED.
-C
-C
-C ------------------------------------------------------------------
-C
-C ********** INITIALIZE Z TO IDENTITY MATRIX **********
- DO 80 I = 1, N
-C
- DO 60 J = 1, N
- 60 Z(I,J) = 0.0D0
-C
- Z(I,I) = 1.0D0
- 80 CONTINUE
-C
- KL = IGH - LOW - 1
- IF (KL .LT. 1) GO TO 200
-C ********** FOR MP=IGH-1 STEP -1 UNTIL LOW+1 DO -- **********
- DO 140 MM = 1, KL
- MP = IGH - MM
- IF (A(MP,MP-1) .EQ. 0.0D0) GO TO 140
- MP1 = MP + 1
-C
- DO 100 I = MP1, IGH
- 100 ORT(I) = A(I,MP-1)
-C
- DO 130 J = MP, IGH
- G = 0.0D0
-C
- DO 110 I = MP, IGH
- 110 G = G + ORT(I) * Z(I,J)
-C ********** DIVISOR BELOW IS NEGATIVE OF H FORMED IN DORTHE.
-C DOUBLE DIVISION AVOIDS POSSIBLE UNDERFLOW **********
- G = (G / ORT(MP)) / A(MP,MP-1)
-C
- DO 120 I = MP, IGH
- 120 Z(I,J) = Z(I,J) + G * ORT(I)
-C
- 130 CONTINUE
-C
- 140 CONTINUE
-C
- 200 RETURN
-C ********** LAST CARD OF DORTRA **********
- END
diff --git a/CEP/PyBDSM/src/port3/dparck.f b/CEP/PyBDSM/src/port3/dparck.f
deleted file mode 100644
index 9ed609b19eef3e4ed988200b74ef8cfabfba3c67..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/dparck.f
+++ /dev/null
@@ -1,333 +0,0 @@
- SUBROUTINE DPARCK(ALG, D, IV, LIV, LV, N, V)
-C
-C *** CHECK ***SOL (VERSION 2.3) PARAMETERS, PRINT CHANGED VALUES ***
-C
-C *** ALG = 1 FOR REGRESSION, ALG = 2 FOR GENERAL UNCONSTRAINED OPT.
-C
- INTEGER ALG, LIV, LV, N
- INTEGER IV(LIV)
- DOUBLE PRECISION D(N), V(LV)
-C
- DOUBLE PRECISION DR7MDC
- EXTERNAL DIVSET, DR7MDC,DV7CPY,DV7DFL
-C DIVSET -- SUPPLIES DEFAULT VALUES TO BOTH IV AND V.
-C DR7MDC -- RETURNS MACHINE-DEPENDENT CONSTANTS.
-C DV7CPY -- COPIES ONE VECTOR TO ANOTHER.
-C DV7DFL -- SUPPLIES DEFAULT PARAMETER VALUES TO V ALONE.
-C
-C *** LOCAL VARIABLES ***
-C
- INTEGER ALG1, I, II, IV1, J, K, L, M, MIV1, MIV2, NDFALT, PARSV1,
- 1 PU
- INTEGER IJMP, JLIM(4), MINIV(4), NDFLT(4)
-C/6S
-C INTEGER VARNM(2), SH(2)
-C REAL CNGD(3), DFLT(3), VN(2,34), WHICH(3)
-C/7S
- CHARACTER*1 VARNM(2), SH(2)
- CHARACTER*4 CNGD(3), DFLT(3), VN(2,34), WHICH(3)
-C/
- DOUBLE PRECISION BIG, MACHEP, TINY, VK, VM(34), VX(34), ZERO
-C
-C *** IV AND V SUBSCRIPTS ***
-C
- INTEGER ALGSAV, DINIT, DTYPE, DTYPE0, EPSLON, INITS, IVNEED,
- 1 LASTIV, LASTV, LMAT, NEXTIV, NEXTV, NVDFLT, OLDN,
- 2 PARPRT, PARSAV, PERM, PRUNIT, VNEED
-C
-C
-C/6
-C DATA ALGSAV/51/, DINIT/38/, DTYPE/16/, DTYPE0/54/, EPSLON/19/,
-C 1 INITS/25/, IVNEED/3/, LASTIV/44/, LASTV/45/, LMAT/42/,
-C 2 NEXTIV/46/, NEXTV/47/, NVDFLT/50/, OLDN/38/, PARPRT/20/,
-C 3 PARSAV/49/, PERM/58/, PRUNIT/21/, VNEED/4/
-C/7
- PARAMETER (ALGSAV=51, DINIT=38, DTYPE=16, DTYPE0=54, EPSLON=19,
- 1 INITS=25, IVNEED=3, LASTIV=44, LASTV=45, LMAT=42,
- 2 NEXTIV=46, NEXTV=47, NVDFLT=50, OLDN=38, PARPRT=20,
- 3 PARSAV=49, PERM=58, PRUNIT=21, VNEED=4)
- SAVE BIG, MACHEP, TINY
-C/
-C
- DATA BIG/0.D+0/, MACHEP/-1.D+0/, TINY/1.D+0/, ZERO/0.D+0/
-C/6S
-C DATA VN(1,1),VN(2,1)/4HEPSL,4HON../
-C DATA VN(1,2),VN(2,2)/4HPHMN,4HFC../
-C DATA VN(1,3),VN(2,3)/4HPHMX,4HFC../
-C DATA VN(1,4),VN(2,4)/4HDECF,4HAC../
-C DATA VN(1,5),VN(2,5)/4HINCF,4HAC../
-C DATA VN(1,6),VN(2,6)/4HRDFC,4HMN../
-C DATA VN(1,7),VN(2,7)/4HRDFC,4HMX../
-C DATA VN(1,8),VN(2,8)/4HTUNE,4HR1../
-C DATA VN(1,9),VN(2,9)/4HTUNE,4HR2../
-C DATA VN(1,10),VN(2,10)/4HTUNE,4HR3../
-C DATA VN(1,11),VN(2,11)/4HTUNE,4HR4../
-C DATA VN(1,12),VN(2,12)/4HTUNE,4HR5../
-C DATA VN(1,13),VN(2,13)/4HAFCT,4HOL../
-C DATA VN(1,14),VN(2,14)/4HRFCT,4HOL../
-C DATA VN(1,15),VN(2,15)/4HXCTO,4HL.../
-C DATA VN(1,16),VN(2,16)/4HXFTO,4HL.../
-C DATA VN(1,17),VN(2,17)/4HLMAX,4H0.../
-C DATA VN(1,18),VN(2,18)/4HLMAX,4HS.../
-C DATA VN(1,19),VN(2,19)/4HSCTO,4HL.../
-C DATA VN(1,20),VN(2,20)/4HDINI,4HT.../
-C DATA VN(1,21),VN(2,21)/4HDTIN,4HIT../
-C DATA VN(1,22),VN(2,22)/4HD0IN,4HIT../
-C DATA VN(1,23),VN(2,23)/4HDFAC,4H..../
-C DATA VN(1,24),VN(2,24)/4HDLTF,4HDC../
-C DATA VN(1,25),VN(2,25)/4HDLTF,4HDJ../
-C DATA VN(1,26),VN(2,26)/4HDELT,4HA0../
-C DATA VN(1,27),VN(2,27)/4HFUZZ,4H..../
-C DATA VN(1,28),VN(2,28)/4HRLIM,4HIT../
-C DATA VN(1,29),VN(2,29)/4HCOSM,4HIN../
-C DATA VN(1,30),VN(2,30)/4HHUBE,4HRC../
-C DATA VN(1,31),VN(2,31)/4HRSPT,4HOL../
-C DATA VN(1,32),VN(2,32)/4HSIGM,4HIN../
-C DATA VN(1,33),VN(2,33)/4HETA0,4H..../
-C DATA VN(1,34),VN(2,34)/4HBIAS,4H..../
-C/7S
- DATA VN(1,1),VN(2,1)/'EPSL','ON..'/
- DATA VN(1,2),VN(2,2)/'PHMN','FC..'/
- DATA VN(1,3),VN(2,3)/'PHMX','FC..'/
- DATA VN(1,4),VN(2,4)/'DECF','AC..'/
- DATA VN(1,5),VN(2,5)/'INCF','AC..'/
- DATA VN(1,6),VN(2,6)/'RDFC','MN..'/
- DATA VN(1,7),VN(2,7)/'RDFC','MX..'/
- DATA VN(1,8),VN(2,8)/'TUNE','R1..'/
- DATA VN(1,9),VN(2,9)/'TUNE','R2..'/
- DATA VN(1,10),VN(2,10)/'TUNE','R3..'/
- DATA VN(1,11),VN(2,11)/'TUNE','R4..'/
- DATA VN(1,12),VN(2,12)/'TUNE','R5..'/
- DATA VN(1,13),VN(2,13)/'AFCT','OL..'/
- DATA VN(1,14),VN(2,14)/'RFCT','OL..'/
- DATA VN(1,15),VN(2,15)/'XCTO','L...'/
- DATA VN(1,16),VN(2,16)/'XFTO','L...'/
- DATA VN(1,17),VN(2,17)/'LMAX','0...'/
- DATA VN(1,18),VN(2,18)/'LMAX','S...'/
- DATA VN(1,19),VN(2,19)/'SCTO','L...'/
- DATA VN(1,20),VN(2,20)/'DINI','T...'/
- DATA VN(1,21),VN(2,21)/'DTIN','IT..'/
- DATA VN(1,22),VN(2,22)/'D0IN','IT..'/
- DATA VN(1,23),VN(2,23)/'DFAC','....'/
- DATA VN(1,24),VN(2,24)/'DLTF','DC..'/
- DATA VN(1,25),VN(2,25)/'DLTF','DJ..'/
- DATA VN(1,26),VN(2,26)/'DELT','A0..'/
- DATA VN(1,27),VN(2,27)/'FUZZ','....'/
- DATA VN(1,28),VN(2,28)/'RLIM','IT..'/
- DATA VN(1,29),VN(2,29)/'COSM','IN..'/
- DATA VN(1,30),VN(2,30)/'HUBE','RC..'/
- DATA VN(1,31),VN(2,31)/'RSPT','OL..'/
- DATA VN(1,32),VN(2,32)/'SIGM','IN..'/
- DATA VN(1,33),VN(2,33)/'ETA0','....'/
- DATA VN(1,34),VN(2,34)/'BIAS','....'/
-C/
-C
- DATA VM(1)/1.0D-3/, VM(2)/-0.99D+0/, VM(3)/1.0D-3/, VM(4)/1.0D-2/,
- 1 VM(5)/1.2D+0/, VM(6)/1.D-2/, VM(7)/1.2D+0/, VM(8)/0.D+0/,
- 2 VM(9)/0.D+0/, VM(10)/1.D-3/, VM(11)/-1.D+0/, VM(13)/0.D+0/,
- 3 VM(15)/0.D+0/, VM(16)/0.D+0/, VM(19)/0.D+0/, VM(20)/-10.D+0/,
- 4 VM(21)/0.D+0/, VM(22)/0.D+0/, VM(23)/0.D+0/, VM(27)/1.01D+0/,
- 5 VM(28)/1.D+10/, VM(30)/0.D+0/, VM(31)/0.D+0/, VM(32)/0.D+0/,
- 6 VM(34)/0.D+0/
- DATA VX(1)/0.9D+0/, VX(2)/-1.D-3/, VX(3)/1.D+1/, VX(4)/0.8D+0/,
- 1 VX(5)/1.D+2/, VX(6)/0.8D+0/, VX(7)/1.D+2/, VX(8)/0.5D+0/,
- 2 VX(9)/0.5D+0/, VX(10)/1.D+0/, VX(11)/1.D+0/, VX(14)/0.1D+0/,
- 3 VX(15)/1.D+0/, VX(16)/1.D+0/, VX(19)/1.D+0/, VX(23)/1.D+0/,
- 4 VX(24)/1.D+0/, VX(25)/1.D+0/, VX(26)/1.D+0/, VX(27)/1.D+10/,
- 5 VX(29)/1.D+0/, VX(31)/1.D+0/, VX(32)/1.D+0/, VX(33)/1.D+0/,
- 6 VX(34)/1.D+0/
-C
-C/6S
-C DATA VARNM(1)/1HP/, VARNM(2)/1HP/, SH(1)/1HS/, SH(2)/1HH/
-C DATA CNGD(1),CNGD(2),CNGD(3)/4H---C,4HHANG,4HED V/,
-C 1 DFLT(1),DFLT(2),DFLT(3)/4HNOND,4HEFAU,4HLT V/
-C/7S
- DATA VARNM(1)/'P'/, VARNM(2)/'P'/, SH(1)/'S'/, SH(2)/'H'/
- DATA CNGD(1),CNGD(2),CNGD(3)/'---C','HANG','ED V'/,
- 1 DFLT(1),DFLT(2),DFLT(3)/'NOND','EFAU','LT V'/
-C/
- DATA IJMP/33/, JLIM(1)/0/, JLIM(2)/24/, JLIM(3)/0/, JLIM(4)/24/,
- 1 NDFLT(1)/32/, NDFLT(2)/25/, NDFLT(3)/32/, NDFLT(4)/25/
- DATA MINIV(1)/82/, MINIV(2)/59/, MINIV(3)/103/, MINIV(4)/103/
-C
-C............................... BODY ................................
-C
- PU = 0
- IF (PRUNIT .LE. LIV) PU = IV(PRUNIT)
- IF (ALGSAV .GT. LIV) GO TO 20
- IF (ALG .EQ. IV(ALGSAV)) GO TO 20
- IF (PU .NE. 0) WRITE(PU,10) ALG, IV(ALGSAV)
- 10 FORMAT(/40H THE FIRST PARAMETER TO DIVSET SHOULD BE,I3,
- 1 12H RATHER THAN,I3)
- IV(1) = 67
- GO TO 999
- 20 IF (ALG .LT. 1 .OR. ALG .GT. 4) GO TO 340
- MIV1 = MINIV(ALG)
- IF (IV(1) .EQ. 15) GO TO 360
- ALG1 = MOD(ALG-1,2) + 1
- IF (IV(1) .EQ. 0) CALL DIVSET(ALG, IV, LIV, LV, V)
- IV1 = IV(1)
- IF (IV1 .NE. 13 .AND. IV1 .NE. 12) GO TO 30
- IF (PERM .LE. LIV) MIV1 = MAX0(MIV1, IV(PERM) - 1)
- IF (IVNEED .LE. LIV) MIV2 = MIV1 + MAX0(IV(IVNEED), 0)
- IF (LASTIV .LE. LIV) IV(LASTIV) = MIV2
- IF (LIV .LT. MIV1) GO TO 300
- IV(IVNEED) = 0
- IV(LASTV) = MAX0(IV(VNEED), 0) + IV(LMAT) - 1
- IV(VNEED) = 0
- IF (LIV .LT. MIV2) GO TO 300
- IF (LV .LT. IV(LASTV)) GO TO 320
- 30 IF (IV1 .LT. 12 .OR. IV1 .GT. 14) GO TO 60
- IF (N .GE. 1) GO TO 50
- IV(1) = 81
- IF (PU .EQ. 0) GO TO 999
- WRITE(PU,40) VARNM(ALG1), N
- 40 FORMAT(/8H /// BAD,A1,2H =,I5)
- GO TO 999
- 50 IF (IV1 .NE. 14) IV(NEXTIV) = IV(PERM)
- IF (IV1 .NE. 14) IV(NEXTV) = IV(LMAT)
- IF (IV1 .EQ. 13) GO TO 999
- K = IV(PARSAV) - EPSLON
- CALL DV7DFL(ALG1, LV-K, V(K+1))
- IV(DTYPE0) = 2 - ALG1
- IV(OLDN) = N
- WHICH(1) = DFLT(1)
- WHICH(2) = DFLT(2)
- WHICH(3) = DFLT(3)
- GO TO 110
- 60 IF (N .EQ. IV(OLDN)) GO TO 80
- IV(1) = 17
- IF (PU .EQ. 0) GO TO 999
- WRITE(PU,70) VARNM(ALG1), IV(OLDN), N
- 70 FORMAT(/5H /// ,1A1,14H CHANGED FROM ,I5,4H TO ,I5)
- GO TO 999
-C
- 80 IF (IV1 .LE. 11 .AND. IV1 .GE. 1) GO TO 100
- IV(1) = 80
- IF (PU .NE. 0) WRITE(PU,90) IV1
- 90 FORMAT(/13H /// IV(1) =,I5,28H SHOULD BE BETWEEN 0 AND 14.)
- GO TO 999
-C
- 100 WHICH(1) = CNGD(1)
- WHICH(2) = CNGD(2)
- WHICH(3) = CNGD(3)
-C
- 110 IF (IV1 .EQ. 14) IV1 = 12
- IF (BIG .GT. TINY) GO TO 120
- TINY = DR7MDC(1)
- MACHEP = DR7MDC(3)
- BIG = DR7MDC(6)
- VM(12) = MACHEP
- VX(12) = BIG
- VX(13) = BIG
- VM(14) = MACHEP
- VM(17) = TINY
- VX(17) = BIG
- VM(18) = TINY
- VX(18) = BIG
- VX(20) = BIG
- VX(21) = BIG
- VX(22) = BIG
- VM(24) = MACHEP
- VM(25) = MACHEP
- VM(26) = MACHEP
- VX(28) = DR7MDC(5)
- VM(29) = MACHEP
- VX(30) = BIG
- VM(33) = MACHEP
- 120 M = 0
- I = 1
- J = JLIM(ALG1)
- K = EPSLON
- NDFALT = NDFLT(ALG1)
- DO 150 L = 1, NDFALT
- VK = V(K)
- IF (VK .GE. VM(I) .AND. VK .LE. VX(I)) GO TO 140
- M = K
- IF (PU .NE. 0) WRITE(PU,130) VN(1,I), VN(2,I), K, VK,
- 1 VM(I), VX(I)
- 130 FORMAT(/6H /// ,2A4,5H.. V(,I2,3H) =,D11.3,7H SHOULD,
- 1 11H BE BETWEEN,D11.3,4H AND,D11.3)
- 140 K = K + 1
- I = I + 1
- IF (I .EQ. J) I = IJMP
- 150 CONTINUE
-C
- IF (IV(NVDFLT) .EQ. NDFALT) GO TO 170
- IV(1) = 51
- IF (PU .EQ. 0) GO TO 999
- WRITE(PU,160) IV(NVDFLT), NDFALT
- 160 FORMAT(/13H IV(NVDFLT) =,I5,13H RATHER THAN ,I5)
- GO TO 999
- 170 IF ((IV(DTYPE) .GT. 0 .OR. V(DINIT) .GT. ZERO) .AND. IV1 .EQ. 12)
- 1 GO TO 200
- DO 190 I = 1, N
- IF (D(I) .GT. ZERO) GO TO 190
- M = 18
- IF (PU .NE. 0) WRITE(PU,180) I, D(I)
- 180 FORMAT(/8H /// D(,I3,3H) =,D11.3,19H SHOULD BE POSITIVE)
- 190 CONTINUE
- 200 IF (M .EQ. 0) GO TO 210
- IV(1) = M
- GO TO 999
-C
- 210 IF (PU .EQ. 0 .OR. IV(PARPRT) .EQ. 0) GO TO 999
- IF (IV1 .NE. 12 .OR. IV(INITS) .EQ. ALG1-1) GO TO 230
- M = 1
- WRITE(PU,220) SH(ALG1), IV(INITS)
- 220 FORMAT(/22H NONDEFAULT VALUES..../5H INIT,A1,14H..... IV(25) =,
- 1 I3)
- 230 IF (IV(DTYPE) .EQ. IV(DTYPE0)) GO TO 250
- IF (M .EQ. 0) WRITE(PU,260) WHICH
- M = 1
- WRITE(PU,240) IV(DTYPE)
- 240 FORMAT(20H DTYPE..... IV(16) =,I3)
- 250 I = 1
- J = JLIM(ALG1)
- K = EPSLON
- L = IV(PARSAV)
- NDFALT = NDFLT(ALG1)
- DO 290 II = 1, NDFALT
- IF (V(K) .EQ. V(L)) GO TO 280
- IF (M .EQ. 0) WRITE(PU,260) WHICH
- 260 FORMAT(/1H ,3A4,9HALUES..../)
- M = 1
- WRITE(PU,270) VN(1,I), VN(2,I), K, V(K)
- 270 FORMAT(1X,2A4,5H.. V(,I2,3H) =,D15.7)
- 280 K = K + 1
- L = L + 1
- I = I + 1
- IF (I .EQ. J) I = IJMP
- 290 CONTINUE
-C
- IV(DTYPE0) = IV(DTYPE)
- PARSV1 = IV(PARSAV)
- CALL DV7CPY(IV(NVDFLT), V(PARSV1), V(EPSLON))
- GO TO 999
-C
- 300 IV(1) = 15
- IF (PU .EQ. 0) GO TO 999
- WRITE(PU,310) LIV, MIV2
- 310 FORMAT(/10H /// LIV =,I5,17H MUST BE AT LEAST,I5)
- IF (LIV .LT. MIV1) GO TO 999
- IF (LV .LT. IV(LASTV)) GO TO 320
- GO TO 999
-C
- 320 IV(1) = 16
- IF (PU .NE. 0) WRITE(PU,330) LV, IV(LASTV)
- 330 FORMAT(/9H /// LV =,I5,17H MUST BE AT LEAST,I5)
- GO TO 999
-C
- 340 IV(1) = 67
- IF (PU .NE. 0) WRITE(PU,350) ALG
- 350 FORMAT(/10H /// ALG =,I5,21H MUST BE 1 2, 3, OR 4)
- GO TO 999
- 360 IF (PU .NE. 0) WRITE(PU,370) LIV, MIV1
- 370 FORMAT(/10H /// LIV =,I5,17H MUST BE AT LEAST,I5,
- 1 37H TO COMPUTE TRUE MIN. LIV AND MIN. LV)
- IF (LASTIV .LE. LIV) IV(LASTIV) = MIV1
- IF (LASTV .LE. LIV) IV(LASTV) = 0
-C
- 999 RETURN
-C *** LAST LINE OF DPARCK FOLLOWS ***
- END
diff --git a/CEP/PyBDSM/src/port3/dpostx1.f b/CEP/PyBDSM/src/port3/dpostx1.f
deleted file mode 100644
index c57eec30de9915dc9572ab3e204c5b5f734a093b..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/dpostx1.f
+++ /dev/null
@@ -1,107 +0,0 @@
-C$TEST DPOST1
-c main program
- common /cstak/ ds
- double precision ds(1000)
- external handle, dpostd, bc, af
- integer ndx, k, is(1000), nu, nv, nmesh
- real errpar(2), rs(1000)
- logical ls(1000)
- complex cs(500)
- double precision u(100), v(1), mesh(100), dt, ws(500), tstop
- equivalence (ds(1), cs(1), ws(1), rs(1), is(1), ls(1))
-c to test dpost on
-c u sub t = u sub xx + f on (0,1)
-c where f is chosen so that the solution is
-c u(x,t) = exp(xt).
-c the port library stack and its aliases.
-c initialize the port library stack length.
- call istkin(1000, 4)
- nu = 1
- nv = 0
- errpar(1) = 0
-c absolute error.
- errpar(2) = 1e-2
- tstop = 1
- dt = 1d-2
- k = 4
-c ndx uniform mesh points on (0,1).
- ndx = 4
- call dumb(0d0, 1d0, ndx, k, mesh, nmesh)
-c initial conditions for u.
- call setd(nmesh-k, 1d0, u)
- call dpost(u, nu, k, mesh, nmesh, v, nv, 0d0, tstop, dt, af, bc,
- 1 dpostd, errpar, handle)
-c check for errors and stack usage statistics.
- call wrapup
- stop
- end
- subroutine af(t, x, nx, u, ux, ut, utx, nu, v, vt, nv, a,
- 1 au, aux, aut, autx, av, avt, f, fu, fux, fut, futx, fv, fvt)
- integer nu, nx
- integer nv
- double precision t, x(nx), u(nx, nu), ux(nx, nu), ut(nx, nu), utx(
- 1 nx, nu)
- double precision v(1), vt(1), a(nx, nu), au(nx, nu, nu), aux(nx,
- 1 nu, nu), aut(nx, nu, nu)
- double precision autx(nx, nu, nu), av(1), avt(1), f(nx, nu), fu(
- 1 nx, nu, nu), fux(nx, nu, nu)
- double precision fut(nx, nu, nu), futx(nx, nu, nu), fv(1), fvt(1)
- integer i
- double precision dexp
- do 1 i = 1, nx
- a(i, 1) = -ux(i, 1)
- aux(i, 1, 1) = -1
- f(i, 1) = (x(i)-t**2)*dexp(x(i)*t)-ut(i, 1)
- fut(i, 1, 1) = -1
- 1 continue
- return
- end
- subroutine bc(t, l, r, u, ux, ut, utx, nu, v, vt, nv, b, bu,
- 1 bux, but, butx, bv, bvt)
- integer nu
- integer nv
- double precision t, l, r, u(nu, 2), ux(nu, 2), ut(nu, 2)
- double precision utx(nu, 2), v(1), vt(1), b(nu, 2), bu(nu, nu, 2),
- 1 bux(nu, nu, 2)
- double precision but(nu, nu, 2), butx(nu, nu, 2), bv(1), bvt(1)
- double precision dexp
- b(1, 1) = u(1, 1)-1d0
- b(1, 2) = u(1, 2)-dexp(t)
- bu(1, 1, 1) = 1
- bu(1, 1, 2) = 1
- return
- end
- subroutine handle(t0, u0, v0, t, u, v, nu, nxmk, nv, k, x,
- 1 nx, dt, tstop)
- integer nxmk, nu, nx
- integer nv, k
- double precision t0, u0(nxmk, nu), v0(1), t, u(nxmk, nu), v(1)
- double precision x(nx), dt, tstop
- common /time/ tt
- double precision tt
- external uofx
- integer i1mach
- double precision deesff, eu
- integer temp
-c output and checking routine.
- if (t0 .eq. t) return
-c uofx needs time.
- tt = t
- eu = deesff(k, x, nx, u, uofx)
- temp = i1mach(2)
- write (temp, 1) t, eu
- 1 format (14h error in u(x,, 1pe10.2, 4h ) =, 1pe10.2)
- return
- end
- subroutine uofx(x, nx, u, w)
- integer nx
- double precision x(nx), u(nx), w(nx)
- common /time/ t
- double precision t
- integer i
- double precision dexp
- do 1 i = 1, nx
- u(i) = dexp(x(i)*t)
- 1 continue
- return
- end
diff --git a/CEP/PyBDSM/src/port3/dpostx10.f b/CEP/PyBDSM/src/port3/dpostx10.f
deleted file mode 100644
index d3e48b7933353abb6f6789b49e2be67139544e72..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/dpostx10.f
+++ /dev/null
@@ -1,151 +0,0 @@
-C$TEST DPOST10
-c main program
- common /cstak/ ds
- double precision ds(2000)
- external handle, dpostd, bc, af
- integer ndx, nxh, i, k, is(1000), nu
- integer nv, nx, i1mach
- real errpar(2), rs(1000)
- logical ls(1000)
- complex cs(500)
- double precision deebsf, err, dabs, u(100), v(1), x(100)
- double precision dmax1, dt, ue(100), uh(100), xh(100), ws(500)
- double precision tstop
- integer temp
- equivalence (ds(1), cs(1), ws(1), rs(1), is(1), ls(1))
-c to estimate x and t error as sum.
-c u sub t = u sub xx + f on (0,1)
-c where f is chosen so that the solution is
-c u(x,t) = exp(xt).
-c the port library stack and its aliases.
-c initialize the port library stack length.
- call istkin(2000, 4)
- nu = 1
- nv = 0
- errpar(1) = 0
- errpar(2) = 1e-2
- k = 4
- ndx = 4
- tstop = 1
- dt = 1d-2
-c crude mesh.
- call dumb(0d0, 1d0, ndx, k, x, nx)
-c initial conditions for u.
- call setd(nx-k, 1d0, u)
- temp = i1mach(2)
- write (temp, 1)
- 1 format (36h solving on crude mesh using errpar.)
- call dpost(u, nu, k, x, nx, v, nv, 0d0, tstop, dt, af, bc, dpostd,
- 1 errpar, handle)
-c get run-time statistics.
- call dpostx
-c halve the mesh spacing.
- call dumb(0d0, 1d0, 2*ndx-1, k, xh, nxh)
-c initial conditions for uh.
- call setd(nxh-k, 1d0, uh)
- dt = 1d-2
- temp = i1mach(2)
- write (temp, 2)
- 2 format (38h solving on refined mesh using errpar.)
- call dpost(uh, nu, k, xh, nxh, v, nv, 0d0, tstop, dt, af, bc,
- 1 dpostd, errpar, handle)
-c get run-time statistics.
- call dpostx
-c estimate u error.
- err = deebsf(k, x, nx, u, xh, nxh, uh)
- write (6, 3) err
- 3 format (24h u error from u and uh =, 1pe10.2)
-c initial conditions for ue.
- call setd(nx-k, 1d0, ue)
- dt = 1d-2
- errpar(1) = errpar(1)/10.
- errpar(2) = errpar(2)/10.
- temp = i1mach(2)
- write (temp, 4)
- 4 format (39h solving on crude mesh using errpar/10.)
- call dpost(ue, nu, k, x, nx, v, nv, 0d0, tstop, dt, af, bc,
- 1 dpostd, errpar, handle)
-c get run-time statistics.
- call dpostx
- err = 0
- temp = nx-k
- do 5 i = 1, temp
- err = dmax1(err, dabs(u(i)-ue(i)))
- 5 continue
- write (6, 6) err
- 6 format (24h u error from u and ue =, 1pe10.2)
- stop
- end
- subroutine af(t, x, nx, u, ux, ut, utx, nu, v, vt, nv, a,
- 1 au, aux, aut, autx, av, avt, f, fu, fux, fut, futx, fv, fvt)
- integer nu, nx
- integer nv
- double precision t, x(nx), u(nx, nu), ux(nx, nu), ut(nx, nu), utx(
- 1 nx, nu)
- double precision v(1), vt(1), a(nx, nu), au(nx, nu, nu), aux(nx,
- 1 nu, nu), aut(nx, nu, nu)
- double precision autx(nx, nu, nu), av(1), avt(1), f(nx, nu), fu(
- 1 nx, nu, nu), fux(nx, nu, nu)
- double precision fut(nx, nu, nu), futx(nx, nu, nu), fv(1), fvt(1)
- integer i
- double precision dexp
- do 1 i = 1, nx
- a(i, 1) = -ux(i, 1)
- aux(i, 1, 1) = -1
- f(i, 1) = (x(i)-t**2)*dexp(x(i)*t)-ut(i, 1)
- fut(i, 1, 1) = -1
- 1 continue
- return
- end
- subroutine bc(t, l, r, u, ux, ut, utx, nu, v, vt, nv, b, bu,
- 1 bux, but, butx, bv, bvt)
- integer nu
- integer nv
- double precision t, l, r, u(nu, 2), ux(nu, 2), ut(nu, 2)
- double precision utx(nu, 2), v(1), vt(1), b(nu, 2), bu(nu, nu, 2),
- 1 bux(nu, nu, 2)
- double precision but(nu, nu, 2), butx(nu, nu, 2), bv(1), bvt(1)
- double precision dexp
- b(1, 1) = u(1, 1)-1d0
- b(1, 2) = u(1, 2)-dexp(t)
- bu(1, 1, 1) = 1
- bu(1, 1, 2) = 1
- return
- end
- subroutine handle(t0, u0, v0, t, u, v, nu, nxmk, nv, k, x,
- 1 nx, dt, tstop)
- integer nxmk, nu, nx
- integer nv, k
- double precision t0, u0(nxmk, nu), v0(1), t, u(nxmk, nu), v(1)
- double precision x(nx), dt, tstop
- common /time/ tt
- double precision tt
- external uofx
- integer i1mach
- double precision deesff, eu
- integer temp
-c output and checking routine.
- if (t0 .ne. t) goto 2
- temp = i1mach(2)
- write (temp, 1) t
- 1 format (16h restart for t =, 1pe10.2)
- return
- 2 tt = t
- eu = deesff(k, x, nx, u, uofx)
- temp = i1mach(2)
- write (temp, 3) t, eu
- 3 format (14h error in u(x,, 1pe10.2, 4h ) =, 1pe10.2)
- return
- end
- subroutine uofx(x, nx, u, w)
- integer nx
- double precision x(nx), u(nx), w(nx)
- common /time/ t
- double precision t
- integer i
- double precision dexp
- do 1 i = 1, nx
- u(i) = dexp(x(i)*t)
- 1 continue
- return
- end
diff --git a/CEP/PyBDSM/src/port3/dpostx2.f b/CEP/PyBDSM/src/port3/dpostx2.f
deleted file mode 100644
index aacfa19b39e116d310cb50e877f620f0d9b8b452..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/dpostx2.f
+++ /dev/null
@@ -1,132 +0,0 @@
-C$TEST DPOST2
-c main program
- common /cstak/ ds
- double precision ds(1100)
- external handle, dpostd, bc, af
- integer ndx, k, is(1000), nu, nv, nmesh
- real errpar(2), rs(1000)
- logical ls(1000)
- complex cs(500)
- double precision u(200), v(1), mesh(100), dt, ws(500), tstop
- integer temp
- equivalence (ds(1), cs(1), ws(1), rs(1), is(1), ls(1))
-c to test dpost on
-c u sub t = u sub xx + f on (0,1)
-c by setting u1 = u and u2 = u1 sub x and solving
-c u1 sub t = u1 sub xx + f
-c on (0,1)
-c u1 sub x = u2
-c where f is chosen so that the solution is
-c u(x,t) = exp(xt).
-c the port library stack and its aliases.
-c initialize the port library stack length.
- call istkin(1100, 4)
- nu = 2
- nv = 0
- errpar(1) = 0
-c absolute error.
- errpar(2) = 1e-2
- tstop = 1
- dt = 1d-2
- k = 4
-c ndx uniform mesh points on (0,1).
- ndx = 4
- call dumb(0d0, 1d0, ndx, k, mesh, nmesh)
-c initial conditions for u1.
- call setd(nmesh-k, 1d0, u)
-c initial conditions for u2.
- temp = nmesh-k
- call setd(nmesh-k, 0d0, u(temp+1))
- call dpost(u, nu, k, mesh, nmesh, v, nv, 0d0, tstop, dt, af, bc,
- 1 dpostd, errpar, handle)
-c check for errors and stack usage statistics.
- call wrapup
- stop
- end
- subroutine af(t, x, nx, u, ux, ut, utx, nu, v, vt, nv, a,
- 1 au, aux, aut, autx, av, avt, f, fu, fux, fut, futx, fv, fvt)
- integer nu, nx
- integer nv
- double precision t, x(nx), u(nx, nu), ux(nx, nu), ut(nx, nu), utx(
- 1 nx, nu)
- double precision v(1), vt(1), a(nx, nu), au(nx, nu, nu), aux(nx,
- 1 nu, nu), aut(nx, nu, nu)
- double precision autx(nx, nu, nu), av(1), avt(1), f(nx, nu), fu(
- 1 nx, nu, nu), fux(nx, nu, nu)
- double precision fut(nx, nu, nu), futx(nx, nu, nu), fv(1), fvt(1)
- integer i
- double precision dexp
- do 1 i = 1, nx
- a(i, 1) = -u(i, 2)
- au(i, 1, 2) = -1
- f(i, 1) = (x(i)-t**2)*dexp(x(i)*t)-ut(i, 1)
- fut(i, 1, 1) = -1
- a(i, 2) = u(i, 1)
- au(i, 2, 1) = 1
- f(i, 2) = u(i, 2)
- fu(i, 2, 2) = 1
- 1 continue
- return
- end
- subroutine bc(t, l, r, u, ux, ut, utx, nu, v, vt, nv, b, bu,
- 1 bux, but, butx, bv, bvt)
- integer nu
- integer nv
- double precision t, l, r, u(nu, 2), ux(nu, 2), ut(nu, 2)
- double precision utx(nu, 2), v(1), vt(1), b(nu, 2), bu(nu, nu, 2),
- 1 bux(nu, nu, 2)
- double precision but(nu, nu, 2), butx(nu, nu, 2), bv(1), bvt(1)
- double precision dexp
- b(1, 1) = u(1, 1)-1d0
- b(1, 2) = u(1, 2)-dexp(t)
- bu(1, 1, 1) = 1
- bu(1, 1, 2) = 1
- return
- end
- subroutine handle(t0, u0, v0, t, u, v, nu, nxmk, nv, k, x,
- 1 nx, dt, tstop)
- integer nxmk, nu, nx
- integer nv, k
- double precision t0, u0(nxmk, nu), v0(1), t, u(nxmk, nu), v(1)
- double precision x(nx), dt, tstop
- common /time/ tt
- double precision tt
- external u1ofx, u2ofx
- integer i1mach
- double precision deesff, eu(2)
- integer temp
-c output and checking routine.
- if (t0 .eq. t) return
-c u1ofx and u2ofx need time.
- tt = t
- eu(1) = deesff(k, x, nx, u, u1ofx)
- eu(2) = deesff(k, x, nx, u(1, 2), u2ofx)
- temp = i1mach(2)
- write (temp, 1) t, eu
- 1 format (14h error in u(x,, 1pe10.2, 4h ) =, 2(1pe10.2))
- return
- end
- subroutine u1ofx(x, nx, u, w)
- integer nx
- double precision x(nx), u(nx), w(nx)
- common /time/ t
- double precision t
- integer i
- double precision dexp
- do 1 i = 1, nx
- u(i) = dexp(x(i)*t)
- 1 continue
- return
- end
- subroutine u2ofx(x, nx, u, w)
- integer nx
- double precision x(nx), u(nx), w(nx)
- common /time/ t
- double precision t
- integer i
- double precision dexp
- do 1 i = 1, nx
- u(i) = t*dexp(x(i)*t)
- 1 continue
- return
- end
diff --git a/CEP/PyBDSM/src/port3/dpostx3.f b/CEP/PyBDSM/src/port3/dpostx3.f
deleted file mode 100644
index d9bba46efb21afe4cf3164f8a0fa1090973ab0af..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/dpostx3.f
+++ /dev/null
@@ -1,143 +0,0 @@
-C$TEST DPOST3
-c main program
- common /cstak/ ds
- double precision ds(2000)
- external dee, handle, bc, af
- integer ndx, k, is(1000), nu, nv, nmesh
- real errpar(2), rs(1000)
- logical ls(1000)
- complex cs(500)
- double precision u(100), v(1), mesh(100), dt, ws(500), tstop
- equivalence (ds(1), cs(1), ws(1), rs(1), is(1), ls(1))
-c to test dpost on
-c u sub t = u sub xx + v + f on (0,1)
-c v sub t = u( 1/2, t )
-c where f is chosen so that the solution is
-c u(x,t) = cos(xt) and v(t) = 2 sin(t/2).
-c the port library stack and its aliases.
-c initialize the port library stack length.
- call istkin(2000, 4)
- nu = 1
- nv = 1
- errpar(1) = 1e-2
-c essentially relative error.
- errpar(2) = 1e-6
- tstop = 1
- dt = 1d-6
- k = 4
- ndx = 4
-c ndx uniform mesh points on (0,1).
- call dumb(0d0, 1d0, ndx, k, mesh, nmesh)
-c initial conditions for u.
- call setd(nmesh-k, 1d0, u)
-c initial value for v.
- v(1) = 0
- call dpost(u, nu, k, mesh, nmesh, v, nv, 0d0, tstop, dt, af, bc,
- 1 dee, errpar, handle)
-c check for errors and stack usage statistics.
- call wrapup
- stop
- end
- subroutine af(t, x, nx, u, ux, ut, utx, nu, v, vt, nv, a,
- 1 au, aux, aut, autx, av, avt, f, fu, fux, fut, futx, fv, fvt)
- integer nu, nv, nx
- double precision t, x(nx), u(nx, nu), ux(nx, nu), ut(nx, nu), utx(
- 1 nx, nu)
- double precision v(nv), vt(nv), a(nx, nu), au(nx, nu, nu), aux(nx,
- 1 nu, nu), aut(nx, nu, nu)
- double precision autx(nx, nu, nu), av(nx, nu, nv), avt(nx, nu, nv)
- 1 , f(nx, nu), fu(nx, nu, nu), fux(nx, nu, nu)
- double precision fut(nx, nu, nu), futx(nx, nu, nu), fv(nx, nu, nv)
- 1 , fvt(nx, nu, nv)
- integer i
- double precision dcos, dsin
- do 1 i = 1, nx
- a(i, 1) = -ux(i, 1)
- aux(i, 1, 1) = -1
- f(i, 1) = v(1)-ut(i, 1)-x(i)*dsin(x(i)*t)+t**2*dcos(x(i)*t)-
- 1 2d0*dsin(t/2d0)
- fut(i, 1, 1) = -1
- fv(i, 1, 1) = 1
- 1 continue
- return
- end
- subroutine bc(t, l, r, u, ux, ut, utx, nu, v, vt, nv, b, bu,
- 1 bux, but, butx, bv, bvt)
- integer nu, nv
- double precision t, l, r, u(nu, 2), ux(nu, 2), ut(nu, 2)
- double precision utx(nu, 2), v(nv), vt(nv), b(nu, 2), bu(nu, nu, 2
- 1 ), bux(nu, nu, 2)
- double precision but(nu, nu, 2), butx(nu, nu, 2), bv(nu, nv, 2),
- 1 bvt(nu, nv, 2)
- double precision dcos
- b(1, 1) = u(1, 1)-1d0
- b(1, 2) = u(1, 2)-dcos(t)
- bu(1, 1, 1) = 1
- bu(1, 1, 2) = 1
- return
- end
- subroutine dee(t, k, x, nx, u, ut, nu, nxmk, v, vt, nv, d,
- 1 du, dut, dv, dvt)
- integer nxmk, nu, nv, nx
- integer k
- double precision t, x(nx), u(nxmk, nu), ut(nxmk, nu), v(nv), vt(
- 1 nv)
- double precision d(nv), du(nv, nxmk, nu), dut(nv, nxmk, nu), dv(
- 1 nv, nv), dvt(nv, nv)
- integer intrvd, i, ileft
- double precision xi(1), basis(10)
- integer temp
- xi(1) = 0.5d0
-c find 0.5 in mesh.
- ileft = intrvd(nx, x, xi(1))
- if (k .gt. 10) call seterr(
- 1 41hdee - k .gt. 10, need more space in basis, 41, 1, 2)
-c b-spline basis at xi(1).
- call dbspln(k, x, nx, xi, 1, ileft, basis)
- d(1) = vt(1)
- dvt(1, 1) = 1
-c vt(1) - u(0.5,t) = 0.
- do 1 i = 1, k
- temp = ileft+i-k
- d(1) = d(1)-u(temp, 1)*basis(i)
- temp = ileft+i-k
- du(1, temp, 1) = du(1, temp, 1)-basis(i)
- 1 continue
- return
- end
- subroutine handle(t0, u0, v0, t, u, v, nu, nxmk, nv, k, x,
- 1 nx, dt, tstop)
- integer nxmk, nu, nv, nx
- integer k
- double precision t0, u0(nxmk, nu), v0(nv), t, u(nxmk, nu), v(nv)
- double precision x(nx), dt, tstop
- common /time/ tt
- double precision tt
- external uofx
- integer i1mach
- double precision deesff, dabs, dsin, eu, ev
- integer temp
-c output and checking routine.
- if (t0 .eq. t) return
-c uofx needs time.
- tt = t
- eu = deesff(k, x, nx, u, uofx)
- ev = dabs(v(1)-2d0*dsin(t/2d0))
- temp = i1mach(2)
- write (temp, 1) t, eu, ev
- 1 format (14h error in u(x,, 1pe10.2, 4h ) =, 1pe10.2, 6h v =, 1p
- 1 e10.2)
- return
- end
- subroutine uofx(x, nx, u, w)
- integer nx
- double precision x(nx), u(nx), w(nx)
- common /time/ t
- double precision t
- integer i
- double precision dcos
- do 1 i = 1, nx
- u(i) = dcos(x(i)*t)
- 1 continue
- return
- end
diff --git a/CEP/PyBDSM/src/port3/dpostx4.f b/CEP/PyBDSM/src/port3/dpostx4.f
deleted file mode 100644
index a9d54452d782296470ad2778493ab21728abe7bd..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/dpostx4.f
+++ /dev/null
@@ -1,133 +0,0 @@
-C$TEST DPOST4
-c main program
- common /cstak/ ds
- double precision ds(2000)
- external dee, handle, bc, af
- integer ndx, k, is(1000), nu, nv, nmesh
- real errpar(2), rs(1000)
- logical ls(1000)
- complex cs(500)
- double precision u(100), v(1), mesh(100), dt, datan, ws(500)
- double precision tstop
- equivalence (ds(1), cs(1), ws(1), rs(1), is(1), ls(1))
-c to test dpost on
-c u sub t = u sub xx - u**3 + f on (-pi,+pi)
-c subject to periodic boundary conditions,
-c where f is chosen so that the solution is
-c u(x,t) = cos(x)*sin(t).
-c the port library stack and its aliases.
-c initialize the port library stack length.
- call istkin(2000, 4)
- nu = 1
- nv = 1
- errpar(1) = 0
-c absolute error.
- errpar(2) = 1e-2
- tstop = 8d0*datan(1d0)
- dt = 0.4
-c make a mesh of ndx uniform points on (-pi,+pi).
- k = 4
- ndx = 7
- call dumb((-4d0)*datan(1d0), 4d0*datan(1d0), ndx, k, mesh, nmesh)
-c initial conditions for u.
- call setd(nmesh-k, 0d0, u)
-c initial conditions for v.
- v(1) = 0
- call dpost(u, nu, k, mesh, nmesh, v, nv, 0d0, tstop, dt, af, bc,
- 1 dee, errpar, handle)
-c check for errors and stack usage statistics.
- call wrapup
- stop
- end
- subroutine af(t, x, nx, u, ux, ut, utx, nu, v, vt, nv, a,
- 1 au, aux, aut, autx, av, avt, f, fu, fux, fut, futx, fv, fvt)
- integer nu, nv, nx
- double precision t, x(nx), u(nx, nu), ux(nx, nu), ut(nx, nu), utx(
- 1 nx, nu)
- double precision v(nv), vt(nv), a(nx, nu), au(nx, nu, nu), aux(nx,
- 1 nu, nu), aut(nx, nu, nu)
- double precision autx(nx, nu, nu), av(nx, nu, nv), avt(nx, nu, nv)
- 1 , f(nx, nu), fu(nx, nu, nu), fux(nx, nu, nu)
- double precision fut(nx, nu, nu), futx(nx, nu, nu), fv(nx, nu, nv)
- 1 , fvt(nx, nu, nv)
- integer i
- double precision dcos, dsin
- do 1 i = 1, nx
- a(i, 1) = -ux(i, 1)
- aux(i, 1, 1) = -1
- f(i, 1) = (-ut(i, 1))-u(i, 1)**3+dcos(x(i))*(dcos(t)+dsin(t)+
- 1 dcos(x(i))**2*dsin(t)**3)
- fut(i, 1, 1) = -1
- fu(i, 1, 1) = (-3d0)*u(i, 1)**2
- 1 continue
- return
- end
- subroutine bc(t, l, r, u, ux, ut, utx, nu, v, vt, nv, b, bu,
- 1 bux, but, butx, bv, bvt)
- integer nu, nv
- double precision t, l, r, u(nu, 2), ux(nu, 2), ut(nu, 2)
- double precision utx(nu, 2), v(nv), vt(nv), b(nu, 2), bu(nu, nu, 2
- 1 ), bux(nu, nu, 2)
- double precision but(nu, nu, 2), butx(nu, nu, 2), bv(nu, nv, 2),
- 1 bvt(nu, nv, 2)
- b(1, 1) = ux(1, 1)-v(1)
- b(1, 2) = ux(1, 2)-v(1)
- bux(1, 1, 1) = 1
- bv(1, 1, 1) = -1
- bux(1, 1, 2) = 1
- bv(1, 1, 2) = -1
- return
- end
- subroutine dee(t, k, x, nx, u, ut, nu, nxmk, v, vt, nv, d,
- 1 du, dut, dv, dvt)
- integer nxmk, nu, nv, nx
- integer k
- double precision t, x(nx), u(nxmk, nu), ut(nxmk, nu), v(nv), vt(
- 1 nv)
- double precision d(nv), du(nv, nxmk, nu), dut(nv, nxmk, nu), dv(
- 1 nv, nv), dvt(nv, nv)
- integer temp
-c u(-pi,t) - u(+pi,t) = 0.
- temp = nx-k
- d(1) = u(1, 1)-u(temp, 1)
- du(1, 1, 1) = 1
- temp = nx-k
- du(1, temp, 1) = -1
- return
- end
- subroutine handle(t0, u0, v0, t, u, v, nu, nxmk, nv, k, x,
- 1 nx, dt, tstop)
- integer nxmk, nu, nv, nx
- integer k
- double precision t0, u0(nxmk, nu), v0(nv), t, u(nxmk, nu), v(nv)
- double precision x(nx), dt, tstop
- common /time/ tt
- double precision tt
- external uofx
- integer i1mach
- double precision deesff, eu, ev
- integer temp
-c output and checking routine.
- if (t0 .eq. t) return
-c uofx needs time.
- tt = t
- eu = deesff(k, x, nx, u, uofx)
- ev = v(1)
- temp = i1mach(2)
- write (temp, 1) t, eu, ev
- 1 format (14h error in u(x,, 1pe10.2, 4h ) =, 1pe10.2, 6h v =, 1p
- 1 e10.2)
- return
- end
- subroutine uofx(x, nx, u, w)
- integer nx
- double precision x(nx), u(nx), w(nx)
- common /time/ t
- double precision t
- integer i
- double precision dcos, dsin
- do 1 i = 1, nx
- u(i) = dcos(x(i))*dsin(t)
- 1 continue
- return
- end
diff --git a/CEP/PyBDSM/src/port3/dpostx5.f b/CEP/PyBDSM/src/port3/dpostx5.f
deleted file mode 100644
index 1568696741fe1d1f26f41fe61f979f8ef8aa212e..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/dpostx5.f
+++ /dev/null
@@ -1,243 +0,0 @@
-C$TEST DPOST5
-c main program
- common /cstak/ ds
- double precision ds(4000)
- common /time/ t
- double precision t
- common /param/ vc, x
- double precision vc(3), x(3)
- external dee, handle, uofx, bc, af
- integer ndx, idlumb, istkgt, k, iu, is(1000)
- integer nu, nv, immmd, imesh, nmesh
- real errpar(2), rs(1000)
- logical ls(1000)
- complex cs(500)
- double precision tstart, v(3), dt, xb(3), ws(500), tstop
- equivalence (ds(1), cs(1), ws(1), rs(1), is(1), ls(1))
-c to test dpost on
-c u sub t = ( k(t,x) * u sub x ) sub x + g on (-1,+2) * (0,+1)
-c with a moving front x(t) characterized by u(x(t),t) == 1 and
-c jump across x(t) of k(t,x) u sub x = - 3 * x'(t).
-c where k(t,x) is piecewise constant, say
-c 1 for x < x(t)
-c k(t,x) =
-c 2 for x > x(t)
-c and g is chosen so that the solution is
-c exp(x-x(t)) for x < x(t)
-c u(x,t) =
-c exp(x(t)-x) for x > x(t)
-c and x(1,t) = t. the moving front is tracked
-c implicitly by forcing u(x(1,t),t) = 1 as a pseudo-rankine-heugoniot re
-clation.
-c v(1,2,3) gives the moving mesh.
-c the port library stack and its aliases.
-c initialize the port library stack length.
- call istkin(4000, 4)
- call enter(1)
- nu = 1
- nv = 3
- errpar(1) = 0
-c absolute error.
- errpar(2) = 1e-2
- tstart = 0
- tstop = 1
- dt = 0.1
- k = 4
-c ndx uniform mesh points on each interval of xb array.
- ndx = 6
- xb(1) = 0
- xb(2) = 1
- xb(3) = 2
-c get mesh on port stack.
- imesh = idlumb(xb, 3, ndx, k, nmesh)
-c make 1 of multiplicity k-1.
- imesh = immmd(imesh, nmesh, 1d0, k-1)
- x(1) = -1
- x(2) = 0
- x(3) = 2
-c initial values for v.
- call dlplmg(3, x, vc)
-c get u on the port stack.
- iu = istkgt(nmesh-k, 4)
-c uofx needs time.
- t = tstart
-c uofx needs v for mapping.
- call movefd(nv, vc, v)
-c initial conditions for u.
- call dl2sff(uofx, k, ws(imesh), nmesh, ws(iu))
-c output the ics.
- call handle(t-1d0, ws(iu), v, t, ws(iu), v, nu, nmesh-k, nv, k,
- 1 ws(imesh), nmesh, dt, tstop)
- call dpost(ws(iu), nu, k, ws(imesh), nmesh, v, nv, tstart, tstop
- 1 , dt, af, bc, dee, errpar, handle)
- call leave
- call wrapup
- stop
- end
- subroutine af(t, xi, nx, u, ux, ut, utx, nu, v, vt, nv, a,
- 1 au, aux, aut, autx, av, avt, f, fu, fux, fut, futx, fv, fvt)
- integer nu, nv, nx
- double precision t, xi(nx), u(nx, nu), ux(nx, nu), ut(nx, nu),
- 1 utx(nx, nu)
- double precision v(nv), vt(nv), a(nx, nu), au(nx, nu, nu), aux(nx,
- 1 nu, nu), aut(nx, nu, nu)
- double precision autx(nx, nu, nu), av(nx, nu, nv), avt(nx, nu, nv)
- 1 , f(nx, nu), fu(nx, nu, nu), fux(nx, nu, nu)
- double precision fut(nx, nu, nu), futx(nx, nu, nu), fv(nx, nu, nv)
- 1 , fvt(nx, nu, nv)
- common /dpostf/ failed
- logical failed
- integer i
- double precision kay, xxi(99), xtv(99), xvv(99), x(99), dexp
- double precision xxiv(99), ax(99), fx(99), xt(99), xv(99)
- logical temp
- temp = v(2) .le. v(1)
- if (.not. temp) temp = v(2) .ge. v(3)
- if (.not. temp) goto 1
- failed = .true.
- return
-c map xi into x.
- 1 call dlplm(xi, nx, v, 3, x, xxi, xxiv, xv, xvv, xt, xtv)
-c map u into x system.
- call dpostu(xi, x, xt, xxi, xv, vt, nx, 3, ux, ut, nu, ax, fx)
- do 7 i = 1, nx
- if (xi(i) .gt. 1d0) goto 2
- kay = 1
- goto 3
- 2 kay = 2
- 3 a(i, 1) = kay*ux(i, 1)
- aux(i, 1, 1) = kay
- if (xi(i) .gt. 1d0) goto 4
- a(i, 1) = a(i, 1)-3d0*vt(2)
- avt(i, 1, 2) = -3
- 4 f(i, 1) = ut(i, 1)
- fut(i, 1, 1) = 1
- if (xi(i) .gt. 1d0) goto 5
- f(i, 1) = f(i, 1)+2d0*dexp(x(i)-t)
- fx(i) = 2d0*dexp(x(i)-t)
- goto 6
- 5 f(i, 1) = f(i, 1)+dexp(t-x(i))
- fx(i) = -dexp(t-x(i))
- 6 continue
- 7 continue
-c map a and f into xi system.
- call dposti(xi, x, xt, xxi, xv, xtv, xxiv, xvv, nx, ux, ut, nu, v,
- 1 vt, nv, 1, 3, a, ax, au, aux, aut, autx, av, avt, f, fx, fu,
- 2 fux, fut, futx, fv, fvt)
- return
- end
- subroutine bc(t, l, r, u, ux, ut, utx, nu, v, vt, nv, b, bu,
- 1 bux, but, butx, bv, bvt)
- integer nu, nv
- double precision t, l, r, u(nu, 2), ux(nu, 2), ut(nu, 2)
- double precision utx(nu, 2), v(nv), vt(nv), b(nu, 2), bu(nu, nu, 2
- 1 ), bux(nu, nu, 2)
- double precision but(nu, nu, 2), butx(nu, nu, 2), bv(nu, nv, 2),
- 1 bvt(nu, nv, 2)
- double precision dexp
- b(1, 1) = u(1, 1)-dexp((-1d0)-t)
- b(1, 2) = u(1, 2)-dexp(t-2d0)
- bu(1, 1, 1) = 1
- bu(1, 1, 2) = 1
- return
- end
- subroutine dee(t, k, x, nx, u, ut, nu, nxmk, v, vt, nv, d,
- 1 du, dut, dv, dvt)
- integer nxmk, nu, nv, nx
- integer k
- double precision t, x(nx), u(nxmk, nu), ut(nxmk, nu), v(nv), vt(
- 1 nv)
- double precision d(nv), du(nv, nxmk, nu), dut(nv, nxmk, nu), dv(
- 1 nv, nv), dvt(nv, nv)
- integer intrvd, i, ileft
- double precision bx(10), xx(1)
- integer temp
- d(1) = v(1)+1d0
-c x(0,v) = -1.
- dv(1, 1) = 1
- xx(1) = 1
-c find 1 in the mesh.
- ileft = intrvd(nx, x, xx(1))
-c get the b-spline basis at xx.
- call dbspln(k, x, nx, xx, 1, ileft, bx)
-c u(x(1,v),t) = 1.
- d(2) = -1
- do 1 i = 1, k
- temp = ileft+i-k
- d(2) = d(2)+u(temp, 1)*bx(i)
- temp = ileft+i-k
- du(2, temp, 1) = bx(i)
- 1 continue
- d(3) = v(3)-2d0
-c x(2,v) = +2.
- dv(3, 3) = 1
- return
- end
- subroutine handle(t0, u0, v0, t, u, v, nu, nxmk, nv, k, x,
- 1 nx, dt, tstop)
- integer nxmk, nu, nv, nx
- integer k
- double precision t0, u0(nxmk, nu), v0(nv), t, u(nxmk, nu), v(nv)
- double precision x(nx), dt, tstop
- common /param/ vc, xx
- double precision vc(3), xx(3)
- common /time/ tt
- double precision tt
- external uofx
- integer i1mach
- double precision deesff, eu, ev(3)
- integer temp
-c output and checking routine.
- if (t0 .ne. t) goto 2
- temp = i1mach(2)
- write (temp, 1) t
- 1 format (16h restart for t =, 1pe10.2)
- return
- 2 tt = t
-c uofx needs v for mapping.
- call movefd(nv, v, vc)
- eu = deesff(k, x, nx, u, uofx)
- ev(1) = v(1)+1d0
- ev(2) = v(2)-t
- ev(3) = v(3)-2d0
- temp = i1mach(2)
- write (temp, 3) t, eu, ev
- 3 format (14h error in u(x,, 1pe10.2, 4h ) =, 1pe10.2, 6h v =, 3(
- 1 1pe10.2))
- return
- end
- subroutine uofx(xi, nx, u, w)
- integer nx
- double precision xi(nx), u(nx), w(nx)
- common /cstak/ ds
- double precision ds(500)
- common /param/ vc, x
- double precision vc(3), x(3)
- common /time/ t
- double precision t
- integer ixv, ixx, istkgt, i, is(1000)
- real rs(1000)
- logical ls(1000)
- complex cs(500)
- double precision dexp, ws(500), xofxi
- integer temp
- equivalence (ds(1), cs(1), ws(1), rs(1), is(1), ls(1))
-c the port library stack and its aliases.
- call enter(1)
- ixx = istkgt(nx, 4)
-c space for x and xv.
- ixv = istkgt(3*nx, 4)
-c map into user system.
- call dlplmx(xi, nx, vc, 3, ws(ixx), ws(ixv))
- do 3 i = 1, nx
- temp = ixx+i
- xofxi = ws(temp-1)
- if (xi(i) .gt. 1d0) goto 1
- u(i) = dexp(xofxi-t)
- goto 2
- 1 u(i) = dexp(t-xofxi)
- 2 continue
- 3 continue
- call leave
- return
- end
diff --git a/CEP/PyBDSM/src/port3/dpostx6.f b/CEP/PyBDSM/src/port3/dpostx6.f
deleted file mode 100644
index 08dd6b4af530c6fc7f38fb8b5ae3ce44553c0e71..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/dpostx6.f
+++ /dev/null
@@ -1,249 +0,0 @@
-C$TEST DPOST6
-c main program
- common /cstak/ ds
- double precision ds(4000)
- common /time/ t
- double precision t
- common /param/ vc, x
- double precision vc(4), x(3)
- external dee, handle, uofx, bc, af
- integer ndx, idlumb, istkgt, k, iu, is(1000)
- integer nu, nv, immmd, imesh, nmesh
- real errpar(2), rs(1000)
- logical ls(1000)
- complex cs(500)
- double precision tstart, v(4), dt, xb(3), ws(500), tstop
- equivalence (ds(1), cs(1), ws(1), rs(1), is(1), ls(1))
-c to test dpost on the hyperbolic problem
-c u sub t = - u sub x + g on (-pi,+pi) * (0,pi)
-c with a moving shock x(t) characterized by
-c u(x(t)+,t) = 0 and
-c u(x(t)+,t) - u(x(t)-,t) = x'(t)
-c where g is chosen so that the solution is
-c sin(x+t) for x < x(t)
-c u(x,t) =
-c cos(x+t) for x > x(t)
-c with x(t) = pi/2 -t .
-c v(1,2,3) gives the moving mesh and v(4) is the height of the jump.
-c the port library stack and its aliases.
-c initialize the port library stack length.
- call istkin(4000, 4)
- call enter(1)
- nu = 1
- nv = 4
- errpar(1) = 0
-c absolute error.
- errpar(2) = 1e-2
- tstart = 0
- tstop = 3.14
- dt = 0.4
- k = 4
-c ndx uniform mesh points on each interval of xb.
- ndx = 6
- xb(1) = 0
- xb(2) = 1
- xb(3) = 2
-c get mesh on port stack.
- imesh = idlumb(xb, 3, ndx, k, nmesh)
-c make 1 of multiplicity k-1.
- imesh = immmd(imesh, nmesh, 1d0, k-1)
- x(1) = -3.14
- x(2) = 3.14/2.
- x(3) = 3.14
-c initial values for v.
- call dlplmg(3, x, vc)
-c get u on the port stack.
- iu = istkgt(nmesh-k, 4)
-c uofx needs time.
- t = tstart
-c the initial height of the jump.
- vc(4) = 1
-c uofx needs v for mapping.
- call movefd(nv, vc, v)
-c initial conditions for u.
- call dl2sff(uofx, k, ws(imesh), nmesh, ws(iu))
-c output ics.
- call handle(t-1d0, ws(iu), v, t, ws(iu), v, nu, nmesh-k, nv, k,
- 1 ws(imesh), nmesh, dt, tstop)
- call dpost(ws(iu), nu, k, ws(imesh), nmesh, v, nv, tstart, tstop
- 1 , dt, af, bc, dee, errpar, handle)
- call leave
- call wrapup
- stop
- end
- subroutine af(t, xi, nx, u, ux, ut, utx, nu, v, vt, nv, a,
- 1 au, aux, aut, autx, av, avt, f, fu, fux, fut, futx, fv, fvt)
- integer nu, nv, nx
- double precision t, xi(nx), u(nx, nu), ux(nx, nu), ut(nx, nu),
- 1 utx(nx, nu)
- double precision v(nv), vt(nv), a(nx, nu), au(nx, nu, nu), aux(nx,
- 1 nu, nu), aut(nx, nu, nu)
- double precision autx(nx, nu, nu), av(nx, nu, nv), avt(nx, nu, nv)
- 1 , f(nx, nu), fu(nx, nu, nu), fux(nx, nu, nu)
- double precision fut(nx, nu, nu), futx(nx, nu, nu), fv(nx, nu, nv)
- 1 , fvt(nx, nu, nv)
- common /dpostf/ failed
- logical failed
- integer i
- double precision xxi(99), xtv(99), xvv(99), x(99), dcos, dsin
- double precision xxiv(99), ax(99), fx(99), xt(99), xv(99)
- logical temp
- temp = v(2) .le. v(1)
- if (.not. temp) temp = v(2) .ge. v(3)
- if (.not. temp) goto 1
- failed = .true.
- return
-c map xi into x.
- 1 call dlplm(xi, nx, v, 3, x, xxi, xxiv, xv, xvv, xt, xtv)
-c map u into x system.
- call dpostu(xi, x, xt, xxi, xv, vt, nx, 3, ux, ut, nu, ax, fx)
- do 4 i = 1, nx
- a(i, 1) = -u(i, 1)
- au(i, 1, 1) = -1
- f(i, 1) = ut(i, 1)
- fut(i, 1, 1) = 1
- if (xi(i) .gt. 1d0) goto 2
- f(i, 1) = f(i, 1)-2d0*dcos(x(i)+t)
- fx(i) = 2d0*dsin(x(i)+t)
- goto 3
- 2 f(i, 1) = f(i, 1)-vt(4)
- fvt(i, 1, 4) = -1
- f(i, 1) = f(i, 1)+2d0*dsin(x(i)+t)
- fx(i) = 2d0*dcos(x(i)+t)
- 3 continue
- 4 continue
-c map a and f into xi system.
- call dposti(xi, x, xt, xxi, xv, xtv, xxiv, xvv, nx, ux, ut, nu, v,
- 1 vt, nv, 1, 3, a, ax, au, aux, aut, autx, av, avt, f, fx, fu,
- 2 fux, fut, futx, fv, fvt)
- return
- end
- subroutine bc(t, l, r, u, ux, ut, utx, nu, v, vt, nv, b, bu,
- 1 bux, but, butx, bv, bvt)
- integer nu, nv
- double precision t, l, r, u(nu, 2), ux(nu, 2), ut(nu, 2)
- double precision utx(nu, 2), v(nv), vt(nv), b(nu, 2), bu(nu, nu, 2
- 1 ), bux(nu, nu, 2)
- double precision but(nu, nu, 2), butx(nu, nu, 2), bv(nu, nv, 2),
- 1 bvt(nu, nv, 2)
- double precision dsin
- b(1, 1) = u(1, 1)-dsin(t-3.14)
-c u(-pi,t) = sin(-pi+t).
- bu(1, 1, 1) = 1
- return
- end
- subroutine dee(t, k, x, nx, u, ut, nu, nxmk, v, vt, nv, d,
- 1 du, dut, dv, dvt)
- integer nxmk, nu, nv, nx
- integer k
- double precision t, x(nx), u(nxmk, nu), ut(nxmk, nu), v(nv), vt(
- 1 nv)
- double precision d(nv), du(nv, nxmk, nu), dut(nv, nxmk, nu), dv(
- 1 nv, nv), dvt(nv, nv)
- integer intrvd, i, ileft
- double precision bx(10), xx(1), d1mach
- integer temp
- d(1) = v(1)+3.14
-c x(0,v) = -pi.
- dv(1, 1) = 1
-c xx(1) = 1 + a rounding error.
- xx(1) = d1mach(4)+1d0
- ileft = intrvd(nx, x, xx(1))
-c get the b-spline basis at xx.
- call dbspln(k, x, nx, xx, 1, ileft, bx)
- d(2) = -v(4)
-c u(x(t)+,t) - jump = 0.
- dv(2, 4) = -1
- do 1 i = 1, k
- temp = ileft+i-k
- d(2) = d(2)+u(temp, 1)*bx(i)
- temp = ileft+i-k
- du(2, temp, 1) = bx(i)
- 1 continue
- d(3) = v(3)-3.14
-c x(2,v) = +pi.
- dv(3, 3) = 1
-c jump + d( x(1,v(t)) )/dt = 0.
- d(4) = vt(2)+v(4)
- dvt(4, 2) = 1
- dv(4, 4) = 1
- return
- end
- subroutine handle(t0, u0, v0, t, u, v, nu, nxmk, nv, k, x,
- 1 nx, dt, tstop)
- integer nxmk, nu, nv, nx
- integer k
- double precision t0, u0(nxmk, nu), v0(nv), t, u(nxmk, nu), v(nv)
- double precision x(nx), dt, tstop
- common /param/ vc, xx
- double precision vc(4), xx(3)
- common /time/ tt
- double precision tt
- external uofx
- integer i1mach
- double precision deesff, eu, ev(2)
- integer temp
-c output and checking routine.
- if (t0 .ne. t) goto 2
- temp = i1mach(2)
- write (temp, 1) t, dt
- 1 format (16h restart for t =, 1pe10.2, 7h dt =, 1pe10.2)
- return
- 2 tt = t
-c uofx needs v for mapping.
- call movefd(nv, v, vc)
- eu = deesff(k, x, nx, u, uofx)
-c error in position of shock.
- ev(1) = v(2)-(3.14/2.-t)
-c error in height of shock.
- ev(2) = v(4)-1d0
- temp = i1mach(2)
- write (temp, 3) t, eu, ev
- 3 format (14h error in u(x,, 1pe10.2, 4h ) =, 1pe10.2, 6h v =, 2(
- 1 1pe10.2))
- return
- end
- subroutine uofx(xi, nx, u, w)
- integer nx
- double precision xi(nx), u(nx), w(nx)
- common /cstak/ ds
- double precision ds(500)
- common /param/ vc, x
- double precision vc(4), x(3)
- common /time/ t
- double precision t
- integer ixv, ixx, istkgt, i, is(1000)
- real rs(1000)
- logical ls(1000)
- complex cs(500)
- double precision ewe, ws(500)
- integer temp
- equivalence (ds(1), cs(1), ws(1), rs(1), is(1), ls(1))
-c the port library stack and its aliases.
- call enter(1)
- ixx = istkgt(nx, 4)
-c space for x and xv.
- ixv = istkgt(3*nx, 4)
-c map into user system.
- call dlplmx(xi, nx, vc, 3, ws(ixx), ws(ixv))
- do 1 i = 1, nx
- temp = ixx+i
- u(i) = ewe(t, ws(temp-1), vc(2))
- if (xi(i) .gt. 1d0) u(i) = u(i)+1d0
- 1 continue
- call leave
- return
- end
- double precision function ewe(t, x, xbreak)
- double precision t, x, xbreak
- double precision dcos, dsin
- if (x .ge. xbreak) goto 1
- ewe = dsin(x+t)
- return
- 1 if (x .le. xbreak) goto 2
- ewe = dcos(x+t)
- return
- 2 call seterr(17hewe - x == xbreak, 17, 1, 2)
- 3 continue
- 4 stop
- end
diff --git a/CEP/PyBDSM/src/port3/dpostx7.f b/CEP/PyBDSM/src/port3/dpostx7.f
deleted file mode 100644
index 61be4eaf21049a857d532f257da7169a18a7c565..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/dpostx7.f
+++ /dev/null
@@ -1,233 +0,0 @@
-C$TEST DPOST7
-c main program
- common /cstak/ ds
- double precision ds(4000)
- common /time/ t
- double precision t
- common /param/ vc, x, xi0
- double precision vc(4), x(3), xi0
- external dee, handle, uofx, bc, af
- integer ndx, idlumb, istkgt, k, iu, is(1000)
- integer nu, nv, immmd, imesh, nmesh
- real errpar(2), rs(1000)
- logical ls(1000)
- complex cs(500)
- double precision tstart, d, v(4), dt, xb(3), ws(500)
- double precision tstop
- equivalence (ds(1), cs(1), ws(1), rs(1), is(1), ls(1))
-c to test dpost on
-c u sub t = u sub xx + f on (20,10**6)
-c where f is chosen so that the solution is
-c u(x,t) = exp(-x*t),
-c and x(1,t) is chosen so that the boundary-layer is tracked
-c implicitly by forcing u(x(1,t)/2.3/d,t) = 1/e.
-c this is the same as requiring the exact solution to have
-c u(x(1,t),t) = 10 ** -d.
-c v(1,2,3) gives the moving mesh, v(4) is time.
-c the port library stack and its aliases.
-c initialize the port library stack length.
- call istkin(4000, 4)
- call enter(1)
- nu = 1
- nv = 4
- errpar(1) = 1e-2
-c mixed relative and absolute error.
- errpar(2) = 1e-2
- d = 3
-c w(xi0,t) = 1/e.
- xi0 = 1./2.3/d
- tstart = 20
- tstop = 1d+6
- dt = 1d-2
- k = 4
-c ndx uniform mesh points on each interval of xb.
- ndx = 6
- xb(1) = 0
- xb(2) = 1
- xb(3) = 2
-c get mesh on port stack.
- imesh = idlumb(xb, 3, ndx, k, nmesh)
-c make 1d0 of multiplicity k-1.
- imesh = immmd(imesh, nmesh, 1d0, k-1)
- x(1) = 0
- x(2) = 2.3*d/tstart
- x(3) = 1
-c initial values for v.
- call dlplmg(3, x, vc)
-c get u on port stack.
- iu = istkgt(nmesh-k, 4)
-c uofx needs time.
- t = tstart
- vc(4) = tstart
-c uofx needs v for mapping.
- call movefd(nv, vc, v)
-c initial conditions for u.
- call dl2sff(uofx, k, ws(imesh), nmesh, ws(iu))
-c output ics.
- call handle(t-1d0, ws(iu), v, t, ws(iu), v, nu, nmesh-k, nv, k,
- 1 ws(imesh), nmesh, dt, tstop)
- call dpost(ws(iu), nu, k, ws(imesh), nmesh, v, nv, tstart, tstop
- 1 , dt, af, bc, dee, errpar, handle)
- call leave
- call wrapup
- stop
- end
- subroutine af(t, xi, nx, u, ux, ut, utx, nu, v, vt, nv, a,
- 1 au, aux, aut, autx, av, avt, f, fu, fux, fut, futx, fv, fvt)
- integer nu, nv, nx
- double precision t, xi(nx), u(nx, nu), ux(nx, nu), ut(nx, nu),
- 1 utx(nx, nu)
- double precision v(nv), vt(nv), a(nx, nu), au(nx, nu, nu), aux(nx,
- 1 nu, nu), aut(nx, nu, nu)
- double precision autx(nx, nu, nu), av(nx, nu, nv), avt(nx, nu, nv)
- 1 , f(nx, nu), fu(nx, nu, nu), fux(nx, nu, nu)
- double precision fut(nx, nu, nu), futx(nx, nu, nu), fv(nx, nu, nv)
- 1 , fvt(nx, nu, nv)
- common /dpostf/ failed
- logical failed
- integer i
- double precision xxi(99), xtv(99), xvv(99), x(99), xxiv(99), ax(
- 1 99)
- double precision fx(99), xt(99), xv(99), dexpl
- logical temp
- temp = v(2) .le. v(1)
- if (.not. temp) temp = v(2) .ge. v(3)
- if (.not. temp) goto 1
- failed = .true.
- return
-c map xi into x.
- 1 call dlplm(xi, nx, v, 3, x, xxi, xxiv, xv, xvv, xt, xtv)
-c map u into x system.
- call dpostu(xi, x, xt, xxi, xv, vt, nx, 3, ux, ut, nu, ax, fx)
- do 2 i = 1, nx
- a(i, 1) = -ux(i, 1)
- aux(i, 1, 1) = -1
- f(i, 1) = (-ut(i, 1))-dexpl((-x(i))*v(4))*(x(i)+v(4)**2)
- fut(i, 1, 1) = -1
- fv(i, 1, 4) = (-dexpl((-x(i))*v(4)))*(2d0*v(4)+(x(i)+v(4)**2)*(
- 1 -x(i)))
- fx(i) = (-dexpl((-x(i))*v(4)))*(1d0-v(4)*x(i)-v(4)**3)
- 2 continue
-c map a and f into xi system.
- call dposti(xi, x, xt, xxi, xv, xtv, xxiv, xvv, nx, ux, ut, nu, v,
- 1 vt, nv, 1, 3, a, ax, au, aux, aut, autx, av, avt, f, fx, fu,
- 2 fux, fut, futx, fv, fvt)
- return
- end
- subroutine bc(t, l, r, u, ux, ut, utx, nu, v, vt, nv, b, bu,
- 1 bux, but, butx, bv, bvt)
- integer nu, nv
- double precision t, l, r, u(nu, 2), ux(nu, 2), ut(nu, 2)
- double precision utx(nu, 2), v(nv), vt(nv), b(nu, 2), bu(nu, nu, 2
- 1 ), bux(nu, nu, 2)
- double precision but(nu, nu, 2), butx(nu, nu, 2), bv(nu, nv, 2),
- 1 bvt(nu, nv, 2)
- double precision dexpl
-c u(0,t) = 1
- b(1, 1) = u(1, 1)-1d0
-c u(1,t) = exp(-t)
- b(1, 2) = u(1, 2)-dexpl(-v(4))
- bu(1, 1, 1) = 1
- bu(1, 1, 2) = 1
- bv(1, 4, 2) = dexpl(-v(4))
- return
- end
- subroutine dee(t, k, x, nx, u, ut, nu, nxmk, v, vt, nv, d,
- 1 du, dut, dv, dvt)
- integer nxmk, nu, nv, nx
- integer k
- double precision t, x(nx), u(nxmk, nu), ut(nxmk, nu), v(nv), vt(
- 1 nv)
- double precision d(nv), du(nv, nxmk, nu), dut(nv, nxmk, nu), dv(
- 1 nv, nv), dvt(nv, nv)
- common /param/ vc, xc, xi0
- double precision vc(4), xc(3), xi0
- integer intrvd, i, ileft
- double precision dexp, bx(10), xx(1)
- integer temp
- d(1) = v(1)
-c x(0,v) = 0.
- dv(1, 1) = 1
- xx(1) = xi0
- ileft = intrvd(nx, x, xx(1))
-c get the b-spline basis at xx.
- call dbspln(k, x, nx, xx, 1, ileft, bx)
- d(2) = -dexp(-1d0)
-c d(2) = w(xi0,t) - exp(-1).
- do 1 i = 1, k
- temp = ileft+i-k
- d(2) = d(2)+u(temp, 1)*bx(i)
- temp = ileft+i-k
- du(2, temp, 1) = bx(i)
- 1 continue
- d(3) = v(3)-1d0
-c x(2,v) = 1.
- dv(3, 3) = 1
- d(4) = vt(4)-1d0
- dvt(4, 4) = 1
- return
- end
- subroutine handle(t0, u0, v0, t, u, v, nu, nxmk, nv, k, x,
- 1 nx, dt, tstop)
- integer nxmk, nu, nv, nx
- integer k
- double precision t0, u0(nxmk, nu), v0(nv), t, u(nxmk, nu), v(nv)
- double precision x(nx), dt, tstop
- common /param/ vc, xx, xi0
- double precision vc(4), xx(3), xi0
- common /time/ tt
- double precision tt
- external uofx
- integer i1mach
- double precision deesff, dlplmt, eu, ev
- integer temp
-c output and checking routine.
- if (t0 .ne. t) goto 2
- temp = i1mach(2)
- write (temp, 1) t, dt
- 1 format (16h restart for t =, 1pe10.2, 7h dt =, 1pe10.2)
- return
-c let dt carry v(2) down by no more than a factor of 10.
- 2 dt = dlplmt(t, v, nv, t0, v0, 1d-1, dt)
- tt = t
-c uofx needs v for mapping.
- call movefd(nv, v, vc)
- eu = deesff(k, x, nx, u, uofx)
-c error in position of boundary layer.
- ev = v(2)-1d0/xi0/t
- temp = i1mach(2)
- write (temp, 3) t, eu, ev
- 3 format (14h error in u(x,, 1pe10.2, 4h ) =, 1pe10.2, 6h v =, 1p
- 1 e10.2)
- return
- end
- subroutine uofx(xi, nx, u, w)
- integer nx
- double precision xi(nx), u(nx), w(nx)
- common /cstak/ ds
- double precision ds(500)
- common /param/ vc, x, xi0
- double precision vc(4), x(3), xi0
- common /time/ t
- double precision t
- integer ixv, ixx, istkgt, i, is(1000)
- real rs(1000)
- logical ls(1000)
- complex cs(500)
- double precision ws(500), dexpl
- integer temp
- equivalence (ds(1), cs(1), ws(1), rs(1), is(1), ls(1))
-c the port library stack and its aliases.
- call enter(1)
- ixx = istkgt(nx, 4)
-c space for x and xv.
- ixv = istkgt(3*nx, 4)
-c map into user system.
- call dlplmx(xi, nx, vc, 3, ws(ixx), ws(ixv))
- do 1 i = 1, nx
- temp = ixx+i
- u(i) = dexpl((-ws(temp-1))*t)
- 1 continue
- call leave
- return
- end
diff --git a/CEP/PyBDSM/src/port3/dpostx8.f b/CEP/PyBDSM/src/port3/dpostx8.f
deleted file mode 100644
index 13bcd3c6b052af6960580d617cc35ae34f702053..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/dpostx8.f
+++ /dev/null
@@ -1,213 +0,0 @@
-C$TEST DPOST8
-c main program
- common /cstak/ ds
- double precision ds(5000)
- common /time/ t
- double precision t
- common /kmesh/ k, nmesh
- integer k, nmesh
- common /cmesh/ mesh
- double precision mesh(100)
- external dee, handle, uofx, bc, af
- integer ndx, i, is(1000), nu, nv
- real errpar(2), rs(1000)
- logical ls(1000)
- complex cs(500)
- double precision u(100), v(100), dt, ws(500), tstop
- integer temp
- equivalence (ds(1), cs(1), ws(1), rs(1), is(1), ls(1))
-c to test dpost on the integro-pde
-c u sub t = 2 * u sub xx - int(0,1) exp(x-y)*u(y) dy on (0,1)
-c subject to given dirichlet bcs, chosen so that the solution is
-c u(x,t) = exp(t+x).
-c the port library stack and its aliases.
-c initialize the port library stack length.
- call istkin(5000, 4)
- nu = 1
- errpar(1) = 0
-c absolute error.
- errpar(2) = 1e-2
- tstop = 1
- dt = 1d-2
- k = 4
-c ndx uniform mesh points on (0,1).
- ndx = 7
- call dumb(0d0, 1d0, ndx, k, mesh, nmesh)
- nv = nmesh-k
-c uofx needs t.
- t = 0
-c ics for u.
- call dl2sff(uofx, k, mesh, nmesh, u)
- temp = nmesh-k
- do 1 i = 1, temp
- v(i) = u(i)
- 1 continue
-c ics for v.
- call dpost(u, nu, k, mesh, nmesh, v, nv, 0d0, tstop, dt, af, bc,
- 1 dee, errpar, handle)
- call wrapup
- stop
- end
- subroutine af(t, x, nx, u, ux, ut, utx, nu, v, vt, nv, a,
- 1 au, aux, aut, autx, av, avt, f, fu, fux, fut, futx, fv, fvt)
- integer nu, nv, nx
- double precision t, x(nx), u(nx, nu), ux(nx, nu), ut(nx, nu), utx(
- 1 nx, nu)
- double precision v(nv), vt(nv), a(nx, nu), au(nx, nu, nu), aux(nx,
- 1 nu, nu), aut(nx, nu, nu)
- double precision autx(nx, nu, nu), av(nx, nu, nv), avt(nx, nu, nv)
- 1 , f(nx, nu), fu(nx, nu, nu), fux(nx, nu, nu)
- double precision fut(nx, nu, nu), futx(nx, nu, nu), fv(nx, nu, nv)
- 1 , fvt(nx, nu, nv)
- common /kmesh/ k, nmesh
- integer k, nmesh
- common /cmesh/ mesh
- double precision mesh(100)
- integer i
- do 1 i = 1, nx
- a(i, 1) = 2d0*ux(i, 1)
- aux(i, 1, 1) = 2
- f(i, 1) = ut(i, 1)
- fut(i, 1, 1) = 1
- 1 continue
-c get the integral.
- call intgrl(k, mesh, nmesh, v, x, nx, f, fv)
- return
- end
- subroutine bc(t, l, r, u, ux, ut, utx, nu, v, vt, nv, b, bu,
- 1 bux, but, butx, bv, bvt)
- integer nu, nv
- double precision t, l, r, u(nu, 2), ux(nu, 2), ut(nu, 2)
- double precision utx(nu, 2), v(nv), vt(nv), b(nu, 2), bu(nu, nu, 2
- 1 ), bux(nu, nu, 2)
- double precision but(nu, nu, 2), butx(nu, nu, 2), bv(nu, nv, 2),
- 1 bvt(nu, nv, 2)
- double precision dexp
- b(1, 1) = u(1, 1)-dexp(t)
- b(1, 2) = u(1, 2)-dexp(t+1d0)
- bu(1, 1, 1) = 1
- bu(1, 1, 2) = 1
- return
- end
- subroutine dee(t, k, x, nx, u, ut, nu, nxmk, v, vt, nv, d,
- 1 du, dut, dv, dvt)
- integer nxmk, nu, nv, nx
- integer k
- double precision t, x(nx), u(nxmk, nu), ut(nxmk, nu), v(nv), vt(
- 1 nv)
- double precision d(nv), du(nv, nxmk, nu), dut(nv, nxmk, nu), dv(
- 1 nv, nv), dvt(nv, nv)
- integer i
- do 1 i = 1, nxmk
- d(i) = u(i, 1)-v(i)
- du(i, i, 1) = 1
- dv(i, i) = -1
- 1 continue
- return
- end
- subroutine handle(t0, u0, v0, t, u, v, nu, nxmk, nv, k, x,
- 1 nx, dt, tstop)
- integer nxmk, nu, nv, nx
- integer k
- double precision t0, u0(nxmk, nu), v0(nv), t, u(nxmk, nu), v(nv)
- double precision x(nx), dt, tstop
- common /time/ tt
- double precision tt
- external uofx
- integer i1mach
- double precision deesff, eu
- integer temp
-c output and checking routine.
- if (t0 .ne. t) goto 2
- temp = i1mach(2)
- write (temp, 1) t0, dt
- 1 format (16h restart for t =, 1pe10.2, 7h dt =, 1pe10.2)
- return
- 2 tt = t
- eu = deesff(k, x, nx, u, uofx)
- temp = i1mach(2)
- write (temp, 3) t, eu
- 3 format (14h error in u(x,, 1pe10.2, 4h ) =, 1pe10.2)
- return
- end
- subroutine uofx(x, nx, u, w)
- integer nx
- double precision x(nx), u(nx), w(nx)
- common /time/ t
- double precision t
- integer i
- double precision dexp
- do 1 i = 1, nx
- u(i) = dexp(t+x(i))
- 1 continue
- return
- end
- subroutine intgrl(k, mesh, nmesh, v, x, nx, f, fv)
- integer nx, nmesh
- integer k
- double precision mesh(nmesh), v(1), x(nx), f(nx), fv(nx, 1)
- integer mgq, i, j, l, ix
- logical first
- double precision ewe, ker, wgq(3), xgq(3), b(3, 4, 200), keru
- double precision xx(3)
- integer temp, temp1
- data first/.true./
-c to compute
-c f = integral from mesh(1) to mesh(nmesh)
-c kernel(x,y,sum(i=1,...,nmesh-k) v(i)*b(i,y)) dy
-c and
-c fv = d(f)/d(v).
-c assume that call kernel(x,y,u,ker,keru) returns
-c ker = kernel(x,y,u) and
-c keru = partial kernel / partial u.
-c v(nmesh-k),fv(nx,nmesh-k)
-c the following declaration is specific to k = 4 splines.
- if (nmesh-k .gt. 200) call seterr(27hintgrl - nmesh-k .gt. nxmax
- 1 , 27, 1, 2)
-c need more local space.
- if (k .ne. 4) call seterr(17hintgrl - k .ne. 4, 17, 2, 2)
-c use k-1 point gaussian-quadrature rule on each interval.
- mgq = k-1
- if (first) call dgqm11(mgq, xgq, wgq)
-c only get gq rule once, its expensive.
-c the gaussian quadrature rule.
-c do integral interval by interval.
- temp = nmesh-k
- do 6 i = k, temp
-c g.q. points on (mesh(i), mesh(i+1)).
- do 1 j = 1, mgq
- xx(j) = 0.5*(mesh(i+1)+mesh(i))+0.5*(mesh(i+1)-mesh(i))*xgq(
- 1 j)
- 1 continue
- if (first) call dbspln(k, mesh, nmesh, xx, mgq, i, b(1, 1, i))
-c only get b-spline basis once, its expensive.
- do 5 j = 1, mgq
-c get sum() v()*b()(xx).
- ewe = 0
- do 2 l = 1, k
- temp1 = i+l-k
- ewe = ewe+v(temp1)*b(j, l, i)
- 2 continue
- do 4 ix = 1, nx
-c get kernel and partial.
- call kernel(x(ix), xx(j), ewe, ker, keru)
- f(ix) = f(ix)+0.5*ker*(mesh(i+1)-mesh(i))*wgq(j)
- do 3 l = 1, k
- temp1 = i+l-k
- fv(ix, temp1) = fv(ix, temp1)+0.5*b(j, l, i)*keru*(
- 1 mesh(i+1)-mesh(i))*wgq(j)
- 3 continue
- 4 continue
- 5 continue
- 6 continue
- first = .false.
- return
- end
- subroutine kernel(x, y, u, ker, keru)
- double precision x, y, u, ker, keru
- double precision dexp
-c to evaluate the kernel exp(x-y)*u(y) and its partial wrt. u.
- keru = dexp(x-y)
- ker = keru*u
- return
- end
diff --git a/CEP/PyBDSM/src/port3/dpostx9.f b/CEP/PyBDSM/src/port3/dpostx9.f
deleted file mode 100644
index 661d1d38f9ddcd666ee6c3438287a83b53d973e1..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/dpostx9.f
+++ /dev/null
@@ -1,153 +0,0 @@
-C$TEST DPOST9
-c main program
- common /cstak/ ds
- double precision ds(2000)
- common /param/ c
- double precision c
- external handle, dpostd, bc, af
- integer ndx, nxc, nxx, i, k, is(1000)
- integer nu, nv, nx, i1mach
- real errpar(2), rs(1000)
- logical ls(1000)
- complex cs(500)
- double precision deebsf, ewe(1000), err, u(100), v(1), x(100)
- double precision errr, dt, xc(100), uc(100), ws(500), xx(1000)
- double precision d1mach, tstop
- integer temp
- equivalence (ds(1), cs(1), ws(1), rs(1), is(1), ls(1))
-c to test dpost on automatic, static mesh refinement.
-c u sub t = u sub xx + c * u sub x on (0,1)
-c the solution is
-c u(x,t) = exp(-c*x).
-c the port library stack and its aliases.
-c initialize the port library stack length.
- call istkin(2000, 4)
- c = 50
- nu = 1
- nv = 0
- errpar(1) = 1e-1
- errpar(2) = 1e-1
- k = 4
- ndx = 8
- call dumb(0d0, 1d0, ndx, k, xc, nxc)
-c initial conditions for uc.
- call setd(nxc-k, 0d0, uc)
-c infinity.
- err = d1mach(2)
- 1 if (err .le. 1d-2) goto 6
-c halve the crude x.
- call dlumb(xc, nxc, 3, k, x, nx)
-c fitting points for refinement.
- call dlumd(x, nx, k, xx, nxx)
-c uc on xx.
- call dsplne(k, xc, nxc, uc, xx, nxx, ewe)
-c fit u to uc on mesh.
- call ddl2sf(xx, ewe, nxx, k, x, nx, u)
- tstop = 1d0/d1mach(4)
- dt = 1d-6
- i = nx-2*(k-1)
- temp = i1mach(2)
- write (temp, 2) i
- 2 format (18h solving for ndx =, i3)
- call dpost(u, nu, k, x, nx, v, nv, 0d0, tstop, dt, af, bc,
- 1 dpostd, errpar, handle)
-c get run-time statistics.
- call dpostx
-c error estimate for uc.
- err = deebsf(k, xc, nxc, uc, x, nx, u)
-c error estimate for u.
- errr = err/16d0
- temp = i1mach(2)
- write (temp, 3) err, errr
- 3 format (21h error estimates uc =, 1pe10.2, 9h and u =, 1p
- 1 e10.2)
- nxc = nx
- do 4 i = 1, nx
- xc(i) = x(i)
- 4 continue
- temp = nx-k
- do 5 i = 1, temp
- uc(i) = u(i)
- 5 continue
- goto 1
- 6 stop
- end
- subroutine af(t, x, nx, u, ux, ut, utx, nu, v, vt, nv, a,
- 1 au, aux, aut, autx, av, avt, f, fu, fux, fut, futx, fv, fvt)
- integer nu, nx
- integer nv
- double precision t, x(nx), u(nx, nu), ux(nx, nu), ut(nx, nu), utx(
- 1 nx, nu)
- double precision v(1), vt(1), a(nx, nu), au(nx, nu, nu), aux(nx,
- 1 nu, nu), aut(nx, nu, nu)
- double precision autx(nx, nu, nu), av(1), avt(1), f(nx, nu), fu(
- 1 nx, nu, nu), fux(nx, nu, nu)
- double precision fut(nx, nu, nu), futx(nx, nu, nu), fv(1), fvt(1)
- common /param/ c
- double precision c
- integer i
- do 1 i = 1, nx
- a(i, 1) = ux(i, 1)+c*u(i, 1)
- aux(i, 1, 1) = 1
- au(i, 1, 1) = c
- f(i, 1) = ut(i, 1)
- fut(i, 1, 1) = 1
- 1 continue
- return
- end
- subroutine bc(t, l, r, u, ux, ut, utx, nu, v, vt, nv, b, bu,
- 1 bux, but, butx, bv, bvt)
- integer nu
- integer nv
- double precision t, l, r, u(nu, 2), ux(nu, 2), ut(nu, 2)
- double precision utx(nu, 2), v(1), vt(1), b(nu, 2), bu(nu, nu, 2),
- 1 bux(nu, nu, 2)
- double precision but(nu, nu, 2), butx(nu, nu, 2), bv(1), bvt(1)
- common /param/ c
- double precision c
- double precision dexp
- b(1, 1) = u(1, 1)-1d0
- b(1, 2) = u(1, 2)-dexp(-c)
- bu(1, 1, 1) = 1
- bu(1, 1, 2) = 1
- return
- end
- subroutine handle(t0, u0, v0, t, u, v, nu, nxmk, nv, k, x,
- 1 nx, dt, tstop)
- integer nxmk, nu, nx
- integer nv, k
- double precision t0, u0(nxmk, nu), v0(1), t, u(nxmk, nu), v(1)
- double precision x(nx), dt, tstop
- common /time/ tt
- double precision tt
- external uofx
- integer i1mach
- double precision deesff, eu
- integer temp
-c output and checking routine.
- if (t0 .ne. t) goto 2
- temp = i1mach(2)
- write (temp, 1) t
- 1 format (16h restart for t =, 1pe10.2)
- return
- 2 tt = t
- eu = deesff(k, x, nx, u, uofx)
- temp = i1mach(2)
- write (temp, 3) t, eu
- 3 format (15h error in u(x, , 1pe10.2, 4h ) =, 1pe10.2)
- return
- end
- subroutine uofx(x, nx, u, w)
- integer nx
- double precision x(nx), u(nx), w(nx)
- common /param/ c
- double precision c
- common /time/ t
- double precision t
- integer i
- double precision dexp
- do 1 i = 1, nx
- u(i) = dexp((-c)*x(i))
- 1 continue
- return
- end
diff --git a/CEP/PyBDSM/src/port3/dq7apl.f b/CEP/PyBDSM/src/port3/dq7apl.f
deleted file mode 100644
index deb3c2ad60ddeff684d637202b8af521967c092b..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/dq7apl.f
+++ /dev/null
@@ -1,87 +0,0 @@
- SUBROUTINE DQ7APL(NN, N, P, J, R, IERR)
-C *****PARAMETERS.
- INTEGER NN, N, P, IERR
- DOUBLE PRECISION J(NN,P), R(N)
-C
-C ..................................................................
-C ..................................................................
-C
-C *****PURPOSE.
-C THIS SUBROUTINE APPLIES TO R THE ORTHOGONAL TRANSFORMATIONS
-C STORED IN J BY QRFACT
-C
-C *****PARAMETER DESCRIPTION.
-C ON INPUT.
-C
-C NN IS THE ROW DIMENSION OF THE MATRIX J AS DECLARED IN
-C THE CALLING PROGRAM DIMENSION STATEMENT
-C
-C N IS THE NUMBER OF ROWS OF J AND THE SIZE OF THE VECTOR R
-C
-C P IS THE NUMBER OF COLUMNS OF J AND THE SIZE OF SIGMA
-C
-C J CONTAINS ON AND BELOW ITS DIAGONAL THE COLUMN VECTORS
-C U WHICH DETERMINE THE HOUSEHOLDER TRANSFORMATIONS
-C IDENT - U*U.TRANSPOSE
-C
-C R IS THE RIGHT HAND SIDE VECTOR TO WHICH THE ORTHOGONAL
-C TRANSFORMATIONS WILL BE APPLIED
-C
-C IERR IF NON-ZERO INDICATES THAT NOT ALL THE TRANSFORMATIONS
-C WERE SUCCESSFULLY DETERMINED AND ONLY THE FIRST
-C ABS(IERR) - 1 TRANSFORMATIONS WILL BE USED
-C
-C ON OUTPUT.
-C
-C R HAS BEEN OVERWRITTEN BY ITS TRANSFORMED IMAGE
-C
-C *****APPLICATION AND USAGE RESTRICTIONS.
-C NONE
-C
-C *****ALGORITHM NOTES.
-C THE VECTORS U WHICH DETERMINE THE HOUSEHOLDER TRANSFORMATIONS
-C ARE NORMALIZED SO THAT THEIR 2-NORM SQUARED IS 2. THE _USE_ OF
-C THESE TRANSFORMATIONS HERE IS IN THE SPIRIT OF (1).
-C
-C *****SUBROUTINES AND FUNCTIONS CALLED.
-C
-C DD7TPR - FUNCTION, RETURNS THE INNER PRODUCT OF VECTORS
-C
-C *****REFERENCES.
-C (1) BUSINGER, P. A., AND GOLUB, G. H. (1965), LINEAR LEAST SQUARES
-C SOLUTIONS BY HOUSEHOLDER TRANSFORMATIONS, NUMER. MATH. 7,
-C PP. 269-276.
-C
-C *****HISTORY.
-C DESIGNED BY DAVID M. GAY, CODED BY STEPHEN C. PETERS (WINTER 1977)
-C CALL ON DV2AXY SUBSTITUTED FOR DO LOOP, FALL 1983.
-C
-C *****GENERAL.
-C
-C THIS SUBROUTINE WAS WRITTEN IN CONNECTION WITH RESEARCH
-C SUPPORTED BY THE NATIONAL SCIENCE FOUNDATION UNDER GRANTS
-C MCS-7600324, DCR75-10143, 76-14311DSS, AND MCS76-11989.
-C
-C ..................................................................
-C ..................................................................
-C
-C *****LOCAL VARIABLES.
- INTEGER K, L, NL1
-C *****FUNCTIONS.
- DOUBLE PRECISION DD7TPR
- EXTERNAL DD7TPR,DV2AXY
-C
-C *** BODY ***
-C
- K = P
- IF (IERR .NE. 0) K = IABS(IERR) - 1
- IF ( K .EQ. 0) GO TO 999
-C
- DO 20 L = 1, K
- NL1 = N - L + 1
- CALL DV2AXY(NL1, R(L), -DD7TPR(NL1,J(L,L),R(L)), J(L,L), R(L))
- 20 CONTINUE
-C
- 999 RETURN
-C *** LAST LINE OF DQ7APL FOLLOWS ***
- END
diff --git a/CEP/PyBDSM/src/port3/dq7rad.f b/CEP/PyBDSM/src/port3/dq7rad.f
deleted file mode 100644
index c43ca13acaccdd6449e666d2ed96c2157eb647af..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/dq7rad.f
+++ /dev/null
@@ -1,136 +0,0 @@
- SUBROUTINE DQ7RAD(N, NN, P, QTR, QTRSET, RMAT, W, Y)
-C
-C *** ADD ROWS W TO QR FACTORIZATION WITH R MATRIX RMAT AND
-C *** Q**T * RESIDUAL = QTR. Y = NEW COMPONENTS OF RESIDUAL
-C *** CORRESPONDING TO W. QTR, Y REFERENCED ONLY IF QTRSET = .TRUE.
-C
- LOGICAL QTRSET
- INTEGER N, NN, P
- DOUBLE PRECISION QTR(P), RMAT(1), W(NN,P), Y(N)
-C DIMENSION RMAT(P*(P+1)/2)
-C/+
- DOUBLE PRECISION DSQRT
-C/
- DOUBLE PRECISION DD7TPR, DR7MDC, DV2NRM
- EXTERNAL DD7TPR, DR7MDC,DV2AXY, DV7SCL, DV2NRM
-C
-C *** LOCAL VARIABLES ***
-C
- INTEGER I, II, IJ, IP1, J, K, NK
- DOUBLE PRECISION ARI, QRI, RI, S, T, WI
- DOUBLE PRECISION BIG, BIGRT, ONE, TINY, TINYRT, ZERO
-C/7
- SAVE BIGRT, TINY, TINYRT
-C/
- DATA BIG/-1.D+0/, BIGRT/-1.D+0/, ONE/1.D+0/, TINY/0.D+0/,
- 1 TINYRT/0.D+0/, ZERO/0.D+0/
-C
-C------------------------------ BODY -----------------------------------
-C
- IF (TINY .GT. ZERO) GO TO 10
- TINY = DR7MDC(1)
- BIG = DR7MDC(6)
- IF (TINY*BIG .LT. ONE) TINY = ONE / BIG
- 10 K = 1
- NK = N
- II = 0
- DO 180 I = 1, P
- II = II + I
- IP1 = I + 1
- IJ = II + I
- IF (NK .LE. 1) T = DABS(W(K,I))
- IF (NK .GT. 1) T = DV2NRM(NK, W(K,I))
- IF (T .LT. TINY) GOTO 180
- RI = RMAT(II)
- IF (RI .NE. ZERO) GO TO 100
- IF (NK .GT. 1) GO TO 30
- IJ = II
- DO 20 J = I, P
- RMAT(IJ) = W(K,J)
- IJ = IJ + J
- 20 CONTINUE
- IF (QTRSET) QTR(I) = Y(K)
- W(K,I) = ZERO
- GO TO 999
- 30 WI = W(K,I)
- IF (BIGRT .GT. ZERO) GO TO 40
- BIGRT = DR7MDC(5)
- TINYRT = DR7MDC(2)
- 40 IF (T .LE. TINYRT) GO TO 50
- IF (T .GE. BIGRT) GO TO 50
- IF (WI .LT. ZERO) T = -T
- WI = WI + T
- S = DSQRT(T * WI)
- GO TO 70
- 50 S = DSQRT(T)
- IF (WI .LT. ZERO) GO TO 60
- WI = WI + T
- S = S * DSQRT(WI)
- GO TO 70
- 60 T = -T
- WI = WI + T
- S = S * DSQRT(-WI)
- 70 W(K,I) = WI
- CALL DV7SCL(NK, W(K,I), ONE/S, W(K,I))
- RMAT(II) = -T
- IF (.NOT. QTRSET) GO TO 80
- CALL DV2AXY(NK, Y(K), -DD7TPR(NK,Y(K),W(K,I)), W(K,I), Y(K))
- QTR(I) = Y(K)
- 80 IF (IP1 .GT. P) GO TO 999
- DO 90 J = IP1, P
- CALL DV2AXY(NK, W(K,J), -DD7TPR(NK,W(K,J),W(K,I)),
- 1 W(K,I), W(K,J))
- RMAT(IJ) = W(K,J)
- IJ = IJ + J
- 90 CONTINUE
- IF (NK .LE. 1) GO TO 999
- K = K + 1
- NK = NK - 1
- GO TO 180
-C
- 100 ARI = DABS(RI)
- IF (ARI .GT. T) GO TO 110
- T = T * DSQRT(ONE + (ARI/T)**2)
- GO TO 120
- 110 T = ARI * DSQRT(ONE + (T/ARI)**2)
- 120 IF (RI .LT. ZERO) T = -T
- RI = RI + T
- RMAT(II) = -T
- S = -RI / T
- IF (NK .LE. 1) GO TO 150
- CALL DV7SCL(NK, W(K,I), ONE/RI, W(K,I))
- IF (.NOT. QTRSET) GO TO 130
- QRI = QTR(I)
- T = S * ( QRI + DD7TPR(NK, Y(K), W(K,I)) )
- QTR(I) = QRI + T
- 130 IF (IP1 .GT. P) GO TO 999
- IF (QTRSET) CALL DV2AXY(NK, Y(K), T, W(K,I), Y(K))
- DO 140 J = IP1, P
- RI = RMAT(IJ)
- T = S * ( RI + DD7TPR(NK, W(K,J), W(K,I)) )
- CALL DV2AXY(NK, W(K,J), T, W(K,I), W(K,J))
- RMAT(IJ) = RI + T
- IJ = IJ + J
- 140 CONTINUE
- GO TO 180
-C
- 150 WI = W(K,I) / RI
- W(K,I) = WI
- IF (.NOT. QTRSET) GO TO 160
- QRI = QTR(I)
- T = S * ( QRI + Y(K)*WI )
- QTR(I) = QRI + T
- 160 IF (IP1 .GT. P) GO TO 999
- IF (QTRSET) Y(K) = T*WI + Y(K)
- DO 170 J = IP1, P
- RI = RMAT(IJ)
- T = S * (RI + W(K,J)*WI)
- W(K,J) = W(K,J) + T*WI
- RMAT(IJ) = RI + T
- IJ = IJ + J
- 170 CONTINUE
- 180 CONTINUE
-C
- 999 RETURN
-C *** LAST LINE OF DQ7RAD FOLLOWS ***
- END
diff --git a/CEP/PyBDSM/src/port3/dq7rfh.f b/CEP/PyBDSM/src/port3/dq7rfh.f
deleted file mode 100644
index f84e2f733173ae1c35ae93c13e3e334773f8bee5..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/dq7rfh.f
+++ /dev/null
@@ -1,198 +0,0 @@
- SUBROUTINE DQ7RFH(IERR, IPIVOT, N, NN, NOPIVK, P, Q, R, RLEN, W)
-C
-C *** COMPUTE QR FACTORIZATION VIA HOUSEHOLDER TRANSFORMATIONS
-C *** WITH COLUMN PIVOTING ***
-C
-C *** PARAMETER DECLARATIONS ***
-C
- INTEGER IERR, N, NN, NOPIVK, P, RLEN
- INTEGER IPIVOT(P)
- DOUBLE PRECISION Q(NN,P), R(RLEN), W(P)
-C DIMENSION R(P*(P+1)/2)
-C
-C---------------------------- DESCRIPTION ----------------------------
-C
-C THIS ROUTINE COMPUTES A QR FACTORIZATION (VIA HOUSEHOLDER TRANS-
-C FORMATIONS) OF THE MATRIX A THAT ON INPUT IS STORED IN Q.
-C IF NOPIVK ALLOWS IT, THIS ROUTINE DOES COLUMN PIVOTING -- IF
-C K .GT. NOPIVK, THEN ORIGINAL COLUMN K IS ELIGIBLE FOR PIVOTING.
-C THE Q AND R RETURNED ARE SUCH THAT COLUMN I OF Q*R EQUALS
-C COLUMN IPIVOT(I) OF THE ORIGINAL MATRIX A. THE UPPER TRIANGULAR
-C MATRIX R IS STORED COMPACTLY BY COLUMNS, I.E., THE OUTPUT VECTOR R
-C CONTAINS R(1,1), R(1,2), R(2,2), R(1,3), R(2,3), ..., R(P,P) (IN
-C THAT ORDER). IF ALL GOES WELL, THEN THIS ROUTINE SETS IERR = 0.
-C BUT IF (PERMUTED) COLUMN K OF A IS LINEARLY DEPENDENT ON
-C (PERMUTED) COLUMNS 1,2,...,K-1, THEN IERR IS SET TO K AND THE R
-C MATRIX RETURNED HAS R(I,J) = 0 FOR I .GE. K AND J .GE. K.
-C THE ORIGINAL MATRIX A IS AN N BY P MATRIX. NN IS THE LEAD
-C DIMENSION OF THE ARRAY Q AND MUST SATISFY NN .GE. N. NO
-C PARAMETER CHECKING IS DONE.
-C PIVOTING IS DONE AS THOUGH ALL COLUMNS OF Q WERE FIRST
-C SCALED TO HAVE THE SAME NORM. IF COLUMN K IS ELIGIBLE FOR
-C PIVOTING AND ITS (SCALED) NORM**2 LOSS IS MORE THAN THE
-C MINIMUM SUCH LOSS (OVER COLUMNS K THRU P), THEN COLUMN K IS
-C SWAPPED WITH THE COLUMN OF LEAST NORM**2 LOSS.
-C
-C CODED BY DAVID M. GAY (FALL 1979, SPRING 1984).
-C
-C-------------------------- LOCAL VARIABLES --------------------------
-C
- INTEGER I, II, J, K, KK, KM1, KP1, NK1
- DOUBLE PRECISION AK, QKK, S, SINGTL, T, T1, WK
- DOUBLE PRECISION DD7TPR, DR7MDC, DV2NRM
- EXTERNAL DD7TPR, DR7MDC,DV2AXY, DV7SCL, DV7SCP,DV7SWP, DV2NRM
-C/+
- DOUBLE PRECISION DSQRT
-C/
- DOUBLE PRECISION BIG, BIGRT, MEPS10, ONE, TEN, TINY, TINYRT,
- 1 WTOL, ZERO
-C/6
-C DATA ONE/1.0D+0/, TEN/1.D+1/, WTOL/0.75D+0/, ZERO/0.0D+0/
-C/7
- PARAMETER (ONE=1.0D+0, TEN=1.D+1, WTOL=0.75D+0, ZERO=0.0D+0)
- SAVE BIGRT, MEPS10, TINY, TINYRT
-C/
- DATA BIGRT/0.0D+0/, MEPS10/0.0D+0/, TINY/0.D+0/, TINYRT/0.D+0/
-C
-C+++++++++++++++++++++++++++++++ BODY ++++++++++++++++++++++++++++++++
-C
- IERR = 0
- IF (MEPS10 .GT. ZERO) GO TO 10
- BIGRT = DR7MDC(5)
- MEPS10 = TEN * DR7MDC(3)
- TINYRT = DR7MDC(2)
- TINY = DR7MDC(1)
- BIG = DR7MDC(6)
- IF (TINY*BIG .LT. ONE) TINY = ONE / BIG
- 10 SINGTL = FLOAT(MAX0(N,P)) * MEPS10
-C
-C *** INITIALIZE W, IPIVOT, AND DIAG(R) ***
-C
- J = 0
- DO 40 I = 1, P
- IPIVOT(I) = I
- T = DV2NRM(N, Q(1,I))
- IF (T .GT. ZERO) GO TO 20
- W(I) = ONE
- GO TO 30
- 20 W(I) = ZERO
- 30 J = J + I
- R(J) = T
- 40 CONTINUE
-C
-C *** MAIN LOOP ***
-C
- KK = 0
- NK1 = N + 1
- DO 130 K = 1, P
- IF (NK1 .LE. 1) GO TO 999
- NK1 = NK1 - 1
- KK = KK + K
- KP1 = K + 1
- IF (K .LE. NOPIVK) GO TO 60
- IF (K .GE. P) GO TO 60
-C
-C *** FIND COLUMN WITH MINIMUM WEIGHT LOSS ***
-C
- T = W(K)
- IF (T .LE. ZERO) GO TO 60
- J = K
- DO 50 I = KP1, P
- IF (W(I) .GE. T) GO TO 50
- T = W(I)
- J = I
- 50 CONTINUE
- IF (J .EQ. K) GO TO 60
-C
-C *** INTERCHANGE COLUMNS K AND J ***
-C
- I = IPIVOT(K)
- IPIVOT(K) = IPIVOT(J)
- IPIVOT(J) = I
- W(J) = W(K)
- W(K) = T
- I = J*(J+1)/2
- T1 = R(I)
- R(I) = R(KK)
- R(KK) = T1
- CALL DV7SWP(N, Q(1,K), Q(1,J))
- IF (K .LE. 1) GO TO 60
- I = I - J + 1
- J = KK - K + 1
- CALL DV7SWP(K-1, R(I), R(J))
-C
-C *** COLUMN K OF Q SHOULD BE NEARLY ORTHOGONAL TO THE PREVIOUS
-C *** COLUMNS. NORMALIZE IT, TEST FOR SINGULARITY, AND DECIDE
-C *** WHETHER TO REORTHOGONALIZE IT.
-C
- 60 AK = R(KK)
- IF (AK .LE. ZERO) GO TO 140
- WK = W(K)
-C
-C *** SET T TO THE NORM OF (Q(K,K),...,Q(N,K))
-C *** AND CHECK FOR SINGULARITY.
-C
- IF (WK .LT. WTOL) GO TO 70
- T = DV2NRM(NK1, Q(K,K))
- IF (T / AK .LE. SINGTL) GO TO 140
- GO TO 80
- 70 T = DSQRT(ONE - WK)
- IF (T .LE. SINGTL) GO TO 140
- T = T * AK
-C
-C *** DETERMINE HOUSEHOLDER TRANSFORMATION ***
-C
- 80 QKK = Q(K,K)
- IF (T .LE. TINYRT) GO TO 90
- IF (T .GE. BIGRT) GO TO 90
- IF (QKK .LT. ZERO) T = -T
- QKK = QKK + T
- S = DSQRT(T * QKK)
- GO TO 110
- 90 S = DSQRT(T)
- IF (QKK .LT. ZERO) GO TO 100
- QKK = QKK + T
- S = S * DSQRT(QKK)
- GO TO 110
- 100 T = -T
- QKK = QKK + T
- S = S * DSQRT(-QKK)
- 110 Q(K,K) = QKK
-C
-C *** SCALE (Q(K,K),...,Q(N,K)) TO HAVE NORM SQRT(2) ***
-C
- IF (S .LE. TINY) GO TO 140
- CALL DV7SCL(NK1, Q(K,K), ONE/S, Q(K,K))
-C
- R(KK) = -T
-C
-C *** COMPUTE R(K,I) FOR I = K+1,...,P AND UPDATE Q ***
-C
- IF (K .GE. P) GO TO 999
- J = KK + K
- II = KK
- DO 120 I = KP1, P
- II = II + I
- CALL DV2AXY(NK1, Q(K,I), -DD7TPR(NK1,Q(K,K),Q(K,I)),
- 1 Q(K,K), Q(K,I))
- T = Q(K,I)
- R(J) = T
- J = J + I
- T1 = R(II)
- IF (T1 .GT. ZERO) W(I) = W(I) + (T/T1)**2
- 120 CONTINUE
- 130 CONTINUE
-C
-C *** SINGULAR Q ***
-C
- 140 IERR = K
- KM1 = K - 1
- J = KK
- DO 150 I = K, P
- CALL DV7SCP(I-KM1, R(J), ZERO)
- J = J + I
- 150 CONTINUE
-C
- 999 RETURN
-C *** LAST CARD OF DQ7RFH FOLLOWS ***
- END
diff --git a/CEP/PyBDSM/src/port3/dq7rsh.f b/CEP/PyBDSM/src/port3/dq7rsh.f
deleted file mode 100644
index dd821b58b7e1739932f3597068e23ae5d2012d44..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/dq7rsh.f
+++ /dev/null
@@ -1,57 +0,0 @@
- SUBROUTINE DQ7RSH(K, P, HAVQTR, QTR, R, W)
-C
-C *** PERMUTE COLUMN K OF R TO COLUMN P, MODIFY QTR ACCORDINGLY ***
-C
- LOGICAL HAVQTR
- INTEGER K, P
- DOUBLE PRECISION QTR(P), R(1), W(P)
-C DIMSNSION R(P*(P+1)/2)
-C
- DOUBLE PRECISION DH2RFG
- EXTERNAL DH2RFA, DH2RFG,DV7CPY
-C
-C *** LOCAL VARIABLES ***
-C
- INTEGER I, I1, J, JM1, JP1, J1, KM1, K1, PM1
- DOUBLE PRECISION A, B, T, WJ, X, Y, Z, ZERO
-C
- DATA ZERO/0.0D+0/
-C
-C+++++++++++++++++++++++++++++++ BODY ++++++++++++++++++++++++++++++++
-C
- IF (K .GE. P) GO TO 999
- KM1 = K - 1
- K1 = K * KM1 / 2
- CALL DV7CPY(K, W, R(K1+1))
- WJ = W(K)
- PM1 = P - 1
- J1 = K1 + KM1
- DO 50 J = K, PM1
- JM1 = J - 1
- JP1 = J + 1
- IF (JM1 .GT. 0) CALL DV7CPY(JM1, R(K1+1), R(J1+2))
- J1 = J1 + JP1
- K1 = K1 + J
- A = R(J1)
- B = R(J1+1)
- IF (B .NE. ZERO) GO TO 10
- R(K1) = A
- X = ZERO
- Z = ZERO
- GO TO 40
- 10 R(K1) = DH2RFG(A, B, X, Y, Z)
- IF (J .EQ. PM1) GO TO 30
- I1 = J1
- DO 20 I = JP1, PM1
- I1 = I1 + I
- CALL DH2RFA(1, R(I1), R(I1+1), X, Y, Z)
- 20 CONTINUE
- 30 IF (HAVQTR) CALL DH2RFA(1, QTR(J), QTR(JP1), X, Y, Z)
- 40 T = X * WJ
- W(J) = WJ + T
- WJ = T * Z
- 50 CONTINUE
- W(P) = WJ
- CALL DV7CPY(P, R(K1+1), W)
- 999 RETURN
- END
diff --git a/CEP/PyBDSM/src/port3/dr7mdc.f b/CEP/PyBDSM/src/port3/dr7mdc.f
deleted file mode 100644
index 621599a890855d67849c929e6e5b276bc32a2138..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/dr7mdc.f
+++ /dev/null
@@ -1,54 +0,0 @@
- DOUBLE PRECISION FUNCTION DR7MDC(K)
-C
-C *** RETURN MACHINE DEPENDENT CONSTANTS USED BY NL2SOL ***
-C
- INTEGER K
-C
-C *** THE CONSTANT RETURNED DEPENDS ON K...
-C
-C *** K = 1... SMALLEST POS. ETA SUCH THAT -ETA EXISTS.
-C *** K = 2... SQUARE ROOT OF ETA.
-C *** K = 3... UNIT ROUNDOFF = SMALLEST POS. NO. MACHEP SUCH
-C *** THAT 1 + MACHEP .GT. 1 .AND. 1 - MACHEP .LT. 1.
-C *** K = 4... SQUARE ROOT OF MACHEP.
-C *** K = 5... SQUARE ROOT OF BIG (SEE K = 6).
-C *** K = 6... LARGEST MACHINE NO. BIG SUCH THAT -BIG EXISTS.
-C
- DOUBLE PRECISION BIG, ETA, MACHEP
-C/+
- DOUBLE PRECISION DSQRT
-C/
-C
- DOUBLE PRECISION D1MACH, ZERO
- EXTERNAL D1MACH
- DATA BIG/0.D+0/, ETA/0.D+0/, MACHEP/0.D+0/, ZERO/0.D+0/
- IF (BIG .GT. ZERO) GO TO 1
- BIG = D1MACH(2)
- ETA = D1MACH(1)
- MACHEP = D1MACH(4)
- 1 CONTINUE
-C
-C------------------------------- BODY --------------------------------
-C
- GO TO (10, 20, 30, 40, 50, 60), K
-C
- 10 DR7MDC = ETA
- GO TO 999
-C
- 20 DR7MDC = DSQRT(256.D+0*ETA)/16.D+0
- GO TO 999
-C
- 30 DR7MDC = MACHEP
- GO TO 999
-C
- 40 DR7MDC = DSQRT(MACHEP)
- GO TO 999
-C
- 50 DR7MDC = DSQRT(BIG/256.D+0)*16.D+0
- GO TO 999
-C
- 60 DR7MDC = BIG
-C
- 999 RETURN
-C *** LAST CARD OF DR7MDC FOLLOWS ***
- END
diff --git a/CEP/PyBDSM/src/port3/dr7tvm.f b/CEP/PyBDSM/src/port3/dr7tvm.f
deleted file mode 100644
index e1dd9f37b4651aee3380eb81e2d575bacaa9bb6f..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/dr7tvm.f
+++ /dev/null
@@ -1,31 +0,0 @@
- SUBROUTINE DR7TVM(N, P, Y, D, U, X)
-C
-C *** SET Y TO R*X, WHERE R IS THE UPPER TRIANGULAR MATRIX WHOSE
-C *** DIAGONAL IS IN D AND WHOSE STRICT UPPER TRIANGLE IS IN U.
-C
-C *** X AND Y MAY SHARE STORAGE.
-C
- INTEGER N, P
- DOUBLE PRECISION Y(P), D(P), U(N,P), X(P)
-C
- DOUBLE PRECISION DD7TPR
- EXTERNAL DD7TPR
-C
-C *** LOCAL VARIABLES ***
-C
- INTEGER I, II, PL, PP1
- DOUBLE PRECISION T
-C
-C *** BODY ***
-C
- PL = MIN0(N, P)
- PP1 = PL + 1
- DO 10 II = 1, PL
- I = PP1 - II
- T = X(I) * D(I)
- IF (I .GT. 1) T = T + DD7TPR(I-1, U(1,I), X)
- Y(I) = T
- 10 CONTINUE
- 999 RETURN
-C *** LAST LINE OF DR7TVM FOLLOWS ***
- END
diff --git a/CEP/PyBDSM/src/port3/drldst.f b/CEP/PyBDSM/src/port3/drldst.f
deleted file mode 100644
index 2d4f145c31a8652c5b161fc94113ffde77588beb..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/drldst.f
+++ /dev/null
@@ -1,31 +0,0 @@
- DOUBLE PRECISION FUNCTION DRLDST(P, D, X, X0)
-C
-C *** COMPUTE AND RETURN RELATIVE DIFFERENCE BETWEEN X AND X0 ***
-C *** NL2SOL VERSION 2.2 ***
-C
- INTEGER P
- DOUBLE PRECISION D(P), X(P), X0(P)
-C
- INTEGER I
- DOUBLE PRECISION EMAX, T, XMAX, ZERO
-C/6
-C DATA ZERO/0.D+0/
-C/7
- PARAMETER (ZERO=0.D+0)
-C/
-C
-C *** BODY ***
-C
- EMAX = ZERO
- XMAX = ZERO
- DO 10 I = 1, P
- T = DABS(D(I) * (X(I) - X0(I)))
- IF (EMAX .LT. T) EMAX = T
- T = D(I) * (DABS(X(I)) + DABS(X0(I)))
- IF (XMAX .LT. T) XMAX = T
- 10 CONTINUE
- DRLDST = ZERO
- IF (XMAX .GT. ZERO) DRLDST = EMAX / XMAX
- 999 RETURN
-C *** LAST CARD OF DRLDST FOLLOWS ***
- END
diff --git a/CEP/PyBDSM/src/port3/drmnf.f b/CEP/PyBDSM/src/port3/drmnf.f
deleted file mode 100644
index ee4d1609fbcde6c3238b66f56c740ecb814192dd..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/drmnf.f
+++ /dev/null
@@ -1,149 +0,0 @@
- SUBROUTINE DRMNF(D, FX, IV, LIV, LV, N, V, X)
-C
-C *** ITERATION DRIVER FOR DMNF...
-C *** MINIMIZE GENERAL UNCONSTRAINED OBJECTIVE FUNCTION USING
-C *** FINITE-DIFFERENCE GRADIENTS AND SECANT HESSIAN APPROXIMATIONS.
-C
- INTEGER LIV, LV, N
- INTEGER IV(LIV)
- DOUBLE PRECISION D(N), FX, X(N), V(LV)
-C DIMENSION V(77 + N*(N+17)/2)
-C
-C *** PURPOSE ***
-C
-C THIS ROUTINE INTERACTS WITH SUBROUTINE DRMNG IN AN ATTEMPT
-C TO FIND AN N-VECTOR X* THAT MINIMIZES THE (UNCONSTRAINED)
-C OBJECTIVE FUNCTION FX = F(X) COMPUTED BY THE CALLER. (OFTEN
-C THE X* FOUND IS A LOCAL MINIMIZER RATHER THAN A GLOBAL ONE.)
-C
-C *** PARAMETERS ***
-C
-C THE PARAMETERS FOR DRMNF ARE THE SAME AS THOSE FOR DMNG
-C (WHICH SEE), EXCEPT THAT CALCF, CALCG, UIPARM, URPARM, AND UFPARM
-C ARE OMITTED, AND A PARAMETER FX FOR THE OBJECTIVE FUNCTION
-C VALUE AT X IS ADDED. INSTEAD OF CALLING CALCG TO OBTAIN THE
-C GRADIENT OF THE OBJECTIVE FUNCTION AT X, DRMNF CALLS DS7GRD,
-C WHICH COMPUTES AN APPROXIMATION TO THE GRADIENT BY FINITE
-C (FORWARD AND CENTRAL) DIFFERENCES USING THE METHOD OF REF. 1.
-C THE FOLLOWING INPUT COMPONENT IS OF INTEREST IN THIS REGARD
-C (AND IS NOT DESCRIBED IN DMNG).
-C
-C V(ETA0)..... V(42) IS AN ESTIMATED BOUND ON THE RELATIVE ERROR IN THE
-C OBJECTIVE FUNCTION VALUE COMPUTED BY CALCF...
-C (TRUE VALUE) = (COMPUTED VALUE) * (1 + E),
-C WHERE ABS(E) .LE. V(ETA0). DEFAULT = MACHEP * 10**3,
-C WHERE MACHEP IS THE UNIT ROUNDOFF.
-C
-C THE OUTPUT VALUES IV(NFCALL) AND IV(NGCALL) HAVE DIFFERENT
-C MEANINGS FOR DMNF THAN FOR DMNG...
-C
-C IV(NFCALL)... IV(6) IS THE NUMBER OF CALLS SO FAR MADE ON CALCF (I.E.,
-C FUNCTION EVALUATIONS) EXCLUDING THOSE MADE ONLY FOR
-C COMPUTING GRADIENTS. THE INPUT VALUE IV(MXFCAL) IS A
-C LIMIT ON IV(NFCALL).
-C IV(NGCALL)... IV(30) IS THE NUMBER OF FUNCTION EVALUATIONS MADE ONLY
-C FOR COMPUTING GRADIENTS. THE TOTAL NUMBER OF FUNCTION
-C EVALUATIONS IS THUS IV(NFCALL) + IV(NGCALL).
-C
-C *** REFERENCES ***
-C
-C 1. STEWART, G.W. (1967), A MODIFICATION OF DAVIDON*S MINIMIZATION
-C METHOD TO ACCEPT DIFFERENCE APPROXIMATIONS OF DERIVATIVES,
-C J. ASSOC. COMPUT. MACH. 14, PP. 72-83.
-C.
-C *** GENERAL ***
-C
-C CODED BY DAVID M. GAY (AUGUST 1982).
-C
-C---------------------------- DECLARATIONS ---------------------------
-C
- DOUBLE PRECISION DD7TPR
- EXTERNAL DIVSET, DD7TPR, DS7GRD, DRMNG, DV7SCP
-C
-C DIVSET.... SUPPLIES DEFAULT PARAMETER VALUES.
-C DD7TPR... RETURNS INNER PRODUCT OF TWO VECTORS.
-C DS7GRD... COMPUTES FINITE-DIFFERENCE GRADIENT APPROXIMATION.
-C DRMNG.... REVERSE-COMMUNICATION ROUTINE THAT DOES DMNG ALGORITHM.
-C DV7SCP... SETS ALL ELEMENTS OF A VECTOR TO A SCALAR.
-C
- INTEGER ALPHA, G1, I, IV1, J, K, W
- DOUBLE PRECISION ZERO
-C
-C *** SUBSCRIPTS FOR IV ***
-C
- INTEGER ETA0, F, G, LMAT, NEXTV, NGCALL, NITER, SGIRC, TOOBIG,
- 1 VNEED
-C
-C/6
-C DATA ETA0/42/, F/10/, G/28/, LMAT/42/, NEXTV/47/, NGCALL/30/,
-C 1 NITER/31/, SGIRC/57/, TOOBIG/2/, VNEED/4/
-C/7
- PARAMETER (ETA0=42, F=10, G=28, LMAT=42, NEXTV=47, NGCALL=30,
- 1 NITER=31, SGIRC=57, TOOBIG=2, VNEED=4)
-C/
-C/6
-C DATA ZERO/0.D+0/
-C/7
- PARAMETER (ZERO=0.D+0)
-C/
-C
-C+++++++++++++++++++++++++++++++ BODY ++++++++++++++++++++++++++++++++
-C
- IV1 = IV(1)
- IF (IV1 .EQ. 1) GO TO 10
- IF (IV1 .EQ. 2) GO TO 50
- IF (IV(1) .EQ. 0) CALL DIVSET(2, IV, LIV, LV, V)
- IV1 = IV(1)
- IF (IV1 .EQ. 12 .OR. IV1 .EQ. 13) IV(VNEED) = IV(VNEED) + 2*N + 6
- IF (IV1 .EQ. 14) GO TO 10
- IF (IV1 .GT. 2 .AND. IV1 .LT. 12) GO TO 10
- G1 = 1
- IF (IV1 .EQ. 12) IV(1) = 13
- GO TO 20
-C
- 10 G1 = IV(G)
-C
- 20 CALL DRMNG(D, FX, V(G1), IV, LIV, LV, N, V, X)
- IF (IV(1) - 2) 999, 30, 70
-C
-C *** COMPUTE GRADIENT ***
-C
- 30 IF (IV(NITER) .EQ. 0) CALL DV7SCP(N, V(G1), ZERO)
- J = IV(LMAT)
- K = G1 - N
- DO 40 I = 1, N
- V(K) = DD7TPR(I, V(J), V(J))
- K = K + 1
- J = J + I
- 40 CONTINUE
-C *** UNDO INCREMENT OF IV(NGCALL) DONE BY DRMNG ***
- IV(NGCALL) = IV(NGCALL) - 1
-C *** STORE RETURN CODE FROM DS7GRD IN IV(SGIRC) ***
- IV(SGIRC) = 0
-C *** X MAY HAVE BEEN RESTORED, SO COPY BACK FX... ***
- FX = V(F)
- GO TO 60
-C
-C *** GRADIENT LOOP ***
-C
- 50 IF (IV(TOOBIG) .NE. 0) GO TO 10
-C
- 60 G1 = IV(G)
- ALPHA = G1 - N
- W = ALPHA - 6
- CALL DS7GRD(V(ALPHA), D, V(ETA0), FX, V(G1), IV(SGIRC), N, V(W),X)
- IF (IV(SGIRC) .EQ. 0) GO TO 10
- IV(NGCALL) = IV(NGCALL) + 1
- GO TO 999
-C
- 70 IF (IV(1) .NE. 14) GO TO 999
-C
-C *** STORAGE ALLOCATION ***
-C
- IV(G) = IV(NEXTV) + N + 6
- IV(NEXTV) = IV(G) + N
- IF (IV1 .NE. 13) GO TO 10
-C
- 999 RETURN
-C *** LAST CARD OF DRMNF FOLLOWS ***
- END
diff --git a/CEP/PyBDSM/src/port3/drmnfb.f b/CEP/PyBDSM/src/port3/drmnfb.f
deleted file mode 100644
index 6cd49d276ffcb593ab360ccf0bfce88915d9243a..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/drmnfb.f
+++ /dev/null
@@ -1,157 +0,0 @@
- SUBROUTINE DRMNFB(B, D, FX, IV, LIV, LV, P, V, X)
-C
-C *** ITERATION DRIVER FOR DMNF...
-C *** MINIMIZE GENERAL UNCONSTRAINED OBJECTIVE FUNCTION USING
-C *** FINITE-DIFFERENCE GRADIENTS AND SECANT HESSIAN APPROXIMATIONS.
-C
- INTEGER LIV, LV, P
- INTEGER IV(LIV)
- DOUBLE PRECISION B(2,P), D(P), FX, X(P), V(LV)
-C DIMENSION IV(59 + P), V(77 + P*(P+23)/2)
-C
-C *** PURPOSE ***
-C
-C THIS ROUTINE INTERACTS WITH SUBROUTINE DRMNGB IN AN ATTEMPT
-C TO FIND AN P-VECTOR X* THAT MINIMIZES THE (UNCONSTRAINED)
-C OBJECTIVE FUNCTION FX = F(X) COMPUTED BY THE CALLER. (OFTEN
-C THE X* FOUND IS A LOCAL MINIMIZER RATHER THAN A GLOBAL ONE.)
-C
-C *** PARAMETERS ***
-C
-C THE PARAMETERS FOR DRMNFB ARE THE SAME AS THOSE FOR DMNG
-C (WHICH SEE), EXCEPT THAT CALCF, CALCG, UIPARM, URPARM, AND UFPARM
-C ARE OMITTED, AND A PARAMETER FX FOR THE OBJECTIVE FUNCTION
-C VALUE AT X IS ADDED. INSTEAD OF CALLING CALCG TO OBTAIN THE
-C GRADIENT OF THE OBJECTIVE FUNCTION AT X, DRMNFB CALLS DS3GRD,
-C WHICH COMPUTES AN APPROXIMATION TO THE GRADIENT BY FINITE
-C (FORWARD AND CENTRAL) DIFFERENCES USING THE METHOD OF REF. 1.
-C THE FOLLOWING INPUT COMPONENT IS OF INTEREST IN THIS REGARD
-C (AND IS NOT DESCRIBED IN DMNG).
-C
-C V(ETA0)..... V(42) IS AN ESTIMATED BOUND ON THE RELATIVE ERROR IN THE
-C OBJECTIVE FUNCTION VALUE COMPUTED BY CALCF...
-C (TRUE VALUE) = (COMPUTED VALUE) * (1 + E),
-C WHERE ABS(E) .LE. V(ETA0). DEFAULT = MACHEP * 10**3,
-C WHERE MACHEP IS THE UNIT ROUNDOFF.
-C
-C THE OUTPUT VALUES IV(NFCALL) AND IV(NGCALL) HAVE DIFFERENT
-C MEANINGS FOR DMNF THAN FOR DMNG...
-C
-C IV(NFCALL)... IV(6) IS THE NUMBER OF CALLS SO FAR MADE ON CALCF (I.E.,
-C FUNCTION EVALUATIONS) EXCLUDING THOSE MADE ONLY FOR
-C COMPUTING GRADIENTS. THE INPUT VALUE IV(MXFCAL) IS A
-C LIMIT ON IV(NFCALL).
-C IV(NGCALL)... IV(30) IS THE NUMBER OF FUNCTION EVALUATIONS MADE ONLY
-C FOR COMPUTING GRADIENTS. THE TOTAL NUMBER OF FUNCTION
-C EVALUATIONS IS THUS IV(NFCALL) + IV(NGCALL).
-C
-C *** REFERENCES ***
-C
-C 1. STEWART, G.W. (1967), A MODIFICATION OF DAVIDON*S MINIMIZATION
-C METHOD TO ACCEPT DIFFERENCE APPROXIMATIONS OF DERIVATIVES,
-C J. ASSOC. COMPUT. MACH. 14, PP. 72-83.
-C.
-C *** GENERAL ***
-C
-C CODED BY DAVID M. GAY (AUGUST 1982).
-C
-C---------------------------- DECLARATIONS ---------------------------
-C
- DOUBLE PRECISION DD7TPR
- EXTERNAL DIVSET, DD7TPR, DS3GRD, DRMNGB, DV7SCP
-C
-C DIVSET.... SUPPLIES DEFAULT PARAMETER VALUES.
-C DD7TPR... RETURNS INNER PRODUCT OF TWO VECTORS.
-C DS3GRD... COMPUTES FINITE-DIFFERENCE GRADIENT APPROXIMATION.
-C DRMNGB... REVERSE-COMMUNICATION ROUTINE THAT DOES DMNGB ALGORITHM.
-C DV7SCP... SETS ALL ELEMENTS OF A VECTOR TO A SCALAR.
-C
- INTEGER ALPHA, ALPHA0, G1, I, IPI, IV1, J, K, W
- DOUBLE PRECISION ZERO
-C
-C *** SUBSCRIPTS FOR IV ***
-C
- INTEGER ETA0, F, G, LMAT, NEXTV, NGCALL,
- 1 NITER, PERM, SGIRC, TOOBIG, VNEED
-C
-C/6
-C DATA ETA0/42/, F/10/, G/28/, LMAT/42/, NEXTV/47/, NGCALL/30/,
-C 1 NITER/31/, PERM/58/, SGIRC/57/, TOOBIG/2/, VNEED/4/
-C/7
- PARAMETER (ETA0=42, F=10, G=28, LMAT=42, NEXTV=47, NGCALL=30,
- 1 NITER=31, PERM=58, SGIRC=57, TOOBIG=2, VNEED=4)
-C/
-C/6
-C DATA ZERO/0.D+0/
-C/7
- PARAMETER (ZERO=0.D+0)
-C/
-C
-C+++++++++++++++++++++++++++++++ BODY ++++++++++++++++++++++++++++++++
-C
- IV1 = IV(1)
- IF (IV1 .EQ. 1) GO TO 10
- IF (IV1 .EQ. 2) GO TO 50
- IF (IV(1) .EQ. 0) CALL DIVSET(2, IV, LIV, LV, V)
- IV1 = IV(1)
- IF (IV1 .EQ. 12 .OR. IV1 .EQ. 13) IV(VNEED) = IV(VNEED) + 2*P + 6
- IF (IV1 .EQ. 14) GO TO 10
- IF (IV1 .GT. 2 .AND. IV1 .LT. 12) GO TO 10
- G1 = 1
- IF (IV1 .EQ. 12) IV(1) = 13
- GO TO 20
-C
- 10 G1 = IV(G)
-C
- 20 CALL DRMNGB(B, D, FX, V(G1), IV, LIV, LV, P, V, X)
- IF (IV(1) - 2) 999, 30, 80
-C
-C *** COMPUTE GRADIENT ***
-C
- 30 IF (IV(NITER) .EQ. 0) CALL DV7SCP(P, V(G1), ZERO)
- J = IV(LMAT)
- ALPHA0 = G1 - P - 1
- IPI = IV(PERM)
- DO 40 I = 1, P
- K = ALPHA0 + IV(IPI)
- V(K) = DD7TPR(I, V(J), V(J))
- IPI = IPI + 1
- J = J + I
- 40 CONTINUE
-C *** UNDO INCREMENT OF IV(NGCALL) DONE BY DRMNGB ***
- IV(NGCALL) = IV(NGCALL) - 1
-C *** STORE RETURN CODE FROM DS3GRD IN IV(SGIRC) ***
- IV(SGIRC) = 0
-C *** X MAY HAVE BEEN RESTORED, SO COPY BACK FX... ***
- FX = V(F)
- GO TO 60
-C
-C *** GRADIENT LOOP ***
-C
- 50 IF (IV(TOOBIG) .NE. 0) GO TO 10
-C
- 60 G1 = IV(G)
- ALPHA = G1 - P
- W = ALPHA - 6
- CALL DS3GRD(V(ALPHA), B, D, V(ETA0), FX, V(G1), IV(SGIRC), P,
- 1 V(W), X)
- I = IV(SGIRC)
- IF (I .EQ. 0) GO TO 10
- IF (I .LE. P) GO TO 70
- IV(TOOBIG) = 1
- GO TO 10
-C
- 70 IV(NGCALL) = IV(NGCALL) + 1
- GO TO 999
-C
- 80 IF (IV(1) .NE. 14) GO TO 999
-C
-C *** STORAGE ALLOCATION ***
-C
- IV(G) = IV(NEXTV) + P + 6
- IV(NEXTV) = IV(G) + P
- IF (IV1 .NE. 13) GO TO 10
-C
- 999 RETURN
-C *** LAST CARD OF DRMNFB FOLLOWS ***
- END
diff --git a/CEP/PyBDSM/src/port3/drmng.f b/CEP/PyBDSM/src/port3/drmng.f
deleted file mode 100644
index 062d3dbbe6660ae4fd96f26968b9bf89a146610b..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/drmng.f
+++ /dev/null
@@ -1,447 +0,0 @@
- SUBROUTINE DRMNG(D, FX, G, IV, LIV, LV, N, V, X)
-C
-C *** CARRY OUT DMNG (UNCONSTRAINED MINIMIZATION) ITERATIONS, USING
-C *** DOUBLE-DOGLEG/BFGS STEPS.
-C
-C *** PARAMETER DECLARATIONS ***
-C
- INTEGER LIV, LV, N
- INTEGER IV(LIV)
- DOUBLE PRECISION D(N), FX, G(N), V(LV), X(N)
-C
-C-------------------------- PARAMETER USAGE --------------------------
-C
-C D.... SCALE VECTOR.
-C FX... FUNCTION VALUE.
-C G.... GRADIENT VECTOR.
-C IV... INTEGER VALUE ARRAY.
-C LIV.. LENGTH OF IV (AT LEAST 60).
-C LV... LENGTH OF V (AT LEAST 71 + N*(N+13)/2).
-C N.... NUMBER OF VARIABLES (COMPONENTS IN X AND G).
-C V.... FLOATING-POINT VALUE ARRAY.
-C X.... VECTOR OF PARAMETERS TO BE OPTIMIZED.
-C
-C *** DISCUSSION ***
-C
-C PARAMETERS IV, N, V, AND X ARE THE SAME AS THE CORRESPONDING
-C ONES TO DMNG (WHICH SEE), EXCEPT THAT V CAN BE SHORTER (SINCE
-C THE PART OF V THAT DMNG USES FOR STORING G IS NOT NEEDED).
-C MOREOVER, COMPARED WITH DMNG, IV(1) MAY HAVE THE TWO ADDITIONAL
-C OUTPUT VALUES 1 AND 2, WHICH ARE EXPLAINED BELOW, AS IS THE USE
-C OF IV(TOOBIG) AND IV(NFGCAL). THE VALUE IV(G), WHICH IS AN
-C OUTPUT VALUE FROM DMNG (AND DMNF), IS NOT REFERENCED BY
-C DRMNG OR THE SUBROUTINES IT CALLS.
-C FX AND G NEED NOT HAVE BEEN INITIALIZED WHEN DRMNG IS CALLED
-C WITH IV(1) = 12, 13, OR 14.
-C
-C IV(1) = 1 MEANS THE CALLER SHOULD SET FX TO F(X), THE FUNCTION VALUE
-C AT X, AND CALL DRMNG AGAIN, HAVING CHANGED NONE OF THE
-C OTHER PARAMETERS. AN EXCEPTION OCCURS IF F(X) CANNOT BE
-C (E.G. IF OVERFLOW WOULD OCCUR), WHICH MAY HAPPEN BECAUSE
-C OF AN OVERSIZED STEP. IN THIS CASE THE CALLER SHOULD SET
-C IV(TOOBIG) = IV(2) TO 1, WHICH WILL CAUSE DRMNG TO IG-
-C NORE FX AND TRY A SMALLER STEP. THE PARAMETER NF THAT
-C DMNG PASSES TO CALCF (FOR POSSIBLE _USE_ BY CALCG) IS A
-C COPY OF IV(NFCALL) = IV(6).
-C IV(1) = 2 MEANS THE CALLER SHOULD SET G TO G(X), THE GRADIENT VECTOR
-C OF F AT X, AND CALL DRMNG AGAIN, HAVING CHANGED NONE OF
-C THE OTHER PARAMETERS EXCEPT POSSIBLY THE SCALE VECTOR D
-C WHEN IV(DTYPE) = 0. THE PARAMETER NF THAT DMNG PASSES
-C TO CALCG IS IV(NFGCAL) = IV(7). IF G(X) CANNOT BE
-C EVALUATED, THEN THE CALLER MAY SET IV(TOOBIG) TO 0, IN
-C WHICH CASE DRMNG WILL RETURN WITH IV(1) = 65.
-C.
-C *** GENERAL ***
-C
-C CODED BY DAVID M. GAY (DECEMBER 1979). REVISED SEPT. 1982.
-C THIS SUBROUTINE WAS WRITTEN IN CONNECTION WITH RESEARCH SUPPORTED
-C IN PART BY THE NATIONAL SCIENCE FOUNDATION UNDER GRANTS
-C MCS-7600324 AND MCS-7906671.
-C
-C (SEE DMNG FOR REFERENCES.)
-C
-C+++++++++++++++++++++++++++ DECLARATIONS ++++++++++++++++++++++++++++
-C
-C *** LOCAL VARIABLES ***
-C
- INTEGER DG1, DUMMY, G01, I, K, L, LSTGST, NWTST1, RSTRST, STEP1,
- 1 TEMP1, W, X01, Z
- DOUBLE PRECISION T
-C
-C *** CONSTANTS ***
-C
- DOUBLE PRECISION HALF, NEGONE, ONE, ONEP2, ZERO
-C
-C *** NO INTRINSIC FUNCTIONS ***
-C
-C *** EXTERNAL FUNCTIONS AND SUBROUTINES ***
-C
- LOGICAL STOPX
- DOUBLE PRECISION DD7TPR, DRLDST, DV2NRM
- EXTERNAL DA7SST,DD7DOG,DIVSET, DD7TPR,DITSUM, DL7ITV, DL7IVM,
- 1 DL7TVM, DL7UPD,DL7VML,DPARCK, DRLDST, STOPX,DV2AXY,
- 2 DV7CPY, DV7SCP, DV7VMP, DV2NRM, DW7ZBF
-C
-C DA7SST.... ASSESSES CANDIDATE STEP.
-C DD7DOG.... COMPUTES DOUBLE-DOGLEG (CANDIDATE) STEP.
-C DIVSET.... SUPPLIES DEFAULT IV AND V INPUT COMPONENTS.
-C DD7TPR... RETURNS INNER PRODUCT OF TWO VECTORS.
-C DITSUM.... PRINTS ITERATION SUMMARY AND INFO ON INITIAL AND FINAL X.
-C DL7ITV... MULTIPLIES INVERSE TRANSPOSE OF LOWER TRIANGLE TIMES VECTOR.
-C DL7IVM... MULTIPLIES INVERSE OF LOWER TRIANGLE TIMES VECTOR.
-C DL7TVM... MULTIPLIES TRANSPOSE OF LOWER TRIANGLE TIMES VECTOR.
-C LUPDT.... UPDATES CHOLESKY FACTOR OF HESSIAN APPROXIMATION.
-C DL7VML.... MULTIPLIES LOWER TRIANGLE TIMES VECTOR.
-C DPARCK.... CHECKS VALIDITY OF INPUT IV AND V VALUES.
-C DRLDST... COMPUTES V(RELDX) = RELATIVE STEP SIZE.
-C STOPX.... RETURNS .TRUE. IF THE BREAK KEY HAS BEEN PRESSED.
-C DV2AXY.... COMPUTES SCALAR TIMES ONE VECTOR PLUS ANOTHER.
-C DV7CPY.... COPIES ONE VECTOR TO ANOTHER.
-C DV7SCP... SETS ALL ELEMENTS OF A VECTOR TO A SCALAR.
-C DV7VMP... MULTIPLIES VECTOR BY VECTOR RAISED TO POWER (COMPONENTWISE).
-C DV2NRM... RETURNS THE 2-NORM OF A VECTOR.
-C DW7ZBF... COMPUTES W AND Z FOR DL7UPD CORRESPONDING TO BFGS UPDATE.
-C
-C *** SUBSCRIPTS FOR IV AND V ***
-C
- INTEGER CNVCOD, DG, DGNORM, DINIT, DSTNRM, DST0, F, F0, FDIF,
- 1 GTHG, GTSTEP, G0, INCFAC, INITH, IRC, KAGQT, LMAT, LMAX0,
- 2 LMAXS, MODE, MODEL, MXFCAL, MXITER, NEXTV, NFCALL, NFGCAL,
- 3 NGCALL, NITER, NREDUC, NWTSTP, PREDUC, RADFAC, RADINC,
- 4 RADIUS, RAD0, RELDX, RESTOR, STEP, STGLIM, STLSTG, TOOBIG,
- 5 TUNER4, TUNER5, VNEED, XIRC, X0
-C
-C *** IV SUBSCRIPT VALUES ***
-C
-C/6
-C DATA CNVCOD/55/, DG/37/, G0/48/, INITH/25/, IRC/29/, KAGQT/33/,
-C 1 MODE/35/, MODEL/5/, MXFCAL/17/, MXITER/18/, NFCALL/6/,
-C 2 NFGCAL/7/, NGCALL/30/, NITER/31/, NWTSTP/34/, RADINC/8/,
-C 3 RESTOR/9/, STEP/40/, STGLIM/11/, STLSTG/41/, TOOBIG/2/,
-C 4 VNEED/4/, XIRC/13/, X0/43/
-C/7
- PARAMETER (CNVCOD=55, DG=37, G0=48, INITH=25, IRC=29, KAGQT=33,
- 1 MODE=35, MODEL=5, MXFCAL=17, MXITER=18, NFCALL=6,
- 2 NFGCAL=7, NGCALL=30, NITER=31, NWTSTP=34, RADINC=8,
- 3 RESTOR=9, STEP=40, STGLIM=11, STLSTG=41, TOOBIG=2,
- 4 VNEED=4, XIRC=13, X0=43)
-C/
-C
-C *** V SUBSCRIPT VALUES ***
-C
-C/6
-C DATA DGNORM/1/, DINIT/38/, DSTNRM/2/, DST0/3/, F/10/, F0/13/,
-C 1 FDIF/11/, GTHG/44/, GTSTEP/4/, INCFAC/23/, LMAT/42/,
-C 2 LMAX0/35/, LMAXS/36/, NEXTV/47/, NREDUC/6/, PREDUC/7/,
-C 3 RADFAC/16/, RADIUS/8/, RAD0/9/, RELDX/17/, TUNER4/29/,
-C 4 TUNER5/30/
-C/7
- PARAMETER (DGNORM=1, DINIT=38, DSTNRM=2, DST0=3, F=10, F0=13,
- 1 FDIF=11, GTHG=44, GTSTEP=4, INCFAC=23, LMAT=42,
- 2 LMAX0=35, LMAXS=36, NEXTV=47, NREDUC=6, PREDUC=7,
- 3 RADFAC=16, RADIUS=8, RAD0=9, RELDX=17, TUNER4=29,
- 4 TUNER5=30)
-C/
-C
-C/6
-C DATA HALF/0.5D+0/, NEGONE/-1.D+0/, ONE/1.D+0/, ONEP2/1.2D+0/,
-C 1 ZERO/0.D+0/
-C/7
- PARAMETER (HALF=0.5D+0, NEGONE=-1.D+0, ONE=1.D+0, ONEP2=1.2D+0,
- 1 ZERO=0.D+0)
-C/
-C
-C+++++++++++++++++++++++++++++++ BODY ++++++++++++++++++++++++++++++++
-C
- I = IV(1)
- IF (I .EQ. 1) GO TO 50
- IF (I .EQ. 2) GO TO 60
-C
-C *** CHECK VALIDITY OF IV AND V INPUT VALUES ***
-C
- IF (IV(1) .EQ. 0) CALL DIVSET(2, IV, LIV, LV, V)
- IF (IV(1) .EQ. 12 .OR. IV(1) .EQ. 13)
- 1 IV(VNEED) = IV(VNEED) + N*(N+13)/2
- CALL DPARCK(2, D, IV, LIV, LV, N, V)
- I = IV(1) - 2
- IF (I .GT. 12) GO TO 999
- GO TO (190, 190, 190, 190, 190, 190, 120, 90, 120, 10, 10, 20), I
-C
-C *** STORAGE ALLOCATION ***
-C
- 10 L = IV(LMAT)
- IV(X0) = L + N*(N+1)/2
- IV(STEP) = IV(X0) + N
- IV(STLSTG) = IV(STEP) + N
- IV(G0) = IV(STLSTG) + N
- IV(NWTSTP) = IV(G0) + N
- IV(DG) = IV(NWTSTP) + N
- IV(NEXTV) = IV(DG) + N
- IF (IV(1) .NE. 13) GO TO 20
- IV(1) = 14
- GO TO 999
-C
-C *** INITIALIZATION ***
-C
- 20 IV(NITER) = 0
- IV(NFCALL) = 1
- IV(NGCALL) = 1
- IV(NFGCAL) = 1
- IV(MODE) = -1
- IV(MODEL) = 1
- IV(STGLIM) = 1
- IV(TOOBIG) = 0
- IV(CNVCOD) = 0
- IV(RADINC) = 0
- V(RAD0) = ZERO
- IF (V(DINIT) .GE. ZERO) CALL DV7SCP(N, D, V(DINIT))
- IF (IV(INITH) .NE. 1) GO TO 40
-C
-C *** SET THE INITIAL HESSIAN APPROXIMATION TO DIAG(D)**-2 ***
-C
- L = IV(LMAT)
- CALL DV7SCP(N*(N+1)/2, V(L), ZERO)
- K = L - 1
- DO 30 I = 1, N
- K = K + I
- T = D(I)
- IF (T .LE. ZERO) T = ONE
- V(K) = T
- 30 CONTINUE
-C
-C *** COMPUTE INITIAL FUNCTION VALUE ***
-C
- 40 IV(1) = 1
- GO TO 999
-C
- 50 V(F) = FX
- IF (IV(MODE) .GE. 0) GO TO 190
- V(F0) = FX
- IV(1) = 2
- IF (IV(TOOBIG) .EQ. 0) GO TO 999
- IV(1) = 63
- GO TO 350
-C
-C *** MAKE SURE GRADIENT COULD BE COMPUTED ***
-C
- 60 IF (IV(TOOBIG) .EQ. 0) GO TO 70
- IV(1) = 65
- GO TO 350
-C
- 70 DG1 = IV(DG)
- CALL DV7VMP(N, V(DG1), G, D, -1)
- V(DGNORM) = DV2NRM(N, V(DG1))
-C
- IF (IV(CNVCOD) .NE. 0) GO TO 340
- IF (IV(MODE) .EQ. 0) GO TO 300
-C
-C *** ALLOW FIRST STEP TO HAVE SCALED 2-NORM AT MOST V(LMAX0) ***
-C
- V(RADIUS) = V(LMAX0)
-C
- IV(MODE) = 0
-C
-C
-C----------------------------- MAIN LOOP -----------------------------
-C
-C
-C *** PRINT ITERATION SUMMARY, CHECK ITERATION LIMIT ***
-C
- 80 CALL DITSUM(D, G, IV, LIV, LV, N, V, X)
- 90 K = IV(NITER)
- IF (K .LT. IV(MXITER)) GO TO 100
- IV(1) = 10
- GO TO 350
-C
-C *** UPDATE RADIUS ***
-C
- 100 IV(NITER) = K + 1
- IF (K .GT. 0) V(RADIUS) = V(RADFAC) * V(DSTNRM)
-C
-C *** INITIALIZE FOR START OF NEXT ITERATION ***
-C
- G01 = IV(G0)
- X01 = IV(X0)
- V(F0) = V(F)
- IV(IRC) = 4
- IV(KAGQT) = -1
-C
-C *** COPY X TO X0, G TO G0 ***
-C
- CALL DV7CPY(N, V(X01), X)
- CALL DV7CPY(N, V(G01), G)
-C
-C *** CHECK STOPX AND FUNCTION EVALUATION LIMIT ***
-C
- 110 IF (.NOT. STOPX(DUMMY)) GO TO 130
- IV(1) = 11
- GO TO 140
-C
-C *** COME HERE WHEN RESTARTING AFTER FUNC. EVAL. LIMIT OR STOPX.
-C
- 120 IF (V(F) .GE. V(F0)) GO TO 130
- V(RADFAC) = ONE
- K = IV(NITER)
- GO TO 100
-C
- 130 IF (IV(NFCALL) .LT. IV(MXFCAL)) GO TO 150
- IV(1) = 9
- 140 IF (V(F) .GE. V(F0)) GO TO 350
-C
-C *** IN CASE OF STOPX OR FUNCTION EVALUATION LIMIT WITH
-C *** IMPROVED V(F), EVALUATE THE GRADIENT AT X.
-C
- IV(CNVCOD) = IV(1)
- GO TO 290
-C
-C. . . . . . . . . . . . . COMPUTE CANDIDATE STEP . . . . . . . . . .
-C
- 150 STEP1 = IV(STEP)
- DG1 = IV(DG)
- NWTST1 = IV(NWTSTP)
- IF (IV(KAGQT) .GE. 0) GO TO 160
- L = IV(LMAT)
- CALL DL7IVM(N, V(NWTST1), V(L), G)
- V(NREDUC) = HALF * DD7TPR(N, V(NWTST1), V(NWTST1))
- CALL DL7ITV(N, V(NWTST1), V(L), V(NWTST1))
- CALL DV7VMP(N, V(STEP1), V(NWTST1), D, 1)
- V(DST0) = DV2NRM(N, V(STEP1))
- CALL DV7VMP(N, V(DG1), V(DG1), D, -1)
- CALL DL7TVM(N, V(STEP1), V(L), V(DG1))
- V(GTHG) = DV2NRM(N, V(STEP1))
- IV(KAGQT) = 0
- 160 CALL DD7DOG(V(DG1), LV, N, V(NWTST1), V(STEP1), V)
- IF (IV(IRC) .NE. 6) GO TO 170
- IF (IV(RESTOR) .NE. 2) GO TO 190
- RSTRST = 2
- GO TO 200
-C
-C *** CHECK WHETHER EVALUATING F(X0 + STEP) LOOKS WORTHWHILE ***
-C
- 170 IV(TOOBIG) = 0
- IF (V(DSTNRM) .LE. ZERO) GO TO 190
- IF (IV(IRC) .NE. 5) GO TO 180
- IF (V(RADFAC) .LE. ONE) GO TO 180
- IF (V(PREDUC) .GT. ONEP2 * V(FDIF)) GO TO 180
- IF (IV(RESTOR) .NE. 2) GO TO 190
- RSTRST = 0
- GO TO 200
-C
-C *** COMPUTE F(X0 + STEP) ***
-C
- 180 X01 = IV(X0)
- STEP1 = IV(STEP)
- CALL DV2AXY(N, X, ONE, V(STEP1), V(X01))
- IV(NFCALL) = IV(NFCALL) + 1
- IV(1) = 1
- GO TO 999
-C
-C. . . . . . . . . . . . . ASSESS CANDIDATE STEP . . . . . . . . . . .
-C
- 190 RSTRST = 3
- 200 X01 = IV(X0)
- V(RELDX) = DRLDST(N, D, X, V(X01))
- CALL DA7SST(IV, LIV, LV, V)
- STEP1 = IV(STEP)
- LSTGST = IV(STLSTG)
- I = IV(RESTOR) + 1
- GO TO (240, 210, 220, 230), I
- 210 CALL DV7CPY(N, X, V(X01))
- GO TO 240
- 220 CALL DV7CPY(N, V(LSTGST), V(STEP1))
- GO TO 240
- 230 CALL DV7CPY(N, V(STEP1), V(LSTGST))
- CALL DV2AXY(N, X, ONE, V(STEP1), V(X01))
- V(RELDX) = DRLDST(N, D, X, V(X01))
- IV(RESTOR) = RSTRST
-C
- 240 K = IV(IRC)
- GO TO (250,280,280,280,250,260,270,270,270,270,270,270,330,300), K
-C
-C *** RECOMPUTE STEP WITH CHANGED RADIUS ***
-C
- 250 V(RADIUS) = V(RADFAC) * V(DSTNRM)
- GO TO 110
-C
-C *** COMPUTE STEP OF LENGTH V(LMAXS) FOR SINGULAR CONVERGENCE TEST.
-C
- 260 V(RADIUS) = V(LMAXS)
- GO TO 150
-C
-C *** CONVERGENCE OR FALSE CONVERGENCE ***
-C
- 270 IV(CNVCOD) = K - 4
- IF (V(F) .GE. V(F0)) GO TO 340
- IF (IV(XIRC) .EQ. 14) GO TO 340
- IV(XIRC) = 14
-C
-C. . . . . . . . . . . . PROCESS ACCEPTABLE STEP . . . . . . . . . . .
-C
- 280 IF (IV(IRC) .NE. 3) GO TO 290
- STEP1 = IV(STEP)
- TEMP1 = IV(STLSTG)
-C
-C *** SET TEMP1 = HESSIAN * STEP FOR _USE_ IN GRADIENT TESTS ***
-C
- L = IV(LMAT)
- CALL DL7TVM(N, V(TEMP1), V(L), V(STEP1))
- CALL DL7VML(N, V(TEMP1), V(L), V(TEMP1))
-C
-C *** COMPUTE GRADIENT ***
-C
- 290 IV(NGCALL) = IV(NGCALL) + 1
- IV(1) = 2
- GO TO 999
-C
-C *** INITIALIZATIONS -- G0 = G - G0, ETC. ***
-C
- 300 G01 = IV(G0)
- CALL DV2AXY(N, V(G01), NEGONE, V(G01), G)
- STEP1 = IV(STEP)
- TEMP1 = IV(STLSTG)
- IF (IV(IRC) .NE. 3) GO TO 320
-C
-C *** SET V(RADFAC) BY GRADIENT TESTS ***
-C
-C *** SET TEMP1 = DIAG(D)**-1 * (HESSIAN*STEP + (G(X0)-G(X))) ***
-C
- CALL DV2AXY(N, V(TEMP1), NEGONE, V(G01), V(TEMP1))
- CALL DV7VMP(N, V(TEMP1), V(TEMP1), D, -1)
-C
-C *** DO GRADIENT TESTS ***
-C
- IF (DV2NRM(N, V(TEMP1)) .LE. V(DGNORM) * V(TUNER4))
- 1 GO TO 310
- IF (DD7TPR(N, G, V(STEP1))
- 1 .GE. V(GTSTEP) * V(TUNER5)) GO TO 320
- 310 V(RADFAC) = V(INCFAC)
-C
-C *** UPDATE H, LOOP ***
-C
- 320 W = IV(NWTSTP)
- Z = IV(X0)
- L = IV(LMAT)
- CALL DW7ZBF(V(L), N, V(STEP1), V(W), V(G01), V(Z))
-C
-C ** _USE_ THE N-VECTORS STARTING AT V(STEP1) AND V(G01) FOR SCRATCH..
- CALL DL7UPD(V(TEMP1), V(STEP1), V(L), V(G01), V(L), N, V(W), V(Z))
- IV(1) = 2
- GO TO 80
-C
-C. . . . . . . . . . . . . . MISC. DETAILS . . . . . . . . . . . . . .
-C
-C *** BAD PARAMETERS TO ASSESS ***
-C
- 330 IV(1) = 64
- GO TO 350
-C
-C *** PRINT SUMMARY OF FINAL ITERATION AND OTHER REQUESTED ITEMS ***
-C
- 340 IV(1) = IV(CNVCOD)
- IV(CNVCOD) = 0
- 350 CALL DITSUM(D, G, IV, LIV, LV, N, V, X)
-C
- 999 RETURN
-C
-C *** LAST LINE OF DRMNG FOLLOWS ***
- END
diff --git a/CEP/PyBDSM/src/port3/drmngb.f b/CEP/PyBDSM/src/port3/drmngb.f
deleted file mode 100644
index f5d98e3d38e8d3dd3545b107943dd6049785e70f..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/drmngb.f
+++ /dev/null
@@ -1,526 +0,0 @@
- SUBROUTINE DRMNGB(B, D, FX, G, IV, LIV, LV, N, V, X)
-C
-C *** CARRY OUT DMNGB (SIMPLY BOUNDED MINIMIZATION) ITERATIONS,
-C *** USING DOUBLE-DOGLEG/BFGS STEPS.
-C
-C *** PARAMETER DECLARATIONS ***
-C
- INTEGER LIV, LV, N
- INTEGER IV(LIV)
- DOUBLE PRECISION B(2,N), D(N), FX, G(N), V(LV), X(N)
-C
-C-------------------------- PARAMETER USAGE --------------------------
-C
-C B.... VECTOR OF LOWER AND UPPER BOUNDS ON X.
-C D.... SCALE VECTOR.
-C FX... FUNCTION VALUE.
-C G.... GRADIENT VECTOR.
-C IV... INTEGER VALUE ARRAY.
-C LIV.. LENGTH OF IV (AT LEAST 59) + N.
-C LV... LENGTH OF V (AT LEAST 71 + N*(N+19)/2).
-C N.... NUMBER OF VARIABLES (COMPONENTS IN X AND G).
-C V.... FLOATING-POINT VALUE ARRAY.
-C X.... VECTOR OF PARAMETERS TO BE OPTIMIZED.
-C
-C *** DISCUSSION ***
-C
-C PARAMETERS IV, N, V, AND X ARE THE SAME AS THE CORRESPONDING
-C ONES TO DMNGB (WHICH SEE), EXCEPT THAT V CAN BE SHORTER (SINCE
-C THE PART OF V THAT DMNGB USES FOR STORING G IS NOT NEEDED).
-C MOREOVER, COMPARED WITH DMNGB, IV(1) MAY HAVE THE TWO ADDITIONAL
-C OUTPUT VALUES 1 AND 2, WHICH ARE EXPLAINED BELOW, AS IS THE USE
-C OF IV(TOOBIG) AND IV(NFGCAL). THE VALUE IV(G), WHICH IS AN
-C OUTPUT VALUE FROM DMNGB (AND SMSNOB), IS NOT REFERENCED BY
-C DRMNGB OR THE SUBROUTINES IT CALLS.
-C FX AND G NEED NOT HAVE BEEN INITIALIZED WHEN DRMNGB IS CALLED
-C WITH IV(1) = 12, 13, OR 14.
-C
-C IV(1) = 1 MEANS THE CALLER SHOULD SET FX TO F(X), THE FUNCTION VALUE
-C AT X, AND CALL DRMNGB AGAIN, HAVING CHANGED NONE OF THE
-C OTHER PARAMETERS. AN EXCEPTION OCCURS IF F(X) CANNOT BE
-C (E.G. IF OVERFLOW WOULD OCCUR), WHICH MAY HAPPEN BECAUSE
-C OF AN OVERSIZED STEP. IN THIS CASE THE CALLER SHOULD SET
-C IV(TOOBIG) = IV(2) TO 1, WHICH WILL CAUSE DRMNGB TO IG-
-C NORE FX AND TRY A SMALLER STEP. THE PARAMETER NF THAT
-C DMNGB PASSES TO CALCF (FOR POSSIBLE _USE_ BY CALCG) IS A
-C COPY OF IV(NFCALL) = IV(6).
-C IV(1) = 2 MEANS THE CALLER SHOULD SET G TO G(X), THE GRADIENT VECTOR
-C OF F AT X, AND CALL DRMNGB AGAIN, HAVING CHANGED NONE OF
-C THE OTHER PARAMETERS EXCEPT POSSIBLY THE SCALE VECTOR D
-C WHEN IV(DTYPE) = 0. THE PARAMETER NF THAT DMNGB PASSES
-C TO CALCG IS IV(NFGCAL) = IV(7). IF G(X) CANNOT BE
-C EVALUATED, THEN THE CALLER MAY SET IV(NFGCAL) TO 0, IN
-C WHICH CASE DRMNGB WILL RETURN WITH IV(1) = 65.
-C.
-C *** GENERAL ***
-C
-C CODED BY DAVID M. GAY (DECEMBER 1979). REVISED SEPT. 1982.
-C THIS SUBROUTINE WAS WRITTEN IN CONNECTION WITH RESEARCH SUPPORTED
-C IN PART BY THE NATIONAL SCIENCE FOUNDATION UNDER GRANTS
-C MCS-7600324 AND MCS-7906671.
-C
-C (SEE DMNG FOR REFERENCES.)
-C
-C+++++++++++++++++++++++++++ DECLARATIONS ++++++++++++++++++++++++++++
-C
-C *** LOCAL VARIABLES ***
-C
- INTEGER DG1, DSTEP1, DUMMY, G01, I, I1, IPI, IPN, J, K, L, LSTGST,
- 1 N1, NP1, NWTST1, RSTRST, STEP1, TEMP0, TEMP1, TD1, TG1,
- 2 W1, X01, Z
- DOUBLE PRECISION GI, T, XI
-C
-C *** CONSTANTS ***
-C
- DOUBLE PRECISION NEGONE, ONE, ONEP2, ZERO
-C
-C *** NO INTRINSIC FUNCTIONS ***
-C
-C *** EXTERNAL FUNCTIONS AND SUBROUTINES ***
-C
- LOGICAL STOPX
- DOUBLE PRECISION DD7TPR, DRLDST, DV2NRM
- EXTERNAL DA7SST, DD7DGB,DIVSET, DD7TPR, I7SHFT,DITSUM, DL7TVM,
- 1 DL7UPD,DL7VML,DPARCK, DQ7RSH, DRLDST, STOPX, DV2NRM,
- 2 DV2AXY,DV7CPY, DV7IPR, DV7SCP, DV7VMP, DW7ZBF
-C
-C DA7SST.... ASSESSES CANDIDATE STEP.
-C DD7DGB... COMPUTES SIMPLY BOUNDED DOUBLE-DOGLEG (CANDIDATE) STEP.
-C DIVSET.... SUPPLIES DEFAULT IV AND V INPUT COMPONENTS.
-C DD7TPR... RETURNS INNER PRODUCT OF TWO VECTORS.
-C I7SHFT... CYCLICALLLY SHIFTS AN ARRAY OF INTEGERS.
-C DITSUM.... PRINTS ITERATION SUMMARY AND INFO ON INITIAL AND FINAL X.
-C DL7TVM... MULTIPLIES TRANSPOSE OF LOWER TRIANGLE TIMES VECTOR.
-C LUPDT.... UPDATES CHOLESKY FACTOR OF HESSIAN APPROXIMATION.
-C DL7VML.... MULTIPLIES LOWER TRIANGLE TIMES VECTOR.
-C DPARCK.... CHECKS VALIDITY OF INPUT IV AND V VALUES.
-C DQ7RSH... CYCLICALLY SHIFTS CHOLESKY FACTOR.
-C DRLDST... COMPUTES V(RELDX) = RELATIVE STEP SIZE.
-C STOPX.... RETURNS .TRUE. IF THE BREAK KEY HAS BEEN PRESSED.
-C DV2NRM... RETURNS THE 2-NORM OF A VECTOR.
-C DV2AXY.... COMPUTES SCALAR TIMES ONE VECTOR PLUS ANOTHER.
-C DV7CPY.... COPIES ONE VECTOR TO ANOTHER.
-C DV7IPR... CYCLICALLY SHIFTS A FLOATING-POINT ARRAY.
-C DV7SCP... SETS ALL ELEMENTS OF A VECTOR TO A SCALAR.
-C DV7VMP... MULTIPLIES VECTOR BY VECTOR RAISED TO POWER (COMPONENTWISE).
-C DW7ZBF... COMPUTES W AND Z FOR DL7UPD CORRESPONDING TO BFGS UPDATE.
-C
-C *** SUBSCRIPTS FOR IV AND V ***
-C
- INTEGER CNVCOD, DG, DGNORM, DINIT, DSTNRM, F, F0, FDIF,
- 1 GTSTEP, INCFAC, INITH, IRC, IVNEED, KAGQT, LMAT,
- 2 LMAX0, LMAXS, MODE, MODEL, MXFCAL, MXITER, NC, NEXTIV,
- 3 NEXTV, NFCALL, NFGCAL, NGCALL, NITER, NWTSTP, PERM,
- 4 PREDUC, RADFAC, RADINC, RADIUS, RAD0, RELDX, RESTOR, STEP,
- 4 STGLIM, STLSTG, TOOBIG, TUNER4, TUNER5, VNEED, XIRC, X0
-C
-C *** IV SUBSCRIPT VALUES ***
-C
-C *** (NOTE THAT NC IS STORED IN IV(G0)) ***
-C
-C/6
-C DATA CNVCOD/55/, DG/37/, INITH/25/, IRC/29/, IVNEED/3/, KAGQT/33/,
-C 1 MODE/35/, MODEL/5/, MXFCAL/17/, MXITER/18/, NC/48/,
-C 2 NEXTIV/46/, NEXTV/47/, NFCALL/6/, NFGCAL/7/, NGCALL/30/,
-C 3 NITER/31/, NWTSTP/34/, PERM/58/, RADINC/8/, RESTOR/9/,
-C 4 STEP/40/, STGLIM/11/, STLSTG/41/, TOOBIG/2/, XIRC/13/, X0/43/
-C/7
- PARAMETER (CNVCOD=55, DG=37, INITH=25, IRC=29, IVNEED=3, KAGQT=33,
- 1 MODE=35, MODEL=5, MXFCAL=17, MXITER=18, NC=48,
- 2 NEXTIV=46, NEXTV=47, NFCALL=6, NFGCAL=7, NGCALL=30,
- 3 NITER=31, NWTSTP=34, PERM=58, RADINC=8, RESTOR=9,
- 4 STEP=40, STGLIM=11, STLSTG=41, TOOBIG=2, XIRC=13,
- 5 X0=43)
-C/
-C
-C *** V SUBSCRIPT VALUES ***
-C
-C/6
-C DATA DGNORM/1/, DINIT/38/, DSTNRM/2/, F/10/, F0/13/, FDIF/11/,
-C 1 GTSTEP/4/, INCFAC/23/, LMAT/42/, LMAX0/35/, LMAXS/36/,
-C 2 PREDUC/7/, RADFAC/16/, RADIUS/8/, RAD0/9/, RELDX/17/,
-C 3 TUNER4/29/, TUNER5/30/, VNEED/4/
-C/7
- PARAMETER (DGNORM=1, DINIT=38, DSTNRM=2, F=10, F0=13, FDIF=11,
- 1 GTSTEP=4, INCFAC=23, LMAT=42, LMAX0=35, LMAXS=36,
- 2 PREDUC=7, RADFAC=16, RADIUS=8, RAD0=9, RELDX=17,
- 3 TUNER4=29, TUNER5=30, VNEED=4)
-C/
-C
-C/6
-C DATA NEGONE/-1.D+0/, ONE/1.D+0/, ONEP2/1.2D+0/, ZERO/0.D+0/
-C/7
- PARAMETER (NEGONE=-1.D+0, ONE=1.D+0, ONEP2=1.2D+0, ZERO=0.D+0)
-C/
-C
-C+++++++++++++++++++++++++++++++ BODY ++++++++++++++++++++++++++++++++
-C
- I = IV(1)
- IF (I .EQ. 1) GO TO 70
- IF (I .EQ. 2) GO TO 80
-C
-C *** CHECK VALIDITY OF IV AND V INPUT VALUES ***
-C
- IF (IV(1) .EQ. 0) CALL DIVSET(2, IV, LIV, LV, V)
- IF (IV(1) .LT. 12) GO TO 10
- IF (IV(1) .GT. 13) GO TO 10
- IV(VNEED) = IV(VNEED) + N*(N+19)/2
- IV(IVNEED) = IV(IVNEED) + N
- 10 CALL DPARCK(2, D, IV, LIV, LV, N, V)
- I = IV(1) - 2
- IF (I .GT. 12) GO TO 999
- GO TO (250, 250, 250, 250, 250, 250, 190, 150, 190, 20, 20, 30), I
-C
-C *** STORAGE ALLOCATION ***
-C
- 20 L = IV(LMAT)
- IV(X0) = L + N*(N+1)/2
- IV(STEP) = IV(X0) + 2*N
- IV(STLSTG) = IV(STEP) + 2*N
- IV(NWTSTP) = IV(STLSTG) + N
- IV(DG) = IV(NWTSTP) + 2*N
- IV(NEXTV) = IV(DG) + 2*N
- IV(NEXTIV) = IV(PERM) + N
- IF (IV(1) .NE. 13) GO TO 30
- IV(1) = 14
- GO TO 999
-C
-C *** INITIALIZATION ***
-C
- 30 IV(NITER) = 0
- IV(NFCALL) = 1
- IV(NGCALL) = 1
- IV(NFGCAL) = 1
- IV(MODE) = -1
- IV(MODEL) = 1
- IV(STGLIM) = 1
- IV(TOOBIG) = 0
- IV(CNVCOD) = 0
- IV(RADINC) = 0
- IV(NC) = N
- V(RAD0) = ZERO
-C
-C *** CHECK CONSISTENCY OF B AND INITIALIZE IP ARRAY ***
-C
- IPI = IV(PERM)
- DO 40 I = 1, N
- IV(IPI) = I
- IPI = IPI + 1
- IF (B(1,I) .GT. B(2,I)) GO TO 410
- 40 CONTINUE
-C
- IF (V(DINIT) .GE. ZERO) CALL DV7SCP(N, D, V(DINIT))
- IF (IV(INITH) .NE. 1) GO TO 60
-C
-C *** SET THE INITIAL HESSIAN APPROXIMATION TO DIAG(D)**-2 ***
-C
- L = IV(LMAT)
- CALL DV7SCP(N*(N+1)/2, V(L), ZERO)
- K = L - 1
- DO 50 I = 1, N
- K = K + I
- T = D(I)
- IF (T .LE. ZERO) T = ONE
- V(K) = T
- 50 CONTINUE
-C
-C *** GET INITIAL FUNCTION VALUE ***
-C
- 60 IV(1) = 1
- GO TO 440
-C
- 70 V(F) = FX
- IF (IV(MODE) .GE. 0) GO TO 250
- V(F0) = FX
- IV(1) = 2
- IF (IV(TOOBIG) .EQ. 0) GO TO 999
- IV(1) = 63
- GO TO 430
-C
-C *** MAKE SURE GRADIENT COULD BE COMPUTED ***
-C
- 80 IF (IV(TOOBIG) .EQ. 0) GO TO 90
- IV(1) = 65
- GO TO 430
-C
-C *** CHOOSE INITIAL PERMUTATION ***
-C
- 90 IPI = IV(PERM)
- IPN = IPI + N
- N1 = N
- NP1 = N + 1
- L = IV(LMAT)
- W1 = IV(NWTSTP) + N
- K = N - IV(NC)
- DO 120 I = 1, N
- IPN = IPN - 1
- J = IV(IPN)
- IF (B(1,J) .GE. B(2,J)) GO TO 100
- XI = X(J)
- GI = G(J)
- IF (XI .LE. B(1,J) .AND. GI .GT. ZERO) GO TO 100
- IF (XI .GE. B(2,J) .AND. GI .LT. ZERO) GO TO 100
-C *** DISALLOW CONVERGENCE IF X(J) HAS JUST BEEN FREED ***
- IF (I .LE. K) IV(CNVCOD) = 0
- GO TO 120
- 100 I1 = NP1 - I
- IF (I1 .GE. N1) GO TO 110
- CALL I7SHFT(N1, I1, IV(IPI))
- CALL DQ7RSH(I1, N1, .FALSE., G, V(L), V(W1))
- 110 N1 = N1 - 1
- 120 CONTINUE
-C
- IV(NC) = N1
- V(DGNORM) = ZERO
- IF (N1 .LE. 0) GO TO 130
- DG1 = IV(DG)
- CALL DV7VMP(N, V(DG1), G, D, -1)
- CALL DV7IPR(N, IV(IPI), V(DG1))
- V(DGNORM) = DV2NRM(N1, V(DG1))
- 130 IF (IV(CNVCOD) .NE. 0) GO TO 420
- IF (IV(MODE) .EQ. 0) GO TO 370
-C
-C *** ALLOW FIRST STEP TO HAVE SCALED 2-NORM AT MOST V(LMAX0) ***
-C
- V(RADIUS) = V(LMAX0)
-C
- IV(MODE) = 0
-C
-C
-C----------------------------- MAIN LOOP -----------------------------
-C
-C
-C *** PRINT ITERATION SUMMARY, CHECK ITERATION LIMIT ***
-C
- 140 CALL DITSUM(D, G, IV, LIV, LV, N, V, X)
- 150 K = IV(NITER)
- IF (K .LT. IV(MXITER)) GO TO 160
- IV(1) = 10
- GO TO 430
-C
-C *** UPDATE RADIUS ***
-C
- 160 IV(NITER) = K + 1
- IF (K .EQ. 0) GO TO 170
- T = V(RADFAC) * V(DSTNRM)
- IF (V(RADFAC) .LT. ONE .OR. T .GT. V(RADIUS)) V(RADIUS) = T
-C
-C *** INITIALIZE FOR START OF NEXT ITERATION ***
-C
- 170 X01 = IV(X0)
- V(F0) = V(F)
- IV(IRC) = 4
- IV(KAGQT) = -1
-C
-C *** COPY X TO X0 ***
-C
- CALL DV7CPY(N, V(X01), X)
-C
-C *** CHECK STOPX AND FUNCTION EVALUATION LIMIT ***
-C
- 180 IF (.NOT. STOPX(DUMMY)) GO TO 200
- IV(1) = 11
- GO TO 210
-C
-C *** COME HERE WHEN RESTARTING AFTER FUNC. EVAL. LIMIT OR STOPX.
-C
- 190 IF (V(F) .GE. V(F0)) GO TO 200
- V(RADFAC) = ONE
- K = IV(NITER)
- GO TO 160
-C
- 200 IF (IV(NFCALL) .LT. IV(MXFCAL)) GO TO 220
- IV(1) = 9
- 210 IF (V(F) .GE. V(F0)) GO TO 430
-C
-C *** IN CASE OF STOPX OR FUNCTION EVALUATION LIMIT WITH
-C *** IMPROVED V(F), EVALUATE THE GRADIENT AT X.
-C
- IV(CNVCOD) = IV(1)
- GO TO 360
-C
-C. . . . . . . . . . . . . COMPUTE CANDIDATE STEP . . . . . . . . . .
-C
- 220 STEP1 = IV(STEP)
- DG1 = IV(DG)
- NWTST1 = IV(NWTSTP)
- W1 = NWTST1 + N
- DSTEP1 = STEP1 + N
- IPI = IV(PERM)
- L = IV(LMAT)
- TG1 = DG1 + N
- X01 = IV(X0)
- TD1 = X01 + N
- CALL DD7DGB(B, D, V(DG1), V(DSTEP1), G, IV(IPI), IV(KAGQT),
- 1 V(L), LV, N, IV(NC), V(NWTST1), V(STEP1), V(TD1),
- 2 V(TG1), V, V(W1), V(X01))
- IF (IV(IRC) .NE. 6) GO TO 230
- IF (IV(RESTOR) .NE. 2) GO TO 250
- RSTRST = 2
- GO TO 260
-C
-C *** CHECK WHETHER EVALUATING F(X0 + STEP) LOOKS WORTHWHILE ***
-C
- 230 IV(TOOBIG) = 0
- IF (V(DSTNRM) .LE. ZERO) GO TO 250
- IF (IV(IRC) .NE. 5) GO TO 240
- IF (V(RADFAC) .LE. ONE) GO TO 240
- IF (V(PREDUC) .GT. ONEP2 * V(FDIF)) GO TO 240
- IF (IV(RESTOR) .NE. 2) GO TO 250
- RSTRST = 0
- GO TO 260
-C
-C *** COMPUTE F(X0 + STEP) ***
-C
- 240 CALL DV2AXY(N, X, ONE, V(STEP1), V(X01))
- IV(NFCALL) = IV(NFCALL) + 1
- IV(1) = 1
- GO TO 440
-C
-C. . . . . . . . . . . . . ASSESS CANDIDATE STEP . . . . . . . . . . .
-C
- 250 RSTRST = 3
- 260 X01 = IV(X0)
- V(RELDX) = DRLDST(N, D, X, V(X01))
- CALL DA7SST(IV, LIV, LV, V)
- STEP1 = IV(STEP)
- LSTGST = IV(STLSTG)
- I = IV(RESTOR) + 1
- GO TO (300, 270, 280, 290), I
- 270 CALL DV7CPY(N, X, V(X01))
- GO TO 300
- 280 CALL DV7CPY(N, V(LSTGST), X)
- GO TO 300
- 290 CALL DV7CPY(N, X, V(LSTGST))
- CALL DV2AXY(N, V(STEP1), NEGONE, V(X01), X)
- V(RELDX) = DRLDST(N, D, X, V(X01))
- IV(RESTOR) = RSTRST
-C
- 300 K = IV(IRC)
- GO TO (310,340,340,340,310,320,330,330,330,330,330,330,400,370), K
-C
-C *** RECOMPUTE STEP WITH CHANGED RADIUS ***
-C
- 310 V(RADIUS) = V(RADFAC) * V(DSTNRM)
- GO TO 180
-C
-C *** COMPUTE STEP OF LENGTH V(LMAXS) FOR SINGULAR CONVERGENCE TEST.
-C
- 320 V(RADIUS) = V(LMAXS)
- GO TO 220
-C
-C *** CONVERGENCE OR FALSE CONVERGENCE ***
-C
- 330 IV(CNVCOD) = K - 4
- IF (V(F) .GE. V(F0)) GO TO 420
- IF (IV(XIRC) .EQ. 14) GO TO 420
- IV(XIRC) = 14
-C
-C. . . . . . . . . . . . PROCESS ACCEPTABLE STEP . . . . . . . . . . .
-C
- 340 X01 = IV(X0)
- STEP1 = IV(STEP)
- CALL DV2AXY(N, V(STEP1), NEGONE, V(X01), X)
- IF (IV(IRC) .NE. 3) GO TO 360
-C
-C *** SET TEMP1 = HESSIAN * STEP FOR _USE_ IN GRADIENT TESTS ***
-C
-C *** _USE_ X0 AS TEMPORARY...
-C
- IPI = IV(PERM)
- CALL DV7CPY(N, V(X01), V(STEP1))
- CALL DV7IPR(N, IV(IPI), V(X01))
- L = IV(LMAT)
- CALL DL7TVM(N, V(X01), V(L), V(X01))
- CALL DL7VML(N, V(X01), V(L), V(X01))
-C
-C *** UNPERMUTE X0 INTO TEMP1 ***
-C
- TEMP1 = IV(STLSTG)
- TEMP0 = TEMP1 - 1
- DO 350 I = 1, N
- J = IV(IPI)
- IPI = IPI + 1
- K = TEMP0 + J
- V(K) = V(X01)
- X01 = X01 + 1
- 350 CONTINUE
-C
-C *** SAVE OLD GRADIENT, COMPUTE NEW ONE ***
-C
- 360 G01 = IV(NWTSTP) + N
- CALL DV7CPY(N, V(G01), G)
- IV(NGCALL) = IV(NGCALL) + 1
- IV(TOOBIG) = 0
- IV(1) = 2
- GO TO 999
-C
-C *** INITIALIZATIONS -- G0 = G - G0, ETC. ***
-C
- 370 G01 = IV(NWTSTP) + N
- CALL DV2AXY(N, V(G01), NEGONE, V(G01), G)
- STEP1 = IV(STEP)
- TEMP1 = IV(STLSTG)
- IF (IV(IRC) .NE. 3) GO TO 390
-C
-C *** SET V(RADFAC) BY GRADIENT TESTS ***
-C
-C *** SET TEMP1 = DIAG(D)**-1 * (HESSIAN*STEP + (G(X0)-G(X))) ***
-C
- CALL DV2AXY(N, V(TEMP1), NEGONE, V(G01), V(TEMP1))
- CALL DV7VMP(N, V(TEMP1), V(TEMP1), D, -1)
-C
-C *** DO GRADIENT TESTS ***
-C
- IF (DV2NRM(N, V(TEMP1)) .LE. V(DGNORM) * V(TUNER4))
- 1 GO TO 380
- IF (DD7TPR(N, G, V(STEP1))
- 1 .GE. V(GTSTEP) * V(TUNER5)) GO TO 390
- 380 V(RADFAC) = V(INCFAC)
-C
-C *** UPDATE H, LOOP ***
-C
- 390 W1 = IV(NWTSTP)
- Z = IV(X0)
- L = IV(LMAT)
- IPI = IV(PERM)
- CALL DV7IPR(N, IV(IPI), V(STEP1))
- CALL DV7IPR(N, IV(IPI), V(G01))
- CALL DW7ZBF(V(L), N, V(STEP1), V(W1), V(G01), V(Z))
-C
-C ** _USE_ THE N-VECTORS STARTING AT V(STEP1) AND V(G01) FOR SCRATCH..
- CALL DL7UPD(V(TEMP1), V(STEP1), V(L), V(G01), V(L), N, V(W1),
- 1 V(Z))
- IV(1) = 2
- GO TO 140
-C
-C. . . . . . . . . . . . . . MISC. DETAILS . . . . . . . . . . . . . .
-C
-C *** BAD PARAMETERS TO ASSESS ***
-C
- 400 IV(1) = 64
- GO TO 430
-C
-C *** INCONSISTENT B ***
-C
- 410 IV(1) = 82
- GO TO 430
-C
-C *** PRINT SUMMARY OF FINAL ITERATION AND OTHER REQUESTED ITEMS ***
-C
- 420 IV(1) = IV(CNVCOD)
- IV(CNVCOD) = 0
- 430 CALL DITSUM(D, G, IV, LIV, LV, N, V, X)
- GO TO 999
-C
-C *** PROJECT X INTO FEASIBLE REGION (PRIOR TO COMPUTING F OR G) ***
-C
- 440 DO 450 I = 1, N
- IF (X(I) .LT. B(1,I)) X(I) = B(1,I)
- IF (X(I) .GT. B(2,I)) X(I) = B(2,I)
- 450 CONTINUE
-C
- 999 RETURN
-C
-C *** LAST CARD OF DRMNGB FOLLOWS ***
- END
diff --git a/CEP/PyBDSM/src/port3/drmnh.f b/CEP/PyBDSM/src/port3/drmnh.f
deleted file mode 100644
index efa869c57da8344d1d4420b01b515935118f29b8..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/drmnh.f
+++ /dev/null
@@ -1,460 +0,0 @@
- SUBROUTINE DRMNH(D, FX, G, H, IV, LH, LIV, LV, N, V, X)
-C
-C *** CARRY OUT DMNH (UNCONSTRAINED MINIMIZATION) ITERATIONS, USING
-C *** HESSIAN MATRIX PROVIDED BY THE CALLER.
-C
-C *** PARAMETER DECLARATIONS ***
-C
- INTEGER LH, LIV, LV, N
- INTEGER IV(LIV)
- DOUBLE PRECISION D(N), FX, G(N), H(LH), V(LV), X(N)
-C
-C-------------------------- PARAMETER USAGE --------------------------
-C
-C D.... SCALE VECTOR.
-C FX... FUNCTION VALUE.
-C G.... GRADIENT VECTOR.
-C H.... LOWER TRIANGLE OF THE HESSIAN, STORED ROWWISE.
-C IV... INTEGER VALUE ARRAY.
-C LH... LENGTH OF H = P*(P+1)/2.
-C LIV.. LENGTH OF IV (AT LEAST 60).
-C LV... LENGTH OF V (AT LEAST 78 + N*(N+21)/2).
-C N.... NUMBER OF VARIABLES (COMPONENTS IN X AND G).
-C V.... FLOATING-POINT VALUE ARRAY.
-C X.... PARAMETER VECTOR.
-C
-C *** DISCUSSION ***
-C
-C PARAMETERS IV, N, V, AND X ARE THE SAME AS THE CORRESPONDING
-C ONES TO DMNH (WHICH SEE), EXCEPT THAT V CAN BE SHORTER (SINCE
-C THE PART OF V THAT DMNH USES FOR STORING G AND H IS NOT NEEDED).
-C MOREOVER, COMPARED WITH DMNH, IV(1) MAY HAVE THE TWO ADDITIONAL
-C OUTPUT VALUES 1 AND 2, WHICH ARE EXPLAINED BELOW, AS IS THE USE
-C OF IV(TOOBIG) AND IV(NFGCAL). THE VALUE IV(G), WHICH IS AN
-C OUTPUT VALUE FROM DMNH, IS NOT REFERENCED BY DRMNH OR THE
-C SUBROUTINES IT CALLS.
-C
-C IV(1) = 1 MEANS THE CALLER SHOULD SET FX TO F(X), THE FUNCTION VALUE
-C AT X, AND CALL DRMNH AGAIN, HAVING CHANGED NONE OF THE
-C OTHER PARAMETERS. AN EXCEPTION OCCURS IF F(X) CANNOT BE
-C COMPUTED (E.G. IF OVERFLOW WOULD OCCUR), WHICH MAY HAPPEN
-C BECAUSE OF AN OVERSIZED STEP. IN THIS CASE THE CALLER
-C SHOULD SET IV(TOOBIG) = IV(2) TO 1, WHICH WILL CAUSE
-C DRMNH TO IGNORE FX AND TRY A SMALLER STEP. THE PARA-
-C METER NF THAT DMNH PASSES TO CALCF (FOR POSSIBLE _USE_ BY
-C CALCGH) IS A COPY OF IV(NFCALL) = IV(6).
-C IV(1) = 2 MEANS THE CALLER SHOULD SET G TO G(X), THE GRADIENT OF F AT
-C X, AND H TO THE LOWER TRIANGLE OF H(X), THE HESSIAN OF F
-C AT X, AND CALL DRMNH AGAIN, HAVING CHANGED NONE OF THE
-C OTHER PARAMETERS EXCEPT PERHAPS THE SCALE VECTOR D.
-C THE PARAMETER NF THAT DMNH PASSES TO CALCG IS
-C IV(NFGCAL) = IV(7). IF G(X) AND H(X) CANNOT BE EVALUATED,
-C THEN THE CALLER MAY SET IV(TOOBIG) TO 0, IN WHICH CASE
-C DRMNH WILL RETURN WITH IV(1) = 65.
-C NOTE -- DRMNH OVERWRITES H WITH THE LOWER TRIANGLE
-C OF DIAG(D)**-1 * H(X) * DIAG(D)**-1.
-C.
-C *** GENERAL ***
-C
-C CODED BY DAVID M. GAY (WINTER 1980). REVISED SEPT. 1982.
-C THIS SUBROUTINE WAS WRITTEN IN CONNECTION WITH RESEARCH SUPPORTED
-C IN PART BY THE NATIONAL SCIENCE FOUNDATION UNDER GRANTS
-C MCS-7600324 AND MCS-7906671.
-C
-C (SEE DMNG AND DMNH FOR REFERENCES.)
-C
-C+++++++++++++++++++++++++++ DECLARATIONS ++++++++++++++++++++++++++++
-C
-C *** LOCAL VARIABLES ***
-C
- INTEGER DG1, DUMMY, I, J, K, L, LSTGST, NN1O2, RSTRST, STEP1,
- 1 TEMP1, W1, X01
- DOUBLE PRECISION T
-C
-C *** CONSTANTS ***
-C
- DOUBLE PRECISION ONE, ONEP2, ZERO
-C
-C *** NO INTRINSIC FUNCTIONS ***
-C
-C *** EXTERNAL FUNCTIONS AND SUBROUTINES ***
-C
- LOGICAL STOPX
- DOUBLE PRECISION DD7TPR, DRLDST, DV2NRM
- EXTERNAL DA7SST,DIVSET, DD7TPR,DD7DUP,DG7QTS,DITSUM,DPARCK,
- 1 DRLDST, DS7LVM, STOPX,DV2AXY,DV7CPY, DV7SCP, DV2NRM
-C
-C DA7SST.... ASSESSES CANDIDATE STEP.
-C DIVSET.... PROVIDES DEFAULT IV AND V INPUT VALUES.
-C DD7TPR... RETURNS INNER PRODUCT OF TWO VECTORS.
-C DD7DUP.... UPDATES SCALE VECTOR D.
-C DG7QTS.... COMPUTES OPTIMALLY LOCALLY CONSTRAINED STEP.
-C DITSUM.... PRINTS ITERATION SUMMARY AND INFO ON INITIAL AND FINAL X.
-C DPARCK.... CHECKS VALIDITY OF INPUT IV AND V VALUES.
-C DRLDST... COMPUTES V(RELDX) = RELATIVE STEP SIZE.
-C DS7LVM... MULTIPLIES SYMMETRIC MATRIX TIMES VECTOR, GIVEN THE LOWER
-C TRIANGLE OF THE MATRIX.
-C STOPX.... RETURNS .TRUE. IF THE BREAK KEY HAS BEEN PRESSED.
-C DV2AXY.... COMPUTES SCALAR TIMES ONE VECTOR PLUS ANOTHER.
-C DV7CPY.... COPIES ONE VECTOR TO ANOTHER.
-C DV7SCP... SETS ALL ELEMENTS OF A VECTOR TO A SCALAR.
-C DV2NRM... RETURNS THE 2-NORM OF A VECTOR.
-C
-C *** SUBSCRIPTS FOR IV AND V ***
-C
- INTEGER CNVCOD, DG, DGNORM, DINIT, DSTNRM, DTINIT, DTOL,
- 1 DTYPE, D0INIT, F, F0, FDIF, GTSTEP, INCFAC, IRC, KAGQT,
- 2 LMAT, LMAX0, LMAXS, MODE, MODEL, MXFCAL, MXITER, NEXTV,
- 3 NFCALL, NFGCAL, NGCALL, NITER, PHMXFC, PREDUC, RADFAC,
- 4 RADINC, RADIUS, RAD0, RELDX, RESTOR, STEP, STGLIM, STLSTG,
- 5 STPPAR, TOOBIG, TUNER4, TUNER5, VNEED, W, XIRC, X0
-C
-C *** IV SUBSCRIPT VALUES ***
-C
-C/6
-C DATA CNVCOD/55/, DG/37/, DTOL/59/, DTYPE/16/, IRC/29/, KAGQT/33/,
-C 1 LMAT/42/, MODE/35/, MODEL/5/, MXFCAL/17/, MXITER/18/,
-C 2 NEXTV/47/, NFCALL/6/, NFGCAL/7/, NGCALL/30/, NITER/31/,
-C 3 RADINC/8/, RESTOR/9/, STEP/40/, STGLIM/11/, STLSTG/41/,
-C 4 TOOBIG/2/, VNEED/4/, W/34/, XIRC/13/, X0/43/
-C/7
- PARAMETER (CNVCOD=55, DG=37, DTOL=59, DTYPE=16, IRC=29, KAGQT=33,
- 1 LMAT=42, MODE=35, MODEL=5, MXFCAL=17, MXITER=18,
- 2 NEXTV=47, NFCALL=6, NFGCAL=7, NGCALL=30, NITER=31,
- 3 RADINC=8, RESTOR=9, STEP=40, STGLIM=11, STLSTG=41,
- 4 TOOBIG=2, VNEED=4, W=34, XIRC=13, X0=43)
-C/
-C
-C *** V SUBSCRIPT VALUES ***
-C
-C/6
-C DATA DGNORM/1/, DINIT/38/, DSTNRM/2/, DTINIT/39/, D0INIT/40/,
-C 1 F/10/, F0/13/, FDIF/11/, GTSTEP/4/, INCFAC/23/, LMAX0/35/,
-C 2 LMAXS/36/, PHMXFC/21/, PREDUC/7/, RADFAC/16/, RADIUS/8/,
-C 3 RAD0/9/, RELDX/17/, STPPAR/5/, TUNER4/29/, TUNER5/30/
-C/7
- PARAMETER (DGNORM=1, DINIT=38, DSTNRM=2, DTINIT=39, D0INIT=40,
- 1 F=10, F0=13, FDIF=11, GTSTEP=4, INCFAC=23, LMAX0=35,
- 2 LMAXS=36, PHMXFC=21, PREDUC=7, RADFAC=16, RADIUS=8,
- 3 RAD0=9, RELDX=17, STPPAR=5, TUNER4=29, TUNER5=30)
-C/
-C
-C/6
-C DATA ONE/1.D+0/, ONEP2/1.2D+0/, ZERO/0.D+0/
-C/7
- PARAMETER (ONE=1.D+0, ONEP2=1.2D+0, ZERO=0.D+0)
-C/
-C
-C+++++++++++++++++++++++++++++++ BODY ++++++++++++++++++++++++++++++++
-C
- I = IV(1)
- IF (I .EQ. 1) GO TO 30
- IF (I .EQ. 2) GO TO 40
-C
-C *** CHECK VALIDITY OF IV AND V INPUT VALUES ***
-C
- IF (IV(1) .EQ. 0) CALL DIVSET(2, IV, LIV, LV, V)
- IF (IV(1) .EQ. 12 .OR. IV(1) .EQ. 13)
- 1 IV(VNEED) = IV(VNEED) + N*(N+21)/2 + 7
- CALL DPARCK(2, D, IV, LIV, LV, N, V)
- I = IV(1) - 2
- IF (I .GT. 12) GO TO 999
- NN1O2 = N * (N + 1) / 2
- IF (LH .GE. NN1O2) GO TO (220,220,220,220,220,220,160,120,160,
- 1 10,10,20), I
- IV(1) = 66
- GO TO 400
-C
-C *** STORAGE ALLOCATION ***
-C
- 10 IV(DTOL) = IV(LMAT) + NN1O2
- IV(X0) = IV(DTOL) + 2*N
- IV(STEP) = IV(X0) + N
- IV(STLSTG) = IV(STEP) + N
- IV(DG) = IV(STLSTG) + N
- IV(W) = IV(DG) + N
- IV(NEXTV) = IV(W) + 4*N + 7
- IF (IV(1) .NE. 13) GO TO 20
- IV(1) = 14
- GO TO 999
-C
-C *** INITIALIZATION ***
-C
- 20 IV(NITER) = 0
- IV(NFCALL) = 1
- IV(NGCALL) = 1
- IV(NFGCAL) = 1
- IV(MODE) = -1
- IV(MODEL) = 1
- IV(STGLIM) = 1
- IV(TOOBIG) = 0
- IV(CNVCOD) = 0
- IV(RADINC) = 0
- V(RAD0) = ZERO
- V(STPPAR) = ZERO
- IF (V(DINIT) .GE. ZERO) CALL DV7SCP(N, D, V(DINIT))
- K = IV(DTOL)
- IF (V(DTINIT) .GT. ZERO) CALL DV7SCP(N, V(K), V(DTINIT))
- K = K + N
- IF (V(D0INIT) .GT. ZERO) CALL DV7SCP(N, V(K), V(D0INIT))
- IV(1) = 1
- GO TO 999
-C
- 30 V(F) = FX
- IF (IV(MODE) .GE. 0) GO TO 220
- V(F0) = FX
- IV(1) = 2
- IF (IV(TOOBIG) .EQ. 0) GO TO 999
- IV(1) = 63
- GO TO 400
-C
-C *** MAKE SURE GRADIENT COULD BE COMPUTED ***
-C
- 40 IF (IV(TOOBIG) .EQ. 0) GO TO 50
- IV(1) = 65
- GO TO 400
-C
-C *** UPDATE THE SCALE VECTOR D ***
-C
- 50 DG1 = IV(DG)
- IF (IV(DTYPE) .LE. 0) GO TO 70
- K = DG1
- J = 0
- DO 60 I = 1, N
- J = J + I
- V(K) = H(J)
- K = K + 1
- 60 CONTINUE
- CALL DD7DUP(D, V(DG1), IV, LIV, LV, N, V)
-C
-C *** COMPUTE SCALED GRADIENT AND ITS NORM ***
-C
- 70 DG1 = IV(DG)
- K = DG1
- DO 80 I = 1, N
- V(K) = G(I) / D(I)
- K = K + 1
- 80 CONTINUE
- V(DGNORM) = DV2NRM(N, V(DG1))
-C
-C *** COMPUTE SCALED HESSIAN ***
-C
- K = 1
- DO 100 I = 1, N
- T = ONE / D(I)
- DO 90 J = 1, I
- H(K) = T * H(K) / D(J)
- K = K + 1
- 90 CONTINUE
- 100 CONTINUE
-C
- IF (IV(CNVCOD) .NE. 0) GO TO 390
- IF (IV(MODE) .EQ. 0) GO TO 350
-C
-C *** ALLOW FIRST STEP TO HAVE SCALED 2-NORM AT MOST V(LMAX0) ***
-C
- V(RADIUS) = V(LMAX0) / (ONE + V(PHMXFC))
-C
- IV(MODE) = 0
-C
-C
-C----------------------------- MAIN LOOP -----------------------------
-C
-C
-C *** PRINT ITERATION SUMMARY, CHECK ITERATION LIMIT ***
-C
- 110 CALL DITSUM(D, G, IV, LIV, LV, N, V, X)
- 120 K = IV(NITER)
- IF (K .LT. IV(MXITER)) GO TO 130
- IV(1) = 10
- GO TO 400
-C
- 130 IV(NITER) = K + 1
-C
-C *** INITIALIZE FOR START OF NEXT ITERATION ***
-C
- DG1 = IV(DG)
- X01 = IV(X0)
- V(F0) = V(F)
- IV(IRC) = 4
- IV(KAGQT) = -1
-C
-C *** COPY X TO X0 ***
-C
- CALL DV7CPY(N, V(X01), X)
-C
-C *** UPDATE RADIUS ***
-C
- IF (K .EQ. 0) GO TO 150
- STEP1 = IV(STEP)
- K = STEP1
- DO 140 I = 1, N
- V(K) = D(I) * V(K)
- K = K + 1
- 140 CONTINUE
- V(RADIUS) = V(RADFAC) * DV2NRM(N, V(STEP1))
-C
-C *** CHECK STOPX AND FUNCTION EVALUATION LIMIT ***
-C
- 150 IF (.NOT. STOPX(DUMMY)) GO TO 170
- IV(1) = 11
- GO TO 180
-C
-C *** COME HERE WHEN RESTARTING AFTER FUNC. EVAL. LIMIT OR STOPX.
-C
- 160 IF (V(F) .GE. V(F0)) GO TO 170
- V(RADFAC) = ONE
- K = IV(NITER)
- GO TO 130
-C
- 170 IF (IV(NFCALL) .LT. IV(MXFCAL)) GO TO 190
- IV(1) = 9
- 180 IF (V(F) .GE. V(F0)) GO TO 400
-C
-C *** IN CASE OF STOPX OR FUNCTION EVALUATION LIMIT WITH
-C *** IMPROVED V(F), EVALUATE THE GRADIENT AT X.
-C
- IV(CNVCOD) = IV(1)
- GO TO 340
-C
-C. . . . . . . . . . . . . COMPUTE CANDIDATE STEP . . . . . . . . . .
-C
- 190 STEP1 = IV(STEP)
- DG1 = IV(DG)
- L = IV(LMAT)
- W1 = IV(W)
- CALL DG7QTS(D, V(DG1), H, IV(KAGQT), V(L), N, V(STEP1), V, V(W1))
- IF (IV(IRC) .NE. 6) GO TO 200
- IF (IV(RESTOR) .NE. 2) GO TO 220
- RSTRST = 2
- GO TO 230
-C
-C *** CHECK WHETHER EVALUATING F(X0 + STEP) LOOKS WORTHWHILE ***
-C
- 200 IV(TOOBIG) = 0
- IF (V(DSTNRM) .LE. ZERO) GO TO 220
- IF (IV(IRC) .NE. 5) GO TO 210
- IF (V(RADFAC) .LE. ONE) GO TO 210
- IF (V(PREDUC) .GT. ONEP2 * V(FDIF)) GO TO 210
- IF (IV(RESTOR) .NE. 2) GO TO 220
- RSTRST = 0
- GO TO 230
-C
-C *** COMPUTE F(X0 + STEP) ***
-C
- 210 X01 = IV(X0)
- STEP1 = IV(STEP)
- CALL DV2AXY(N, X, ONE, V(STEP1), V(X01))
- IV(NFCALL) = IV(NFCALL) + 1
- IV(1) = 1
- GO TO 999
-C
-C. . . . . . . . . . . . . ASSESS CANDIDATE STEP . . . . . . . . . . .
-C
- 220 RSTRST = 3
- 230 X01 = IV(X0)
- V(RELDX) = DRLDST(N, D, X, V(X01))
- CALL DA7SST(IV, LIV, LV, V)
- STEP1 = IV(STEP)
- LSTGST = IV(STLSTG)
- I = IV(RESTOR) + 1
- GO TO (270, 240, 250, 260), I
- 240 CALL DV7CPY(N, X, V(X01))
- GO TO 270
- 250 CALL DV7CPY(N, V(LSTGST), V(STEP1))
- GO TO 270
- 260 CALL DV7CPY(N, V(STEP1), V(LSTGST))
- CALL DV2AXY(N, X, ONE, V(STEP1), V(X01))
- V(RELDX) = DRLDST(N, D, X, V(X01))
- IV(RESTOR) = RSTRST
-C
- 270 K = IV(IRC)
- GO TO (280,310,310,310,280,290,300,300,300,300,300,300,380,350), K
-C
-C *** RECOMPUTE STEP WITH NEW RADIUS ***
-C
- 280 V(RADIUS) = V(RADFAC) * V(DSTNRM)
- GO TO 150
-C
-C *** COMPUTE STEP OF LENGTH V(LMAXS) FOR SINGULAR CONVERGENCE TEST.
-C
- 290 V(RADIUS) = V(LMAXS)
- GO TO 190
-C
-C *** CONVERGENCE OR FALSE CONVERGENCE ***
-C
- 300 IV(CNVCOD) = K - 4
- IF (V(F) .GE. V(F0)) GO TO 390
- IF (IV(XIRC) .EQ. 14) GO TO 390
- IV(XIRC) = 14
-C
-C. . . . . . . . . . . . PROCESS ACCEPTABLE STEP . . . . . . . . . . .
-C
- 310 IF (IV(IRC) .NE. 3) GO TO 340
- TEMP1 = LSTGST
-C
-C *** PREPARE FOR GRADIENT TESTS ***
-C *** SET TEMP1 = HESSIAN * STEP + G(X0)
-C *** = DIAG(D) * (H * STEP + G(X0))
-C
-C _USE_ X0 VECTOR AS TEMPORARY.
- K = X01
- DO 320 I = 1, N
- V(K) = D(I) * V(STEP1)
- K = K + 1
- STEP1 = STEP1 + 1
- 320 CONTINUE
- CALL DS7LVM(N, V(TEMP1), H, V(X01))
- DO 330 I = 1, N
- V(TEMP1) = D(I) * V(TEMP1) + G(I)
- TEMP1 = TEMP1 + 1
- 330 CONTINUE
-C
-C *** COMPUTE GRADIENT AND HESSIAN ***
-C
- 340 IV(NGCALL) = IV(NGCALL) + 1
- IV(TOOBIG) = 0
- IV(1) = 2
- GO TO 999
-C
- 350 IV(1) = 2
- IF (IV(IRC) .NE. 3) GO TO 110
-C
-C *** SET V(RADFAC) BY GRADIENT TESTS ***
-C
- TEMP1 = IV(STLSTG)
- STEP1 = IV(STEP)
-C
-C *** SET TEMP1 = DIAG(D)**-1 * (HESSIAN*STEP + (G(X0)-G(X))) ***
-C
- K = TEMP1
- DO 360 I = 1, N
- V(K) = (V(K) - G(I)) / D(I)
- K = K + 1
- 360 CONTINUE
-C
-C *** DO GRADIENT TESTS ***
-C
- IF (DV2NRM(N, V(TEMP1)) .LE. V(DGNORM) * V(TUNER4)) GO TO 370
- IF (DD7TPR(N, G, V(STEP1))
- 1 .GE. V(GTSTEP) * V(TUNER5)) GO TO 110
- 370 V(RADFAC) = V(INCFAC)
- GO TO 110
-C
-C. . . . . . . . . . . . . . MISC. DETAILS . . . . . . . . . . . . . .
-C
-C *** BAD PARAMETERS TO ASSESS ***
-C
- 380 IV(1) = 64
- GO TO 400
-C
-C *** PRINT SUMMARY OF FINAL ITERATION AND OTHER REQUESTED ITEMS ***
-C
- 390 IV(1) = IV(CNVCOD)
- IV(CNVCOD) = 0
- 400 CALL DITSUM(D, G, IV, LIV, LV, N, V, X)
-C
- 999 RETURN
-C
-C *** LAST CARD OF DRMNH FOLLOWS ***
- END
diff --git a/CEP/PyBDSM/src/port3/drmnhb.f b/CEP/PyBDSM/src/port3/drmnhb.f
deleted file mode 100644
index e1ac5363d82792b6661ad6d3e2facf30081bf58d..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/drmnhb.f
+++ /dev/null
@@ -1,539 +0,0 @@
- SUBROUTINE DRMNHB(B, D, FX, G, H, IV, LH, LIV, LV, N, V, X)
-C
-C *** CARRY OUT DMNHB (SIMPLY BOUNDED MINIMIZATION) ITERATIONS,
-C *** USING HESSIAN MATRIX PROVIDED BY THE CALLER.
-C
-C *** PARAMETER DECLARATIONS ***
-C
- INTEGER LH, LIV, LV, N
- INTEGER IV(LIV)
- DOUBLE PRECISION B(2,N), D(N), FX, G(N), H(LH), V(LV), X(N)
-C
-C-------------------------- PARAMETER USAGE --------------------------
-C
-C D.... SCALE VECTOR.
-C FX... FUNCTION VALUE.
-C G.... GRADIENT VECTOR.
-C H.... LOWER TRIANGLE OF THE HESSIAN, STORED ROWWISE.
-C IV... INTEGER VALUE ARRAY.
-C LH... LENGTH OF H = P*(P+1)/2.
-C LIV.. LENGTH OF IV (AT LEAST 59 + 3*N).
-C LV... LENGTH OF V (AT LEAST 78 + N*(N+27)/2).
-C N.... NUMBER OF VARIABLES (COMPONENTS IN X AND G).
-C V.... FLOATING-POINT VALUE ARRAY.
-C X.... PARAMETER VECTOR.
-C
-C *** DISCUSSION ***
-C
-C PARAMETERS IV, N, V, AND X ARE THE SAME AS THE CORRESPONDING
-C ONES TO DMNHB (WHICH SEE), EXCEPT THAT V CAN BE SHORTER (SINCE
-C THE PART OF V THAT DMNHB USES FOR STORING G AND H IS NOT NEEDED).
-C MOREOVER, COMPARED WITH DMNHB, IV(1) MAY HAVE THE TWO ADDITIONAL
-C OUTPUT VALUES 1 AND 2, WHICH ARE EXPLAINED BELOW, AS IS THE USE
-C OF IV(TOOBIG) AND IV(NFGCAL). THE VALUE IV(G), WHICH IS AN
-C OUTPUT VALUE FROM DMNHB, IS NOT REFERENCED BY DRMNHB OR THE
-C SUBROUTINES IT CALLS.
-C
-C IV(1) = 1 MEANS THE CALLER SHOULD SET FX TO F(X), THE FUNCTION VALUE
-C AT X, AND CALL DRMNHB AGAIN, HAVING CHANGED NONE OF THE
-C OTHER PARAMETERS. AN EXCEPTION OCCURS IF F(X) CANNOT BE
-C COMPUTED (E.G. IF OVERFLOW WOULD OCCUR), WHICH MAY HAPPEN
-C BECAUSE OF AN OVERSIZED STEP. IN THIS CASE THE CALLER
-C SHOULD SET IV(TOOBIG) = IV(2) TO 1, WHICH WILL CAUSE
-C DRMNHB TO IGNORE FX AND TRY A SMALLER STEP. THE PARA-
-C METER NF THAT DMNH PASSES TO CALCF (FOR POSSIBLE _USE_ BY
-C CALCGH) IS A COPY OF IV(NFCALL) = IV(6).
-C IV(1) = 2 MEANS THE CALLER SHOULD SET G TO G(X), THE GRADIENT OF F AT
-C X, AND H TO THE LOWER TRIANGLE OF H(X), THE HESSIAN OF F
-C AT X, AND CALL DRMNHB AGAIN, HAVING CHANGED NONE OF THE
-C OTHER PARAMETERS EXCEPT PERHAPS THE SCALE VECTOR D.
-C THE PARAMETER NF THAT DMNHB PASSES TO CALCG IS
-C IV(NFGCAL) = IV(7). IF G(X) AND H(X) CANNOT BE EVALUATED,
-C THEN THE CALLER MAY SET IV(NFGCAL) TO 0, IN WHICH CASE
-C DRMNHB WILL RETURN WITH IV(1) = 65.
-C NOTE -- DRMNHB OVERWRITES H WITH THE LOWER TRIANGLE
-C OF DIAG(D)**-1 * H(X) * DIAG(D)**-1.
-C.
-C *** GENERAL ***
-C
-C CODED BY DAVID M. GAY (WINTER, SPRING 1983).
-C
-C (SEE DMNG AND DMNH FOR REFERENCES.)
-C
-C+++++++++++++++++++++++++++ DECLARATIONS ++++++++++++++++++++++++++++
-C
-C *** LOCAL VARIABLES ***
-C
- INTEGER DG1, DUMMY, I, IPI, IPIV2, IPN, J, K, L, LSTGST, NN1O2,
- 1 RSTRST, STEP0, STEP1, TD1, TEMP0, TEMP1, TG1, W1, X01, X11
- DOUBLE PRECISION GI, T, XI
-C
-C *** CONSTANTS ***
-C
- DOUBLE PRECISION NEGONE, ONE, ONEP2, ZERO
-C
-C *** NO INTRINSIC FUNCTIONS ***
-C
-C *** EXTERNAL FUNCTIONS AND SUBROUTINES ***
-C
- LOGICAL STOPX
- DOUBLE PRECISION DD7TPR, DRLDST, DV2NRM
- EXTERNAL DA7SST,DIVSET, DD7TPR,DD7DUP, DG7QSB, I7PNVR,DITSUM,
- 1 DPARCK, DRLDST, DS7IPR, DS7LVM, STOPX, DV2NRM,DV2AXY,
- 2 DV7CPY, DV7IPR, DV7SCP, DV7VMP
-C
-C DA7SST.... ASSESSES CANDIDATE STEP.
-C DIVSET.... PROVIDES DEFAULT IV AND V INPUT VALUES.
-C DD7TPR... RETURNS INNER PRODUCT OF TWO VECTORS.
-C DD7DUP.... UPDATES SCALE VECTOR D.
-C DG7QSB... COMPUTES APPROXIMATE OPTIMAL BOUNDED STEP.
-C I7PNVR... INVERTS PERMUTATION ARRAY.
-C DITSUM.... PRINTS ITERATION SUMMARY AND INFO ON INITIAL AND FINAL X.
-C DPARCK.... CHECKS VALIDITY OF INPUT IV AND V VALUES.
-C DRLDST... COMPUTES V(RELDX) = RELATIVE STEP SIZE.
-C DS7IPR... APPLIES PERMUTATION TO LOWER TRIANG. OF SYM. MATRIX.
-C DS7LVM... MULTIPLIES SYMMETRIC MATRIX TIMES VECTOR, GIVEN THE LOWER
-C TRIANGLE OF THE MATRIX.
-C STOPX.... RETURNS .TRUE. IF THE BREAK KEY HAS BEEN PRESSED.
-C DV2NRM... RETURNS THE 2-NORM OF A VECTOR.
-C DV2AXY.... COMPUTES SCALAR TIMES ONE VECTOR PLUS ANOTHER.
-C DV7CPY.... COPIES ONE VECTOR TO ANOTHER.
-C DV7IPR... APPLIES PERMUTATION TO VECTOR.
-C DV7SCP... SETS ALL ELEMENTS OF A VECTOR TO A SCALAR.
-C DV7VMP... MULTIPLIES (OR DIVIDES) TWO VECTORS COMPONENTWISE.
-C
-C *** SUBSCRIPTS FOR IV AND V ***
-C
- INTEGER CNVCOD, DG, DGNORM, DINIT, DSTNRM, DTINIT, DTOL, DTYPE,
- 1 D0INIT, F, F0, FDIF, GTSTEP, INCFAC, IVNEED, IRC, KAGQT,
- 2 LMAT, LMAX0, LMAXS, MODE, MODEL, MXFCAL, MXITER, N0, NC,
- 3 NEXTIV, NEXTV, NFCALL, NFGCAL, NGCALL, NITER, PERM,
- 4 PHMXFC, PREDUC, RADFAC, RADINC, RADIUS, RAD0, RELDX,
- 5 RESTOR, STEP, STGLIM, STPPAR, TOOBIG, TUNER4, TUNER5,
- 6 VNEED, W, XIRC, X0
-C
-C *** IV SUBSCRIPT VALUES ***
-C
-C *** (NOTE THAT NC AND N0 ARE STORED IN IV(G0) AND IV(STLSTG) RESP.)
-C
-C/6
-C DATA CNVCOD/55/, DG/37/, DTOL/59/, DTYPE/16/, IRC/29/, IVNEED/3/,
-C 1 KAGQT/33/, LMAT/42/, MODE/35/, MODEL/5/, MXFCAL/17/,
-C 2 MXITER/18/, N0/41/, NC/48/, NEXTIV/46/, NEXTV/47/, NFCALL/6/,
-C 3 NFGCAL/7/, NGCALL/30/, NITER/31/, PERM/58/, RADINC/8/,
-C 4 RESTOR/9/, STEP/40/, STGLIM/11/, TOOBIG/2/, VNEED/4/, W/34/,
-C 5 XIRC/13/, X0/43/
-C/7
- PARAMETER (CNVCOD=55, DG=37, DTOL=59, DTYPE=16, IRC=29, IVNEED=3,
- 1 KAGQT=33, LMAT=42, MODE=35, MODEL=5, MXFCAL=17,
- 2 MXITER=18, N0=41, NC=48, NEXTIV=46, NEXTV=47, NFCALL=6,
- 3 NFGCAL=7, NGCALL=30, NITER=31, PERM=58, RADINC=8,
- 4 RESTOR=9, STEP=40, STGLIM=11, TOOBIG=2, VNEED=4, W=34,
- 5 XIRC=13, X0=43)
-C/
-C
-C *** V SUBSCRIPT VALUES ***
-C
-C/6
-C DATA DGNORM/1/, DINIT/38/, DSTNRM/2/, DTINIT/39/, D0INIT/40/,
-C 1 F/10/, F0/13/, FDIF/11/, GTSTEP/4/, INCFAC/23/, LMAX0/35/,
-C 2 LMAXS/36/, PHMXFC/21/, PREDUC/7/, RADFAC/16/, RADIUS/8/,
-C 3 RAD0/9/, RELDX/17/, STPPAR/5/, TUNER4/29/, TUNER5/30/
-C/7
- PARAMETER (DGNORM=1, DINIT=38, DSTNRM=2, DTINIT=39, D0INIT=40,
- 1 F=10, F0=13, FDIF=11, GTSTEP=4, INCFAC=23, LMAX0=35,
- 2 LMAXS=36, PHMXFC=21, PREDUC=7, RADFAC=16, RADIUS=8,
- 3 RAD0=9, RELDX=17, STPPAR=5, TUNER4=29, TUNER5=30)
-C/
-C
-C/6
-C DATA NEGONE/-1.D+0/, ONE/1.D+0/, ONEP2/1.2D+0/, ZERO/0.D+0/
-C/7
- PARAMETER (NEGONE=-1.D+0, ONE=1.D+0, ONEP2=1.2D+0, ZERO=0.D+0)
-C/
-C
-C+++++++++++++++++++++++++++++++ BODY ++++++++++++++++++++++++++++++++
-C
- I = IV(1)
- IF (I .EQ. 1) GO TO 50
- IF (I .EQ. 2) GO TO 60
-C
-C *** CHECK VALIDITY OF IV AND V INPUT VALUES ***
-C
- IF (IV(1) .EQ. 0) CALL DIVSET(2, IV, LIV, LV, V)
- IF (IV(1) .LT. 12) GO TO 10
- IF (IV(1) .GT. 13) GO TO 10
- IV(VNEED) = IV(VNEED) + N*(N+27)/2 + 7
- IV(IVNEED) = IV(IVNEED) + 3*N
- 10 CALL DPARCK(2, D, IV, LIV, LV, N, V)
- I = IV(1) - 2
- IF (I .GT. 12) GO TO 999
- NN1O2 = N * (N + 1) / 2
- IF (LH .GE. NN1O2) GO TO (250,250,250,250,250,250,190,150,190,
- 1 20,20,30), I
- IV(1) = 81
- GO TO 440
-C
-C *** STORAGE ALLOCATION ***
-C
- 20 IV(DTOL) = IV(LMAT) + NN1O2
- IV(X0) = IV(DTOL) + 2*N
- IV(STEP) = IV(X0) + 2*N
- IV(DG) = IV(STEP) + 3*N
- IV(W) = IV(DG) + 2*N
- IV(NEXTV) = IV(W) + 4*N + 7
- IV(NEXTIV) = IV(PERM) + 3*N
- IF (IV(1) .NE. 13) GO TO 30
- IV(1) = 14
- GO TO 999
-C
-C *** INITIALIZATION ***
-C
- 30 IV(NITER) = 0
- IV(NFCALL) = 1
- IV(NGCALL) = 1
- IV(NFGCAL) = 1
- IV(MODE) = -1
- IV(MODEL) = 1
- IV(STGLIM) = 1
- IV(TOOBIG) = 0
- IV(CNVCOD) = 0
- IV(RADINC) = 0
- IV(NC) = N
- V(RAD0) = ZERO
- V(STPPAR) = ZERO
- IF (V(DINIT) .GE. ZERO) CALL DV7SCP(N, D, V(DINIT))
- K = IV(DTOL)
- IF (V(DTINIT) .GT. ZERO) CALL DV7SCP(N, V(K), V(DTINIT))
- K = K + N
- IF (V(D0INIT) .GT. ZERO) CALL DV7SCP(N, V(K), V(D0INIT))
-C
-C *** CHECK CONSISTENCY OF B AND INITIALIZE IP ARRAY ***
-C
- IPI = IV(PERM)
- DO 40 I = 1, N
- IV(IPI) = I
- IPI = IPI + 1
- IF (B(1,I) .GT. B(2,I)) GO TO 420
- 40 CONTINUE
-C
-C *** GET INITIAL FUNCTION VALUE ***
-C
- IV(1) = 1
- GO TO 450
-C
- 50 V(F) = FX
- IF (IV(MODE) .GE. 0) GO TO 250
- V(F0) = FX
- IV(1) = 2
- IF (IV(TOOBIG) .EQ. 0) GO TO 999
- IV(1) = 63
- GO TO 440
-C
-C *** MAKE SURE GRADIENT COULD BE COMPUTED ***
-C
- 60 IF (IV(TOOBIG) .EQ. 0) GO TO 70
- IV(1) = 65
- GO TO 440
-C
-C *** UPDATE THE SCALE VECTOR D ***
-C
- 70 DG1 = IV(DG)
- IF (IV(DTYPE) .LE. 0) GO TO 90
- K = DG1
- J = 0
- DO 80 I = 1, N
- J = J + I
- V(K) = H(J)
- K = K + 1
- 80 CONTINUE
- CALL DD7DUP(D, V(DG1), IV, LIV, LV, N, V)
-C
-C *** COMPUTE SCALED GRADIENT AND ITS NORM ***
-C
- 90 DG1 = IV(DG)
- CALL DV7VMP(N, V(DG1), G, D, -1)
-C
-C *** COMPUTE SCALED HESSIAN ***
-C
- K = 1
- DO 110 I = 1, N
- T = ONE / D(I)
- DO 100 J = 1, I
- H(K) = T * H(K) / D(J)
- K = K + 1
- 100 CONTINUE
- 110 CONTINUE
-C
-C *** CHOOSE INITIAL PERMUTATION ***
-C
- IPI = IV(PERM)
- IPN = IPI + N
- IPIV2 = IPN - 1
-C *** INVERT OLD PERMUTATION ARRAY ***
- CALL I7PNVR(N, IV(IPN), IV(IPI))
- K = IV(NC)
- DO 130 I = 1, N
- IF (B(1,I) .GE. B(2,I)) GO TO 120
- XI = X(I)
- GI = G(I)
- IF (XI .LE. B(1,I) .AND. GI .GT. ZERO) GO TO 120
- IF (XI .GE. B(2,I) .AND. GI .LT. ZERO) GO TO 120
- IV(IPI) = I
- IPI = IPI + 1
- J = IPIV2 + I
-C *** DISALLOW CONVERGENCE IF X(I) HAS JUST BEEN FREED ***
- IF (IV(J) .GT. K) IV(CNVCOD) = 0
- GO TO 130
- 120 IPN = IPN - 1
- IV(IPN) = I
- 130 CONTINUE
- IV(NC) = IPN - IV(PERM)
-C
-C *** PERMUTE SCALED GRADIENT AND HESSIAN ACCORDINGLY ***
-C
- IPI = IV(PERM)
- CALL DS7IPR(N, IV(IPI), H)
- CALL DV7IPR(N, IV(IPI), V(DG1))
- V(DGNORM) = ZERO
- IF (IV(NC) .GT. 0) V(DGNORM) = DV2NRM(IV(NC), V(DG1))
-C
- IF (IV(CNVCOD) .NE. 0) GO TO 430
- IF (IV(MODE) .EQ. 0) GO TO 380
-C
-C *** ALLOW FIRST STEP TO HAVE SCALED 2-NORM AT MOST V(LMAX0) ***
-C
- V(RADIUS) = V(LMAX0) / (ONE + V(PHMXFC))
-C
- IV(MODE) = 0
-C
-C
-C----------------------------- MAIN LOOP -----------------------------
-C
-C
-C *** PRINT ITERATION SUMMARY, CHECK ITERATION LIMIT ***
-C
- 140 CALL DITSUM(D, G, IV, LIV, LV, N, V, X)
- 150 K = IV(NITER)
- IF (K .LT. IV(MXITER)) GO TO 160
- IV(1) = 10
- GO TO 440
-C
- 160 IV(NITER) = K + 1
-C
-C *** INITIALIZE FOR START OF NEXT ITERATION ***
-C
- X01 = IV(X0)
- V(F0) = V(F)
- IV(IRC) = 4
- IV(KAGQT) = -1
-C
-C *** COPY X TO X0 ***
-C
- CALL DV7CPY(N, V(X01), X)
-C
-C *** UPDATE RADIUS ***
-C
- IF (K .EQ. 0) GO TO 180
- STEP1 = IV(STEP)
- K = STEP1
- DO 170 I = 1, N
- V(K) = D(I) * V(K)
- K = K + 1
- 170 CONTINUE
- T = V(RADFAC) * DV2NRM(N, V(STEP1))
- IF (V(RADFAC) .LT. ONE .OR. T .GT. V(RADIUS)) V(RADIUS) = T
-C
-C *** CHECK STOPX AND FUNCTION EVALUATION LIMIT ***
-C
- 180 IF (.NOT. STOPX(DUMMY)) GO TO 200
- IV(1) = 11
- GO TO 210
-C
-C *** COME HERE WHEN RESTARTING AFTER FUNC. EVAL. LIMIT OR STOPX.
-C
- 190 IF (V(F) .GE. V(F0)) GO TO 200
- V(RADFAC) = ONE
- K = IV(NITER)
- GO TO 160
-C
- 200 IF (IV(NFCALL) .LT. IV(MXFCAL)) GO TO 220
- IV(1) = 9
- 210 IF (V(F) .GE. V(F0)) GO TO 440
-C
-C *** IN CASE OF STOPX OR FUNCTION EVALUATION LIMIT WITH
-C *** IMPROVED V(F), EVALUATE THE GRADIENT AT X.
-C
- IV(CNVCOD) = IV(1)
- GO TO 370
-C
-C. . . . . . . . . . . . . COMPUTE CANDIDATE STEP . . . . . . . . . .
-C
- 220 STEP1 = IV(STEP)
- L = IV(LMAT)
- W1 = IV(W)
- IPI = IV(PERM)
- IPN = IPI + N
- IPIV2 = IPN + N
- TG1 = IV(DG)
- TD1 = TG1 + N
- X01 = IV(X0)
- X11 = X01 + N
- CALL DG7QSB(B, D, H, G, IV(IPI), IV(IPN), IV(IPIV2), IV(KAGQT),
- 1 V(L), LV, N, IV(N0), IV(NC), V(STEP1), V(TD1), V(TG1),
- 2 V, V(W1), V(X11), V(X01))
- IF (IV(IRC) .NE. 6) GO TO 230
- IF (IV(RESTOR) .NE. 2) GO TO 250
- RSTRST = 2
- GO TO 260
-C
-C *** CHECK WHETHER EVALUATING F(X0 + STEP) LOOKS WORTHWHILE ***
-C
- 230 IV(TOOBIG) = 0
- IF (V(DSTNRM) .LE. ZERO) GO TO 250
- IF (IV(IRC) .NE. 5) GO TO 240
- IF (V(RADFAC) .LE. ONE) GO TO 240
- IF (V(PREDUC) .GT. ONEP2 * V(FDIF)) GO TO 240
- IF (IV(RESTOR) .NE. 2) GO TO 250
- RSTRST = 0
- GO TO 260
-C
-C *** COMPUTE F(X0 + STEP) ***
-C
- 240 CALL DV2AXY(N, X, ONE, V(STEP1), V(X01))
- IV(NFCALL) = IV(NFCALL) + 1
- IV(1) = 1
- GO TO 450
-C
-C. . . . . . . . . . . . . ASSESS CANDIDATE STEP . . . . . . . . . . .
-C
- 250 RSTRST = 3
- 260 X01 = IV(X0)
- V(RELDX) = DRLDST(N, D, X, V(X01))
- CALL DA7SST(IV, LIV, LV, V)
- STEP1 = IV(STEP)
- LSTGST = STEP1 + 2*N
- I = IV(RESTOR) + 1
- GO TO (300, 270, 280, 290), I
- 270 CALL DV7CPY(N, X, V(X01))
- GO TO 300
- 280 CALL DV7CPY(N, V(LSTGST), X)
- GO TO 300
- 290 CALL DV7CPY(N, X, V(LSTGST))
- CALL DV2AXY(N, V(STEP1), NEGONE, V(X01), X)
- V(RELDX) = DRLDST(N, D, X, V(X01))
- IV(RESTOR) = RSTRST
-C
- 300 K = IV(IRC)
- GO TO (310,340,340,340,310,320,330,330,330,330,330,330,410,380), K
-C
-C *** RECOMPUTE STEP WITH NEW RADIUS ***
-C
- 310 V(RADIUS) = V(RADFAC) * V(DSTNRM)
- GO TO 180
-C
-C *** COMPUTE STEP OF LENGTH V(LMAXS) FOR SINGULAR CONVERGENCE TEST.
-C
- 320 V(RADIUS) = V(LMAXS)
- GO TO 220
-C
-C *** CONVERGENCE OR FALSE CONVERGENCE ***
-C
- 330 IV(CNVCOD) = K - 4
- IF (V(F) .GE. V(F0)) GO TO 430
- IF (IV(XIRC) .EQ. 14) GO TO 430
- IV(XIRC) = 14
-C
-C. . . . . . . . . . . . PROCESS ACCEPTABLE STEP . . . . . . . . . . .
-C
- 340 IF (IV(IRC) .NE. 3) GO TO 370
- TEMP1 = LSTGST
-C
-C *** PREPARE FOR GRADIENT TESTS ***
-C *** SET TEMP1 = HESSIAN * STEP + G(X0)
-C *** = DIAG(D) * (H * STEP + G(X0))
-C
- K = TEMP1
- STEP0 = STEP1 - 1
- IPI = IV(PERM)
- DO 350 I = 1, N
- J = IV(IPI)
- IPI = IPI + 1
- STEP1 = STEP0 + J
- V(K) = D(J) * V(STEP1)
- K = K + 1
- 350 CONTINUE
-C _USE_ X0 VECTOR AS TEMPORARY.
- CALL DS7LVM(N, V(X01), H, V(TEMP1))
- TEMP0 = TEMP1 - 1
- IPI = IV(PERM)
- DO 360 I = 1, N
- J = IV(IPI)
- IPI = IPI + 1
- TEMP1 = TEMP0 + J
- V(TEMP1) = D(J) * V(X01) + G(J)
- X01 = X01 + 1
- 360 CONTINUE
-C
-C *** COMPUTE GRADIENT AND HESSIAN ***
-C
- 370 IV(NGCALL) = IV(NGCALL) + 1
- IV(TOOBIG) = 0
- IV(1) = 2
- GO TO 450
-C
- 380 IV(1) = 2
- IF (IV(IRC) .NE. 3) GO TO 140
-C
-C *** SET V(RADFAC) BY GRADIENT TESTS ***
-C
- STEP1 = IV(STEP)
-C *** TEMP1 = STLSTG ***
- TEMP1 = STEP1 + 2*N
-C
-C *** SET TEMP1 = DIAG(D)**-1 * (HESSIAN*STEP + (G(X0)-G(X))) ***
-C
- K = TEMP1
- DO 390 I = 1, N
- V(K) = (V(K) - G(I)) / D(I)
- K = K + 1
- 390 CONTINUE
-C
-C *** DO GRADIENT TESTS ***
-C
- IF (DV2NRM(N, V(TEMP1)) .LE. V(DGNORM) * V(TUNER4)) GO TO 400
- IF (DD7TPR(N, G, V(STEP1))
- 1 .GE. V(GTSTEP) * V(TUNER5)) GO TO 140
- 400 V(RADFAC) = V(INCFAC)
- GO TO 140
-C
-C. . . . . . . . . . . . . . MISC. DETAILS . . . . . . . . . . . . . .
-C
-C *** BAD PARAMETERS TO ASSESS ***
-C
- 410 IV(1) = 64
- GO TO 440
-C
-C *** INCONSISTENT B ***
-C
- 420 IV(1) = 82
- GO TO 440
-C
-C *** PRINT SUMMARY OF FINAL ITERATION AND OTHER REQUESTED ITEMS ***
-C
- 430 IV(1) = IV(CNVCOD)
- IV(CNVCOD) = 0
- 440 CALL DITSUM(D, G, IV, LIV, LV, N, V, X)
- GO TO 999
-C
-C *** PROJECT X INTO FEASIBLE REGION (PRIOR TO COMPUTING F OR G) ***
-C
- 450 DO 460 I = 1, N
- IF (X(I) .LT. B(1,I)) X(I) = B(1,I)
- IF (X(I) .GT. B(2,I)) X(I) = B(2,I)
- 460 CONTINUE
-C
- 999 RETURN
-C
-C *** LAST CARD OF DRMNHB FOLLOWS ***
- END
diff --git a/CEP/PyBDSM/src/port3/drn2g.f b/CEP/PyBDSM/src/port3/drn2g.f
deleted file mode 100644
index 1f7646a01b979751e09776d882d4dec7b3d36fa4..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/drn2g.f
+++ /dev/null
@@ -1,461 +0,0 @@
- SUBROUTINE DRN2G(D, DR, IV, LIV, LV, N, ND, N1, N2, P, R,
- 1 RD, V, X)
-C
-C *** REVISED ITERATION DRIVER FOR NL2SOL (VERSION 2.3) ***
-C
- INTEGER LIV, LV, N, ND, N1, N2, P
- INTEGER IV(LIV)
- DOUBLE PRECISION D(P), DR(ND,P), R(ND), RD(ND), V(LV), X(P)
-C
-C-------------------------- PARAMETER USAGE --------------------------
-C
-C D........ SCALE VECTOR.
-C DR....... DERIVATIVES OF R AT X.
-C IV....... INTEGER VALUES ARRAY.
-C LIV...... LENGTH OF IV... LIV MUST BE AT LEAST P + 82.
-C LV....... LENGTH OF V... LV MUST BE AT LEAST 105 + P*(2*P+16).
-C N........ TOTAL NUMBER OF RESIDUALS.
-C ND....... MAX. NO. OF RESIDUALS PASSED ON ONE CALL.
-C N1....... LOWEST ROW INDEX FOR RESIDUALS SUPPLIED THIS TIME.
-C N2....... HIGHEST ROW INDEX FOR RESIDUALS SUPPLIED THIS TIME.
-C P........ NUMBER OF PARAMETERS (COMPONENTS OF X) BEING ESTIMATED.
-C R........ RESIDUALS.
-C RD....... RD(I) = SQRT(G(I)**T * H(I)**-1 * G(I)) ON OUTPUT WHEN
-C IV(RDREQ) IS NONZERO. DRN2G SETS IV(REGD) = 1 IF RD
-C IS SUCCESSFULLY COMPUTED, TO 0 IF NO ATTEMPT WAS MADE
-C TO COMPUTE IT, AND TO -1 IF H (THE FINITE-DIFFERENCE HESSIAN)
-C WAS INDEFINITE. IF ND .GE. N, THEN RD IS ALSO USED AS
-C TEMPORARY STORAGE.
-C V........ FLOATING-POINT VALUES ARRAY.
-C X........ PARAMETER VECTOR BEING ESTIMATED (INPUT = INITIAL GUESS,
-C OUTPUT = BEST VALUE FOUND).
-C
-C *** DISCUSSION ***
-C
-C NOTE... NL2SOL AND NL2ITR (MENTIONED BELOW) ARE DESCRIBED IN
-C ACM TRANS. MATH. SOFTWARE, VOL. 7, PP. 369-383 (AN ADAPTIVE
-C NONLINEAR LEAST-SQUARES ALGORITHM, BY J.E. DENNIS, D.M. GAY,
-C AND R.E. WELSCH).
-C
-C THIS ROUTINE CARRIES OUT ITERATIONS FOR SOLVING NONLINEAR
-C LEAST SQUARES PROBLEMS. WHEN ND = N, IT IS SIMILAR TO NL2ITR
-C (WITH J = DR), EXCEPT THAT R(X) AND DR(X) NEED NOT BE INITIALIZED
-C WHEN DRN2G IS CALLED WITH IV(1) = 0 OR 12. DRN2G ALSO ALLOWS
-C R AND DR TO BE SUPPLIED ROW-WISE -- JUST SET ND = 1 AND CALL
-C DRN2G ONCE FOR EACH ROW WHEN PROVIDING RESIDUALS AND JACOBIANS.
-C ANOTHER NEW FEATURE IS THAT CALLING DRN2G WITH IV(1) = 13
-C CAUSES STORAGE ALLOCATION ONLY TO BE PERFORMED -- ON RETURN, SUCH
-C COMPONENTS AS IV(G) (THE FIRST SUBSCRIPT IN G OF THE GRADIENT)
-C AND IV(S) (THE FIRST SUBSCRIPT IN V OF THE S LOWER TRIANGLE OF
-C THE S MATRIX) WILL HAVE BEEN SET (UNLESS LIV OR LV IS TOO SMALL),
-C AND IV(1) WILL HAVE BEEN SET TO 14. CALLING DRN2G WITH IV(1) = 14
-C CAUSES EXECUTION OF THE ALGORITHM TO BEGIN UNDER THE ASSUMPTION
-C THAT STORAGE HAS BEEN ALLOCATED.
-C
-C *** SUPPLYING R AND DR ***
-C
-C DRN2G USES IV AND V IN THE SAME WAY AS NL2SOL, WITH A SMALL
-C NUMBER OF OBVIOUS CHANGES. ONE DIFFERENCE BETWEEN DRN2G AND
-C NL2ITR IS THAT INITIAL FUNCTION AND GRADIENT INFORMATION NEED NOT
-C BE SUPPLIED IN THE VERY FIRST CALL ON DRN2G, THE ONE WITH
-C IV(1) = 0 OR 12. ANOTHER DIFFERENCE IS THAT DRN2G RETURNS WITH
-C IV(1) = -2 WHEN IT WANTS ANOTHER LOOK AT THE OLD JACOBIAN MATRIX
-C AND THE CURRENT RESIDUAL -- THE ONE CORRESPONDING TO X AND
-C IV(NFGCAL). IT THEN RETURNS WITH IV(1) = -3 WHEN IT WANTS TO SEE
-C BOTH THE NEW RESIDUAL AND THE NEW JACOBIAN MATRIX AT ONCE. NOTE
-C THAT IV(NFGCAL) = IV(7) CONTAINS THE VALUE THAT IV(NFCALL) = IV(6)
-C HAD WHEN THE CURRENT RESIDUAL WAS EVALUATED. ALSO NOTE THAT THE
-C VALUE OF X CORRESPONDING TO THE OLD JACOBIAN MATRIX IS STORED IN
-C V, STARTING AT V(IV(X0)) = V(IV(43)).
-C ANOTHER NEW RETURN... DRN2G IV(1) = -1 WHEN IT WANTS BOTH THE
-C RESIDUAL AND THE JACOBIAN TO BE EVALUATED AT X.
-C A NEW RESIDUAL VECTOR MUST BE SUPPLIED WHEN DRN2G RETURNS WITH
-C IV(1) = 1 OR -1. THIS TAKES THE FORM OF VALUES OF R(I,X) PASSED
-C IN R(I-N1+1), I = N1(1)N2. YOU MAY PASS ALL THESE VALUES AT ONCE
-C (I.E., N1 = 1 AND N2 = N) OR IN PIECES BY MAKING SEVERAL CALLS ON
-C DRN2G. EACH TIME DRN2G RETURNS WITH IV(1) = 1, N1 WILL HAVE
-C BEEN SET TO THE INDEX OF THE NEXT RESIDUAL THAT DRN2G EXPECTS TO
-C SEE, AND N2 WILL BE SET TO THE INDEX OF THE HIGHEST RESIDUAL THAT
-C COULD BE GIVEN ON THE NEXT CALL, I.E., N2 = N1 + ND - 1. (THUS
-C WHEN DRN2G FIRST RETURNS WITH IV(1) = 1 FOR A NEW X, IT WILL
-C HAVE SET N1 TO 1 AND N2 TO MIN(ND,N).) THE CALLER MAY PROVIDE
-C FEWER THAN N2-N1+1 RESIDUALS ON THE NEXT CALL BY SETTING N2 TO
-C A SMALLER VALUE. DRN2G ASSUMES IT HAS SEEN ALL THE RESIDUALS
-C FOR THE CURRENT X WHEN IT IS CALLED WITH N2 .GE. N.
-C EXAMPLE... SUPPOSE N = 80 AND THAT R IS TO BE PASSED IN 8
-C BLOCKS OF SIZE 10. THE FOLLOWING CODE WOULD DO THE JOB.
-C
-C N = 80
-C ND = 10
-C ...
-C DO 10 K = 1, 8
-C *** COMPUTE R(I,X) FOR I = 10*K-9 TO 10*K ***
-C *** AND STORE THEM IN R(1),...,R(10) ***
-C CALL DRN2G(..., R, ...)
-C 10 CONTINUE
-C
-C THE SITUATION IS SIMILAR WHEN GRADIENT INFORMATION IS
-C REQUIRED, I.E., WHEN DRN2G RETURNS WITH IV(1) = 2, -1, OR -2.
-C NOTE THAT DRN2G OVERWRITES R, BUT THAT IN THE SPECIAL CASE OF
-C N1 = 1 AND N2 = N ON PREVIOUS CALLS, DRN2G NEVER RETURNS WITH
-C IV(1) = -2. IT SHOULD BE CLEAR THAT THE PARTIAL DERIVATIVE OF
-C R(I,X) WITH RESPECT TO X(L) IS TO BE STORED IN DR(I-N1+1,L),
-C L = 1(1)P, I = N1(1)N2. IT IS ESSENTIAL THAT R(I) AND DR(I,L)
-C ALL CORRESPOND TO THE SAME RESIDUALS WHEN IV(1) = -1 OR -2.
-C
-C *** COVARIANCE MATRIX ***
-C
-C IV(RDREQ) = IV(57) TELLS WHETHER TO COMPUTE A COVARIANCE
-C MATRIX AND/OR REGRESSION DIAGNOSTICS... 0 MEANS NEITHER,
-C 1 MEANS COVARIANCE MATRIX ONLY, 2 MEANS REG. DIAGNOSTICS ONLY,
-C 3 MEANS BOTH. AS WITH NL2SOL, IV(COVREQ) = IV(15) TELLS WHAT
-C HESSIAN APPROXIMATION TO _USE_ IN THIS COMPUTING.
-C
-C *** REGRESSION DIAGNOSTICS ***
-C
-C SEE THE COMMENTS IN SUBROUTINE DN2G.
-C
-C *** GENERAL ***
-C
-C CODED BY DAVID M. GAY.
-C
-C+++++++++++++++++++++++++++++ DECLARATIONS ++++++++++++++++++++++++++
-C
-C *** INTRINSIC FUNCTIONS ***
-C/+
- INTEGER IABS, MOD
-C/
-C *** EXTERNAL FUNCTIONS AND SUBROUTINES ***
-C
- DOUBLE PRECISION DD7TPR, DV2NRM
- EXTERNAL DC7VFN,DIVSET, DD7TPR,DD7UPD,DG7LIT,DITSUM,DL7VML,
- 1 DN2CVP, DN2LRD, DQ7APL,DQ7RAD,DV7CPY, DV7SCP, DV2NRM
-C
-C DC7VFN... FINISHES COVARIANCE COMPUTATION.
-C DIVSET.... PROVIDES DEFAULT IV AND V INPUT COMPONENTS.
-C DD7TPR... COMPUTES INNER PRODUCT OF TWO VECTORS.
-C DD7UPD... UPDATES SCALE VECTOR D.
-C DG7LIT.... PERFORMS BASIC MINIMIZATION ALGORITHM.
-C DITSUM.... PRINTS ITERATION SUMMARY, INFO ABOUT INITIAL AND FINAL X.
-C DL7VML.... COMPUTES L * V, V = VECTOR, L = LOWER TRIANGULAR MATRIX.
-C DN2CVP... PRINTS COVARIANCE MATRIX.
-C DN2LRD... COMPUTES REGRESSION DIAGNOSTICS.
-C DQ7APL... APPLIES QR TRANSFORMATIONS STORED BY DQ7RAD.
-C DQ7RAD.... ADDS A NEW BLOCK OF ROWS TO QR DECOMPOSITION.
-C DV7CPY.... COPIES ONE VECTOR TO ANOTHER.
-C DV7SCP... SETS ALL ELEMENTS OF A VECTOR TO A SCALAR.
-C
-C *** LOCAL VARIABLES ***
-C
- INTEGER G1, GI, I, IV1, IVMODE, JTOL1, K, L, LH, NN, QTR1,
- 1 RMAT1, YI, Y1
- DOUBLE PRECISION T
-C
- DOUBLE PRECISION HALF, ZERO
-C
-C *** SUBSCRIPTS FOR IV AND V ***
-C
- INTEGER CNVCOD, COVMAT, COVREQ, DINIT, DTYPE, DTINIT, D0INIT, F,
- 1 FDH, G, H, IPIVOT, IVNEED, JCN, JTOL, LMAT, MODE,
- 2 NEXTIV, NEXTV, NF0, NF00, NF1, NFCALL, NFCOV, NFGCAL,
- 3 NGCALL, NGCOV, QTR, RDREQ, REGD, RESTOR, RLIMIT, RMAT,
- 4 TOOBIG, VNEED, Y
-C
-C *** IV SUBSCRIPT VALUES ***
-C
-C/6
-C DATA CNVCOD/55/, COVMAT/26/, COVREQ/15/, DTYPE/16/, FDH/74/,
-C 1 G/28/, H/56/, IPIVOT/76/, IVNEED/3/, JCN/66/, JTOL/59/,
-C 2 LMAT/42/, MODE/35/, NEXTIV/46/, NEXTV/47/, NFCALL/6/,
-C 3 NFCOV/52/, NF0/68/, NF00/81/, NF1/69/, NFGCAL/7/, NGCALL/30/,
-C 4 NGCOV/53/, QTR/77/, RESTOR/9/, RMAT/78/, RDREQ/57/, REGD/67/,
-C 5 TOOBIG/2/, VNEED/4/, Y/48/
-C/7
- PARAMETER (CNVCOD=55, COVMAT=26, COVREQ=15, DTYPE=16, FDH=74,
- 1 G=28, H=56, IPIVOT=76, IVNEED=3, JCN=66, JTOL=59,
- 2 LMAT=42, MODE=35, NEXTIV=46, NEXTV=47, NFCALL=6,
- 3 NFCOV=52, NF0=68, NF00=81, NF1=69, NFGCAL=7, NGCALL=30,
- 4 NGCOV=53, QTR=77, RESTOR=9, RMAT=78, RDREQ=57, REGD=67,
- 5 TOOBIG=2, VNEED=4, Y=48)
-C/
-C
-C *** V SUBSCRIPT VALUES ***
-C
-C/6
-C DATA DINIT/38/, DTINIT/39/, D0INIT/40/, F/10/, RLIMIT/46/
-C/7
- PARAMETER (DINIT=38, DTINIT=39, D0INIT=40, F=10, RLIMIT=46)
-C/
-C/6
-C DATA HALF/0.5D+0/, ZERO/0.D+0/
-C/7
- PARAMETER (HALF=0.5D+0, ZERO=0.D+0)
-C/
-C
-C+++++++++++++++++++++++++++++++ BODY ++++++++++++++++++++++++++++++++
-C
- LH = P * (P+1) / 2
- IF (IV(1) .EQ. 0) CALL DIVSET(1, IV, LIV, LV, V)
- IV1 = IV(1)
- IF (IV1 .GT. 2) GO TO 10
- NN = N2 - N1 + 1
- IV(RESTOR) = 0
- I = IV1 + 4
- IF (IV(TOOBIG) .EQ. 0) GO TO (150, 130, 150, 120, 120, 150), I
- IF (I .NE. 5) IV(1) = 2
- GO TO 40
-C
-C *** FRESH START OR RESTART -- CHECK INPUT INTEGERS ***
-C
- 10 IF (ND .LE. 0) GO TO 210
- IF (P .LE. 0) GO TO 210
- IF (N .LE. 0) GO TO 210
- IF (IV1 .EQ. 14) GO TO 30
- IF (IV1 .GT. 16) GO TO 300
- IF (IV1 .LT. 12) GO TO 40
- IF (IV1 .EQ. 12) IV(1) = 13
- IF (IV(1) .NE. 13) GO TO 20
- IV(IVNEED) = IV(IVNEED) + P
- IV(VNEED) = IV(VNEED) + P*(P+13)/2
- 20 CALL DG7LIT(D, X, IV, LIV, LV, P, P, V, X, X)
- IF (IV(1) .NE. 14) GO TO 999
-C
-C *** STORAGE ALLOCATION ***
-C
- IV(IPIVOT) = IV(NEXTIV)
- IV(NEXTIV) = IV(IPIVOT) + P
- IV(Y) = IV(NEXTV)
- IV(G) = IV(Y) + P
- IV(JCN) = IV(G) + P
- IV(RMAT) = IV(JCN) + P
- IV(QTR) = IV(RMAT) + LH
- IV(JTOL) = IV(QTR) + P
- IV(NEXTV) = IV(JTOL) + 2*P
- IF (IV1 .EQ. 13) GO TO 999
-C
- 30 JTOL1 = IV(JTOL)
- IF (V(DINIT) .GE. ZERO) CALL DV7SCP(P, D, V(DINIT))
- IF (V(DTINIT) .GT. ZERO) CALL DV7SCP(P, V(JTOL1), V(DTINIT))
- I = JTOL1 + P
- IF (V(D0INIT) .GT. ZERO) CALL DV7SCP(P, V(I), V(D0INIT))
- IV(NF0) = 0
- IV(NF1) = 0
- IF (ND .GE. N) GO TO 40
-C
-C *** SPECIAL CASE HANDLING OF FIRST FUNCTION AND GRADIENT EVALUATION
-C *** -- ASK FOR BOTH RESIDUAL AND JACOBIAN AT ONCE
-C
- G1 = IV(G)
- Y1 = IV(Y)
- CALL DG7LIT(D, V(G1), IV, LIV, LV, P, P, V, X, V(Y1))
- IF (IV(1) .NE. 1) GO TO 220
- V(F) = ZERO
- CALL DV7SCP(P, V(G1), ZERO)
- IV(1) = -1
- QTR1 = IV(QTR)
- CALL DV7SCP(P, V(QTR1), ZERO)
- IV(REGD) = 0
- RMAT1 = IV(RMAT)
- GO TO 100
-C
- 40 G1 = IV(G)
- Y1 = IV(Y)
- CALL DG7LIT(D, V(G1), IV, LIV, LV, P, P, V, X, V(Y1))
- IF (IV(1) - 2) 50, 60, 220
-C
- 50 V(F) = ZERO
- IF (IV(NF1) .EQ. 0) GO TO 260
- IF (IV(RESTOR) .NE. 2) GO TO 260
- IV(NF0) = IV(NF1)
- CALL DV7CPY(N, RD, R)
- IV(REGD) = 0
- GO TO 260
-C
- 60 CALL DV7SCP(P, V(G1), ZERO)
- IF (IV(MODE) .GT. 0) GO TO 230
- RMAT1 = IV(RMAT)
- QTR1 = IV(QTR)
- CALL DV7SCP(P, V(QTR1), ZERO)
- IV(REGD) = 0
- IF (ND .LT. N) GO TO 90
- IF (N1 .NE. 1) GO TO 90
- IF (IV(MODE) .LT. 0) GO TO 100
- IF (IV(NF1) .EQ. IV(NFGCAL)) GO TO 70
- IF (IV(NF0) .NE. IV(NFGCAL)) GO TO 90
- CALL DV7CPY(N, R, RD)
- GO TO 80
- 70 CALL DV7CPY(N, RD, R)
- 80 CALL DQ7APL(ND, N, P, DR, RD, 0)
- CALL DL7VML(P, V(Y1), V(RMAT1), RD)
- GO TO 110
-C
- 90 IV(1) = -2
- IF (IV(MODE) .LT. 0) IV(1) = -1
- 100 CALL DV7SCP(P, V(Y1), ZERO)
- 110 CALL DV7SCP(LH, V(RMAT1), ZERO)
- GO TO 260
-C
-C *** COMPUTE F(X) ***
-C
- 120 T = DV2NRM(NN, R)
- IF (T .GT. V(RLIMIT)) GO TO 200
- V(F) = V(F) + HALF * T**2
- IF (N2 .LT. N) GO TO 270
- IF (N1 .EQ. 1) IV(NF1) = IV(NFCALL)
- GO TO 40
-C
-C *** COMPUTE Y ***
-C
- 130 Y1 = IV(Y)
- YI = Y1
- DO 140 L = 1, P
- V(YI) = V(YI) + DD7TPR(NN, DR(1,L), R)
- YI = YI + 1
- 140 CONTINUE
- IF (N2 .LT. N) GO TO 270
- IV(1) = 2
- IF (N1 .GT. 1) IV(1) = -3
- GO TO 260
-C
-C *** COMPUTE GRADIENT INFORMATION ***
-C
- 150 IF (IV(MODE) .GT. P) GO TO 240
- G1 = IV(G)
- IVMODE = IV(MODE)
- IF (IVMODE .LT. 0) GO TO 170
- IF (IVMODE .EQ. 0) GO TO 180
- IV(1) = 2
-C
-C *** COMPUTE GRADIENT ONLY (FOR _USE_ IN COVARIANCE COMPUTATION) ***
-C
- GI = G1
- DO 160 L = 1, P
- V(GI) = V(GI) + DD7TPR(NN, R, DR(1,L))
- GI = GI + 1
- 160 CONTINUE
- GO TO 190
-C
-C *** COMPUTE INITIAL FUNCTION VALUE WHEN ND .LT. N ***
-C
- 170 IF (N .LE. ND) GO TO 180
- T = DV2NRM(NN, R)
- IF (T .GT. V(RLIMIT)) GO TO 200
- V(F) = V(F) + HALF * T**2
-C
-C *** UPDATE D IF DESIRED ***
-C
- 180 IF (IV(DTYPE) .GT. 0)
- 1 CALL DD7UPD(D, DR, IV, LIV, LV, N, ND, NN, N2, P, V)
-C
-C *** COMPUTE RMAT AND QTR ***
-C
- QTR1 = IV(QTR)
- RMAT1 = IV(RMAT)
- CALL DQ7RAD(NN, ND, P, V(QTR1), .TRUE., V(RMAT1), DR, R)
- IV(NF1) = 0
-C
- 190 IF (N2 .LT. N) GO TO 270
- IF (IVMODE .GT. 0) GO TO 40
- IV(NF00) = IV(NFGCAL)
-C
-C *** COMPUTE G FROM RMAT AND QTR ***
-C
- CALL DL7VML(P, V(G1), V(RMAT1), V(QTR1))
- IV(1) = 2
- IF (IVMODE .EQ. 0) GO TO 40
- IF (N .LE. ND) GO TO 40
-C
-C *** FINISH SPECIAL CASE HANDLING OF FIRST FUNCTION AND GRADIENT
-C
- Y1 = IV(Y)
- IV(1) = 1
- CALL DG7LIT(D, V(G1), IV, LIV, LV, P, P, V, X, V(Y1))
- IF (IV(1) .NE. 2) GO TO 220
- GO TO 40
-C
-C *** MISC. DETAILS ***
-C
-C *** X IS OUT OF RANGE (OVERSIZE STEP) ***
-C
- 200 IV(TOOBIG) = 1
- GO TO 40
-C
-C *** BAD N, ND, OR P ***
-C
- 210 IV(1) = 66
- GO TO 300
-C
-C *** CONVERGENCE OBTAINED -- SEE WHETHER TO COMPUTE COVARIANCE ***
-C
- 220 IF (IV(COVMAT) .NE. 0) GO TO 290
- IF (IV(REGD) .NE. 0) GO TO 290
-C
-C *** SEE IF CHOLESKY FACTOR OF HESSIAN IS AVAILABLE ***
-C
- K = IV(FDH)
- IF (K .LE. 0) GO TO 280
- IF (IV(RDREQ) .LE. 0) GO TO 290
-C
-C *** COMPUTE REGRESSION DIAGNOSTICS AND DEFAULT COVARIANCE IF
-C DESIRED ***
-C
- I = 0
- IF (MOD(IV(RDREQ),4) .GE. 2) I = 1
- IF (MOD(IV(RDREQ),2) .EQ. 1 .AND. IABS(IV(COVREQ)) .LE. 1) I = I+2
- IF (I .EQ. 0) GO TO 250
- IV(MODE) = P + I
- IV(NGCALL) = IV(NGCALL) + 1
- IV(NGCOV) = IV(NGCOV) + 1
- IV(CNVCOD) = IV(1)
- IF (I .LT. 2) GO TO 230
- L = IABS(IV(H))
- CALL DV7SCP(LH, V(L), ZERO)
- 230 IV(NFCOV) = IV(NFCOV) + 1
- IV(NFCALL) = IV(NFCALL) + 1
- IV(NFGCAL) = IV(NFCALL)
- IV(1) = -1
- GO TO 260
-C
- 240 L = IV(LMAT)
- CALL DN2LRD(DR, IV, V(L), LH, LIV, LV, ND, NN, P, R, RD, V)
- IF (N2 .LT. N) GO TO 270
- IF (N1 .GT. 1) GO TO 250
-C
-C *** ENSURE WE CAN RESTART -- AND MAKE RETURN STATE OF DR
-C *** INDEPENDENT OF WHETHER REGRESSION DIAGNOSTICS ARE COMPUTED.
-C *** _USE_ STEP VECTOR (ALLOCATED BY DG7LIT) FOR SCRATCH.
-C
- RMAT1 = IV(RMAT)
- CALL DV7SCP(LH, V(RMAT1), ZERO)
- CALL DQ7RAD(NN, ND, P, R, .FALSE., V(RMAT1), DR, R)
- IV(NF1) = 0
-C
-C *** FINISH COMPUTING COVARIANCE ***
-C
- 250 L = IV(LMAT)
- CALL DC7VFN(IV, V(L), LH, LIV, LV, N, P, V)
- GO TO 290
-C
-C *** RETURN FOR MORE FUNCTION OR GRADIENT INFORMATION ***
-C
- 260 N2 = 0
- 270 N1 = N2 + 1
- N2 = N2 + ND
- IF (N2 .GT. N) N2 = N
- GO TO 999
-C
-C *** COME HERE FOR INDEFINITE FINITE-DIFFERENCE HESSIAN ***
-C
- 280 IV(COVMAT) = K
- IV(REGD) = K
-C
-C *** PRINT SUMMARY OF FINAL ITERATION AND OTHER REQUESTED ITEMS ***
-C
- 290 G1 = IV(G)
- 300 CALL DITSUM(D, V(G1), IV, LIV, LV, P, V, X)
- IF (IV(1) .LE. 6 .AND. IV(RDREQ) .GT. 0)
- 1 CALL DN2CVP(IV, LIV, LV, P, V)
-C
- 999 RETURN
-C *** LAST LINE OF DRN2G FOLLOWS ***
- END
diff --git a/CEP/PyBDSM/src/port3/drn2gb.f b/CEP/PyBDSM/src/port3/drn2gb.f
deleted file mode 100644
index 1ef28a1fdda207346a6a1a8af09769a527a5102a..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/drn2gb.f
+++ /dev/null
@@ -1,329 +0,0 @@
- SUBROUTINE DRN2GB(B, D, DR, IV, LIV, LV, N, ND, N1, N2, P, R,
- 1 RD, V, X)
-C
-C *** REVISED ITERATION DRIVER FOR NL2SOL WITH SIMPLE BOUNDS ***
-C
- INTEGER LIV, LV, N, ND, N1, N2, P
- INTEGER IV(LIV)
- DOUBLE PRECISION B(2,P), D(P), DR(ND,P), R(ND), RD(ND), V(LV),
- 1 X(P)
-C
-C-------------------------- PARAMETER USAGE --------------------------
-C
-C B........ BOUNDS ON X.
-C D........ SCALE VECTOR.
-C DR....... DERIVATIVES OF R AT X.
-C IV....... INTEGER VALUES ARRAY.
-C LIV...... LENGTH OF IV... LIV MUST BE AT LEAST 4*P + 82.
-C LV....... LENGTH OF V... LV MUST BE AT LEAST 105 + P*(2*P+20).
-C N........ TOTAL NUMBER OF RESIDUALS.
-C ND....... MAX. NO. OF RESIDUALS PASSED ON ONE CALL.
-C N1....... LOWEST ROW INDEX FOR RESIDUALS SUPPLIED THIS TIME.
-C N2....... HIGHEST ROW INDEX FOR RESIDUALS SUPPLIED THIS TIME.
-C P........ NUMBER OF PARAMETERS (COMPONENTS OF X) BEING ESTIMATED.
-C R........ RESIDUALS.
-C V........ FLOATING-POINT VALUES ARRAY.
-C X........ PARAMETER VECTOR BEING ESTIMATED (INPUT = INITIAL GUESS,
-C OUTPUT = BEST VALUE FOUND).
-C
-C *** DISCUSSION ***
-C
-C THIS ROUTINE CARRIES OUT ITERATIONS FOR SOLVING NONLINEAR
-C LEAST SQUARES PROBLEMS. IT IS SIMILAR TO DRN2G, EXCEPT THAT
-C THIS ROUTINE ENFORCES THE BOUNDS B(1,I) .LE. X(I) .LE. B(2,I),
-C I = 1(1)P.
-C
-C *** GENERAL ***
-C
-C CODED BY DAVID M. GAY.
-C
-C+++++++++++++++++++++++++++++ DECLARATIONS ++++++++++++++++++++++++++
-C
-C *** EXTERNAL FUNCTIONS AND SUBROUTINES ***
-C
- DOUBLE PRECISION DD7TPR, DV2NRM
- EXTERNAL DIVSET, DD7TPR,DD7UPD, DG7ITB,DITSUM,DL7VML, DQ7APL,
- 1 DQ7RAD, DR7TVM,DV7CPY, DV7SCP, DV2NRM
-C
-C DIVSET.... PROVIDES DEFAULT IV AND V INPUT COMPONENTS.
-C DD7TPR... COMPUTES INNER PRODUCT OF TWO VECTORS.
-C DD7UPD... UPDATES SCALE VECTOR D.
-C DG7ITB... PERFORMS BASIC MINIMIZATION ALGORITHM.
-C DITSUM.... PRINTS ITERATION SUMMARY, INFO ABOUT INITIAL AND FINAL X.
-C DL7VML.... COMPUTES L * V, V = VECTOR, L = LOWER TRIANGULAR MATRIX.
-C DQ7APL... APPLIES QR TRANSFORMATIONS STORED BY DQ7RAD.
-C DQ7RAD.... ADDS A NEW BLOCK OF ROWS TO QR DECOMPOSITION.
-C DR7TVM... MULT. VECTOR BY TRANS. OF UPPER TRIANG. MATRIX FROM QR FACT.
-C DV7CPY.... COPIES ONE VECTOR TO ANOTHER.
-C DV7SCP... SETS ALL ELEMENTS OF A VECTOR TO A SCALAR.
-C DV2NRM... RETURNS THE 2-NORM OF A VECTOR.
-C
-C
-C *** LOCAL VARIABLES ***
-C
- INTEGER G1, GI, I, IV1, IVMODE, JTOL1, L, LH, NN, QTR1,
- 1 RD1, RMAT1, YI, Y1
- DOUBLE PRECISION T
-C
- DOUBLE PRECISION HALF, ZERO
-C
-C *** SUBSCRIPTS FOR IV AND V ***
-C
- INTEGER DINIT, DTYPE, DTINIT, D0INIT, F, G, JCN, JTOL, MODE,
- 1 NEXTV, NF0, NF00, NF1, NFCALL, NFCOV, NFGCAL, QTR, RDREQ,
- 1 REGD, RESTOR, RLIMIT, RMAT, TOOBIG, VNEED
-C
-C *** IV SUBSCRIPT VALUES ***
-C
-C/6
-C DATA DTYPE/16/, G/28/, JCN/66/, JTOL/59/, MODE/35/, NEXTV/47/,
-C 1 NF0/68/, NF00/81/, NF1/69/, NFCALL/6/, NFCOV/52/, NFGCAL/7/,
-C 2 QTR/77/, RDREQ/57/, RESTOR/9/, REGD/67/, RMAT/78/, TOOBIG/2/,
-C 3 VNEED/4/
-C/7
- PARAMETER (DTYPE=16, G=28, JCN=66, JTOL=59, MODE=35, NEXTV=47,
- 1 NF0=68, NF00=81, NF1=69, NFCALL=6, NFCOV=52, NFGCAL=7,
- 2 QTR=77, RDREQ=57, RESTOR=9, REGD=67, RMAT=78, TOOBIG=2,
- 3 VNEED=4)
-C/
-C
-C *** V SUBSCRIPT VALUES ***
-C
-C/6
-C DATA DINIT/38/, DTINIT/39/, D0INIT/40/, F/10/, RLIMIT/46/
-C/7
- PARAMETER (DINIT=38, DTINIT=39, D0INIT=40, F=10, RLIMIT=46)
-C/
-C/6
-C DATA HALF/0.5D+0/, ZERO/0.D+0/
-C/7
- PARAMETER (HALF=0.5D+0, ZERO=0.D+0)
-C/
-C
-C+++++++++++++++++++++++++++++++ BODY ++++++++++++++++++++++++++++++++
-C
- LH = P * (P+1) / 2
- IF (IV(1) .EQ. 0) CALL DIVSET(1, IV, LIV, LV, V)
- IV1 = IV(1)
- IF (IV1 .GT. 2) GO TO 10
- NN = N2 - N1 + 1
- IV(RESTOR) = 0
- I = IV1 + 4
- IF (IV(TOOBIG) .EQ. 0) GO TO (150, 130, 150, 120, 120, 150), I
- IF (I .NE. 5) IV(1) = 2
- GO TO 40
-C
-C *** FRESH START OR RESTART -- CHECK INPUT INTEGERS ***
-C
- 10 IF (ND .LE. 0) GO TO 220
- IF (P .LE. 0) GO TO 220
- IF (N .LE. 0) GO TO 220
- IF (IV1 .EQ. 14) GO TO 30
- IF (IV1 .GT. 16) GO TO 270
- IF (IV1 .LT. 12) GO TO 40
- IF (IV1 .EQ. 12) IV(1) = 13
- IF (IV(1) .NE. 13) GO TO 20
- IV(VNEED) = IV(VNEED) + P*(P+15)/2
- 20 CALL DG7ITB(B, D, X, IV, LIV, LV, P, P, V, X, X)
- IF (IV(1) .NE. 14) GO TO 999
-C
-C *** STORAGE ALLOCATION ***
-C
- IV(G) = IV(NEXTV)
- IV(JCN) = IV(G) + 2*P
- IV(RMAT) = IV(JCN) + P
- IV(QTR) = IV(RMAT) + LH
- IV(JTOL) = IV(QTR) + 2*P
- IV(NEXTV) = IV(JTOL) + 2*P
-C *** TURN OFF COVARIANCE COMPUTATION ***
- IV(RDREQ) = 0
- IF (IV1 .EQ. 13) GO TO 999
-C
- 30 JTOL1 = IV(JTOL)
- IF (V(DINIT) .GE. ZERO) CALL DV7SCP(P, D, V(DINIT))
- IF (V(DTINIT) .GT. ZERO) CALL DV7SCP(P, V(JTOL1), V(DTINIT))
- I = JTOL1 + P
- IF (V(D0INIT) .GT. ZERO) CALL DV7SCP(P, V(I), V(D0INIT))
- IV(NF0) = 0
- IV(NF1) = 0
- IF (ND .GE. N) GO TO 40
-C
-C *** SPECIAL CASE HANDLING OF FIRST FUNCTION AND GRADIENT EVALUATION
-C *** -- ASK FOR BOTH RESIDUAL AND JACOBIAN AT ONCE
-C
- G1 = IV(G)
- Y1 = G1 + P
- CALL DG7ITB(B, D, V(G1), IV, LIV, LV, P, P, V, X, V(Y1))
- IF (IV(1) .NE. 1) GO TO 260
- V(F) = ZERO
- CALL DV7SCP(P, V(G1), ZERO)
- IV(1) = -1
- QTR1 = IV(QTR)
- CALL DV7SCP(P, V(QTR1), ZERO)
- IV(REGD) = 0
- RMAT1 = IV(RMAT)
- GO TO 100
-C
- 40 G1 = IV(G)
- Y1 = G1 + P
- CALL DG7ITB(B, D, V(G1), IV, LIV, LV, P, P, V, X, V(Y1))
- IF (IV(1) - 2) 50, 60, 260
-C
- 50 V(F) = ZERO
- IF (IV(NF1) .EQ. 0) GO TO 240
- IF (IV(RESTOR) .NE. 2) GO TO 240
- IV(NF0) = IV(NF1)
- CALL DV7CPY(N, RD, R)
- IV(REGD) = 0
- GO TO 240
-C
- 60 CALL DV7SCP(P, V(G1), ZERO)
- IF (IV(MODE) .GT. 0) GO TO 230
- RMAT1 = IV(RMAT)
- QTR1 = IV(QTR)
- RD1 = QTR1 + P
- CALL DV7SCP(P, V(QTR1), ZERO)
- IV(REGD) = 0
- IF (ND .LT. N) GO TO 90
- IF (N1 .NE. 1) GO TO 90
- IF (IV(MODE) .LT. 0) GO TO 100
- IF (IV(NF1) .EQ. IV(NFGCAL)) GO TO 70
- IF (IV(NF0) .NE. IV(NFGCAL)) GO TO 90
- CALL DV7CPY(N, R, RD)
- GO TO 80
- 70 CALL DV7CPY(N, RD, R)
- 80 CALL DQ7APL(ND, N, P, DR, RD, 0)
- CALL DR7TVM(ND, MIN0(N,P), V(Y1), V(RD1), DR, RD)
- IV(REGD) = 0
- GO TO 110
-C
- 90 IV(1) = -2
- IF (IV(MODE) .LT. 0) IV(1) = -3
- 100 CALL DV7SCP(P, V(Y1), ZERO)
- 110 CALL DV7SCP(LH, V(RMAT1), ZERO)
- GO TO 240
-C
-C *** COMPUTE F(X) ***
-C
- 120 T = DV2NRM(NN, R)
- IF (T .GT. V(RLIMIT)) GO TO 210
- V(F) = V(F) + HALF * T**2
- IF (N2 .LT. N) GO TO 250
- IF (N1 .EQ. 1) IV(NF1) = IV(NFCALL)
- GO TO 40
-C
-C *** COMPUTE Y ***
-C
- 130 Y1 = IV(G) + P
- YI = Y1
- DO 140 L = 1, P
- V(YI) = V(YI) + DD7TPR(NN, DR(1,L), R)
- YI = YI + 1
- 140 CONTINUE
- IF (N2 .LT. N) GO TO 250
- IV(1) = 2
- IF (N1 .GT. 1) IV(1) = -3
- GO TO 240
-C
-C *** COMPUTE GRADIENT INFORMATION ***
-C
- 150 G1 = IV(G)
- IVMODE = IV(MODE)
- IF (IVMODE .LT. 0) GO TO 170
- IF (IVMODE .EQ. 0) GO TO 180
- IV(1) = 2
-C
-C *** COMPUTE GRADIENT ONLY (FOR _USE_ IN COVARIANCE COMPUTATION) ***
-C
- GI = G1
- DO 160 L = 1, P
- V(GI) = V(GI) + DD7TPR(NN, R, DR(1,L))
- GI = GI + 1
- 160 CONTINUE
- GO TO 200
-C
-C *** COMPUTE INITIAL FUNCTION VALUE WHEN ND .LT. N ***
-C
- 170 IF (N .LE. ND) GO TO 180
- T = DV2NRM(NN, R)
- IF (T .GT. V(RLIMIT)) GO TO 210
- V(F) = V(F) + HALF * T**2
-C
-C *** UPDATE D IF DESIRED ***
-C
- 180 IF (IV(DTYPE) .GT. 0)
- 1 CALL DD7UPD(D, DR, IV, LIV, LV, N, ND, NN, N2, P, V)
-C
-C *** COMPUTE RMAT AND QTR ***
-C
- QTR1 = IV(QTR)
- RMAT1 = IV(RMAT)
- CALL DQ7RAD(NN, ND, P, V(QTR1), .TRUE., V(RMAT1), DR, R)
- IV(NF1) = 0
- IF (N1 .GT. 1) GO TO 200
- IF (N2 .LT. N) GO TO 250
-C
-C *** SAVE DIAGONAL OF R FOR COMPUTING Y LATER ***
-C
- RD1 = QTR1 + P
- L = RMAT1 - 1
- DO 190 I = 1, P
- L = L + I
- V(RD1) = V(L)
- RD1 = RD1 + 1
- 190 CONTINUE
-C
- 200 IF (N2 .LT. N) GO TO 250
- IF (IVMODE .GT. 0) GO TO 40
- IV(NF00) = IV(NFGCAL)
-C
-C *** COMPUTE G FROM RMAT AND QTR ***
-C
- CALL DL7VML(P, V(G1), V(RMAT1), V(QTR1))
- IV(1) = 2
- IF (IVMODE .EQ. 0) GO TO 40
- IF (N .LE. ND) GO TO 40
-C
-C *** FINISH SPECIAL CASE HANDLING OF FIRST FUNCTION AND GRADIENT
-C
- Y1 = G1 + P
- IV(1) = 1
- CALL DG7ITB(B, D, V(G1), IV, LIV, LV, P, P, V, X, V(Y1))
- IF (IV(1) .NE. 2) GO TO 260
- GO TO 40
-C
-C *** MISC. DETAILS ***
-C
-C *** X IS OUT OF RANGE (OVERSIZE STEP) ***
-C
- 210 IV(TOOBIG) = 1
- GO TO 40
-C
-C *** BAD N, ND, OR P ***
-C
- 220 IV(1) = 66
- GO TO 270
-C
-C *** RECORD EXTRA EVALUATIONS FOR FINITE-DIFFERENCE HESSIAN ***
-C
- 230 IV(NFCOV) = IV(NFCOV) + 1
- IV(NFCALL) = IV(NFCALL) + 1
- IV(NFGCAL) = IV(NFCALL)
- IV(1) = -1
-C
-C *** RETURN FOR MORE FUNCTION OR GRADIENT INFORMATION ***
-C
- 240 N2 = 0
- 250 N1 = N2 + 1
- N2 = N2 + ND
- IF (N2 .GT. N) N2 = N
- GO TO 999
-C
-C *** PRINT SUMMARY OF FINAL ITERATION AND OTHER REQUESTED ITEMS ***
-C
- 260 G1 = IV(G)
- 270 CALL DITSUM(D, V(G1), IV, LIV, LV, P, V, X)
-C
- 999 RETURN
-C *** LAST CARD OF DRN2GB FOLLOWS ***
- END
diff --git a/CEP/PyBDSM/src/port3/drnsg.f b/CEP/PyBDSM/src/port3/drnsg.f
deleted file mode 100644
index 824da1263b6f7613ce3d9c186c1a7ed32d04a627..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/drnsg.f
+++ /dev/null
@@ -1,455 +0,0 @@
- SUBROUTINE DRNSG(A, ALF, C, DA, IN, IV, L, L1, LA, LIV, LV,
- 1 N, NDA, P, V, Y)
-C
-C *** ITERATION DRIVER FOR SEPARABLE NONLINEAR LEAST SQUARES.
-C
-C *** PARAMETER DECLARATIONS ***
-C
- INTEGER L, L1, LA, LIV, LV, N, NDA, P
- INTEGER IN(2,NDA), IV(LIV)
-C DIMENSION UIPARM(*)
- DOUBLE PRECISION A(LA,L1), ALF(P), C(L), DA(LA,NDA), V(LV), Y(N)
-C
-C *** PURPOSE ***
-C
-C GIVEN A SET OF N OBSERVATIONS Y(1)....Y(N) OF A DEPENDENT VARIABLE
-C T(1)...T(N), DRNSG ATTEMPTS TO COMPUTE A LEAST SQUARES FIT
-C TO A FUNCTION ETA (THE MODEL) WHICH IS A LINEAR COMBINATION
-C
-C L
-C ETA(C,ALF,T) = SUM C * PHI(ALF,T) +PHI (ALF,T)
-C J=1 J J L+1
-C
-C OF NONLINEAR FUNCTIONS PHI(J) DEPENDENT ON T AND ALF(1),...,ALF(P)
-C (.E.G. A SUM OF EXPONENTIALS OR GAUSSIANS). THAT IS, IT DETERMINES
-C NONLINEAR PARAMETERS ALF WHICH MINIMIZE
-C
-C 2 N 2
-C NORM(RESIDUAL) = SUM (Y - ETA(C,ALF,T )).
-C I=1 I I
-C
-C THE (L+1)ST TERM IS OPTIONAL.
-C
-C
-C *** PARAMETERS ***
-C
-C A (IN) MATRIX PHI(ALF,T) OF THE MODEL.
-C ALF (I/O) NONLINEAR PARAMETERS.
-C INPUT = INITIAL GUESS,
-C OUTPUT = BEST ESTIMATE FOUND.
-C C (OUT) LINEAR PARAMETERS (ESTIMATED).
-C DA (IN) DERIVATIVES OF COLUMNS OF A WITH RESPECT TO COMPONENTS
-C OF ALF, AS SPECIFIED BY THE IN ARRAY...
-C IN (IN) WHEN DRNSG IS CALLED WITH IV(1) = 2 OR -2, THEN FOR
-C I = 1(1)NDA, COLUMN I OF DA IS THE PARTIAL
-C DERIVATIVE WITH RESPECT TO ALF(IN(1,I)) OF COLUMN
-C IN(2,I) OF A, UNLESS IV(1,I) IS NOT POSITIVE (IN
-C WHICH CASE COLUMN I OF DA IS IGNORED. IV(1) = -2
-C MEANS THERE ARE MORE COLUMNS OF DA TO COME AND
-C DRNSG SHOULD RETURN FOR THEM.
-C IV (I/O) INTEGER PARAMETER AND SCRATCH VECTOR. DRNSG RETURNS
-C WITH IV(1) = 1 WHEN IT WANTS A TO BE EVALUATED AT
-C ALF AND WITH IV(1) = 2 WHEN IT WANTS DA TO BE
-C EVALUATED AT ALF. WHEN CALLED WITH IV(1) = -2
-C (AFTER A RETURN WITH IV(1) = 2), DRNSG RETURNS
-C WITH IV(1) = -2 TO GET MORE COLUMNS OF DA.
-C L (IN) NUMBER OF LINEAR PARAMETERS TO BE ESTIMATED.
-C L1 (IN) L+1 IF PHI(L+1) IS IN THE MODEL, L IF NOT.
-C LA (IN) LEAD DIMENSION OF A. MUST BE AT LEAST N.
-C LIV (IN) LENGTH OF IV. MUST BE AT LEAST 110 + L + P.
-C LV (IN) LENGTH OF V. MUST BE AT LEAST
-C 105 + 2*N + JLEN + L*(L+3)/2 + P*(2*P + 17),
-C WHERE JLEN = (L+P)*(N+L+P+1), UNLESS NEITHER A
-C COVARIANCE MATRIX NOR REGRESSION DIAGNOSTICS ARE
-C REQUESTED, IN WHICH CASE JLEN = N*P.
-C N (IN) NUMBER OF OBSERVATIONS.
-C NDA (IN) NUMBER OF COLUMNS IN DA AND IN.
-C P (IN) NUMBER OF NONLINEAR PARAMETERS TO BE ESTIMATED.
-C V (I/O) FLOATING-POINT PARAMETER AND SCRATCH VECTOR.
-C IF A COVARIANCE ESTIMATE IS REQUESTED, IT IS FOR
-C (ALF,C) -- NONLINEAR PARAMETERS ORDERED FIRST,
-C FOLLOWED BY LINEAR PARAMETERS.
-C Y (IN) RIGHT-HAND SIDE VECTOR.
-C
-C
-C *** EXTERNAL SUBROUTINES ***
-C
- DOUBLE PRECISION DD7TPR, DL7SVX, DL7SVN, DR7MDC
- EXTERNAL DC7VFN,DIVSET, DD7TPR,DITSUM, DL7ITV,DL7SRT, DL7SVX,
- 1 DL7SVN, DN2CVP, DN2LRD, DN2RDP, DRN2G, DQ7APL,DQ7RAD,
- 2 DQ7RFH, DR7MDC, DS7CPR,DV2AXY,DV7CPY,DV7PRM, DV7SCL,
- 3 DV7SCP
-C
-C DC7VFN... FINISHES COVARIANCE COMPUTATION.
-C DIVSET.... SUPPLIES DEFAULT PARAMETER VALUES.
-C DD7TPR... RETURNS INNER PRODUCT OF TWO VECTORS.
-C DITSUM.... PRINTS ITERATION SUMMARY, INITIAL AND FINAL ALF.
-C DL7ITV... APPLIES INVERSE-TRANSPOSE OF COMPACT LOWER TRIANG. MATRIX.
-C DL7SRT.... COMPUTES (PARTIAL) CHOLESKY FACTORIZATION.
-C DL7SVX... ESTIMATES LARGEST SING. VALUE OF LOWER TRIANG. MATRIX.
-C DL7SVN... ESTIMATES SMALLEST SING. VALUE OF LOWER TRIANG. MATRIX.
-C DN2CVP... PRINTS COVARIANCE MATRIX.
-C DN2LRD... COMPUTES COVARIANCE AND REGRESSION DIAGNOSTICS.
-C DN2RDP... PRINTS REGRESSION DIAGNOSTICS.
-C DRN2G... UNDERLYING NONLINEAR LEAST-SQUARES SOLVER.
-C DQ7APL... APPLIES HOUSEHOLDER TRANSFORMS STORED BY DQ7RFH.
-C DQ7RFH.... COMPUTES QR FACT. VIA HOUSEHOLDER TRANSFORMS WITH PIVOTING.
-C DQ7RAD.... QR FACT., NO PIVOTING.
-C DR7MDC... RETURNS MACHINE-DEP. CONSTANTS.
-C DS7CPR... PRINTS LINEAR PARAMETERS AT SOLUTION.
-C DV2AXY.... ADDS MULTIPLE OF ONE VECTOR TO ANOTHER.
-C DV7CPY.... COPIES ONE VECTOR TO ANOTHER.
-C DV7PRM.... PERMUTES A VECTOR.
-C DV7SCL... SCALES AND COPIES ONE VECTOR TO ANOTHER.
-C DV7SCP... SETS ALL COMPONENTS OF A VECTOR TO A SCALAR.
-C
-C *** LOCAL VARIABLES ***
-C
- LOGICAL NOCOV
- INTEGER AR1, CSAVE1, D1, DR1, DR1L, DRI, DRI1, FDH0, HSAVE, I, I1,
- 1 IPIV1, IER, IV1, J1, JLEN, K, LH, LI, LL1O2, MD, N1, N2,
- 2 NML, NRAN, PP, PP1, R1, R1L, RD1, TEMP1
- DOUBLE PRECISION SINGTL, T
- DOUBLE PRECISION MACHEP, NEGONE, SNGFAC, ZERO
-C
-C *** SUBSCRIPTS FOR IV AND V ***
-C
- INTEGER AR, CNVCOD, COVMAT, COVREQ, CSAVE, CVRQSV, D, FDH, H,
- 1 IERS, IPIVS, IV1SAV, IVNEED, J, LMAT, MODE, NEXTIV, NEXTV,
- 2 NFCALL, NFCOV, NFGCAL, NGCALL, NGCOV, PERM, R, RCOND,
- 3 RDREQ, RDRQSV, REGD, REGD0, RESTOR, TOOBIG, VNEED
-C
-C *** IV SUBSCRIPT VALUES ***
-C
-C/6
-C DATA AR/110/, CNVCOD/55/, COVMAT/26/, COVREQ/15/, CSAVE/105/,
-C 1 CVRQSV/106/, D/27/, FDH/74/, H/56/, IERS/108/, IPIVS/109/,
-C 2 IV1SAV/104/, IVNEED/3/, J/70/, LMAT/42/, MODE/35/,
-C 3 NEXTIV/46/, NEXTV/47/, NFCALL/6/, NFCOV/52/, NFGCAL/7/,
-C 4 NGCALL/30/, NGCOV/53/, PERM/58/, R/61/, RCOND/53/, RDREQ/57/,
-C 5 RDRQSV/107/, REGD/67/, REGD0/82/, RESTOR/9/, TOOBIG/2/,
-C 6 VNEED/4/
-C/7
- PARAMETER (AR=110, CNVCOD=55, COVMAT=26, COVREQ=15, CSAVE=105,
- 1 CVRQSV=106, D=27, FDH=74, H=56, IERS=108, IPIVS=109,
- 2 IV1SAV=104, IVNEED=3, J=70, LMAT=42, MODE=35,
- 3 NEXTIV=46, NEXTV=47, NFCALL=6, NFCOV=52, NFGCAL=7,
- 4 NGCALL=30, NGCOV=53, PERM=58, R=61, RCOND=53, RDREQ=57,
- 5 RDRQSV=107, REGD=67, REGD0=82, RESTOR=9, TOOBIG=2,
- 6 VNEED=4)
-C/
- DATA MACHEP/-1.D+0/, NEGONE/-1.D+0/, SNGFAC/1.D+2/, ZERO/0.D+0/
-C
-C++++++++++++++++++++++++++++++++ BODY ++++++++++++++++++++++++++++++
-C
-C
- IF (IV(1) .EQ. 0) CALL DIVSET(1, IV, LIV, LV, V)
- N1 = 1
- NML = N
- IV1 = IV(1)
- IF (IV1 .LE. 2) GO TO 20
-C
-C *** CHECK INPUT INTEGERS ***
-C
- IF (P .LE. 0) GO TO 370
- IF (L .LT. 0) GO TO 370
- IF (N .LE. L) GO TO 370
- IF (LA .LT. N) GO TO 370
- IF (IV1 .LT. 12) GO TO 20
- IF (IV1 .EQ. 14) GO TO 20
- IF (IV1 .EQ. 12) IV(1) = 13
-C
-C *** FRESH START -- COMPUTE STORAGE REQUIREMENTS ***
-C
- IF (IV(1) .GT. 16) GO TO 370
- LL1O2 = L*(L+1)/2
- JLEN = N*P
- I = L + P
- IF (IV(RDREQ) .GT. 0 .AND. IV(COVREQ) .NE. 0) JLEN = I*(N + I + 1)
- IF (IV(1) .NE. 13) GO TO 10
- IV(IVNEED) = IV(IVNEED) + L
- IV(VNEED) = IV(VNEED) + P + 2*N + JLEN + LL1O2 + L
- 10 IF (IV(PERM) .LE. AR) IV(PERM) = AR + 1
- CALL DRN2G(V, V, IV, LIV, LV, N, N, N1, NML, P, V, V, V, ALF)
- IF (IV(1) .NE. 14) GO TO 999
-C
-C *** STORAGE ALLOCATION ***
-C
- IV(IPIVS) = IV(NEXTIV)
- IV(NEXTIV) = IV(NEXTIV) + L
- IV(D) = IV(NEXTV)
- IV(REGD0) = IV(D) + P
- IV(AR) = IV(REGD0) + N
- IV(CSAVE) = IV(AR) + LL1O2
- IV(J) = IV(CSAVE) + L
- IV(R) = IV(J) + JLEN
- IV(NEXTV) = IV(R) + N
- IV(IERS) = 0
- IF (IV1 .EQ. 13) GO TO 999
-C
-C *** SET POINTERS INTO IV AND V ***
-C
- 20 AR1 = IV(AR)
- D1 = IV(D)
- DR1 = IV(J)
- DR1L = DR1 + L
- R1 = IV(R)
- R1L = R1 + L
- RD1 = IV(REGD0)
- CSAVE1 = IV(CSAVE)
- NML = N - L
- IF (IV1 .LE. 2) GO TO 50
-C
-C *** IF F.D. HESSIAN WILL BE NEEDED (FOR COVARIANCE OR REG.
-C *** DIAGNOSTICS), HAVE DRN2G COMPUTE ONLY THE PART CORRESP.
-C *** TO ALF WITH C FIXED...
-C
- IF (L .LE. 0) GO TO 30
- IV(CVRQSV) = IV(COVREQ)
- IF (IABS(IV(COVREQ)) .GE. 3) IV(COVREQ) = 0
- IV(RDRQSV) = IV(RDREQ)
- IF (IV(RDREQ) .GT. 0) IV(RDREQ) = -1
-C
- 30 N2 = NML
- CALL DRN2G(V(D1), V(DR1L), IV, LIV, LV, NML, N, N1, N2, P,
- 1 V(R1L), V(RD1), V, ALF)
- IF (IABS(IV(RESTOR)-2) .EQ. 1 .AND. L .GT. 0)
- 1 CALL DV7CPY(L, C, V(CSAVE1))
- IV1 = IV(1)
- IF (IV1-2) 40, 150, 230
-C
-C *** NEW FUNCTION VALUE (RESIDUAL) NEEDED ***
-C
- 40 IV(IV1SAV) = IV(1)
- IV(1) = IABS(IV1)
- IF (IV(RESTOR) .EQ. 2 .AND. L .GT. 0) CALL DV7CPY(L, V(CSAVE1), C)
- GO TO 999
-C
-C *** COMPUTE NEW RESIDUAL OR GRADIENT ***
-C
- 50 IV(1) = IV(IV1SAV)
- MD = IV(MODE)
- IF (MD .LE. 0) GO TO 60
- NML = N
- DR1L = DR1
- R1L = R1
- 60 IF (IV(TOOBIG) .NE. 0) GO TO 30
- IF (IABS(IV1) .EQ. 2) GO TO 170
-C
-C *** COMPUTE NEW RESIDUAL ***
-C
- IF (L1 .LE. L) CALL DV7CPY(N, V(R1), Y)
- IF (L1 .GT. L) CALL DV2AXY(N, V(R1), NEGONE, A(1,L1), Y)
- IF (MD .GT. 0) GO TO 120
- IER = 0
- IF (L .LE. 0) GO TO 110
- LL1O2 = L * (L + 1) / 2
- IPIV1 = IV(IPIVS)
- CALL DQ7RFH(IER, IV(IPIV1), N, LA, 0, L, A, V(AR1), LL1O2, C)
-C
-C *** DETERMINE NUMERICAL RANK OF A ***
-C
- IF (MACHEP .LE. ZERO) MACHEP = DR7MDC(3)
- SINGTL = SNGFAC * FLOAT(MAX0(L,N)) * MACHEP
- K = L
- IF (IER .NE. 0) K = IER - 1
- 70 IF (K .LE. 0) GO TO 90
- T = DL7SVX(K, V(AR1), C, C)
- IF (T .GT. ZERO) T = DL7SVN(K, V(AR1), C, C) / T
- IF (T .GT. SINGTL) GO TO 80
- K = K - 1
- GO TO 70
-C
-C *** RECORD RANK IN IV(IERS)... IV(IERS) = 0 MEANS FULL RANK,
-C *** IV(IERS) .GT. 0 MEANS RANK IV(IERS) - 1.
-C
- 80 IF (K .GE. L) GO TO 100
- 90 IER = K + 1
- CALL DV7SCP(L-K, C(K+1), ZERO)
- 100 IV(IERS) = IER
- IF (K .LE. 0) GO TO 110
-C
-C *** APPLY HOUSEHOLDER TRANSFORMATONS TO RESIDUALS...
-C
- CALL DQ7APL(LA, N, K, A, V(R1), IER)
-C
-C *** COMPUTING C NOW MAY SAVE A FUNCTION EVALUATION AT
-C *** THE LAST ITERATION.
-C
- CALL DL7ITV(K, C, V(AR1), V(R1))
- CALL DV7PRM(L, IV(IPIV1), C)
-C
- 110 IF(IV(1) .LT. 2) GO TO 220
- GO TO 999
-C
-C
-C *** RESIDUAL COMPUTATION FOR F.D. HESSIAN ***
-C
- 120 IF (L .LE. 0) GO TO 140
- DO 130 I = 1, L
- 130 CALL DV2AXY(N, V(R1), -C(I), A(1,I), V(R1))
- 140 IF (IV(1) .GT. 0) GO TO 30
- IV(1) = 2
- GO TO 160
-C
-C *** NEW GRADIENT (JACOBIAN) NEEDED ***
-C
- 150 IV(IV1SAV) = IV1
- IF (IV(NFGCAL) .NE. IV(NFCALL)) IV(1) = 1
- 160 CALL DV7SCP(N*P, V(DR1), ZERO)
- GO TO 999
-C
-C *** COMPUTE NEW JACOBIAN ***
-C
- 170 NOCOV = MD .LE. P .OR. IABS(IV(COVREQ)) .GE. 3
- FDH0 = DR1 + N*(P+L)
- IF (NDA .LE. 0) GO TO 370
- DO 180 I = 1, NDA
- I1 = IN(1,I) - 1
- IF (I1 .LT. 0) GO TO 180
- J1 = IN(2,I)
- K = DR1 + I1*N
- T = NEGONE
- IF (J1 .LE. L) T = -C(J1)
- CALL DV2AXY(N, V(K), T, DA(1,I), V(K))
- IF (NOCOV) GO TO 180
- IF (J1 .GT. L) GO TO 180
-C *** ADD IN (L,P) PORTION OF SECOND-ORDER PART OF HESSIAN
-C *** FOR COVARIANCE OR REG. DIAG. COMPUTATIONS...
- J1 = J1 + P
- K = FDH0 + J1*(J1-1)/2 + I1
- V(K) = V(K) - DD7TPR(N, V(R1), DA(1,I))
- 180 CONTINUE
- IF (IV1 .EQ. 2) GO TO 190
- IV(1) = IV1
- GO TO 999
- 190 IF (L .LE. 0) GO TO 30
- IF (MD .GT. P) GO TO 240
- IF (MD .GT. 0) GO TO 30
- K = DR1
- IER = IV(IERS)
- NRAN = L
- IF (IER .GT. 0) NRAN = IER - 1
- IF (NRAN .LE. 0) GO TO 210
- DO 200 I = 1, P
- CALL DQ7APL(LA, N, NRAN, A, V(K), IER)
- K = K + N
- 200 CONTINUE
- 210 CALL DV7CPY(L, V(CSAVE1), C)
- 220 IF (IER .EQ. 0) GO TO 30
-C
-C *** ADJUST SUBSCRIPTS DESCRIBING R AND DR...
-C
- NRAN = IER - 1
- DR1L = DR1 + NRAN
- NML = N - NRAN
- R1L = R1 + NRAN
- GO TO 30
-C
-C *** CONVERGENCE OR LIMIT REACHED ***
-C
- 230 IF (L .LE. 0) GO TO 350
- IV(COVREQ) = IV(CVRQSV)
- IV(RDREQ) = IV(RDRQSV)
- IF (IV(1) .GT. 6) GO TO 360
- IF (MOD(IV(RDREQ),4) .EQ. 0) GO TO 360
- IF (IV(FDH) .LE. 0 .AND. IABS(IV(COVREQ)) .LT. 3) GO TO 360
- IF (IV(REGD) .GT. 0) GO TO 360
- IF (IV(COVMAT) .GT. 0) GO TO 360
-C
-C *** PREPARE TO FINISH COMPUTING COVARIANCE MATRIX AND REG. DIAG. ***
-C
- PP = L + P
- I = 0
- IF (MOD(IV(RDREQ),4) .GE. 2) I = 1
- IF (MOD(IV(RDREQ),2) .EQ. 1 .AND. IABS(IV(COVREQ)) .EQ. 1) I = I+2
- IV(MODE) = PP + I
- I = DR1 + N*PP
- K = P * (P + 1) / 2
- I1 = IV(LMAT)
- CALL DV7CPY(K, V(I), V(I1))
- I = I + K
- CALL DV7SCP(PP*(PP+1)/2 - K, V(I), ZERO)
- IV(NFCOV) = IV(NFCOV) + 1
- IV(NFCALL) = IV(NFCALL) + 1
- IV(NFGCAL) = IV(NFCALL)
- IV(CNVCOD) = IV(1)
- IV(IV1SAV) = -1
- IV(1) = 1
- IV(NGCALL) = IV(NGCALL) + 1
- IV(NGCOV) = IV(NGCOV) + 1
- GO TO 999
-C
-C *** FINISH COVARIANCE COMPUTATION ***
-C
- 240 I = DR1 + N*P
- DO 250 I1 = 1, L
- CALL DV7SCL(N, V(I), NEGONE, A(1,I1))
- I = I + N
- 250 CONTINUE
- PP = L + P
- HSAVE = IV(H)
- K = DR1 + N*PP
- LH = PP * (PP + 1) / 2
- IF (IABS(IV(COVREQ)) .LT. 3) GO TO 270
- I = IV(MODE) - 4
- IF (I .GE. PP) GO TO 260
- CALL DV7SCP(LH, V(K), ZERO)
- CALL DQ7RAD(N, N, PP, V, .FALSE., V(K), V(DR1), V)
- IV(MODE) = I + 8
- IV(1) = 2
- IV(NGCALL) = IV(NGCALL) + 1
- IV(NGCOV) = IV(NGCOV) + 1
- GO TO 160
-C
- 260 IV(MODE) = I
- GO TO 300
-C
- 270 PP1 = P + 1
- DRI = DR1 + N*P
- LI = K + P*PP1/2
- DO 290 I = PP1, PP
- DRI1 = DR1
- DO 280 I1 = 1, I
- V(LI) = V(LI) + DD7TPR(N, V(DRI), V(DRI1))
- LI = LI + 1
- DRI1 = DRI1 + N
- 280 CONTINUE
- DRI = DRI + N
- 290 CONTINUE
- CALL DL7SRT(PP1, PP, V(K), V(K), I)
- IF (I .NE. 0) GO TO 310
- 300 TEMP1 = K + LH
- T = DL7SVN(PP, V(K), V(TEMP1), V(TEMP1))
- IF (T .LE. ZERO) GO TO 310
- T = T / DL7SVX(PP, V(K), V(TEMP1), V(TEMP1))
- V(RCOND) = T
- IF (T .GT. DR7MDC(4)) GO TO 320
- 310 IV(REGD) = -1
- IV(COVMAT) = -1
- IV(FDH) = -1
- GO TO 340
- 320 IV(H) = TEMP1
- IV(FDH) = IABS(HSAVE)
- IF (IV(MODE) - PP .LT. 2) GO TO 330
- I = IV(H)
- CALL DV7SCP(LH, V(I), ZERO)
- 330 CALL DN2LRD(V(DR1), IV, V(K), LH, LIV, LV, N, N, PP, V(R1),
- 1 V(RD1), V)
- 340 CALL DC7VFN(IV, V(K), LH, LIV, LV, N, PP, V)
- IV(H) = HSAVE
-C
- 350 IF (IV(REGD) .EQ. 1) IV(REGD) = RD1
- 360 IF (IV(1) .LE. 11) CALL DS7CPR(C, IV, L, LIV)
- IF (IV(1) .GT. 6) GO TO 999
- CALL DN2CVP(IV, LIV, LV, P+L, V)
- CALL DN2RDP(IV, LIV, LV, N, V(RD1), V)
- GO TO 999
-C
- 370 IV(1) = 66
- CALL DITSUM(V, V, IV, LIV, LV, P, V, ALF)
-C
- 999 RETURN
-C
-C *** LAST CARD OF DRNSG FOLLOWS ***
- END
diff --git a/CEP/PyBDSM/src/port3/drnsgb.f b/CEP/PyBDSM/src/port3/drnsgb.f
deleted file mode 100644
index 3003a8af3c72b3931eea4257285e629127bb60c2..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/drnsgb.f
+++ /dev/null
@@ -1,322 +0,0 @@
- SUBROUTINE DRNSGB(A, ALF, B, C, DA, IN, IV, L, L1, LA, LIV, LV,
- 1 N, NDA, P, V, Y)
-C
-C *** ITERATION DRIVER FOR SEPARABLE NONLINEAR LEAST SQUARES,
-C *** WITH SIMPLE BOUNDS ON THE NONLINEAR VARIABLES.
-C
-C *** PARAMETER DECLARATIONS ***
-C
- INTEGER L, L1, LA, LIV, LV, N, NDA, P
- INTEGER IN(2,NDA), IV(LIV)
-C DIMENSION UIPARM(*)
- DOUBLE PRECISION A(LA,L1), ALF(P), B(2,P), C(L), DA(LA,NDA),
- 1 V(LV), Y(N)
-C
-C *** PURPOSE ***
-C
-C GIVEN A SET OF N OBSERVATIONS Y(1)....Y(N) OF A DEPENDENT VARIABLE
-C T(1)...T(N), DRNSGB ATTEMPTS TO COMPUTE A LEAST SQUARES FIT
-C TO A FUNCTION ETA (THE MODEL) WHICH IS A LINEAR COMBINATION
-C
-C L
-C ETA(C,ALF,T) = SUM C * PHI(ALF,T) +PHI (ALF,T)
-C J=1 J J L+1
-C
-C OF NONLINEAR FUNCTIONS PHI(J) DEPENDENT ON T AND ALF(1),...,ALF(P)
-C (.E.G. A SUM OF EXPONENTIALS OR GAUSSIANS). THAT IS, IT DETERMINES
-C NONLINEAR PARAMETERS ALF WHICH MINIMIZE
-C
-C 2 N 2
-C NORM(RESIDUAL) = SUM (Y - ETA(C,ALF,T )) ,
-C I=1 I I
-C
-C SUBJECT TO THE SIMPLE BOUND CONSTRAINTS
-C B(1,I) .LE. ALF(I) .LE. B(2,I), I = 1(1)P.
-C
-C THE (L+1)ST TERM IS OPTIONAL.
-C
-C
-C *** PARAMETERS ***
-C
-C A (IN) MATRIX PHI(ALF,T) OF THE MODEL.
-C ALF (I/O) NONLINEAR PARAMETERS.
-C INPUT = INITIAL GUESS,
-C OUTPUT = BEST ESTIMATE FOUND.
-C C (OUT) LINEAR PARAMETERS (ESTIMATED).
-C DA (IN) DERIVATIVES OF COLUMNS OF A WITH RESPECT TO COMPONENTS
-C OF ALF, AS SPECIFIED BY THE IN ARRAY...
-C IN (IN) WHEN DRNSGB IS CALLED WITH IV(1) = 2 OR -2, THEN FOR
-C I = 1(1)NDA, COLUMN I OF DA IS THE PARTIAL
-C DERIVATIVE WITH RESPECT TO ALF(IN(1,I)) OF COLUMN
-C IN(2,I) OF A, UNLESS IV(1,I) IS NOT POSITIVE (IN
-C WHICH CASE COLUMN I OF DA IS IGNORED. IV(1) = -2
-C MEANS THERE ARE MORE COLUMNS OF DA TO COME AND
-C DRNSGB SHOULD RETURN FOR THEM.
-C IV (I/O) INTEGER PARAMETER AND SCRATCH VECTOR. DRNSGB RETURNS
-C WITH IV(1) = 1 WHEN IT WANTS A TO BE EVALUATED AT
-C ALF AND WITH IV(1) = 2 WHEN IT WANTS DA TO BE
-C EVALUATED AT ALF. WHEN CALLED WITH IV(1) = -2
-C (AFTER A RETURN WITH IV(1) = 2), DRNSGB RETURNS
-C WITH IV(1) = -2 TO GET MORE COLUMNS OF DA.
-C L (IN) NUMBER OF LINEAR PARAMETERS TO BE ESTIMATED.
-C L1 (IN) L+1 IF PHI(L+1) IS IN THE MODEL, L IF NOT.
-C LA (IN) LEAD DIMENSION OF A. MUST BE AT LEAST N.
-C LIV (IN) LENGTH OF IV. MUST BE AT LEAST 110 + L + 4*P.
-C LV (IN) LENGTH OF V. MUST BE AT LEAST
-C 105 + 2*N + L*(L+3)/2 + P*(2*P + 21 + N).
-C N (IN) NUMBER OF OBSERVATIONS.
-C NDA (IN) NUMBER OF COLUMNS IN DA AND IN.
-C P (IN) NUMBER OF NONLINEAR PARAMETERS TO BE ESTIMATED.
-C V (I/O) FLOATING-POINT PARAMETER AND SCRATCH VECTOR.
-C Y (IN) RIGHT-HAND SIDE VECTOR.
-C
-C
-C *** EXTERNAL SUBROUTINES ***
-C
- DOUBLE PRECISION DL7SVX, DL7SVN, DR7MDC
- EXTERNAL DIVSET,DITSUM, DL7ITV, DL7SVX, DL7SVN, DRN2GB, DQ7APL,
- 1 DQ7RFH, DR7MDC, DS7CPR,DV2AXY,DV7CPY,DV7PRM, DV7SCP
-C
-C DIVSET.... SUPPLIES DEFAULT PARAMETER VALUES.
-C DITSUM.... PRINTS ITERATION SUMMARY, INITIAL AND FINAL ALF.
-C DL7ITV... APPLIES INVERSE-TRANSPOSE OF COMPACT LOWER TRIANG. MATRIX.
-C DL7SVX... ESTIMATES LARGEST SING. VALUE OF LOWER TRIANG. MATRIX.
-C DL7SVN... ESTIMATES SMALLEST SING. VALUE OF LOWER TRIANG. MATRIX.
-C DRN2GB... UNDERLYING NONLINEAR LEAST-SQUARES SOLVER.
-C DQ7APL... APPLIES HOUSEHOLDER TRANSFORMS STORED BY DQ7RFH.
-C DQ7RFH.... COMPUTES QR FACT. VIA HOUSEHOLDER TRANSFORMS WITH PIVOTING.
-C DR7MDC... RETURNS MACHINE-DEP. CONSTANTS.
-C DS7CPR... PRINTS LINEAR PARAMETERS AT SOLUTION.
-C DV2AXY.... ADDS MULTIPLE OF ONE VECTOR TO ANOTHER.
-C DV7CPY.... COPIES ONE VECTOR TO ANOTHER.
-C DV7PRM.... PERMUTES VECTOR.
-C DV7SCL... SCALES AND COPIES ONE VECTOR TO ANOTHER.
-C
-C *** LOCAL VARIABLES ***
-C
- INTEGER AR1, CSAVE1, D1, DR1, DR1L, I, I1,
- 1 IPIV1, IER, IV1, J1, JLEN, K, LL1O2, MD, N1, N2,
- 2 NML, NRAN, R1, R1L, RD1
- DOUBLE PRECISION SINGTL, T
- DOUBLE PRECISION MACHEP, NEGONE, SNGFAC, ZERO
-C
-C *** SUBSCRIPTS FOR IV AND V ***
-C
- INTEGER AR, CSAVE, D, IERS, IPIVS, IV1SAV,
- 2 IVNEED, J, MODE, NEXTIV, NEXTV,
- 2 NFCALL, NFGCAL, PERM, R,
- 3 REGD, REGD0, RESTOR, TOOBIG, VNEED
-C
-C *** IV SUBSCRIPT VALUES ***
-C
-C/6
-C DATA AR/110/, CSAVE/105/, D/27/, IERS/108/, IPIVS/109/,
-C 1 IV1SAV/104/, IVNEED/3/, J/70/, MODE/35/, NEXTIV/46/,
-C 2 NEXTV/47/, NFCALL/6/, NFGCAL/7/, PERM/58/, R/61/, REGD/67/,
-C 3 REGD0/82/, RESTOR/9/, TOOBIG/2/, VNEED/4/
-C/7
- PARAMETER (AR=110, CSAVE=105, D=27, IERS=108, IPIVS=109,
- 1 IV1SAV=104, IVNEED=3, J=70, MODE=35, NEXTIV=46,
- 2 NEXTV=47, NFCALL=6, NFGCAL=7, PERM=58, R=61, REGD=67,
- 3 REGD0=82, RESTOR=9, TOOBIG=2, VNEED=4)
-C/
- DATA MACHEP/-1.D+0/, NEGONE/-1.D+0/, SNGFAC/1.D+2/, ZERO/0.D+0/
-C
-C++++++++++++++++++++++++++++++++ BODY ++++++++++++++++++++++++++++++
-C
-C
- IF (IV(1) .EQ. 0) CALL DIVSET(1, IV, LIV, LV, V)
- N1 = 1
- NML = N
- IV1 = IV(1)
- IF (IV1 .LE. 2) GO TO 20
-C
-C *** CHECK INPUT INTEGERS ***
-C
- IF (P .LE. 0) GO TO 240
- IF (L .LT. 0) GO TO 240
- IF (N .LE. L) GO TO 240
- IF (LA .LT. N) GO TO 240
- IF (IV1 .LT. 12) GO TO 20
- IF (IV1 .EQ. 14) GO TO 20
- IF (IV1 .EQ. 12) IV(1) = 13
-C
-C *** FRESH START -- COMPUTE STORAGE REQUIREMENTS ***
-C
- IF (IV(1) .GT. 16) GO TO 240
- LL1O2 = L*(L+1)/2
- JLEN = N*P
- I = L + P
- IF (IV(1) .NE. 13) GO TO 10
- IV(IVNEED) = IV(IVNEED) + L
- IV(VNEED) = IV(VNEED) + P + 2*N + JLEN + LL1O2 + L
- 10 IF (IV(PERM) .LE. AR) IV(PERM) = AR + 1
- CALL DRN2GB(B, V, V, IV, LIV, LV, N, N, N1, NML, P, V, V, V, ALF)
- IF (IV(1) .NE. 14) GO TO 999
-C
-C *** STORAGE ALLOCATION ***
-C
- IV(IPIVS) = IV(NEXTIV)
- IV(NEXTIV) = IV(NEXTIV) + L
- IV(D) = IV(NEXTV)
- IV(REGD0) = IV(D) + P
- IV(AR) = IV(REGD0) + N
- IV(CSAVE) = IV(AR) + LL1O2
- IV(J) = IV(CSAVE) + L
- IV(R) = IV(J) + JLEN
- IV(NEXTV) = IV(R) + N
- IV(IERS) = 0
- IF (IV1 .EQ. 13) GO TO 999
-C
-C *** SET POINTERS INTO IV AND V ***
-C
- 20 AR1 = IV(AR)
- D1 = IV(D)
- DR1 = IV(J)
- DR1L = DR1 + L
- R1 = IV(R)
- R1L = R1 + L
- RD1 = IV(REGD0)
- CSAVE1 = IV(CSAVE)
- NML = N - L
- IF (IV1 .LE. 2) GO TO 50
-C
- 30 N2 = NML
- CALL DRN2GB(B, V(D1), V(DR1L), IV, LIV, LV, NML, N, N1, N2, P,
- 1 V(R1L), V(RD1), V, ALF)
- IF (IABS(IV(RESTOR)-2) .EQ. 1 .AND. L .GT. 0)
- 1 CALL DV7CPY(L, C, V(CSAVE1))
- IV1 = IV(1)
- IF (IV1-2) 40, 150, 230
-C
-C *** NEW FUNCTION VALUE (RESIDUAL) NEEDED ***
-C
- 40 IV(IV1SAV) = IV(1)
- IV(1) = IABS(IV1)
- IF (IV(RESTOR) .EQ. 2 .AND. L .GT. 0) CALL DV7CPY(L, V(CSAVE1), C)
- GO TO 999
-C
-C *** COMPUTE NEW RESIDUAL OR GRADIENT ***
-C
- 50 IV(1) = IV(IV1SAV)
- MD = IV(MODE)
- IF (MD .LE. 0) GO TO 60
- NML = N
- DR1L = DR1
- R1L = R1
- 60 IF (IV(TOOBIG) .NE. 0) GO TO 30
- IF (IABS(IV1) .EQ. 2) GO TO 170
-C
-C *** COMPUTE NEW RESIDUAL ***
-C
- IF (L1 .LE. L) CALL DV7CPY(N, V(R1), Y)
- IF (L1 .GT. L) CALL DV2AXY(N, V(R1), NEGONE, A(1,L1), Y)
- IF (MD .GT. 0) GO TO 120
- IER = 0
- IF (L .LE. 0) GO TO 110
- LL1O2 = L * (L + 1) / 2
- IPIV1 = IV(IPIVS)
- CALL DQ7RFH(IER, IV(IPIV1), N, LA, 0, L, A, V(AR1), LL1O2, C)
-C
-C *** DETERMINE NUMERICAL RANK OF A ***
-C
- IF (MACHEP .LE. ZERO) MACHEP = DR7MDC(3)
- SINGTL = SNGFAC * FLOAT(MAX0(L,N)) * MACHEP
- K = L
- IF (IER .NE. 0) K = IER - 1
- 70 IF (K .LE. 0) GO TO 90
- T = DL7SVX(K, V(AR1), C, C)
- IF (T .GT. ZERO) T = DL7SVN(K, V(AR1), C, C) / T
- IF (T .GT. SINGTL) GO TO 80
- K = K - 1
- GO TO 70
-C
-C *** RECORD RANK IN IV(IERS)... IV(IERS) = 0 MEANS FULL RANK,
-C *** IV(IERS) .GT. 0 MEANS RANK IV(IERS) - 1.
-C
- 80 IF (K .GE. L) GO TO 100
- 90 IER = K + 1
- CALL DV7SCP(L-K, C(K+1), ZERO)
- 100 IV(IERS) = IER
- IF (K .LE. 0) GO TO 110
-C
-C *** APPLY HOUSEHOLDER TRANSFORMATONS TO RESIDUALS...
-C
- CALL DQ7APL(LA, N, K, A, V(R1), IER)
-C
-C *** COMPUTING C NOW MAY SAVE A FUNCTION EVALUATION AT
-C *** THE LAST ITERATION.
-C
- CALL DL7ITV(K, C, V(AR1), V(R1))
- CALL DV7PRM(L, IV(IPIV1), C)
-C
- 110 IF(IV(1) .LT. 2) GO TO 220
- GO TO 999
-C
-C
-C *** RESIDUAL COMPUTATION FOR F.D. HESSIAN ***
-C
- 120 IF (L .LE. 0) GO TO 140
- DO 130 I = 1, L
- 130 CALL DV2AXY(N, V(R1), -C(I), A(1,I), V(R1))
- 140 IF (IV(1) .GT. 0) GO TO 30
- IV(1) = 2
- GO TO 160
-C
-C *** NEW GRADIENT (JACOBIAN) NEEDED ***
-C
- 150 IV(IV1SAV) = IV1
- IF (IV(NFGCAL) .NE. IV(NFCALL)) IV(1) = 1
- 160 CALL DV7SCP(N*P, V(DR1), ZERO)
- GO TO 999
-C
-C *** COMPUTE NEW JACOBIAN ***
-C
- 170 IF (NDA .LE. 0) GO TO 240
- DO 180 I = 1, NDA
- I1 = IN(1,I) - 1
- IF (I1 .LT. 0) GO TO 180
- J1 = IN(2,I)
- K = DR1 + I1*N
- T = NEGONE
- IF (J1 .LE. L) T = -C(J1)
- CALL DV2AXY(N, V(K), T, DA(1,I), V(K))
- 180 CONTINUE
- IF (IV1 .EQ. 2) GO TO 190
- IV(1) = IV1
- GO TO 999
- 190 IF (L .LE. 0) GO TO 30
- IF (MD .GT. 0) GO TO 30
- K = DR1
- IER = IV(IERS)
- NRAN = L
- IF (IER .GT. 0) NRAN = IER - 1
- IF (NRAN .LE. 0) GO TO 210
- DO 200 I = 1, P
- CALL DQ7APL(LA, N, NRAN, A, V(K), IER)
- K = K + N
- 200 CONTINUE
- 210 CALL DV7CPY(L, V(CSAVE1), C)
- 220 IF (IER .EQ. 0) GO TO 30
-C
-C *** ADJUST SUBSCRIPTS DESCRIBING R AND DR...
-C
- NRAN = IER - 1
- DR1L = DR1 + NRAN
- NML = N - NRAN
- R1L = R1 + NRAN
- GO TO 30
-C
-C *** CONVERGENCE OR LIMIT REACHED ***
-C
- 230 IF (IV(REGD) .EQ. 1) IV(REGD) = RD1
- IF (IV(1) .LE. 11) CALL DS7CPR(C, IV, L, LIV)
- GO TO 999
-C
- 240 IV(1) = 66
- CALL DITSUM(V, V, IV, LIV, LV, P, V, ALF)
-C
- 999 RETURN
-C
-C *** LAST CARD OF DRNSGB FOLLOWS ***
- END
diff --git a/CEP/PyBDSM/src/port3/ds3grd.f b/CEP/PyBDSM/src/port3/ds3grd.f
deleted file mode 100644
index 71f1321ac8acd59753fedb033bacb59bafed8836..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ds3grd.f
+++ /dev/null
@@ -1,282 +0,0 @@
- SUBROUTINE DS3GRD(ALPHA, B, D, ETA0, FX, G, IRC, P, W, X)
-C
-C *** COMPUTE FINITE DIFFERENCE GRADIENT BY STWEART*S SCHEME ***
-C
-C *** PARAMETERS ***
-C
- INTEGER IRC, P
- DOUBLE PRECISION ALPHA(P), B(2,P), D(P), ETA0, FX, G(P), W(6),
- 1 X(P)
-C
-C.......................................................................
-C
-C *** PURPOSE ***
-C
-C THIS SUBROUTINE USES AN EMBELLISHED FORM OF THE FINITE-DIFFER-
-C ENCE SCHEME PROPOSED BY STEWART (REF. 1) TO APPROXIMATE THE
-C GRADIENT OF THE FUNCTION F(X), WHOSE VALUES ARE SUPPLIED BY
-C REVERSE COMMUNICATION.
-C
-C *** PARAMETER DESCRIPTION ***
-C
-C ALPHA IN (APPROXIMATE) DIAGONAL ELEMENTS OF THE HESSIAN OF F(X).
-C B IN ARRAY OF SIMPLE LOWER AND UPPER BOUNDS ON X. X MUST
-C SATISFY B(1,I) .LE. X(I) .LE. B(2,I), I = 1(1)P.
-C FOR ALL I WITH B(1,I) .GE. B(2,I), DS3GRD SIMPLY
-C SETS G(I) TO 0.
-C D IN SCALE VECTOR SUCH THAT D(I)*X(I), I = 1,...,P, ARE IN
-C COMPARABLE UNITS.
-C ETA0 IN ESTIMATED BOUND ON RELATIVE ERROR IN THE FUNCTION VALUE...
-C (TRUE VALUE) = (COMPUTED VALUE)*(1+E), WHERE
-C ABS(E) .LE. ETA0.
-C FX I/O ON INPUT, FX MUST BE THE COMPUTED VALUE OF F(X). ON
-C OUTPUT WITH IRC = 0, FX HAS BEEN RESTORED TO ITS ORIGINAL
-C VALUE, THE ONE IT HAD WHEN DS3GRD WAS LAST CALLED WITH
-C IRC = 0.
-C G I/O ON INPUT WITH IRC = 0, G SHOULD CONTAIN AN APPROXIMATION
-C TO THE GRADIENT OF F NEAR X, E.G., THE GRADIENT AT THE
-C PREVIOUS ITERATE. WHEN DS3GRD RETURNS WITH IRC = 0, G IS
-C THE DESIRED FINITE-DIFFERENCE APPROXIMATION TO THE
-C GRADIENT AT X.
-C IRC I/O INPUT/RETURN CODE... BEFORE THE VERY FIRST CALL ON DS3GRD,
-C THE CALLER MUST SET IRC TO 0. WHENEVER DS3GRD RETURNS A
-C NONZERO VALUE (OF AT MOST P) FOR IRC, IT HAS PERTURBED
-C SOME COMPONENT OF X... THE CALLER SHOULD EVALUATE F(X)
-C AND CALL DS3GRD AGAIN WITH FX = F(X). IF B PREVENTS
-C ESTIMATING G(I) I.E., IF THERE IS AN I WITH
-C B(1,I) .LT. B(2,I) BUT WITH B(1,I) SO CLOSE TO B(2,I)
-C THAT THE FINITE-DIFFERENCING STEPS CANNOT BE CHOSEN,
-C THEN DS3GRD RETURNS WITH IRC .GT. P.
-C P IN THE NUMBER OF VARIABLES (COMPONENTS OF X) ON WHICH F
-C DEPENDS.
-C X I/O ON INPUT WITH IRC = 0, X IS THE POINT AT WHICH THE
-C GRADIENT OF F IS DESIRED. ON OUTPUT WITH IRC NONZERO, X
-C IS THE POINT AT WHICH F SHOULD BE EVALUATED. ON OUTPUT
-C WITH IRC = 0, X HAS BEEN RESTORED TO ITS ORIGINAL VALUE
-C (THE ONE IT HAD WHEN DS3GRD WAS LAST CALLED WITH IRC = 0)
-C AND G CONTAINS THE DESIRED GRADIENT APPROXIMATION.
-C W I/O WORK VECTOR OF LENGTH 6 IN WHICH DS3GRD SAVES CERTAIN
-C QUANTITIES WHILE THE CALLER IS EVALUATING F(X) AT A
-C PERTURBED X.
-C
-C *** APPLICATION AND USAGE RESTRICTIONS ***
-C
-C THIS ROUTINE IS INTENDED FOR _USE_ WITH QUASI-NEWTON ROUTINES
-C FOR UNCONSTRAINED MINIMIZATION (IN WHICH CASE ALPHA COMES FROM
-C THE DIAGONAL OF THE QUASI-NEWTON HESSIAN APPROXIMATION).
-C
-C *** ALGORITHM NOTES ***
-C
-C THIS CODE DEPARTS FROM THE SCHEME PROPOSED BY STEWART (REF. 1)
-C IN ITS GUARDING AGAINST OVERLY LARGE OR SMALL STEP SIZES AND ITS
-C HANDLING OF SPECIAL CASES (SUCH AS ZERO COMPONENTS OF ALPHA OR G).
-C
-C *** REFERENCES ***
-C
-C 1. STEWART, G.W. (1967), A MODIFICATION OF DAVIDON*S MINIMIZATION
-C METHOD TO ACCEPT DIFFERENCE APPROXIMATIONS OF DERIVATIVES,
-C J. ASSOC. COMPUT. MACH. 14, PP. 72-83.
-C
-C *** HISTORY ***
-C
-C DESIGNED AND CODED BY DAVID M. GAY (SUMMER 1977/SUMMER 1980).
-C
-C *** GENERAL ***
-C
-C THIS ROUTINE WAS PREPARED IN CONNECTION WITH WORK SUPPORTED BY
-C THE NATIONAL SCIENCE FOUNDATION UNDER GRANTS MCS76-00324 AND
-C MCS-7906671.
-C
-C.......................................................................
-C
-C ***** EXTERNAL FUNCTION *****
-C
- DOUBLE PRECISION DR7MDC
- EXTERNAL DR7MDC
-C DR7MDC... RETURNS MACHINE-DEPENDENT CONSTANTS.
-C
-C ***** INTRINSIC FUNCTIONS *****
-C/+
- DOUBLE PRECISION DSQRT
-C/
-C ***** LOCAL VARIABLES *****
-C
- LOGICAL HIT
- INTEGER FH, FX0, HSAVE, I, XISAVE
- DOUBLE PRECISION AAI, AFX, AFXETA, AGI, ALPHAI, AXI, AXIBAR,
- 1 DISCON, ETA, GI, H, HMIN, XI, XIH
- DOUBLE PRECISION C2000, FOUR, HMAX0, HMIN0, H0, MACHEP, ONE, P002,
- 1 THREE, TWO, ZERO
-C
-C/6
-C DATA C2000/2.0D+3/, FOUR/4.0D+0/, HMAX0/0.02D+0/, HMIN0/5.0D+1/,
-C 1 ONE/1.0D+0/, P002/0.002D+0/, THREE/3.0D+0/,
-C 2 TWO/2.0D+0/, ZERO/0.0D+0/
-C/7
- PARAMETER (C2000=2.0D+3, FOUR=4.0D+0, HMAX0=0.02D+0, HMIN0=5.0D+1,
- 1 ONE=1.0D+0, P002=0.002D+0, THREE=3.0D+0,
- 2 TWO=2.0D+0, ZERO=0.0D+0)
-C/
-C/6
-C DATA FH/3/, FX0/4/, HSAVE/5/, XISAVE/6/
-C/7
- PARAMETER (FH=3, FX0=4, HSAVE=5, XISAVE=6)
-C/
-C
-C--------------------------------- BODY ------------------------------
-C
- IF (IRC) 80, 10, 210
-C
-C *** FRESH START -- GET MACHINE-DEPENDENT CONSTANTS ***
-C
-C STORE MACHEP IN W(1) AND H0 IN W(2), WHERE MACHEP IS THE UNIT
-C ROUNDOFF (THE SMALLEST POSITIVE NUMBER SUCH THAT
-C 1 + MACHEP .GT. 1 AND 1 - MACHEP .LT. 1), AND H0 IS THE
-C SQUARE-ROOT OF MACHEP.
-C
- 10 W(1) = DR7MDC(3)
- W(2) = DSQRT(W(1))
-C
- W(FX0) = FX
-C
-C *** INCREMENT I AND START COMPUTING G(I) ***
-C
- 20 I = IABS(IRC) + 1
- IF (I .GT. P) GO TO 220
- IRC = I
- IF (B(1,I) .LT. B(2,I)) GO TO 30
- G(I) = ZERO
- GO TO 20
- 30 AFX = DABS(W(FX0))
- MACHEP = W(1)
- H0 = W(2)
- HMIN = HMIN0 * MACHEP
- XI = X(I)
- W(XISAVE) = XI
- AXI = DABS(XI)
- AXIBAR = DMAX1(AXI, ONE/D(I))
- GI = G(I)
- AGI = DABS(GI)
- ETA = DABS(ETA0)
- IF (AFX .GT. ZERO) ETA = DMAX1(ETA, AGI*AXI*MACHEP/AFX)
- ALPHAI = ALPHA(I)
- IF (ALPHAI .EQ. ZERO) GO TO 130
- IF (GI .EQ. ZERO .OR. FX .EQ. ZERO) GO TO 140
- AFXETA = AFX*ETA
- AAI = DABS(ALPHAI)
-C
-C *** COMPUTE H = STEWART*S FORWARD-DIFFERENCE STEP SIZE.
-C
- IF (GI**2 .LE. AFXETA*AAI) GO TO 40
- H = TWO*DSQRT(AFXETA/AAI)
- H = H*(ONE - AAI*H/(THREE*AAI*H + FOUR*AGI))
- GO TO 50
-C40 H = TWO*(AFXETA*AGI/(AAI**2))**(ONE/THREE)
- 40 H = TWO * (AFXETA*AGI)**(ONE/THREE) * AAI**(-TWO/THREE)
- H = H*(ONE - TWO*AGI/(THREE*AAI*H + FOUR*AGI))
-C
-C *** ENSURE THAT H IS NOT INSIGNIFICANTLY SMALL ***
-C
- 50 H = DMAX1(H, HMIN*AXIBAR)
-C
-C *** _USE_ FORWARD DIFFERENCE IF BOUND ON TRUNCATION ERROR IS AT
-C *** MOST 10**-3.
-C
- IF (AAI*H .LE. P002*AGI) GO TO 120
-C
-C *** COMPUTE H = STEWART*S STEP FOR CENTRAL DIFFERENCE.
-C
- DISCON = C2000*AFXETA
- H = DISCON/(AGI + DSQRT(GI**2 + AAI*DISCON))
-C
-C *** ENSURE THAT H IS NEITHER TOO SMALL NOR TOO BIG ***
-C
- H = DMAX1(H, HMIN*AXIBAR)
- IF (H .GE. HMAX0*AXIBAR) H = AXIBAR * H0**(TWO/THREE)
-C
-C *** COMPUTE CENTRAL DIFFERENCE ***
-C
- XIH = XI + H
- IF (XI - H .LT. B(1,I)) GO TO 60
- IRC = -I
- IF (XIH .LE. B(2,I)) GO TO 200
- H = -H
- XIH = XI + H
- IF (XI + TWO*H .LT. B(1,I)) GO TO 190
- GO TO 70
- 60 IF (XI + TWO*H .GT. B(2,I)) GO TO 190
-C *** MUST DO OFF-SIDE CENTRAL DIFFERENCE ***
- 70 IRC = -(I + P)
- GO TO 200
-C
- 80 I = -IRC
- IF (I .LE. P) GO TO 100
- I = I - P
- IF (I .GT. P) GO TO 90
- W(FH) = FX
- H = TWO * W(HSAVE)
- XIH = W(XISAVE) + H
- IRC = IRC - P
- GO TO 200
-C
-C *** FINISH OFF-SIDE CENTRAL DIFFERENCE ***
-C
- 90 I = I - P
- G(I) = (FOUR*W(FH) - FX - THREE*W(FX0)) / W(HSAVE)
- IRC = I
- X(I) = W(XISAVE)
- GO TO 20
-C
- 100 H = -W(HSAVE)
- IF (H .GT. ZERO) GO TO 110
- W(FH) = FX
- XIH = W(XISAVE) + H
- GO TO 200
-C
- 110 G(I) = (W(FH) - FX) / (TWO * H)
- X(I) = W(XISAVE)
- GO TO 20
-C
-C *** COMPUTE FORWARD DIFFERENCES IN VARIOUS CASES ***
-C
- 120 IF (H .GE. HMAX0*AXIBAR) H = H0 * AXIBAR
- IF (ALPHAI*GI .LT. ZERO) H = -H
- GO TO 150
- 130 H = AXIBAR
- GO TO 150
- 140 H = H0 * AXIBAR
-C
- 150 HIT = .FALSE.
- 160 XIH = XI + H
- IF (H .GT. ZERO) GO TO 170
- IF (XIH .GE. B(1,I)) GO TO 200
- GO TO 180
- 170 IF (XIH .LE. B(2,I)) GO TO 200
- 180 IF (HIT) GO TO 190
- HIT = .TRUE.
- H = -H
- GO TO 160
-C
-C *** ERROR RETURN...
- 190 IRC = I + P
- GO TO 230
-C
-C *** RETURN FOR NEW FUNCTION VALUE...
- 200 X(I) = XIH
- W(HSAVE) = H
- GO TO 999
-C
-C *** COMPUTE ACTUAL FORWARD DIFFERENCE ***
-C
- 210 G(IRC) = (FX - W(FX0)) / W(HSAVE)
- X(IRC) = W(XISAVE)
- GO TO 20
-C
-C *** RESTORE FX AND INDICATE THAT G HAS BEEN COMPUTED ***
-C
- 220 IRC = 0
- 230 FX = W(FX0)
-C
- 999 RETURN
-C *** LAST LINE OF DS3GRD FOLLOWS ***
- END
diff --git a/CEP/PyBDSM/src/port3/ds7bqn.f b/CEP/PyBDSM/src/port3/ds7bqn.f
deleted file mode 100644
index 5486ccd7685be7628d447fef5148cb266e3fb359..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ds7bqn.f
+++ /dev/null
@@ -1,154 +0,0 @@
- SUBROUTINE DS7BQN(B, D, DST, IPIV, IPIV1, IPIV2, KB, L, LV, NS,
- 1 P, P1, STEP, TD, TG, V, W, X, X0)
-C
-C *** COMPUTE BOUNDED MODIFIED NEWTON STEP ***
-C
- INTEGER KB, LV, NS, P, P1
- INTEGER IPIV(P), IPIV1(P), IPIV2(P)
- DOUBLE PRECISION B(2,P), D(P), DST(P), L(1),
- 1 STEP(P), TD(P), TG(P), V(LV), W(P), X(P),
- 2 X0(P)
-C DIMENSION L(P*(P+1)/2)
-C
- DOUBLE PRECISION DD7TPR, DR7MDC, DV2NRM
- EXTERNAL DD7TPR, I7SHFT, DL7ITV, DL7IVM, DQ7RSH, DR7MDC, DV2NRM,
- 1 DV2AXY,DV7CPY, DV7IPR, DV7SCP, DV7SHF
-C
-C *** LOCAL VARIABLES ***
-C
- INTEGER I, J, K, P0, P1M1
- DOUBLE PRECISION ALPHA, DST0, DST1, DSTMAX, DSTMIN, DX, GTS, T,
- 1 TI, T1, XI
- DOUBLE PRECISION FUDGE, HALF, MEPS2, ONE, TWO, ZERO
-C
-C *** V SUBSCRIPTS ***
-C
- INTEGER DSTNRM, GTSTEP, PHMNFC, PHMXFC, PREDUC, RADIUS, STPPAR
-C
-C/6
-C DATA DSTNRM/2/, GTSTEP/4/, PHMNFC/20/, PHMXFC/21/, PREDUC/7/,
-C 1 RADIUS/8/, STPPAR/5/
-C/7
- PARAMETER (DSTNRM=2, GTSTEP=4, PHMNFC=20, PHMXFC=21, PREDUC=7,
- 1 RADIUS=8, STPPAR=5)
- SAVE MEPS2
-C/
-C
- DATA FUDGE/1.0001D+0/, HALF/0.5D+0/, MEPS2/0.D+0/,
- 1 ONE/1.0D+0/, TWO/2.D+0/, ZERO/0.D+0/
-C
-C+++++++++++++++++++++++++++++++ BODY ++++++++++++++++++++++++++++++++
-C
- DSTMAX = FUDGE * (ONE + V(PHMXFC)) * V(RADIUS)
- DSTMIN = (ONE + V(PHMNFC)) * V(RADIUS)
- DST1 = ZERO
- IF (MEPS2 .LE. ZERO) MEPS2 = TWO * DR7MDC(3)
- P0 = P1
- NS = 0
- DO 10 I = 1, P
- IPIV1(I) = I
- IPIV2(I) = I
- 10 CONTINUE
- DO 20 I = 1, P1
- 20 W(I) = -STEP(I) * TD(I)
- ALPHA = DABS(V(STPPAR))
- V(PREDUC) = ZERO
- GTS = -V(GTSTEP)
- IF (KB .LT. 0) CALL DV7SCP(P, DST, ZERO)
- KB = 1
-C
-C *** -W = D TIMES RESTRICTED NEWTON STEP FROM X + DST/D.
-C
-C *** FIND T SUCH THAT X - T*W IS STILL FEASIBLE.
-C
- 30 T = ONE
- K = 0
- DO 60 I = 1, P1
- J = IPIV(I)
- DX = W(I) / D(J)
- XI = X(J) - DX
- IF (XI .LT. B(1,J)) GO TO 40
- IF (XI .LE. B(2,J)) GO TO 60
- TI = ( X(J) - B(2,J) ) / DX
- K = I
- GO TO 50
- 40 TI = ( X(J) - B(1,J) ) / DX
- K = -I
- 50 IF (T .LE. TI) GO TO 60
- T = TI
- 60 CONTINUE
-C
- IF (P .GT. P1) CALL DV7CPY(P-P1, STEP(P1+1), DST(P1+1))
- CALL DV2AXY(P1, STEP, -T, W, DST)
- DST0 = DST1
- DST1 = DV2NRM(P, STEP)
-C
-C *** CHECK FOR OVERSIZE STEP ***
-C
- IF (DST1 .LE. DSTMAX) GO TO 80
- IF (P1 .GE. P0) GO TO 70
- IF (DST0 .LT. DSTMIN) KB = 0
- GO TO 110
-C
- 70 K = 0
-C
-C *** UPDATE DST, TG, AND V(PREDUC) ***
-C
- 80 V(DSTNRM) = DST1
- CALL DV7CPY(P1, DST, STEP)
- T1 = ONE - T
- DO 90 I = 1, P1
- 90 TG(I) = T1 * TG(I)
- IF (ALPHA .GT. ZERO) CALL DV2AXY(P1, TG, T*ALPHA, W, TG)
- V(PREDUC) = V(PREDUC) + T*((ONE - HALF*T)*GTS +
- 1 HALF*ALPHA*T*DD7TPR(P1,W,W))
- IF (K .EQ. 0) GO TO 110
-C
-C *** PERMUTE L, ETC. IF NECESSARY ***
-C
- P1M1 = P1 - 1
- J = IABS(K)
- IF (J .EQ. P1) GO TO 100
- NS = NS + 1
- IPIV2(P1) = J
- CALL DQ7RSH(J, P1, .FALSE., TG, L, W)
- CALL I7SHFT(P1, J, IPIV)
- CALL I7SHFT(P1, J, IPIV1)
- CALL DV7SHF(P1, J, TG)
- CALL DV7SHF(P1, J, DST)
- 100 IF (K .LT. 0) IPIV(P1) = -IPIV(P1)
- P1 = P1M1
- IF (P1 .LE. 0) GO TO 110
- CALL DL7IVM(P1, W, L, TG)
- GTS = DD7TPR(P1, W, W)
- CALL DL7ITV(P1, W, L, W)
- GO TO 30
-C
-C *** UNSCALE STEP ***
-C
- 110 DO 120 I = 1, P
- J = IABS(IPIV(I))
- STEP(J) = DST(I) / D(J)
- 120 CONTINUE
-C
-C *** FUDGE STEP TO ENSURE THAT IT FORCES APPROPRIATE COMPONENTS
-C *** TO THEIR BOUNDS ***
-C
- IF (P1 .GE. P0) GO TO 150
- K = P1 + 1
- DO 140 I = K, P0
- J = IPIV(I)
- T = MEPS2
- IF (J .GT. 0) GO TO 130
- T = -T
- J = -J
- IPIV(I) = J
- 130 T = T * DMAX1(DABS(X(J)), DABS(X0(J)))
- STEP(J) = STEP(J) + T
- 140 CONTINUE
-C
- 150 CALL DV2AXY(P, X, ONE, STEP, X0)
- IF (NS .GT. 0) CALL DV7IPR(P0, IPIV1, TD)
- 999 RETURN
-C *** LAST LINE OF DS7BQN FOLLOWS ***
- END
diff --git a/CEP/PyBDSM/src/port3/ds7cpr.f b/CEP/PyBDSM/src/port3/ds7cpr.f
deleted file mode 100644
index 5e8a417d84d47bc997f749d5bf57f6c9c920d3c7..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ds7cpr.f
+++ /dev/null
@@ -1,29 +0,0 @@
- SUBROUTINE DS7CPR(C, IV, L, LIV)
-C
-C *** PRINT C FOR DNSG (ETC.) ***
-C
- INTEGER L, LIV
- INTEGER IV(LIV)
- DOUBLE PRECISION C(L)
-C
- INTEGER I, PU
-C
- INTEGER PRUNIT, SOLPRT
-C
-C/6
-C DATA PRUNIT/21/, SOLPRT/22/
-C/7
- PARAMETER (PRUNIT=21, SOLPRT=22)
-C/
-C *** BODY ***
-C
- IF (IV(1) .GT. 11) GO TO 999
- IF (IV(SOLPRT) .EQ. 0) GO TO 999
- PU = IV(PRUNIT)
- IF (PU .EQ. 0) GO TO 999
- IF (L .GT. 0) WRITE(PU,10) (I, C(I), I = 1, L)
- 10 FORMAT(/21H LINEAR PARAMETERS...//(1X,I5,D16.6))
-C
- 999 RETURN
-C *** LAST LINE OF DS7CPR FOLLOWS ***
- END
diff --git a/CEP/PyBDSM/src/port3/ds7dmp.f b/CEP/PyBDSM/src/port3/ds7dmp.f
deleted file mode 100644
index 358f02ceec7ec152129e164cf489a6a7fd59aa69..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ds7dmp.f
+++ /dev/null
@@ -1,37 +0,0 @@
- SUBROUTINE DS7DMP(N, X, Y, Z, K)
-C
-C *** SET X = DIAG(Z)**K * Y * DIAG(Z)**K
-C *** FOR X, Y = COMPACTLY STORED LOWER TRIANG. MATRICES
-C *** K = 1 OR -1.
-C
- INTEGER N, K
-C/6S
-C DOUBLE PRECISION X(1), Y(1), Z(N)
-C/7S
- DOUBLE PRECISION X(*), Y(*), Z(N)
-C/
- INTEGER I, J, L
- DOUBLE PRECISION ONE, T
- DATA ONE/1.D+0/
-C
- L = 1
- IF (K .GE. 0) GO TO 30
- DO 20 I = 1, N
- T = ONE / Z(I)
- DO 10 J = 1, I
- X(L) = T * Y(L) / Z(J)
- L = L + 1
- 10 CONTINUE
- 20 CONTINUE
- GO TO 999
-C
- 30 DO 50 I = 1, N
- T = Z(I)
- DO 40 J = 1, I
- X(L) = T * Y(L) * Z(J)
- L = L + 1
- 40 CONTINUE
- 50 CONTINUE
- 999 RETURN
-C *** LAST CARD OF DS7DMP FOLLOWS ***
- END
diff --git a/CEP/PyBDSM/src/port3/ds7grd.f b/CEP/PyBDSM/src/port3/ds7grd.f
deleted file mode 100644
index a67dc6f9771c9e2bae1c45c6a83f25a0aee5c4c2..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ds7grd.f
+++ /dev/null
@@ -1,224 +0,0 @@
- SUBROUTINE DS7GRD (ALPHA, D, ETA0, FX, G, IRC, N, W, X)
-C
-C *** COMPUTE FINITE DIFFERENCE GRADIENT BY STWEART*S SCHEME ***
-C
-C *** PARAMETERS ***
-C
- INTEGER IRC, N
- DOUBLE PRECISION ALPHA(N), D(N), ETA0, FX, G(N), W(6), X(N)
-C
-C.......................................................................
-C
-C *** PURPOSE ***
-C
-C THIS SUBROUTINE USES AN EMBELLISHED FORM OF THE FINITE-DIFFER-
-C ENCE SCHEME PROPOSED BY STEWART (REF. 1) TO APPROXIMATE THE
-C GRADIENT OF THE FUNCTION F(X), WHOSE VALUES ARE SUPPLIED BY
-C REVERSE COMMUNICATION.
-C
-C *** PARAMETER DESCRIPTION ***
-C
-C ALPHA IN (APPROXIMATE) DIAGONAL ELEMENTS OF THE HESSIAN OF F(X).
-C D IN SCALE VECTOR SUCH THAT D(I)*X(I), I = 1,...,N, ARE IN
-C COMPARABLE UNITS.
-C ETA0 IN ESTIMATED BOUND ON RELATIVE ERROR IN THE FUNCTION VALUE...
-C (TRUE VALUE) = (COMPUTED VALUE)*(1+E), WHERE
-C ABS(E) .LE. ETA0.
-C FX I/O ON INPUT, FX MUST BE THE COMPUTED VALUE OF F(X). ON
-C OUTPUT WITH IRC = 0, FX HAS BEEN RESTORED TO ITS ORIGINAL
-C VALUE, THE ONE IT HAD WHEN DS7GRD WAS LAST CALLED WITH
-C IRC = 0.
-C G I/O ON INPUT WITH IRC = 0, G SHOULD CONTAIN AN APPROXIMATION
-C TO THE GRADIENT OF F NEAR X, E.G., THE GRADIENT AT THE
-C PREVIOUS ITERATE. WHEN DS7GRD RETURNS WITH IRC = 0, G IS
-C THE DESIRED FINITE-DIFFERENCE APPROXIMATION TO THE
-C GRADIENT AT X.
-C IRC I/O INPUT/RETURN CODE... BEFORE THE VERY FIRST CALL ON DS7GRD,
-C THE CALLER MUST SET IRC TO 0. WHENEVER DS7GRD RETURNS A
-C NONZERO VALUE FOR IRC, IT HAS PERTURBED SOME COMPONENT OF
-C X... THE CALLER SHOULD EVALUATE F(X) AND CALL DS7GRD
-C AGAIN WITH FX = F(X).
-C N IN THE NUMBER OF VARIABLES (COMPONENTS OF X) ON WHICH F
-C DEPENDS.
-C X I/O ON INPUT WITH IRC = 0, X IS THE POINT AT WHICH THE
-C GRADIENT OF F IS DESIRED. ON OUTPUT WITH IRC NONZERO, X
-C IS THE POINT AT WHICH F SHOULD BE EVALUATED. ON OUTPUT
-C WITH IRC = 0, X HAS BEEN RESTORED TO ITS ORIGINAL VALUE
-C (THE ONE IT HAD WHEN DS7GRD WAS LAST CALLED WITH IRC = 0)
-C AND G CONTAINS THE DESIRED GRADIENT APPROXIMATION.
-C W I/O WORK VECTOR OF LENGTH 6 IN WHICH DS7GRD SAVES CERTAIN
-C QUANTITIES WHILE THE CALLER IS EVALUATING F(X) AT A
-C PERTURBED X.
-C
-C *** APPLICATION AND USAGE RESTRICTIONS ***
-C
-C THIS ROUTINE IS INTENDED FOR _USE_ WITH QUASI-NEWTON ROUTINES
-C FOR UNCONSTRAINED MINIMIZATION (IN WHICH CASE ALPHA COMES FROM
-C THE DIAGONAL OF THE QUASI-NEWTON HESSIAN APPROXIMATION).
-C
-C *** ALGORITHM NOTES ***
-C
-C THIS CODE DEPARTS FROM THE SCHEME PROPOSED BY STEWART (REF. 1)
-C IN ITS GUARDING AGAINST OVERLY LARGE OR SMALL STEP SIZES AND ITS
-C HANDLING OF SPECIAL CASES (SUCH AS ZERO COMPONENTS OF ALPHA OR G).
-C
-C *** REFERENCES ***
-C
-C 1. STEWART, G.W. (1967), A MODIFICATION OF DAVIDON*S MINIMIZATION
-C METHOD TO ACCEPT DIFFERENCE APPROXIMATIONS OF DERIVATIVES,
-C J. ASSOC. COMPUT. MACH. 14, PP. 72-83.
-C
-C *** HISTORY ***
-C
-C DESIGNED AND CODED BY DAVID M. GAY (SUMMER 1977/SUMMER 1980).
-C
-C *** GENERAL ***
-C
-C THIS ROUTINE WAS PREPARED IN CONNECTION WITH WORK SUPPORTED BY
-C THE NATIONAL SCIENCE FOUNDATION UNDER GRANTS MCS76-00324 AND
-C MCS-7906671.
-C
-C.......................................................................
-C
-C ***** EXTERNAL FUNCTION *****
-C
- DOUBLE PRECISION DR7MDC
- EXTERNAL DR7MDC
-C DR7MDC... RETURNS MACHINE-DEPENDENT CONSTANTS.
-C
-C ***** INTRINSIC FUNCTIONS *****
-C/+
- DOUBLE PRECISION DSQRT
-C/
-C ***** LOCAL VARIABLES *****
-C
- INTEGER FH, FX0, HSAVE, I, XISAVE
- DOUBLE PRECISION AAI, AFX, AFXETA, AGI, ALPHAI, AXI, AXIBAR,
- 1 DISCON, ETA, GI, H, HMIN
- DOUBLE PRECISION C2000, FOUR, HMAX0, HMIN0, H0, MACHEP, ONE, P002,
- 1 THREE, TWO, ZERO
-C
-C/6
-C DATA C2000/2.0D+3/, FOUR/4.0D+0/, HMAX0/0.02D+0/, HMIN0/5.0D+1/,
-C 1 ONE/1.0D+0/, P002/0.002D+0/, THREE/3.0D+0/,
-C 2 TWO/2.0D+0/, ZERO/0.0D+0/
-C/7
- PARAMETER (C2000=2.0D+3, FOUR=4.0D+0, HMAX0=0.02D+0, HMIN0=5.0D+1,
- 1 ONE=1.0D+0, P002=0.002D+0, THREE=3.0D+0,
- 2 TWO=2.0D+0, ZERO=0.0D+0)
-C/
-C/6
-C DATA FH/3/, FX0/4/, HSAVE/5/, XISAVE/6/
-C/7
- PARAMETER (FH=3, FX0=4, HSAVE=5, XISAVE=6)
-C/
-C
-C--------------------------------- BODY ------------------------------
-C
- IF (IRC) 140, 100, 210
-C
-C *** FRESH START -- GET MACHINE-DEPENDENT CONSTANTS ***
-C
-C STORE MACHEP IN W(1) AND H0 IN W(2), WHERE MACHEP IS THE UNIT
-C ROUNDOFF (THE SMALLEST POSITIVE NUMBER SUCH THAT
-C 1 + MACHEP .GT. 1 AND 1 - MACHEP .LT. 1), AND H0 IS THE
-C SQUARE-ROOT OF MACHEP.
-C
- 100 W(1) = DR7MDC(3)
- W(2) = DSQRT(W(1))
-C
- W(FX0) = FX
-C
-C *** INCREMENT I AND START COMPUTING G(I) ***
-C
- 110 I = IABS(IRC) + 1
- IF (I .GT. N) GO TO 300
- IRC = I
- AFX = DABS(W(FX0))
- MACHEP = W(1)
- H0 = W(2)
- HMIN = HMIN0 * MACHEP
- W(XISAVE) = X(I)
- AXI = DABS(X(I))
- AXIBAR = DMAX1(AXI, ONE/D(I))
- GI = G(I)
- AGI = DABS(GI)
- ETA = DABS(ETA0)
- IF (AFX .GT. ZERO) ETA = DMAX1(ETA, AGI*AXI*MACHEP/AFX)
- ALPHAI = ALPHA(I)
- IF (ALPHAI .EQ. ZERO) GO TO 170
- IF (GI .EQ. ZERO .OR. FX .EQ. ZERO) GO TO 180
- AFXETA = AFX*ETA
- AAI = DABS(ALPHAI)
-C
-C *** COMPUTE H = STEWART*S FORWARD-DIFFERENCE STEP SIZE.
-C
- IF (GI**2 .LE. AFXETA*AAI) GO TO 120
- H = TWO*DSQRT(AFXETA/AAI)
- H = H*(ONE - AAI*H/(THREE*AAI*H + FOUR*AGI))
- GO TO 130
-C120 H = TWO*(AFXETA*AGI/(AAI**2))**(ONE/THREE)
- 120 H = TWO * (AFXETA*AGI)**(ONE/THREE) * AAI**(-TWO/THREE)
- H = H*(ONE - TWO*AGI/(THREE*AAI*H + FOUR*AGI))
-C
-C *** ENSURE THAT H IS NOT INSIGNIFICANTLY SMALL ***
-C
- 130 H = DMAX1(H, HMIN*AXIBAR)
-C
-C *** _USE_ FORWARD DIFFERENCE IF BOUND ON TRUNCATION ERROR IS AT
-C *** MOST 10**-3.
-C
- IF (AAI*H .LE. P002*AGI) GO TO 160
-C
-C *** COMPUTE H = STEWART*S STEP FOR CENTRAL DIFFERENCE.
-C
- DISCON = C2000*AFXETA
- H = DISCON/(AGI + DSQRT(GI**2 + AAI*DISCON))
-C
-C *** ENSURE THAT H IS NEITHER TOO SMALL NOR TOO BIG ***
-C
- H = DMAX1(H, HMIN*AXIBAR)
- IF (H .GE. HMAX0*AXIBAR) H = AXIBAR * H0**(TWO/THREE)
-C
-C *** COMPUTE CENTRAL DIFFERENCE ***
-C
- IRC = -I
- GO TO 200
-C
- 140 H = -W(HSAVE)
- I = IABS(IRC)
- IF (H .GT. ZERO) GO TO 150
- W(FH) = FX
- GO TO 200
-C
- 150 G(I) = (W(FH) - FX) / (TWO * H)
- X(I) = W(XISAVE)
- GO TO 110
-C
-C *** COMPUTE FORWARD DIFFERENCES IN VARIOUS CASES ***
-C
- 160 IF (H .GE. HMAX0*AXIBAR) H = H0 * AXIBAR
- IF (ALPHAI*GI .LT. ZERO) H = -H
- GO TO 200
- 170 H = AXIBAR
- GO TO 200
- 180 H = H0 * AXIBAR
-C
- 200 X(I) = W(XISAVE) + H
- W(HSAVE) = H
- GO TO 999
-C
-C *** COMPUTE ACTUAL FORWARD DIFFERENCE ***
-C
- 210 G(IRC) = (FX - W(FX0)) / W(HSAVE)
- X(IRC) = W(XISAVE)
- GO TO 110
-C
-C *** RESTORE FX AND INDICATE THAT G HAS BEEN COMPUTED ***
-C
- 300 FX = W(FX0)
- IRC = 0
-C
- 999 RETURN
-C *** LAST CARD OF DS7GRD FOLLOWS ***
- END
diff --git a/CEP/PyBDSM/src/port3/ds7ipr.f b/CEP/PyBDSM/src/port3/ds7ipr.f
deleted file mode 100644
index 7316be1f7347e88d110258edee3239ab388f3762..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ds7ipr.f
+++ /dev/null
@@ -1,73 +0,0 @@
- SUBROUTINE DS7IPR(P, IP, H)
-C
-C APPLY THE PERMUTATION DEFINED BY IP TO THE ROWS AND COLUMNS OF THE
-C P X P SYMMETRIC MATRIX WHOSE LOWER TRIANGLE IS STORED COMPACTLY IN H.
-C THUS H.OUTPUT(I,J) = H.INPUT(IP(I), IP(J)).
-C
- INTEGER P
- INTEGER IP(P)
- DOUBLE PRECISION H(1)
-C
- INTEGER I, J, J1, JM, K, K1, KK, KM, KMJ, L, M
- DOUBLE PRECISION T
-C
-C *** BODY ***
-C
- DO 90 I = 1, P
- J = IP(I)
- IF (J .EQ. I) GO TO 90
- IP(I) = IABS(J)
- IF (J .LT. 0) GO TO 90
- K = I
- 10 J1 = J
- K1 = K
- IF (J .LE. K) GO TO 20
- J1 = K
- K1 = J
- 20 KMJ = K1-J1
- L = J1-1
- JM = J1*L/2
- KM = K1*(K1-1)/2
- IF (L .LE. 0) GO TO 40
- DO 30 M = 1, L
- JM = JM+1
- T = H(JM)
- KM = KM+1
- H(JM) = H(KM)
- H(KM) = T
- 30 CONTINUE
- 40 KM = KM+1
- KK = KM+KMJ
- JM = JM+1
- T = H(JM)
- H(JM) = H(KK)
- H(KK) = T
- J1 = L
- L = KMJ-1
- IF (L .LE. 0) GO TO 60
- DO 50 M = 1, L
- JM = JM+J1+M
- T = H(JM)
- KM = KM+1
- H(JM) = H(KM)
- H(KM) = T
- 50 CONTINUE
- 60 IF (K1 .GE. P) GO TO 80
- L = P-K1
- K1 = K1-1
- KM = KK
- DO 70 M = 1, L
- KM = KM+K1+M
- JM = KM-KMJ
- T = H(JM)
- H(JM) = H(KM)
- H(KM) = T
- 70 CONTINUE
- 80 K = J
- J = IP(K)
- IP(K) = -J
- IF (J .GT. I) GO TO 10
- 90 CONTINUE
- 999 RETURN
-C *** LAST LINE OF DS7IPR FOLLOWS ***
- END
diff --git a/CEP/PyBDSM/src/port3/ds7lup.f b/CEP/PyBDSM/src/port3/ds7lup.f
deleted file mode 100644
index 1b74937c0c4b59edd410f585149690b5fd57231c..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ds7lup.f
+++ /dev/null
@@ -1,62 +0,0 @@
- SUBROUTINE DS7LUP(A, COSMIN, P, SIZE, STEP, U, W, WCHMTD, WSCALE,
- 1 Y)
-C
-C *** UPDATE SYMMETRIC A SO THAT A * STEP = Y ***
-C *** (LOWER TRIANGLE OF A STORED ROWWISE ***
-C
-C *** PARAMETER DECLARATIONS ***
-C
- INTEGER P
- DOUBLE PRECISION A(1), COSMIN, SIZE, STEP(P), U(P), W(P),
- 1 WCHMTD(P), WSCALE, Y(P)
-C DIMENSION A(P*(P+1)/2)
-C
-C *** LOCAL VARIABLES ***
-C
- INTEGER I, J, K
- DOUBLE PRECISION DENMIN, SDOTWM, T, UI, WI
-C
-C *** CONSTANTS ***
- DOUBLE PRECISION HALF, ONE, ZERO
-C
-C *** EXTERNAL FUNCTIONS AND SUBROUTINES ***
-C
- DOUBLE PRECISION DD7TPR, DV2NRM
- EXTERNAL DD7TPR, DS7LVM, DV2NRM
-C
-C/6
-C DATA HALF/0.5D+0/, ONE/1.D+0/, ZERO/0.D+0/
-C/7
- PARAMETER (HALF=0.5D+0, ONE=1.D+0, ZERO=0.D+0)
-C/
-C
-C-----------------------------------------------------------------------
-C
- SDOTWM = DD7TPR(P, STEP, WCHMTD)
- DENMIN = COSMIN * DV2NRM(P,STEP) * DV2NRM(P,WCHMTD)
- WSCALE = ONE
- IF (DENMIN .NE. ZERO) WSCALE = DMIN1(ONE, DABS(SDOTWM/DENMIN))
- T = ZERO
- IF (SDOTWM .NE. ZERO) T = WSCALE / SDOTWM
- DO 10 I = 1, P
- 10 W(I) = T * WCHMTD(I)
- CALL DS7LVM(P, U, A, STEP)
- T = HALF * (SIZE * DD7TPR(P, STEP, U) - DD7TPR(P, STEP, Y))
- DO 20 I = 1, P
- 20 U(I) = T*W(I) + Y(I) - SIZE*U(I)
-C
-C *** SET A = A + U*(W**T) + W*(U**T) ***
-C
- K = 1
- DO 40 I = 1, P
- UI = U(I)
- WI = W(I)
- DO 30 J = 1, I
- A(K) = SIZE*A(K) + UI*W(J) + WI*U(J)
- K = K + 1
- 30 CONTINUE
- 40 CONTINUE
-C
- 999 RETURN
-C *** LAST CARD OF DS7LUP FOLLOWS ***
- END
diff --git a/CEP/PyBDSM/src/port3/ds7lvm.f b/CEP/PyBDSM/src/port3/ds7lvm.f
deleted file mode 100644
index 97f5843ac017fa715e7ce6ea49cf32b9e4e40b02..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ds7lvm.f
+++ /dev/null
@@ -1,46 +0,0 @@
- SUBROUTINE DS7LVM(P, Y, S, X)
-C
-C *** SET Y = S * X, S = P X P SYMMETRIC MATRIX. ***
-C *** LOWER TRIANGLE OF S STORED ROWWISE. ***
-C
-C *** PARAMETER DECLARATIONS ***
-C
- INTEGER P
- DOUBLE PRECISION S(1), X(P), Y(P)
-C DIMENSION S(P*(P+1)/2)
-C
-C *** LOCAL VARIABLES ***
-C
- INTEGER I, IM1, J, K
- DOUBLE PRECISION XI
-C
-C *** NO INTRINSIC FUNCTIONS ***
-C
-C *** EXTERNAL FUNCTION ***
-C
- DOUBLE PRECISION DD7TPR
- EXTERNAL DD7TPR
-C
-C-----------------------------------------------------------------------
-C
- J = 1
- DO 10 I = 1, P
- Y(I) = DD7TPR(I, S(J), X)
- J = J + I
- 10 CONTINUE
-C
- IF (P .LE. 1) GO TO 999
- J = 1
- DO 40 I = 2, P
- XI = X(I)
- IM1 = I - 1
- J = J + 1
- DO 30 K = 1, IM1
- Y(K) = Y(K) + S(J)*XI
- J = J + 1
- 30 CONTINUE
- 40 CONTINUE
-C
- 999 RETURN
-C *** LAST CARD OF DS7LVM FOLLOWS ***
- END
diff --git a/CEP/PyBDSM/src/port3/dsm.f b/CEP/PyBDSM/src/port3/dsm.f
deleted file mode 100644
index 104ebb1efc171bcbee5991171fc5884ab66bbbd2..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/dsm.f
+++ /dev/null
@@ -1,222 +0,0 @@
- SUBROUTINE DSM(M,N,NPAIRS,INDROW,INDCOL,NGRP,MAXGRP,MINGRP,
- * INFO,IPNTR,JPNTR,IWA,LIWA,BWA)
- INTEGER M,N,NPAIRS,MAXGRP,MINGRP,INFO,LIWA
- INTEGER INDROW(NPAIRS),INDCOL(NPAIRS),NGRP(N),
- * IPNTR(1),JPNTR(1),IWA(LIWA)
- LOGICAL BWA(N)
-C **********
-C
-C SUBROUTINE DSM
-C
-C THE PURPOSE OF DSM IS TO DETERMINE AN OPTIMAL OR NEAR-
-C OPTIMAL CONSISTENT PARTITION OF THE COLUMNS OF A SPARSE
-C M BY N MATRIX A.
-C
-C THE SPARSITY PATTERN OF THE MATRIX A IS SPECIFIED BY
-C THE ARRAYS INDROW AND INDCOL. ON INPUT THE INDICES
-C FOR THE NON-ZERO ELEMENTS OF A ARE
-C
-C INDROW(K),INDCOL(K), K = 1,2,...,NPAIRS.
-C
-C THE (INDROW,INDCOL) PAIRS MAY BE SPECIFIED IN ANY ORDER.
-C DUPLICATE INPUT PAIRS ARE PERMITTED, BUT THE SUBROUTINE
-C ELIMINATES THEM.
-C
-C THE SUBROUTINE PARTITIONS THE COLUMNS OF A INTO GROUPS
-C SUCH THAT COLUMNS IN THE SAME GROUP DO NOT HAVE A
-C NON-ZERO IN THE SAME ROW POSITION. A PARTITION OF THE
-C COLUMNS OF A WITH THIS PROPERTY IS CONSISTENT WITH THE
-C DIRECT DETERMINATION OF A.
-C
-C THE SUBROUTINE STATEMENT IS
-C
-C SUBROUTINE DSM(M,N,NPAIRS,INDROW,INDCOL,NGRP,MAXGRP,MINGRP,
-C INFO,IPNTR,JPNTR,IWA,LIWA,BWA)
-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 NPAIRS IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE
-C NUMBER OF (INDROW,INDCOL) PAIRS USED TO DESCRIBE THE
-C SPARSITY PATTERN OF A.
-C
-C INDROW IS AN INTEGER ARRAY OF LENGTH NPAIRS. ON INPUT INDROW
-C MUST CONTAIN THE ROW INDICES OF THE NON-ZERO ELEMENTS OF A.
-C ON OUTPUT INDROW IS PERMUTED SO THAT THE CORRESPONDING
-C COLUMN INDICES ARE IN NON-DECREASING ORDER. THE COLUMN
-C INDICES CAN BE RECOVERED FROM THE ARRAY JPNTR.
-C
-C INDCOL IS AN INTEGER ARRAY OF LENGTH NPAIRS. ON INPUT INDCOL
-C MUST CONTAIN THE COLUMN INDICES OF THE NON-ZERO ELEMENTS OF
-C A. ON OUTPUT INDCOL IS PERMUTED SO THAT THE CORRESPONDING
-C ROW INDICES ARE IN NON-DECREASING ORDER. THE ROW INDICES
-C CAN BE RECOVERED FROM THE ARRAY IPNTR.
-C
-C NGRP IS AN INTEGER OUTPUT ARRAY OF LENGTH N WHICH SPECIFIES
-C THE PARTITION OF THE COLUMNS OF A. COLUMN JCOL BELONGS
-C TO GROUP NGRP(JCOL).
-C
-C MAXGRP IS AN INTEGER OUTPUT VARIABLE WHICH SPECIFIES THE
-C NUMBER OF GROUPS IN THE PARTITION OF THE COLUMNS OF A.
-C
-C MINGRP IS AN INTEGER OUTPUT VARIABLE WHICH SPECIFIES A LOWER
-C BOUND FOR THE NUMBER OF GROUPS IN ANY CONSISTENT PARTITION
-C OF THE COLUMNS OF A.
-C
-C INFO IS AN INTEGER OUTPUT VARIABLE SET AS FOLLOWS. FOR
-C NORMAL TERMINATION INFO = 1. IF M, N, OR NPAIRS IS NOT
-C POSITIVE OR LIWA IS LESS THAN MAX(M,6*N), THEN INFO = 0.
-C IF THE K-TH ELEMENT OF INDROW IS NOT AN INTEGER BETWEEN
-C 1 AND M OR THE K-TH ELEMENT OF INDCOL IS NOT AN INTEGER
-C BETWEEN 1 AND N, THEN INFO = -K.
-C
-C IPNTR IS AN INTEGER OUTPUT ARRAY OF LENGTH M + 1 WHICH
-C SPECIFIES THE LOCATIONS OF THE COLUMN INDICES IN INDCOL.
-C THE COLUMN INDICES FOR ROW I ARE
-C
-C INDCOL(K), K = IPNTR(I),...,IPNTR(I+1)-1.
-C
-C NOTE THAT IPNTR(M+1)-1 IS THEN THE NUMBER OF NON-ZERO
-C ELEMENTS OF THE MATRIX A.
-C
-C JPNTR IS AN INTEGER OUTPUT ARRAY OF LENGTH N + 1 WHICH
-C SPECIFIES THE LOCATIONS OF THE ROW INDICES IN INDROW.
-C THE ROW INDICES FOR COLUMN J ARE
-C
-C INDROW(K), K = JPNTR(J),...,JPNTR(J+1)-1.
-C
-C NOTE THAT JPNTR(N+1)-1 IS THEN THE NUMBER OF NON-ZERO
-C ELEMENTS OF THE MATRIX A.
-C
-C IWA IS AN INTEGER WORK ARRAY OF LENGTH LIWA.
-C
-C LIWA IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN
-C MAX(M,6*N).
-C
-C BWA IS A LOGICAL WORK ARRAY OF LENGTH N.
-C
-C SUBPROGRAMS CALLED
-C
-C MINPACK-SUPPLIED ...D7EGR,I7DO,N7MSRT,M7SEQ,S7ETR,M7SLO,S7RTDT
-C
-C FORTRAN-SUPPLIED ... MAX0
-C
-C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. JUNE 1982.
-C THOMAS F. COLEMAN, BURTON S. GARBOW, JORGE J. MORE
-C
-C **********
- INTEGER I,IR,J,JP,JPL,JPU,K,MAXCLQ,NNZ,NUMGRP
-C
-C CHECK THE INPUT DATA.
-C
- INFO = 0
- IF (M .LT. 1 .OR. N .LT. 1 .OR. NPAIRS .LT. 1 .OR.
- * LIWA .LT. MAX0(M,6*N)) GO TO 130
- DO 10 K = 1, NPAIRS
- INFO = -K
- IF (INDROW(K) .LT. 1 .OR. INDROW(K) .GT. M .OR.
- * INDCOL(K) .LT. 1 .OR. INDCOL(K) .GT. N) GO TO 130
- 10 CONTINUE
- INFO = 1
-C
-C SORT THE DATA STRUCTURE BY COLUMNS.
-C
- CALL S7RTDT(N,NPAIRS,INDROW,INDCOL,JPNTR,IWA(1))
-C
-C COMPRESS THE DATA AND DETERMINE THE NUMBER OF
-C NON-ZERO ELEMENTS OF A.
-C
- DO 20 I = 1, M
- IWA(I) = 0
- 20 CONTINUE
- NNZ = 0
- DO 70 J = 1, N
- JPL = JPNTR(J)
- JPU = JPNTR(J+1) - 1
- JPNTR(J) = NNZ + 1
- IF (JPU .LT. JPL) GO TO 60
- DO 40 JP = JPL, JPU
- IR = INDROW(JP)
- IF (IWA(IR) .NE. 0) GO TO 30
- NNZ = NNZ + 1
- INDROW(NNZ) = IR
- IWA(IR) = 1
- 30 CONTINUE
- 40 CONTINUE
- JPL = JPNTR(J)
- DO 50 JP = JPL, NNZ
- IR = INDROW(JP)
- IWA(IR) = 0
- 50 CONTINUE
- 60 CONTINUE
- 70 CONTINUE
- JPNTR(N+1) = NNZ + 1
-C
-C EXTEND THE DATA STRUCTURE TO ROWS.
-C
- CALL S7ETR(M,N,INDROW,JPNTR,INDCOL,IPNTR,IWA(1))
-C
-C DETERMINE A LOWER BOUND FOR THE NUMBER OF GROUPS.
-C
- MINGRP = 0
- DO 80 I = 1, M
- MINGRP = MAX0(MINGRP,IPNTR(I+1)-IPNTR(I))
- 80 CONTINUE
-C
-C DETERMINE THE DEGREE SEQUENCE FOR THE INTERSECTION
-C GRAPH OF THE COLUMNS OF A.
-C
- CALL D7EGR(N,INDROW,JPNTR,INDCOL,IPNTR,IWA(5*N+1),IWA(N+1),BWA)
-C
-C COLOR THE INTERSECTION GRAPH OF THE COLUMNS OF A
-C WITH THE SMALLEST-LAST (SL) ORDERING.
-C
- CALL M7SLO(N,INDROW,JPNTR,INDCOL,IPNTR,IWA(5*N+1),IWA(4*N+1),
- * MAXCLQ,IWA(1),IWA(N+1),IWA(2*N+1),IWA(3*N+1),BWA)
- CALL M7SEQ(N,INDROW,JPNTR,INDCOL,IPNTR,IWA(4*N+1),NGRP,MAXGRP,
- * IWA(N+1),BWA)
- MINGRP = MAX0(MINGRP,MAXCLQ)
- IF (MAXGRP .EQ. MINGRP) GO TO 130
-C
-C COLOR THE INTERSECTION GRAPH OF THE COLUMNS OF A
-C WITH THE INCIDENCE-DEGREE (ID) ORDERING.
-C
- CALL I7DO(M,N,INDROW,JPNTR,INDCOL,IPNTR,IWA(5*N+1),IWA(4*N+1),
- * MAXCLQ,IWA(1),IWA(N+1),IWA(2*N+1),IWA(3*N+1),BWA)
- CALL M7SEQ(N,INDROW,JPNTR,INDCOL,IPNTR,IWA(4*N+1),IWA(1),NUMGRP,
- * IWA(N+1),BWA)
- MINGRP = MAX0(MINGRP,MAXCLQ)
- IF (NUMGRP .GE. MAXGRP) GO TO 100
- MAXGRP = NUMGRP
- DO 90 J = 1, N
- NGRP(J) = IWA(J)
- 90 CONTINUE
- IF (MAXGRP .EQ. MINGRP) GO TO 130
- 100 CONTINUE
-C
-C COLOR THE INTERSECTION GRAPH OF THE COLUMNS OF A
-C WITH THE LARGEST-FIRST (LF) ORDERING.
-C
- CALL N7MSRT(N,N-1,IWA(5*N+1),-1,IWA(4*N+1),IWA(2*N+1),IWA(N+1))
- CALL M7SEQ(N,INDROW,JPNTR,INDCOL,IPNTR,IWA(4*N+1),IWA(1),NUMGRP,
- * IWA(N+1),BWA)
- IF (NUMGRP .GE. MAXGRP) GO TO 120
- MAXGRP = NUMGRP
- DO 110 J = 1, N
- NGRP(J) = IWA(J)
- 110 CONTINUE
- 120 CONTINUE
-C
-C EXIT FROM PROGRAM.
-C
- 130 CONTINUE
- RETURN
-C
-C LAST CARD OF SUBROUTINE DSM.
-C
- END
diff --git a/CEP/PyBDSM/src/port3/dsmnfb.f b/CEP/PyBDSM/src/port3/dsmnfb.f
deleted file mode 100644
index 9502e9a453fde4275a5715396be33efb67d36395..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/dsmnfb.f
+++ /dev/null
@@ -1,89 +0,0 @@
- SUBROUTINE DSMNFB( P, X,B, CALCF, MXFCAL, ACC )
-C
-C ** SIMPLIED VERSION OF DMNF
-C
-C INPUT PARAMETERS
-C P NUMBER OF UNKNOWNS
-C X APPROXIMATE SOLUTION
-C B FIRST ROW OF B GIVES LOWER BOUNDS ON X AND SECOND GIVES UPPER
-C BOUNDS
-C CALCF SUBROUTINE TO EVALUATE FUNCTION
-C MXFCAL MAXIMUM NUMBER OF PERMITTED FUNCTION EVALUATIONS
-C ACC ACCURACY IN X
-C OUTPUT PARAMETERS
-C X SOLUTION
- INTEGER P, MXFCAL
- DOUBLE PRECISION X(P), ACC ,B(2,P)
- EXTERNAL CALCF, DC6LCF
-C
-C
-C
-C *** LOCAL VARIABLES ***
-C
- INTEGER IV, LIV, LV, V1
- INTEGER IDI,IDM1,ID,J
- DOUBLE PRECISION UR
- DOUBLE PRECISION DSTAK(500)
- COMMON /CSTAK/ DSTAK
- INTEGER ISTAK(1000)
- EQUIVALENCE (DSTAK(1), ISTAK(1))
-C
-C *** BODY ***
-C
- CALL ENTER(0)
-C/6S
-C IF (P.LT.1)
-C 1CALL SETERR(14HDSMNFB- P.LT.1,14,1,2)
-C IF (MXFCAL.LT.1)
-C 1CALL SETERR(19HDSMNFB- MXFCAL.LT.1,19,2,2)
-C IF (ACC.LT.0.0D0)
-C 1CALL SETERR(18HDSMNFB-ACC .LT.0.0,18,3,2)
-C/7S
- IF (P.LT.1)
- 1CALL SETERR('DSMNFB- P.LT.1',14,1,2)
- IF (MXFCAL.LT.1)
- 1CALL SETERR('DSMNFB- MXFCAL.LT.1',19,2,2)
- IF (ACC.LT.0.0D0)
- 1CALL SETERR('DSMNFB-ACC .LT.0.0',18,3,2)
-C/
- LIV =59+P
- LV=77+P*(P+23)/2
- IV=ISTKGT(LIV,2)
- V1=ISTKGT(LV, 4)
- CALL DIVSET(2,ISTAK(IV),LIV,LV,DSTAK(V1))
- ISTAK(IV+20)=0
- ISTAK(IV+16)=MXFCAL
- ISTAK(IV+17)=MXFCAL
- DSTAK(V1+32)=ACC
- DSTAK(V1+31)=ACC
- ID=ISTKGT(P, 4)
- IDM1=ID-1
- DO 10 I=1,P
- IDI=IDM1+I
- DSTAK(IDI)=1.0
- IF (X(I).NE.0.0)DSTAK(IDI)=1.0/DABS(X(I))
- 10 CONTINUE
- CALL DMNFB( P, DSTAK(ID),X,B, DC6LCF, ISTAK(IV), LIV, LV,
- 1 DSTAK(V1), IU, UR, CALCF)
- J=ISTAK(IV)
- IF(J.LT.7) GO TO 20
-C/6S
-C IF (J.EQ.82)CALL SETERR(26HDSMNFB-INCONSISTENT BOUNDS,26,4,1)
-C IF (J.EQ.7)CALL SETERR(27HDSMNFB-SINGULAR CONVERGENCE,27,5,1)
-C IF(J.EQ.8)CALL SETERR(24HDSMNFB-FALSE CONVERGENCE,24,6,1)
-C IF(J.EQ.9)CALL SETERR(32HDSMNFB-FUNCTION EVALUATION LIMIT,32,7,1)
-C IF (J.EQ.63)
-C 1CALL SETERR(43HDSMNFB-F(X) CANNOT BE COMPUTED AT INITIAL X,43,8,1)
-C/7S
- IF (J.EQ.82)CALL SETERR('DSMNFB-INCONSISTENT BOUNDS',26,4,1)
- IF (J.EQ.7)CALL SETERR('DSMNFB-SINGULAR CONVERGENCE',27,5,1)
- IF(J.EQ.8)CALL SETERR('DSMNFB-FALSE CONVERGENCE',24,6,1)
- IF(J.EQ.9)CALL SETERR('DSMNFB-FUNCTION EVALUATION LIMIT',32,7,1)
- IF (J.EQ.63)
- 1CALL SETERR('DSMNFB-F(X) CANNOT BE COMPUTED AT INITIAL X',43,8,1)
-C/
- 20 CALL LEAVE
-C
- RETURN
-C *** LAST LINE OF DSMNFB FOLLOWS ***
- END
diff --git a/CEP/PyBDSM/src/port3/dttgrx1.f b/CEP/PyBDSM/src/port3/dttgrx1.f
deleted file mode 100644
index 94c6ea76d598e9d3bd878539018a018238617fa5..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/dttgrx1.f
+++ /dev/null
@@ -1,191 +0,0 @@
-C$TEST DTTGR1
-c main program
- common /cstak/ ds
- double precision ds(350000)
- external handle, bc, af
- integer ndx, ndy, istkgt, is(1000), iu, ix
- integer iy, nu, kx, nx, ky, ny
- integer idumb
- real errpar(2), rs(1000)
- logical ls(1000)
- complex cs(500)
- double precision tstart, dt, lx, ly, rx, ry
- double precision ws(500), tstop
- equivalence (ds(1), cs(1), ws(1), rs(1), is(1), ls(1))
-c to solve the heat equation with solution u == t*x*y,
-c grad . ( u + ux + .1 * uy, u + uy + .1 * ux ) = ut + ux + uy +g(x,t)
-c the port library stack and its aliases.
-c initialize the port library stack length.
- call istkin(350000, 4)
- call enter(1)
- nu = 1
- lx = 0
- rx = 1
- ly = 0
- ry = 1
- kx = 2
- ky = 2
- ndx = 3
- ndy = 3
- tstart = 0
- tstop = 1
- dt = 1
- errpar(1) = 1e-2
- errpar(2) = 1e-4
-c uniform grid.
- ix = idumb(lx, rx, ndx, kx, nx)
-c uniform grid.
- iy = idumb(ly, ry, ndy, ky, ny)
-c space for the solution.
- iu = istkgt(nu*(nx-kx)*(ny-ky), 4)
-c initial conditions for u.
- call setd(nu*(nx-kx)*(ny-ky), 0d0, ws(iu))
- call dttgr(ws(iu), nu, kx, ws(ix), nx, ky, ws(iy), ny, tstart,
- 1 tstop, dt, af, bc, errpar, handle)
- call leave
- call wrapup
- stop
- end
- subroutine af(t, x, nx, y, ny, nu, u, ut, ux, uy, uxt, uyt
- 1 , a, au, aut, aux, auy, auxt, auyt, f, fu, fut, fux, fuy, fuxt,
- 2 fuyt)
- integer nu, nx, ny
- double precision t, x(nx), y(ny), u(nx, ny, nu), ut(nx, ny, nu),
- 1 ux(nx, ny, nu)
- double precision uy(nx, ny, nu), uxt(nx, ny, nu), uyt(nx, ny, nu),
- 1 a(nx, ny, nu, 2), au(nx, ny, nu, nu, 2), aut(nx, ny, nu, nu, 2)
- double precision aux(nx, ny, nu, nu, 2), auy(nx, ny, nu, nu, 2),
- 1 auxt(nx, ny, nu, nu, 2), auyt(nx, ny, nu, nu, 2), f(nx, ny, nu)
- 2 , fu(nx, ny, nu, nu)
- double precision fut(nx, ny, nu, nu), fux(nx, ny, nu, nu), fuy(nx,
- 1 ny, nu, nu), fuxt(nx, ny, nu, nu), fuyt(nx, ny, nu, nu)
- integer i, p, q
- do 3 i = 1, nu
- do 2 q = 1, ny
- do 1 p = 1, nx
- a(p, q, i, 1) = ux(p, q, i)+.1*uy(p, q, i)+u(p, q, i)
- a(p, q, i, 2) = uy(p, q, i)+.1*ux(p, q, i)+u(p, q, i)
- aux(p, q, i, i, 1) = 1
- auy(p, q, i, i, 2) = 1
- auy(p, q, i, i, 1) = .1
- aux(p, q, i, i, 2) = .1
- au(p, q, i, i, 1) = 1
- au(p, q, i, i, 2) = 1
- f(p, q, i) = ut(p, q, i)+ux(p, q, i)+uy(p, q, i)
- fut(p, q, i, i) = 1
- fux(p, q, i, i) = 1
- fuy(p, q, i, i) = 1
- f(p, q, i) = f(p, q, i)+.2*t-x(p)*y(q)
- 1 continue
- 2 continue
- 3 continue
- return
- end
- subroutine bc(t, x, nx, y, ny, lx, rx, ly, ry, u, ut, ux,
- 1 uy, uxt, uyt, nu, b, bu, but, bux, buy, buxt, buyt)
- integer nu, nx, ny
- double precision t, x(nx), y(ny), lx, rx, ly
- double precision ry, u(nx, ny, nu), ut(nx, ny, nu), ux(nx, ny, nu)
- 1 , uy(nx, ny, nu), uxt(nx, ny, nu)
- double precision uyt(nx, ny, nu), b(nx, ny, nu), bu(nx, ny, nu,
- 1 nu), but(nx, ny, nu, nu), bux(nx, ny, nu, nu), buy(nx, ny, nu
- 2 , nu)
- double precision buxt(nx, ny, nu, nu), buyt(nx, ny, nu, nu)
- integer i, j
- do 2 j = 1, ny
- do 1 i = 1, nx
- bu(i, j, 1, 1) = 1
- b(i, j, 1) = u(i, j, 1)-t*x(i)*y(j)
- 1 continue
- 2 continue
- return
- end
- subroutine handle(t0, u0, t, u, nv, dt, tstop)
- integer nv
- double precision t0, u0(nv), t, u(nv), dt, tstop
- common /d7tgrp/ errpar, nu, mxq, myq
- integer nu, mxq, myq
- real errpar(2)
- common /d7tgrm/ kx, ix, nx, ky, iy, ny
- integer kx, ix, nx, ky, iy, ny
- if (t0 .ne. t) goto 2
- write (6, 1) t
- 1 format (16h restart for t =, 1pe10.2)
- return
-c get and print the error.
- 2 call gerr(kx, ix, nx, ky, iy, ny, u, nu, t)
- return
- end
- subroutine gerr(kx, ix, nx, ky, iy, ny, u, nu, t)
- integer kx, ix, nx, ky, iy, ny
- integer nu
- double precision u(1), t
- common /cstak/ ds
- double precision ds(500)
- integer ifa, ita(2), ixa(2), nta(2), nxa(2), idlumd
- integer ixs, iys, nxs, nys, istkgt, i
- integer iewe, ka(2), ma(2), is(1000), i1mach
- real rs(1000)
- logical ls(1000)
- complex cs(500)
- double precision dabs, erru, dmax1, ws(500)
- integer temp, temp1, temp2
- equivalence (ds(1), cs(1), ws(1), rs(1), is(1), ls(1))
-c to get and print the error at each time-step.
-c u(nx-kx,ny0ky,nu).
-c the port library stack and its aliases.
- call enter(1)
-c find the error in the solution at 2*kx * 2*ky points / mesh rectangle.
-c x search grid.
- ixs = idlumd(ws(ix), nx, 2*kx, nxs)
-c y search grid.
- iys = idlumd(ws(iy), ny, 2*ky, nys)
-c u search grid values.
- iewe = istkgt(nxs*nys, 4)
-c the exact solution.
- call ewe(t, ws(ixs), nxs, ws(iys), nys, ws(iewe), nu)
- ka(1) = kx
- ka(2) = ky
- ita(1) = ix
- ita(2) = iy
- nta(1) = nx
- nta(2) = ny
- ixa(1) = ixs
- ixa(2) = iys
- nxa(1) = nxs
- nxa(2) = nys
- ma(1) = 0
-c get solution.
- ma(2) = 0
-c approximate solution values.
- ifa = istkgt(nxs*nys, 4)
-c evaluate them.
- call dtsd1(2, ka, ws, ita, nta, u, ws, ixa, nxa, ma, ws(ifa))
-c error in solution values.
- erru = 0
- temp = nxs*nys
- do 1 i = 1, temp
- temp2 = iewe+i
- temp1 = ifa+i
- erru = dmax1(erru, dabs(ws(temp2-1)-ws(temp1-1)))
- 1 continue
- temp = i1mach(2)
- write (temp, 2) t, erru
- 2 format (14h error in u(.,, 1pe10.2, 3h) =, 1pe10.2)
- call leave
- return
- end
- subroutine ewe(t, x, nx, y, ny, u, nu)
- integer nu, nx, ny
- double precision t, x(nx), y(ny), u(nx, ny, nu)
- integer i, j, p
-c the exact solution.
- do 3 p = 1, nu
- do 2 i = 1, nx
- do 1 j = 1, ny
- u(i, j, p) = t*x(i)*y(j)
- 1 continue
- 2 continue
- 3 continue
- return
- end
diff --git a/CEP/PyBDSM/src/port3/dttgrx1p.f b/CEP/PyBDSM/src/port3/dttgrx1p.f
deleted file mode 100644
index 8dbba688e2920e717a9bcbf65727aab9998adfa3..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/dttgrx1p.f
+++ /dev/null
@@ -1,180 +0,0 @@
-C$TEST DTTGR1P
-c main program
- common /cstak/ ds
- double precision ds(350000)
- external handle, bc, af
- integer ndx, ndy, istkgt, is(1000), iu, ix
- integer iy, nu, kx, nx, ky, ny
- integer idumb
- real errpar(2), rs(1000)
- logical ls(1000)
- complex cs(500)
- double precision tstart, dt, lx, ly, rx, ry
- double precision ws(500), tstop
- equivalence (ds(1), cs(1), ws(1), rs(1), is(1), ls(1))
-c to solve the heat equation with solution u == t*x*y,
-c grad . ( u + ux + .1 * uy, u + uy + .1 * ux ) = ut + ux + uy +g(x,t)
-c the port library stack and its aliases.
-c initialize the port library stack length.
- call istkin(350000, 4)
- call enter(1)
- nu = 1
- lx = 0
- rx = 1
- ly = 0
- ry = 1
- kx = 2
- ky = 2
- ndx = 3
- ndy = 3
- tstart = 0
- tstop = 1
- dt = 1
- errpar(1) = 1e-2
- errpar(2) = 1e-4
-c uniform grid.
- ix = idumb(lx, rx, ndx, kx, nx)
-c uniform grid.
- iy = idumb(ly, ry, ndy, ky, ny)
-c space for the solution.
- iu = istkgt(nu*(nx-kx)*(ny-ky), 4)
-c initial conditions for u.
- call setd(nu*(nx-kx)*(ny-ky), 0d0, ws(iu))
- call dttgr(ws(iu), nu, kx, ws(ix), nx, ky, ws(iy), ny, tstart,
- 1 tstop, dt, af, bc, errpar, handle)
- call leave
- call wrapup
- stop
- end
- subroutine af(t, x, nx, y, ny, nu, u, ut, ux, uy, uxt, uyt
- 1 , a, au, aut, aux, auy, auxt, auyt, f, fu, fut, fux, fuy, fuxt,
- 2 fuyt)
- integer nu, nx, ny
- double precision t, x(nx), y(ny), u(nx, ny, nu), ut(nx, ny, nu),
- 1 ux(nx, ny, nu)
- double precision uy(nx, ny, nu), uxt(nx, ny, nu), uyt(nx, ny, nu),
- 1 a(nx, ny, nu, 2), au(nx, ny, nu, nu, 2), aut(nx, ny, nu, nu, 2)
- double precision aux(nx, ny, nu, nu, 2), auy(nx, ny, nu, nu, 2),
- 1 auxt(nx, ny, nu, nu, 2), auyt(nx, ny, nu, nu, 2), f(nx, ny, nu)
- 2 , fu(nx, ny, nu, nu)
- double precision fut(nx, ny, nu, nu), fux(nx, ny, nu, nu), fuy(nx,
- 1 ny, nu, nu), fuxt(nx, ny, nu, nu), fuyt(nx, ny, nu, nu)
- integer i, p, q
- do 3 i = 1, nu
- do 2 q = 1, ny
- do 1 p = 1, nx
- a(p, q, i, 1) = ux(p, q, i)+.1*uy(p, q, i)+u(p, q, i)
- a(p, q, i, 2) = uy(p, q, i)+.1*ux(p, q, i)+u(p, q, i)
- aux(p, q, i, i, 1) = 1
- auy(p, q, i, i, 2) = 1
- auy(p, q, i, i, 1) = .1
- aux(p, q, i, i, 2) = .1
- au(p, q, i, i, 1) = 1
- au(p, q, i, i, 2) = 1
- f(p, q, i) = ut(p, q, i)+ux(p, q, i)+uy(p, q, i)
- fut(p, q, i, i) = 1
- fux(p, q, i, i) = 1
- fuy(p, q, i, i) = 1
- f(p, q, i) = f(p, q, i)+.2*t-x(p)*y(q)
- 1 continue
- 2 continue
- 3 continue
- return
- end
- subroutine bc(t, x, nx, y, ny, lx, rx, ly, ry, u, ut, ux,
- 1 uy, uxt, uyt, nu, b, bu, but, bux, buy, buxt, buyt)
- integer nu, nx, ny
- double precision t, x(nx), y(ny), lx, rx, ly
- double precision ry, u(nx, ny, nu), ut(nx, ny, nu), ux(nx, ny, nu)
- 1 , uy(nx, ny, nu), uxt(nx, ny, nu)
- double precision uyt(nx, ny, nu), b(nx, ny, nu), bu(nx, ny, nu,
- 1 nu), but(nx, ny, nu, nu), bux(nx, ny, nu, nu), buy(nx, ny, nu
- 2 , nu)
- double precision buxt(nx, ny, nu, nu), buyt(nx, ny, nu, nu)
- integer i, j
- do 2 j = 1, ny
- do 1 i = 1, nx
- bu(i, j, 1, 1) = 1
- b(i, j, 1) = u(i, j, 1)-t*x(i)*y(j)
- 1 continue
- 2 continue
- return
- end
- subroutine handle(t0, u0, t, u, nv, dt, tstop)
- integer nv
- double precision t0, u0(nv), t, u(nv), dt, tstop
- common /d7tgrp/ errpar, nu, mxq, myq
- integer nu, mxq, myq
- real errpar(2)
- common /d7tgrm/ kx, ix, nx, ky, iy, ny
- integer kx, ix, nx, ky, iy, ny
- if (t0 .ne. t) goto 2
- write (6, 1) t
- 1 format (16h restart for t =, 1pe10.2)
- return
-c print results.
- 2 call gerr(kx, ix, nx, ky, iy, ny, u, nu, t)
- return
- end
- subroutine gerr(kx, ix, nx, ky, iy, ny, u, nu, t)
- integer kx, ix, nx, ky, iy, ny
- integer nu
- double precision u(1), t
- common /cstak/ ds
- double precision ds(500)
- integer ifa, ita(2), ixa(2), nta(2), nxa(2), idlumd
- integer ixs, iys, nxs, nys, istkgt, i
- integer ka(2), ma(2), is(1000), i1mach
- real rs(1000)
- logical ls(1000)
- complex cs(500)
- double precision ws(500)
- integer temp, temp1
- equivalence (ds(1), cs(1), ws(1), rs(1), is(1), ls(1))
-c to print the solution at each time-step.
-c u(nx-kx,ny,ky,nu).
-c the port library stack and its aliases.
- call enter(1)
-c find the solution at 2 * 2 points / mesh rectangle.
-c x search grid.
- ixs = idlumd(ws(ix), nx, 2, nxs)
-c y search grid.
- iys = idlumd(ws(iy), ny, 2, nys)
- ka(1) = kx
- ka(2) = ky
- ita(1) = ix
- ita(2) = iy
- nta(1) = nx
- nta(2) = ny
- ixa(1) = ixs
- ixa(2) = iys
- nxa(1) = nxs
- nxa(2) = nys
- ma(1) = 0
-c get solution.
- ma(2) = 0
-c approximate solution values.
- ifa = istkgt(nxs*nys, 4)
-c evaluate them.
- call dtsd1(2, ka, ws, ita, nta, u, ws, ixa, nxa, ma, ws(ifa))
- temp1 = ifa+nxs*nys-1
- temp = i1mach(2)
- write (temp, 1) t, (ws(i), i = ifa, temp1)
- 1 format (3h u(, 1pe10.2, 7h,.,.) =, (1p5e10.2/20x,1p4e10.2))
- call leave
- return
- end
- subroutine ewe(t, x, nx, y, ny, u, nu)
- integer nu, nx, ny
- double precision t, x(nx), y(ny), u(nx, ny, nu)
- integer i, j, p
-c the exact solution.
- do 3 p = 1, nu
- do 2 i = 1, nx
- do 1 j = 1, ny
- u(i, j, p) = t*x(i)*y(j)
- 1 continue
- 2 continue
- 3 continue
- return
- end
diff --git a/CEP/PyBDSM/src/port3/dttgrx2.f b/CEP/PyBDSM/src/port3/dttgrx2.f
deleted file mode 100644
index 9f115c04c1312c9a034f2ae647cdf75f087e32c8..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/dttgrx2.f
+++ /dev/null
@@ -1,196 +0,0 @@
-C$TEST DTTGR2
-c main program
- common /cstak/ ds
- double precision ds(350000)
- external handle, bc, af
- integer ndx, ndy, istkgt, is(1000), iu, ix
- integer iy, nu, kx, nx, ky, ny
- integer idumb
- real errpar(2), rs(1000)
- logical ls(1000)
- complex cs(500)
- double precision tstart, dt, lx, ly, rx, ry
- double precision ws(500), tstop
- equivalence (ds(1), cs(1), ws(1), rs(1), is(1), ls(1))
-c to solve two coupled, nonlinear heat equations.
-c u1 sub t = div . ( u1x, u1y ) - u1*u2 + g1
-c u2 sub t = div . ( u2x, u2y ) - u1*u2 + g2
-c the port library stack and its aliases.
-c initialize the port library stack length.
- call istkin(350000, 4)
- call enter(1)
- nu = 2
- lx = 0
- rx = 1
- ly = 0
- ry = 1
- kx = 4
- ky = 4
- ndx = 3
- ndy = 3
- tstart = 0
- tstop = 1
- dt = 1e-2
- errpar(1) = 1e-2
- errpar(2) = 1e-4
-c uniform grid.
- ix = idumb(lx, rx, ndx, kx, nx)
-c uniform grid.
- iy = idumb(ly, ry, ndy, ky, ny)
-c space for the solution.
- iu = istkgt(nu*(nx-kx)*(ny-ky), 4)
- call setd(nu*(nx-kx)*(ny-ky), 1d0, ws(iu))
- call dttgr(ws(iu), nu, kx, ws(ix), nx, ky, ws(iy), ny, tstart,
- 1 tstop, dt, af, bc, errpar, handle)
- call leave
- call wrapup
- stop
- end
- subroutine af(t, x, nx, y, ny, nu, u, ut, ux, uy, uxt, uyt
- 1 , a, au, aut, aux, auy, auxt, auyt, f, fu, fut, fux, fuy, fuxt,
- 2 fuyt)
- integer nu, nx, ny
- double precision t, x(nx), y(ny), u(nx, ny, nu), ut(nx, ny, nu),
- 1 ux(nx, ny, nu)
- double precision uy(nx, ny, nu), uxt(nx, ny, nu), uyt(nx, ny, nu),
- 1 a(nx, ny, nu, 2), au(nx, ny, nu, nu, 2), aut(nx, ny, nu, nu, 2)
- double precision aux(nx, ny, nu, nu, 2), auy(nx, ny, nu, nu, 2),
- 1 auxt(nx, ny, nu, nu, 2), auyt(nx, ny, nu, nu, 2), f(nx, ny, nu)
- 2 , fu(nx, ny, nu, nu)
- double precision fut(nx, ny, nu, nu), fux(nx, ny, nu, nu), fuy(nx,
- 1 ny, nu, nu), fuxt(nx, ny, nu, nu), fuyt(nx, ny, nu, nu)
- integer p, q
- double precision dexp
- do 2 q = 1, ny
- do 1 p = 1, nx
- a(p, q, 1, 1) = ux(p, q, 1)
- aux(p, q, 1, 1, 1) = 1
- a(p, q, 1, 2) = uy(p, q, 1)
- auy(p, q, 1, 1, 2) = 1
- f(p, q, 1) = ut(p, q, 1)+u(p, q, 1)*u(p, q, 2)
- fu(p, q, 1, 1) = u(p, q, 2)
- fu(p, q, 1, 2) = u(p, q, 1)
- fut(p, q, 1, 1) = 1
- a(p, q, 2, 1) = ux(p, q, 2)
- aux(p, q, 2, 2, 1) = 1
- a(p, q, 2, 2) = uy(p, q, 2)
- auy(p, q, 2, 2, 2) = 1
- f(p, q, 2) = ut(p, q, 2)+u(p, q, 1)*u(p, q, 2)
- fu(p, q, 2, 1) = u(p, q, 2)
- fu(p, q, 2, 2) = u(p, q, 1)
- fut(p, q, 2, 2) = 1
- f(p, q, 1) = f(p, q, 1)-(dexp(t*(x(p)-y(q)))*(x(p)-y(q)-2d0*
- 1 t*t)+1d0)
- f(p, q, 2) = f(p, q, 2)-(dexp(t*(y(q)-x(p)))*(y(q)-x(p)-2d0*
- 1 t*t)+1d0)
- 1 continue
- 2 continue
- return
- end
- subroutine bc(t, x, nx, y, ny, lx, rx, ly, ry, u, ut, ux,
- 1 uy, uxt, uyt, nu, b, bu, but, bux, buy, buxt, buyt)
- integer nu, nx, ny
- double precision t, x(nx), y(ny), lx, rx, ly
- double precision ry, u(nx, ny, nu), ut(nx, ny, nu), ux(nx, ny, nu)
- 1 , uy(nx, ny, nu), uxt(nx, ny, nu)
- double precision uyt(nx, ny, nu), b(nx, ny, nu), bu(nx, ny, nu,
- 1 nu), but(nx, ny, nu, nu), bux(nx, ny, nu, nu), buy(nx, ny, nu
- 2 , nu)
- double precision buxt(nx, ny, nu, nu), buyt(nx, ny, nu, nu)
- integer i, j
- double precision dexp
- do 2 j = 1, ny
- do 1 i = 1, nx
- bu(i, j, 1, 1) = 1
- b(i, j, 1) = u(i, j, 1)-dexp(t*(x(i)-y(j)))
- bu(i, j, 2, 2) = 1
- b(i, j, 2) = u(i, j, 2)-dexp(t*(y(j)-x(i)))
- 1 continue
- 2 continue
- return
- end
- subroutine handle(t0, u0, t, u, nv, dt, tstop)
- integer nv
- double precision t0, u0(nv), t, u(nv), dt, tstop
- common /cstak/ ds
- double precision ds(500)
- common /d7tgrp/ errpar, nu, mxq, myq
- integer nu, mxq, myq
- real errpar(2)
- common /d7tgrm/ kx, ix, nx, ky, iy, ny
- integer kx, ix, nx, ky, iy, ny
- integer ifa, ita(2), ixa(2), nta(2), nxa(2), idlumd
- integer ixs, iys, nxs, nys, istkgt, i
- integer j, iewe, ka(2), ma(2), is(1000), i1mach
- real rs(1000)
- logical ls(1000)
- complex cs(500)
- double precision dabs, erru, dmax1, ws(500)
- integer temp, temp1, temp2
- equivalence (ds(1), cs(1), ws(1), rs(1), is(1), ls(1))
-c the port library stack and its aliases.
- if (t0 .ne. t) goto 2
- write (6, 1) t
- 1 format (16h restart for t =, 1pe10.2)
- return
- 2 call enter(1)
-c find the error in the solution at 2*kx * 2*ky points / mesh rectangle.
-c x search grid.
- ixs = idlumd(ws(ix), nx, 2*kx, nxs)
-c y search grid.
- iys = idlumd(ws(iy), ny, 2*ky, nys)
-c u search grid values.
- iewe = istkgt(nu*nxs*nys, 4)
-c the exact solution.
- call ewe(t, ws(ixs), nxs, ws(iys), nys, ws(iewe), nu)
- ka(1) = kx
- ka(2) = ky
- ita(1) = ix
- ita(2) = iy
- nta(1) = nx
- nta(2) = ny
- ixa(1) = ixs
- ixa(2) = iys
- nxa(1) = nxs
- nxa(2) = nys
- ma(1) = 0
-c get solution.
- ma(2) = 0
-c approximate solution values.
- ifa = istkgt(nxs*nys, 4)
- do 5 j = 1, nu
-c evaluate them.
- temp = (j-1)*(nx-kx)*(ny-ky)
- call dtsd1(2, ka, ws, ita, nta, u(temp+1), ws, ixa, nxa, ma,
- 1 ws(ifa))
-c error in solution values.
- erru = 0
- temp = nxs*nys
- do 3 i = 1, temp
- temp2 = iewe+i-1+(j-1)*nxs*nys
- temp1 = ifa+i
- erru = dmax1(erru, dabs(ws(temp2)-ws(temp1-1)))
- 3 continue
- temp = i1mach(2)
- write (temp, 4) t, j, erru
- 4 format (14h error in u(.,, 1pe10.2, 1h,, i2, 3h) =, 1pe10.2)
- 5 continue
- call leave
- return
- end
- subroutine ewe(t, x, nx, y, ny, u, nu)
- integer nu, nx, ny
- double precision t, x(nx), y(ny), u(nx, ny, nu)
- integer i, j, p
- real float
- double precision dble, dexp
-c the exact solution.
- do 3 p = 1, nu
- do 2 i = 1, nx
- do 1 j = 1, ny
- u(i, j, p) = dexp(dble(float((-1)**(p+1)))*t*(x(i)-y(j)))
- 1 continue
- 2 continue
- 3 continue
- return
- end
diff --git a/CEP/PyBDSM/src/port3/dttgrx3.f b/CEP/PyBDSM/src/port3/dttgrx3.f
deleted file mode 100644
index f093036ad0d1f84398c90e1ae30dc8f2820a9226..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/dttgrx3.f
+++ /dev/null
@@ -1,229 +0,0 @@
-C$TEST DTTGR3
-c main program
- common /cstak/ ds
- double precision ds(350000)
- external handle, bc, af
- integer ndx, ndy, idlumb, istkgt, i, is(1000)
- integer iu, ix, iy, nu, kx, nx
- integer ky, ny, idumb, immmd
- real errpar(2), rs(1000)
- logical ls(1000)
- complex cs(500)
- double precision tstart, dt, yb(4), lx, rx, ws(500)
- double precision tstop
- equivalence (ds(1), cs(1), ws(1), rs(1), is(1), ls(1))
-c to solve the layered heat equation, with kappa = 1, 1/2, 1/3,
-c div . ( kappa(x,y) * grad u ) = ut + g
-c the port library stack and its aliases.
-c initialize the port library stack length.
- call istkin(350000, 4)
- call enter(1)
- nu = 1
- lx = 0
- rx = 1
- do 1 i = 1, 4
- yb(i) = i-1
- 1 continue
- kx = 2
- ky = 2
- ndx = 3
- ndy = 3
- tstart = 0
- tstop = 1
- dt = 1
- errpar(1) = 1e-2
- errpar(2) = 1e-4
-c uniform grid.
- ix = idumb(lx, rx, ndx, kx, nx)
-c uniform grid.
- iy = idlumb(yb, 4, ndy, ky, ny)
-c make mult = ky-1.
- iy = immmd(iy, ny, yb(2), ky-1)
-c make mult = ky-1.
- iy = immmd(iy, ny, yb(3), ky-1)
-c space for the solution.
- iu = istkgt(nu*(nx-kx)*(ny-ky), 4)
- call setd(nu*(nx-kx)*(ny-ky), 0d0, ws(iu))
- call dttgr(ws(iu), nu, kx, ws(ix), nx, ky, ws(iy), ny, tstart,
- 1 tstop, dt, af, bc, errpar, handle)
- call leave
- call wrapup
- stop
- end
- subroutine af(t, x, nx, y, ny, nu, u, ut, ux, uy, uxt, uyt
- 1 , a, au, aut, aux, auy, auxt, auyt, f, fu, fut, fux, fuy, fuxt,
- 2 fuyt)
- integer nu, nx, ny
- double precision t, x(nx), y(ny), u(nx, ny, nu), ut(nx, ny, nu),
- 1 ux(nx, ny, nu)
- double precision uy(nx, ny, nu), uxt(nx, ny, nu), uyt(nx, ny, nu),
- 1 a(nx, ny, nu, 2), au(nx, ny, nu, nu, 2), aut(nx, ny, nu, nu, 2)
- double precision aux(nx, ny, nu, nu, 2), auy(nx, ny, nu, nu, 2),
- 1 auxt(nx, ny, nu, nu, 2), auyt(nx, ny, nu, nu, 2), f(nx, ny, nu)
- 2 , fu(nx, ny, nu, nu)
- double precision fut(nx, ny, nu, nu), fux(nx, ny, nu, nu), fuy(nx,
- 1 ny, nu, nu), fuxt(nx, ny, nu, nu), fuyt(nx, ny, nu, nu)
- integer i, p, q
- double precision kappa
- logical temp
- do 7 i = 1, nu
- do 6 q = 1, ny
- do 5 p = 1, nx
- if (y(q) .ge. 1d0) goto 1
- kappa = 1
- goto 4
- 1 if (y(q) .ge. 2d0) goto 2
- kappa = 0.5
- goto 3
- 2 kappa = 1d0/3d0
- 3 continue
- 4 a(p, q, i, 1) = kappa*ux(p, q, i)
- aux(p, q, i, i, 1) = kappa
- a(p, q, i, 2) = kappa*uy(p, q, i)
- auy(p, q, i, i, 2) = kappa
- f(p, q, i) = ut(p, q, i)
- fut(p, q, i, i) = 1
- f(p, q, i) = f(p, q, i)-y(q)/kappa
- temp = 1d0 .lt. y(q)
- if (temp) temp = y(q) .lt. 2d0
- if (temp) f(p, q, i) = f(p, q, i)+1d0
- temp = 2d0 .lt. y(q)
- if (temp) temp = y(q) .lt. 3d0
- if (temp) f(p, q, i) = f(p, q, i)+3d0
- 5 continue
- 6 continue
- 7 continue
- return
- end
- subroutine bc(t, x, nx, y, ny, lx, rx, ly, ry, u, ut, ux,
- 1 uy, uxt, uyt, nu, b, bu, but, bux, buy, buxt, buyt)
- integer nu, nx, ny
- double precision t, x(nx), y(ny), lx, rx, ly
- double precision ry, u(nx, ny, nu), ut(nx, ny, nu), ux(nx, ny, nu)
- 1 , uy(nx, ny, nu), uxt(nx, ny, nu)
- double precision uyt(nx, ny, nu), b(nx, ny, nu), bu(nx, ny, nu,
- 1 nu), but(nx, ny, nu, nu), bux(nx, ny, nu, nu), buy(nx, ny, nu
- 2 , nu)
- double precision buxt(nx, ny, nu, nu), buyt(nx, ny, nu, nu)
- integer i, j
- logical temp
- do 6 j = 1, ny
- do 5 i = 1, nx
- temp = x(i) .eq. lx
- if (.not. temp) temp = x(i) .eq. rx
- if (.not. temp) goto 1
- bux(i, j, 1, 1) = 1
-c left or right.
-c neumann bcs.
- b(i, j, 1) = ux(i, j, 1)
- goto 4
- 1 if (y(j) .ne. ly) goto 2
- b(i, j, 1) = u(i, j, 1)
-c bottom.
- bu(i, j, 1, 1) = 1
- goto 3
- 2 b(i, j, 1) = u(i, j, 1)-6d0*t
-c top.
- bu(i, j, 1, 1) = 1
- 3 continue
- 4 continue
- 5 continue
- 6 continue
- return
- end
- subroutine handle(t0, u0, t, u, nv, dt, tstop)
- integer nv
- double precision t0, u0(nv), t, u(nv), dt, tstop
- common /d7tgrp/ errpar, nu, mxq, myq
- integer nu, mxq, myq
- real errpar(2)
- common /d7tgrm/ kx, ix, nx, ky, iy, ny
- integer kx, ix, nx, ky, iy, ny
- if (t0 .ne. t) goto 2
- write (6, 1) t
- 1 format (16h restart for t =, 1pe10.2)
- return
- 2 call gerr(kx, ix, nx, ky, iy, ny, u, nu, t)
- return
- end
- subroutine gerr(kx, ix, nx, ky, iy, ny, u, nu, t)
- integer kx, ix, nx, ky, iy, ny
- integer nu
- double precision u(1), t
- common /cstak/ ds
- double precision ds(500)
- integer ifa, ita(2), ixa(2), nta(2), nxa(2), idlumd
- integer ixs, iys, nxs, nys, istkgt, i
- integer iewe, ka(2), ma(2), is(1000), i1mach
- real rs(1000)
- logical ls(1000)
- complex cs(500)
- double precision dabs, erru, dmax1, ws(500)
- integer temp, temp1, temp2
- equivalence (ds(1), cs(1), ws(1), rs(1), is(1), ls(1))
-c to get and print the error at each time-step.
-c u(nx-kx,ny,ky,nu).
-c the port library stack and its aliases.
- call enter(1)
-c find the error in the solution at 2*kx * 2*ky points / mesh rectangle.
-c x search grid.
- ixs = idlumd(ws(ix), nx, 2*kx, nxs)
-c y search grid.
- iys = idlumd(ws(iy), ny, 2*ky, nys)
-c u search grid values.
- iewe = istkgt(nxs*nys, 4)
-c the exact solution.
- call ewe(t, ws(ixs), nxs, ws(iys), nys, ws(iewe), nu)
- ka(1) = kx
- ka(2) = ky
- ita(1) = ix
- ita(2) = iy
- nta(1) = nx
- nta(2) = ny
- ixa(1) = ixs
- ixa(2) = iys
- nxa(1) = nxs
- nxa(2) = nys
- ma(1) = 0
-c get solution.
- ma(2) = 0
-c approximate solution values.
- ifa = istkgt(nxs*nys, 4)
-c evaluate them.
- call dtsd1(2, ka, ws, ita, nta, u, ws, ixa, nxa, ma, ws(ifa))
-c error in solution values.
- erru = 0
- temp = nxs*nys
- do 1 i = 1, temp
- temp2 = iewe+i
- temp1 = ifa+i
- erru = dmax1(erru, dabs(ws(temp2-1)-ws(temp1-1)))
- 1 continue
- temp = i1mach(2)
- write (temp, 2) t, erru
- 2 format (14h error in u(.,, 1pe10.2, 3h) =, 1pe10.2)
- call leave
- return
- end
- subroutine ewe(t, x, nx, y, ny, u, nu)
- integer nu, nx, ny
- double precision t, x(nx), y(ny), u(nx, ny, nu)
- integer i, j, p
-c the exact solution.
- do 7 p = 1, nu
- do 6 i = 1, nx
- do 5 j = 1, ny
- if (y(j) .ge. 1d0) goto 1
- u(i, j, p) = t*y(j)
- goto 4
- 1 if (y(j) .ge. 2d0) goto 2
- u(i, j, p) = 2d0*t*y(j)-t
- goto 3
- 2 u(i, j, p) = 3d0*t*y(j)-3d0*t
- 3 continue
- 4 continue
- 5 continue
- 6 continue
- 7 continue
- return
- end
diff --git a/CEP/PyBDSM/src/port3/dttgrx4.f b/CEP/PyBDSM/src/port3/dttgrx4.f
deleted file mode 100644
index 4574e4212b254b0767988c24b67bc88727669333..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/dttgrx4.f
+++ /dev/null
@@ -1,259 +0,0 @@
-C$TEST DTTGR4
-c main program
- common /cstak/ ds
- double precision ds(350000)
- external handle, bc, af
- integer ndx, ndy, istkgt, is(1000), iu, ix
- integer iy, nu, kx, nx, ky, ny
- integer idumb
- real errpar(2), rs(1000)
- logical ls(1000)
- complex cs(500)
- double precision tstart, dt, lx, ly, rx, ry
- double precision ws(500), tstop
- equivalence (ds(1), cs(1), ws(1), rs(1), is(1), ls(1))
-c to solve the linear heat equation
-c grad . ( ux - 0.1 * uy , 0.1*ux + uy ) = ut - x*y
-c with solution u == t*x*y on [0,+1]**2, exact for k = 4,
-c with tilted top and bottom, normal bcs there.
-c the port library stack and its aliases.
-c initialize the port library stack length.
- call istkin(350000, 4)
- call enter(1)
- nu = 1
- lx = 0
- rx = 1
- ly = 0
- ry = 1
- kx = 4
- ky = 4
- ndx = 3
- ndy = 3
- tstart = 0
- tstop = 1
- dt = 1
- errpar(1) = 1e-2
- errpar(2) = 1e-4
-c uniform grid.
- ix = idumb(lx, rx, ndx, kx, nx)
-c uniform grid.
- iy = idumb(ly, ry, ndy, ky, ny)
-c space for the solution.
- iu = istkgt(nu*(nx-kx)*(ny-ky), 4)
- call setd(nu*(nx-kx)*(ny-ky), 0d0, ws(iu))
- call dttgr(ws(iu), nu, kx, ws(ix), nx, ky, ws(iy), ny, tstart,
- 1 tstop, dt, af, bc, errpar, handle)
- call leave
- call wrapup
- stop
- end
- subroutine af(t, xi, nx, yi, ny, nu, u, ut, ux, uy, uxt,
- 1 uyt, a, au, aut, aux, auy, auxt, auyt, f, fu, fut, fux, fuy,
- 2 fuxt, fuyt)
- integer nu, nx, ny
- double precision t, xi(nx), yi(ny), u(nx, ny, nu), ut(nx, ny, nu),
- 1 ux(nx, ny, nu)
- double precision uy(nx, ny, nu), uxt(nx, ny, nu), uyt(nx, ny, nu),
- 1 a(nx, ny, nu, 2), au(nx, ny, nu, nu, 2), aut(nx, ny, nu, nu, 2)
- double precision aux(nx, ny, nu, nu, 2), auy(nx, ny, nu, nu, 2),
- 1 auxt(nx, ny, nu, nu, 2), auyt(nx, ny, nu, nu, 2), f(nx, ny, nu)
- 2 , fu(nx, ny, nu, nu)
- double precision fut(nx, ny, nu, nu), fux(nx, ny, nu, nu), fuy(nx,
- 1 ny, nu, nu), fuxt(nx, ny, nu, nu), fuyt(nx, ny, nu, nu)
- external bt, lr
- integer i, p, q
- double precision d(600), x, y, xx(100), yy(100)
- integer temp
- if (nx*ny .gt. 100) call seterr(19haf - nx*ny .gt. 100, 19, 1, 2)
- call dbtmap(t, xi, yi, nx, ny, lr, bt, xx, yy, d)
-c map into (x,y).
- call dttgru(nx, ny, d, ux, uy, ut, nu)
- do 3 i = 1, nu
- do 2 q = 1, ny
- do 1 p = 1, nx
- temp = p+(q-1)*nx
- x = xx(temp)
- temp = p+(q-1)*nx
- y = yy(temp)
- a(p, q, i, 1) = ux(p, q, i)-.1*uy(p, q, i)
- a(p, q, i, 2) = uy(p, q, i)+.1*ux(p, q, i)
- aux(p, q, i, i, 1) = 1
- auy(p, q, i, i, 2) = 1
- auy(p, q, i, i, 1) = -.1
- aux(p, q, i, i, 2) = .1
- f(p, q, 1) = ut(p, q, 1)-x*y
- fut(p, q, 1, 1) = 1
- 1 continue
- 2 continue
- 3 continue
-c map into (xi,eta).
- call dttgrg(nx, ny, d, nu, a, au, aux, auy, f, fu, fux, fuy)
- return
- end
- subroutine bc(t, xi, nx, yi, ny, lx, rx, ly, ry, u, ut, ux
- 1 , uy, uxt, uyt, nu, b, bu, but, bux, buy, buxt, buyt)
- integer nu, nx, ny
- double precision t, xi(nx), yi(ny), lx, rx, ly
- double precision ry, u(nx, ny, nu), ut(nx, ny, nu), ux(nx, ny, nu)
- 1 , uy(nx, ny, nu), uxt(nx, ny, nu)
- double precision uyt(nx, ny, nu), b(nx, ny, nu), bu(nx, ny, nu,
- 1 nu), but(nx, ny, nu, nu), bux(nx, ny, nu, nu), buy(nx, ny, nu
- 2 , nu)
- double precision buxt(nx, ny, nu, nu), buyt(nx, ny, nu, nu)
- external bt, lr
- integer i, j
- double precision d(600), x, y, xx(100), yy(100)
- integer temp1
- logical temp
- if (nx*ny .gt. 100) call seterr(19hbc - nx*ny .gt. 100, 19, 1, 2)
- call dbtmap(t, xi, yi, nx, ny, lr, bt, xx, yy, d)
-c map into (x,y).
- call dttgru(nx, ny, d, ux, uy, ut, nu)
- do 6 j = 1, ny
- do 5 i = 1, nx
- temp1 = i+(j-1)*nx
- x = xx(temp1)
- temp1 = i+(j-1)*nx
- y = yy(temp1)
- temp = xi(i) .eq. lx
- if (.not. temp) temp = xi(i) .eq. rx
- if (.not. temp) goto 1
- bu(i, j, 1, 1) = 1
-c left or right.
- b(i, j, 1) = u(i, j, 1)-t*x*y
- goto 4
- 1 if (yi(j) .ne. ly) goto 2
- b(i, j, 1) = (ux(i, j, 1)-t*y)-(uy(i, j, 1)-t*x)
-c bottom.
- bux(i, j, 1, 1) = 1
-c normal is (1,-1).
- buy(i, j, 1, 1) = -1
- goto 3
- 2 b(i, j, 1) = (uy(i, j, 1)-t*x)-(ux(i, j, 1)-t*y)
-c top.
- bux(i, j, 1, 1) = -1
-c normal is (-1,1).
- buy(i, j, 1, 1) = 1
- 3 continue
- 4 continue
- 5 continue
- 6 continue
-c map into (xi,eta).
- call dttgrb(nx, ny, d, nu, bux, buy, but)
- return
- end
- subroutine handle(t0, u0, t, u, nv, dt, tstop)
- integer nv
- double precision t0, u0(nv), t, u(nv), dt, tstop
- common /d7tgrp/ errpar, nu, mxq, myq
- integer nu, mxq, myq
- real errpar(2)
- common /d7tgrm/ kx, ix, nx, ky, iy, ny
- integer kx, ix, nx, ky, iy, ny
- if (t0 .ne. t) goto 2
- write (6, 1) t
- 1 format (16h restart for t =, 1pe10.2)
- return
- 2 call gerr(kx, ix, nx, ky, iy, ny, u, nu, t)
- return
- end
- subroutine gerr(kx, ix, nx, ky, iy, ny, u, nu, t)
- integer kx, ix, nx, ky, iy, ny
- integer nu
- double precision u(1), t
- common /cstak/ ds
- double precision ds(500)
- integer ifa, ita(2), ixa(2), nta(2), nxa(2), idlumd
- integer ixs, iys, nxs, nys, istkgt, i
- integer iewe, ka(2), ma(2), is(1000), i1mach
- real rs(1000)
- logical ls(1000)
- complex cs(500)
- double precision dabs, erru, dmax1, ws(500)
- integer temp, temp1, temp2
- equivalence (ds(1), cs(1), ws(1), rs(1), is(1), ls(1))
-c to get and print the error at each time-step.
-c u(nx-kx,ny-ky,nu).
-c the port library stack and its aliases.
- call enter(1)
-c find the error in the solution at 2*kx * 2*ky points / mesh rectangle.
-c x search grid.
- ixs = idlumd(ws(ix), nx, 2*kx, nxs)
-c y search grid.
- iys = idlumd(ws(iy), ny, 2*ky, nys)
-c u search grid values.
- iewe = istkgt(nxs*nys, 4)
-c the exact solution.
- call ewe(t, ws(ixs), nxs, ws(iys), nys, ws(iewe), nu)
- ka(1) = kx
- ka(2) = ky
- ita(1) = ix
- ita(2) = iy
- nta(1) = nx
- nta(2) = ny
- ixa(1) = ixs
- ixa(2) = iys
- nxa(1) = nxs
- nxa(2) = nys
- ma(1) = 0
-c get solution.
- ma(2) = 0
-c approximate solution values.
- ifa = istkgt(nxs*nys, 4)
-c evaluate them.
- call dtsd1(2, ka, ws, ita, nta, u, ws, ixa, nxa, ma, ws(ifa))
-c error in solution values.
- erru = 0
- temp = nxs*nys
- do 1 i = 1, temp
- temp2 = iewe+i
- temp1 = ifa+i
- erru = dmax1(erru, dabs(ws(temp2-1)-ws(temp1-1)))
- 1 continue
- temp = i1mach(2)
- write (temp, 2) t, erru
- 2 format (14h error in u(.,, 1pe10.2, 3h) =, 1pe10.2)
- call leave
- return
- end
- subroutine ewe(t, xi, nx, yi, ny, u, nu)
- integer nu, nx, ny
- double precision t, xi(nx), yi(ny), u(nx, ny, nu)
- external bt, lr
- integer i, j, p
- double precision d(6000), x, y, xx(1000), yy(1000)
-c the exact solution.
- if (ny .gt. 1000) call seterr(18hewe - ny .gt. 1000, 18, 1, 2)
- do 3 p = 1, nu
- do 2 i = 1, nx
- call dbtmap(t, xi(i), yi, 1, ny, lr, bt, xx, yy, d)
- do 1 j = 1, ny
- x = xx(j)
- y = yy(j)
- u(i, j, p) = t*x*y
- 1 continue
- 2 continue
- 3 continue
- return
- end
- subroutine lr(t, lx, rx, lxt, rxt)
- double precision t, lx, rx, lxt, rxt
-c to get the l and r end-points of the mapping in x.
- lx = 0
- rx = 1
- lxt = 0
- rxt = 0
- return
- end
- subroutine bt(t, x, f, g, fx, gx, ft, gt)
- double precision t, x, f, g, fx, gx
- double precision ft, gt
-c to get the bottom and top of mapping in y.
- f = x-1d0
- g = x
- ft = 0
- gt = 0
- fx = 1
- gx = 1
- return
- end
diff --git a/CEP/PyBDSM/src/port3/dttgrx5.f b/CEP/PyBDSM/src/port3/dttgrx5.f
deleted file mode 100644
index 43d802401493d42f47fd0b67daae87a8c6659f27..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/dttgrx5.f
+++ /dev/null
@@ -1,232 +0,0 @@
-C$TEST DTTGR5
-c main program
- common /cstak/ ds
- double precision ds(350000)
- external handle, bc, af
- integer ndx, ndy, istkgt, i, is(1000), iu
- integer ix, iy, nu, kx, nx, ky
- integer ny
- real errpar(2), rs(1000), float
- logical ls(1000)
- complex cs(500)
- double precision tstart, dble, dt, lx, ly, rx
- double precision ry, ws(500), tstop
- integer temp, temp1
- equivalence (ds(1), cs(1), ws(1), rs(1), is(1), ls(1))
-c to solve laplaces equation with real ( z*log(z) ) as solution.
-c the port library stack and its aliases.
-c initialize the port library stack length.
- call istkin(350000, 4)
- call enter(1)
- nu = 1
- lx = 0
- rx = 1
- ly = 0
- ry = 1
- kx = 4
- ky = 4
- ndx = 2
- ndy = 2
- tstart = 0
- tstop = 1
- dt = 1
- errpar(1) = 1e-2
- errpar(2) = 1e-4
- nx = ndx+2*(kx-1)
-c space for x mesh.
- ix = istkgt(nx, 4)
- do 1 i = 1, kx
- temp = ix+i
- ws(temp-1) = 0
- temp = ix+nx-i
- ws(temp) = rx
- 1 continue
-c 0 and rx mult = kx.
- temp = ndx-1
- do 2 i = 1, temp
- temp1 = ix+kx-2+i
- ws(temp1) = rx*(dble(float(i-1))/(dble(float(ndx))-1d0))**kx
- 2 continue
- ny = ndy+2*(ky-1)
-c space for y mesh.
- iy = istkgt(ny, 4)
- do 3 i = 1, ky
- temp = iy+i
- ws(temp-1) = 0
- temp = iy+ny-i
- ws(temp) = ry
- 3 continue
-c 0 and ry mult = ky.
- temp = ndy-1
- do 4 i = 1, temp
- temp1 = iy+ky-2+i
- ws(temp1) = ry*(dble(float(i-1))/(dble(float(ndy))-1d0))**ky
- 4 continue
-c space for the solution.
- iu = istkgt(nu*(nx-kx)*(ny-ky), 4)
- call setd(nu*(nx-kx)*(ny-ky), 0d0, ws(iu))
- call dttgr(ws(iu), nu, kx, ws(ix), nx, ky, ws(iy), ny, tstart,
- 1 tstop, dt, af, bc, errpar, handle)
- call leave
- call wrapup
- stop
- end
- subroutine af(t, xi, nx, yi, ny, nu, u, ut, ux, uy, uxt,
- 1 uyt, a, au, aut, aux, auy, auxt, auyt, f, fu, fut, fux, fuy,
- 2 fuxt, fuyt)
- integer nu, nx, ny
- double precision t, xi(nx), yi(ny), u(nx, ny, nu), ut(nx, ny, nu),
- 1 ux(nx, ny, nu)
- double precision uy(nx, ny, nu), uxt(nx, ny, nu), uyt(nx, ny, nu),
- 1 a(nx, ny, nu, 2), au(nx, ny, nu, nu, 2), aut(nx, ny, nu, nu, 2)
- double precision aux(nx, ny, nu, nu, 2), auy(nx, ny, nu, nu, 2),
- 1 auxt(nx, ny, nu, nu, 2), auyt(nx, ny, nu, nu, 2), f(nx, ny, nu)
- 2 , fu(nx, ny, nu, nu)
- double precision fut(nx, ny, nu, nu), fux(nx, ny, nu, nu), fuy(nx,
- 1 ny, nu, nu), fuxt(nx, ny, nu, nu), fuyt(nx, ny, nu, nu)
- integer i, p, q
- do 3 i = 1, nu
- do 2 q = 1, ny
- do 1 p = 1, nx
- a(p, q, i, 1) = ux(p, q, i)
- a(p, q, i, 2) = uy(p, q, i)
- aux(p, q, i, i, 1) = 1
- auy(p, q, i, i, 2) = 1
- 1 continue
- 2 continue
- 3 continue
- return
- end
- subroutine bc(t, x, nx, y, ny, lx, rx, ly, ry, u, ut, ux,
- 1 uy, uxt, uyt, nu, b, bu, but, bux, buy, buxt, buyt)
- integer nu, nx, ny
- double precision t, x(nx), y(ny), lx, rx, ly
- double precision ry, u(nx, ny, nu), ut(nx, ny, nu), ux(nx, ny, nu)
- 1 , uy(nx, ny, nu), uxt(nx, ny, nu)
- double precision uyt(nx, ny, nu), b(nx, ny, nu), bu(nx, ny, nu,
- 1 nu), but(nx, ny, nu, nu), bux(nx, ny, nu, nu), buy(nx, ny, nu
- 2 , nu)
- double precision buxt(nx, ny, nu, nu), buyt(nx, ny, nu, nu)
- integer i, j
- double precision r, dcos, dlog, dsin, datan, theta
- double precision dsqrt
- do 6 j = 1, ny
- do 5 i = 1, nx
- if (y(j) .ne. ly) goto 1
- b(i, j, 1) = uy(i, j, 1)
-c neumann data on bottom.
- buy(i, j, 1, 1) = 1
- goto 4
- 1 r = dsqrt(x(i)**2+y(j)**2)
-c dirichlet data.
- if (x(i) .le. 0d0) goto 2
- theta = datan(y(j)/x(i))
- goto 3
- 2 theta = 2d0*datan(1d0)
- 3 b(i, j, 1) = u(i, j, 1)-r*(dcos(theta)*dlog(r)-theta*
- 1 dsin(theta))
- bu(i, j, 1, 1) = 1
- 4 continue
- 5 continue
- 6 continue
- return
- end
- subroutine handle(t0, u0, t, u, nv, dt, tstop)
- integer nv
- double precision t0, u0(nv), t, u(nv), dt, tstop
- common /d7tgrp/ errpar, nu, mxq, myq
- integer nu, mxq, myq
- real errpar(2)
- common /d7tgrm/ kx, ix, nx, ky, iy, ny
- integer kx, ix, nx, ky, iy, ny
- if (t0 .ne. t) goto 2
- write (6, 1) t
- 1 format (16h restart for t =, 1pe10.2)
- return
- 2 call gerr(kx, ix, nx, ky, iy, ny, u, nu, t)
- return
- end
- subroutine gerr(kx, ix, nx, ky, iy, ny, u, nu, t)
- integer kx, ix, nx, ky, iy, ny
- integer nu
- double precision u(1), t
- common /cstak/ ds
- double precision ds(500)
- integer ifa, ita(2), ixa(2), nta(2), nxa(2), idlumd
- integer ixs, iys, nxs, nys, istkgt, i
- integer iewe, ka(2), ma(2), is(1000), i1mach
- real rs(1000)
- logical ls(1000)
- complex cs(500)
- double precision dabs, erru, dmax1, ws(500)
- integer temp, temp1, temp2
- equivalence (ds(1), cs(1), ws(1), rs(1), is(1), ls(1))
-c to get and print the error at each time-step.
-c u(nx-kx,ny-ky,nu).
-c the port library stack and its aliases.
- call enter(1)
-c find the error in the solution at 2*kx * 2*ky points / mesh rectangle.
-c x search grid.
- ixs = idlumd(ws(ix), nx, 2*kx, nxs)
-c y search grid.
- iys = idlumd(ws(iy), ny, 2*ky, nys)
-c u search grid values.
- iewe = istkgt(nxs*nys, 4)
-c the exact solution.
- call ewe(t, ws(ixs), nxs, ws(iys), nys, ws(iewe), nu)
- ka(1) = kx
- ka(2) = ky
- ita(1) = ix
- ita(2) = iy
- nta(1) = nx
- nta(2) = ny
- ixa(1) = ixs
- ixa(2) = iys
- nxa(1) = nxs
- nxa(2) = nys
- ma(1) = 0
-c get solution.
- ma(2) = 0
-c approximate solution values.
- ifa = istkgt(nxs*nys, 4)
-c evaluate them.
- call dtsd1(2, ka, ws, ita, nta, u, ws, ixa, nxa, ma, ws(ifa))
-c error in solution values.
- erru = 0
- temp = nxs*nys
- do 1 i = 1, temp
- temp2 = iewe+i
- temp1 = ifa+i
- erru = dmax1(erru, dabs(ws(temp2-1)-ws(temp1-1)))
- 1 continue
- temp = i1mach(2)
- write (temp, 2) t, erru
- 2 format (14h error in u(.,, 1pe10.2, 3h) =, 1pe10.2)
- call leave
- return
- end
- subroutine ewe(t, x, nx, y, ny, u, nu)
- integer nu, nx, ny
- double precision t, x(nx), y(ny), u(nx, ny, nu)
- integer i, j, p
- double precision r, dcos, dlog, dsin, datan, theta
- double precision dsqrt
-c the exact solution.
- do 7 p = 1, nu
- do 6 i = 1, nx
- do 5 j = 1, ny
- r = dsqrt(x(i)**2+y(j)**2)
- if (x(i) .le. 0d0) goto 1
- theta = datan(y(j)/x(i))
- goto 2
- 1 theta = 2d0*datan(1d0)
- 2 if (r .le. 0d0) goto 3
- u(i, j, p) = r*(dcos(theta)*dlog(r)-theta*dsin(theta))
- goto 4
- 3 u(i, j, p) = 0
- 4 continue
- 5 continue
- 6 continue
- 7 continue
- return
- end
diff --git a/CEP/PyBDSM/src/port3/dttgrx6.f b/CEP/PyBDSM/src/port3/dttgrx6.f
deleted file mode 100644
index 7f8d8547e0f96b6d4f79c207ea58d6be52586c55..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/dttgrx6.f
+++ /dev/null
@@ -1,378 +0,0 @@
-C$TEST DTTGR6
-c main program
- common /cstak/ ds
- double precision ds(350000)
- external handle, bc, af
- integer iue, ndx, ndy, iur, ixr, iyr
- integer nxr, nyr, istkgt, i, is(1000), iu
- integer ix, iy, nu, kx, nx, ky
- integer ny, i1mach
- real errpar(2), rs(1000), float
- logical ls(1000)
- complex cs(500)
- double precision tstart, dble, dabs, eerr, erre, errr
- double precision dmax1, dt, lx, ly, rx, ry
- double precision ws(500), tstop
- integer temp, temp1, temp2
- equivalence (ds(1), cs(1), ws(1), rs(1), is(1), ls(1))
-c to get error estimates for laplaces equation with real ( z*log(z) ) as
-c solution.
-c the port library stack and its aliases.
-c initialize the port library stack length.
- call istkin(350000, 4)
- call enter(1)
- nu = 1
- lx = 0
- rx = 1
- ly = 0
- ry = 1
- kx = 4
- ky = 4
- ndx = 2
- ndy = 2
- tstart = 0
- tstop = 1
- dt = 1
- errpar(1) = 1e-2
- errpar(2) = 1e-4
- nx = ndx+2*(kx-1)
-c space for x mesh.
- ix = istkgt(nx, 4)
- do 1 i = 1, kx
- temp = ix+i
- ws(temp-1) = 0
- temp = ix+nx-i
- ws(temp) = rx
- 1 continue
-c 0 and rx mult = kx.
- temp = ndx-1
- do 2 i = 1, temp
- temp2 = ix+kx-2+i
- ws(temp2) = rx*(dble(float(i-1))/(dble(float(ndx))-1d0))**kx
- 2 continue
- ny = ndy+2*(ky-1)
-c space for y mesh.
- iy = istkgt(ny, 4)
- do 3 i = 1, ky
- temp = iy+i
- ws(temp-1) = 0
- temp = iy+ny-i
- ws(temp) = ry
- 3 continue
-c 0 and ry mult = ky.
- temp = ndy-1
- do 4 i = 1, temp
- temp2 = iy+ky-2+i
- ws(temp2) = ry*(dble(float(i-1))/(dble(float(ndy))-1d0))**ky
- 4 continue
-c space for the solution.
- iu = istkgt(nu*(nx-kx)*(ny-ky), 4)
- call setd(nu*(nx-kx)*(ny-ky), 0d0, ws(iu))
- temp = i1mach(2)
- write (temp, 5)
- 5 format (23h solving on crude mesh.)
- call dttgr(ws(iu), nu, kx, ws(ix), nx, ky, ws(iy), ny, tstart,
- 1 tstop, dt, af, bc, errpar, handle)
- dt = 1
- ndx = 2*ndx-1
-c refine mesh.
- ndy = 2*ndy-1
- nxr = ndx+2*(kx-1)
-c space for x mesh.
- ixr = istkgt(nxr, 4)
- do 6 i = 1, kx
- temp = ixr+i
- ws(temp-1) = 0
- temp = ixr+nxr-i
- ws(temp) = rx
- 6 continue
-c 0 and rx mult = kx.
- temp = ndx-1
- do 7 i = 1, temp
- temp2 = ixr+kx-2+i
- ws(temp2) = rx*(dble(float(i-1))/(dble(float(ndx))-1d0))**kx
- 7 continue
- nyr = ndy+2*(ky-1)
-c space for y mesh.
- iyr = istkgt(nyr, 4)
- do 8 i = 1, ky
- temp = iyr+i
- ws(temp-1) = 0
- temp = iyr+nyr-i
- ws(temp) = ry
- 8 continue
-c 0 and ry mult = ky.
- temp = ndy-1
- do 9 i = 1, temp
- temp2 = iyr+ky-2+i
- ws(temp2) = ry*(dble(float(i-1))/(dble(float(ndy))-1d0))**ky
- 9 continue
-c space for the solution.
- iur = istkgt(nu*(nxr-kx)*(nyr-ky), 4)
- call setd(nu*(nxr-kx)*(nyr-ky), 0d0, ws(iur))
- temp = i1mach(2)
- write (temp, 10)
- 10 format (25h solving on refined mesh.)
- call dttgr(ws(iur), nu, kx, ws(ixr), nxr, ky, ws(iyr), nyr,
- 1 tstart, tstop, dt, af, bc, errpar, handle)
- dt = 1
- errpar(1) = errpar(1)/10.
- errpar(2) = errpar(2)/10.
-c space for the solution.
- iue = istkgt(nu*(nx-kx)*(ny-ky), 4)
- call setd(nu*(nx-kx)*(ny-ky), 0d0, ws(iue))
- temp = i1mach(2)
- write (temp, 11)
- 11 format (24h solving with errpar/10.)
- call dttgr(ws(iue), nu, kx, ws(ix), nx, ky, ws(iy), ny, tstart,
- 1 tstop, dt, af, bc, errpar, handle)
- errr = eerr(kx, ix, nx, ky, iy, ny, ws(iu), nu, ixr, nxr, iyr,
- 1 nyr, ws(iur), tstop)
- erre = 0
- temp = nu*(nx-kx)*(ny-ky)
- do 12 i = 1, temp
- temp2 = iu+i
- temp1 = iue+i
- erre = dmax1(erre, dabs(ws(temp2-1)-ws(temp1-1)))
- 12 continue
- temp = i1mach(2)
- write (temp, 13) erre
- 13 format (24h u error from u and ue =, 1pe10.2)
- temp = i1mach(2)
- write (temp, 14) errr
- 14 format (24h u error from u and ur =, 1pe10.2)
- call leave
- call wrapup
- stop
- end
- subroutine af(t, xi, nx, yi, ny, nu, u, ut, ux, uy, uxt,
- 1 uyt, a, au, aut, aux, auy, auxt, auyt, f, fu, fut, fux, fuy,
- 2 fuxt, fuyt)
- integer nu, nx, ny
- double precision t, xi(nx), yi(ny), u(nx, ny, nu), ut(nx, ny, nu),
- 1 ux(nx, ny, nu)
- double precision uy(nx, ny, nu), uxt(nx, ny, nu), uyt(nx, ny, nu),
- 1 a(nx, ny, nu, 2), au(nx, ny, nu, nu, 2), aut(nx, ny, nu, nu, 2)
- double precision aux(nx, ny, nu, nu, 2), auy(nx, ny, nu, nu, 2),
- 1 auxt(nx, ny, nu, nu, 2), auyt(nx, ny, nu, nu, 2), f(nx, ny, nu)
- 2 , fu(nx, ny, nu, nu)
- double precision fut(nx, ny, nu, nu), fux(nx, ny, nu, nu), fuy(nx,
- 1 ny, nu, nu), fuxt(nx, ny, nu, nu), fuyt(nx, ny, nu, nu)
- integer i, p, q
- do 3 i = 1, nu
- do 2 q = 1, ny
- do 1 p = 1, nx
- a(p, q, i, 1) = ux(p, q, i)
- a(p, q, i, 2) = uy(p, q, i)
- aux(p, q, i, i, 1) = 1
- auy(p, q, i, i, 2) = 1
- 1 continue
- 2 continue
- 3 continue
- return
- end
- subroutine bc(t, x, nx, y, ny, lx, rx, ly, ry, u, ut, ux,
- 1 uy, uxt, uyt, nu, b, bu, but, bux, buy, buxt, buyt)
- integer nu, nx, ny
- double precision t, x(nx), y(ny), lx, rx, ly
- double precision ry, u(nx, ny, nu), ut(nx, ny, nu), ux(nx, ny, nu)
- 1 , uy(nx, ny, nu), uxt(nx, ny, nu)
- double precision uyt(nx, ny, nu), b(nx, ny, nu), bu(nx, ny, nu,
- 1 nu), but(nx, ny, nu, nu), bux(nx, ny, nu, nu), buy(nx, ny, nu
- 2 , nu)
- double precision buxt(nx, ny, nu, nu), buyt(nx, ny, nu, nu)
- integer i, j
- double precision r, dcos, dlog, dsin, datan, theta
- double precision dsqrt
- do 6 j = 1, ny
- do 5 i = 1, nx
- if (y(j) .ne. ly) goto 1
- b(i, j, 1) = uy(i, j, 1)
-c neumann data on bottom.
- buy(i, j, 1, 1) = 1
- goto 4
- 1 r = dsqrt(x(i)**2+y(j)**2)
-c dirichlet data.
- if (x(i) .le. 0d0) goto 2
- theta = datan(y(j)/x(i))
- goto 3
- 2 theta = 2d0*datan(1d0)
- 3 b(i, j, 1) = u(i, j, 1)-r*(dcos(theta)*dlog(r)-theta*
- 1 dsin(theta))
- bu(i, j, 1, 1) = 1
- 4 continue
- 5 continue
- 6 continue
- return
- end
- subroutine handle(t0, u0, t, u, nv, dt, tstop)
- integer nv
- double precision t0, u0(nv), t, u(nv), dt, tstop
- common /d7tgrp/ errpar, nu, mxq, myq
- integer nu, mxq, myq
- real errpar(2)
- common /d7tgrm/ kx, ix, nx, ky, iy, ny
- integer kx, ix, nx, ky, iy, ny
- if (t0 .ne. t) goto 2
- write (6, 1) t
- 1 format (16h restart for t =, 1pe10.2)
- return
- 2 call gerr(kx, ix, nx, ky, iy, ny, u, nu, t)
- return
- end
- subroutine gerr(kx, ix, nx, ky, iy, ny, u, nu, t)
- integer kx, ix, nx, ky, iy, ny
- integer nu
- double precision u(1), t
- common /cstak/ ds
- double precision ds(500)
- integer ifa, ita(2), ixa(2), nta(2), nxa(2), idlumd
- integer ixs, iys, nxs, nys, istkgt, i
- integer iewe, ka(2), ma(2), is(1000), i1mach
- real rs(1000)
- logical ls(1000)
- complex cs(500)
- double precision dabs, erru, dmax1, ws(500)
- integer temp, temp1, temp2
- equivalence (ds(1), cs(1), ws(1), rs(1), is(1), ls(1))
-c to get and print the error at each time-step.
-c u(nx-kx,ny-ky,nu).
-c the port library stack and its aliases.
- call enter(1)
-c find the error in the solution at 2*kx * 2*ky points / mesh rectangle.
-c x search grid.
- ixs = idlumd(ws(ix), nx, 2*kx, nxs)
-c y search grid.
- iys = idlumd(ws(iy), ny, 2*ky, nys)
-c u search grid values.
- iewe = istkgt(nxs*nys, 4)
-c the exact solution.
- call ewe(t, ws(ixs), nxs, ws(iys), nys, ws(iewe), nu)
- ka(1) = kx
- ka(2) = ky
- ita(1) = ix
- ita(2) = iy
- nta(1) = nx
- nta(2) = ny
- ixa(1) = ixs
- ixa(2) = iys
- nxa(1) = nxs
- nxa(2) = nys
- ma(1) = 0
-c get solution.
- ma(2) = 0
-c approximate solution values.
- ifa = istkgt(nxs*nys, 4)
-c evaluate them.
- call dtsd1(2, ka, ws, ita, nta, u, ws, ixa, nxa, ma, ws(ifa))
-c error in solution values.
- erru = 0
- temp = nxs*nys
- do 1 i = 1, temp
- temp2 = iewe+i
- temp1 = ifa+i
- erru = dmax1(erru, dabs(ws(temp2-1)-ws(temp1-1)))
- 1 continue
- temp = i1mach(2)
- write (temp, 2) t, erru
- 2 format (14h error in u(.,, 1pe10.2, 3h) =, 1pe10.2)
- call leave
- return
- end
- double precision function eerr(kx, ix, nx, ky, iy, ny, u,
- 1 nu, ixr, nxr, iyr, nyr, ur, t)
- integer kx, ix, nx, ky, iy, ny
- integer nu, ixr, nxr, iyr, nyr
- double precision u(1), ur(1), t
- common /cstak/ ds
- double precision ds(500)
- integer ifa, ita(2), ixa(2), nta(2), nxa(2), idlumd
- integer ixs, iys, nxs, nys, istkgt, i
- integer ifar, ka(2), ma(2), is(1000), i1mach
- real rs(1000)
- logical ls(1000)
- complex cs(500)
- double precision dabs, erru, dmax1, ws(500)
- integer temp, temp1, temp2
- equivalence (ds(1), cs(1), ws(1), rs(1), is(1), ls(1))
-c to get and print the error estimate at each time-step.
-c u(nx-kx,ny-ky,nu), ur(nxr-kx,nyr-ky,nu).
-c the port library stack and its aliases.
- call enter(1)
-c find the error in the solution at 2*kx * 2*ky points / fine mesh recta
-cngle.
-c x search grid.
- ixs = idlumd(ws(ixr), nxr, 2*kx, nxs)
-c y search grid.
- iys = idlumd(ws(iyr), nyr, 2*ky, nys)
- ka(1) = kx
- ka(2) = ky
- ita(1) = ix
- ita(2) = iy
- nta(1) = nx
- nta(2) = ny
- ixa(1) = ixs
- ixa(2) = iys
- nxa(1) = nxs
- nxa(2) = nys
- ma(1) = 0
-c get solution.
- ma(2) = 0
-c approximate solution values.
- ifa = istkgt(nxs*nys, 4)
-c evaluate them.
- call dtsd1(2, ka, ws, ita, nta, u, ws, ixa, nxa, ma, ws(ifa))
- ka(1) = kx
- ka(2) = ky
- ita(1) = ixr
- ita(2) = iyr
- nta(1) = nxr
- nta(2) = nyr
- ixa(1) = ixs
- ixa(2) = iys
- nxa(1) = nxs
- nxa(2) = nys
- ma(1) = 0
-c get solution.
- ma(2) = 0
-c approximate solution values.
- ifar = istkgt(nxs*nys, 4)
-c evaluate them.
- call dtsd1(2, ka, ws, ita, nta, ur, ws, ixa, nxa, ma, ws(ifar))
-c error in solution values.
- erru = 0
- temp = nxs*nys
- do 1 i = 1, temp
- temp2 = ifar+i
- temp1 = ifa+i
- erru = dmax1(erru, dabs(ws(temp2-1)-ws(temp1-1)))
- 1 continue
- call leave
- eerr = erru
- return
- end
- subroutine ewe(t, x, nx, y, ny, u, nu)
- integer nu, nx, ny
- double precision t, x(nx), y(ny), u(nx, ny, nu)
- integer i, j, p
- double precision r, dcos, dlog, dsin, datan, theta
- double precision dsqrt
-c the exact solution.
- do 7 p = 1, nu
- do 6 i = 1, nx
- do 5 j = 1, ny
- r = dsqrt(x(i)**2+y(j)**2)
- if (x(i) .le. 0d0) goto 1
- theta = datan(y(j)/x(i))
- goto 2
- 1 theta = 2d0*datan(1d0)
- 2 if (r .le. 0d0) goto 3
- u(i, j, p) = r*(dcos(theta)*dlog(r)-theta*dsin(theta))
- goto 4
- 3 u(i, j, p) = 0
- 4 continue
- 5 continue
- 6 continue
- 7 continue
- return
- end
diff --git a/CEP/PyBDSM/src/port3/dttgux1.f b/CEP/PyBDSM/src/port3/dttgux1.f
deleted file mode 100644
index e80fd6d8522aae2bca99be2b5ff8a530f8e299b6..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/dttgux1.f
+++ /dev/null
@@ -1,224 +0,0 @@
-C$TEST DTTGU1
-c main program
-c to solve the heat equation with solution u == t*x*y,
-c grad . ( u + ux + .1 * uy, u + uy + .1 * ux ) = ut + ux + uy +g(x,t)
- common /cstak/ ds
- double precision ds(350000)
- integer ixb(4), iyb(4), nxr(4), nyr(4), kxr(4), kyr(4)
- external handlu, bc, af
- integer ndx, ndy, istkgt, is(1000), iu, nu, kx, ky, idumb
- real errpar(2), rs(1000)
- logical ls(1000)
- complex cs(500)
- double precision tstart, dt, tstop, ws(500)
-c the port library stack and its aliases.
- equivalence (ds(1), cs(1), ws(1), rs(1), is(1), ls(1))
-c initialize the port library stack length.
- call istkin(350000, 4)
- call enter(1)
- nu = 1
- kx = 2
- ky = 2
- ndx = 3
- ndy = 3
- nr=4
- tstart = 0.d0
- tstop = 1.d0
- dt = 1
- errpar(1) = 1e-2
- errpar(2) = 1e-4
-c uniform grid.
-c
-c make grid for t-shaped region
-c
- ixb(1) = idumb(-1.0d0, 0.0d0, ndx, kx, nxr(1))
- ixb(2) = idumb(0.0d0, 1.0d0, ndx, kx, nxr(2))
- ixb(3) = idumb(1.0d0, 2.0d0, ndx, kx, nxr(3))
- ixb(4) = idumb(0.0d0, 1.0d0, ndx, kx, nxr(4))
- iyb(1) = idumb(0.0d0, 1.0d0, ndy, ky, nyr(1))
- iyb(2) = idumb(0.0d0, 1.0d0, ndy, ky, nyr(2))
- iyb(3) = idumb(0.0d0, 1.0d0, ndy, ky, nyr(3))
- iyb(4) = idumb(-1.0d0, 0.0d0, ndy, ky, nyr(4))
- nnu =nu*((nxr(1)-kx)*(nyr(1)+nyr(3)-2*ky)+
- 1 (nxr(2)-kx)*(nyr(2)-ky)+
- 4 (nxr(4)-kx)*(nyr(4)-ky))
- nr=4
-c space for the solution.
- iu = istkgt(nnu, 4)
- do 1 i=1,nr
- kxr(i)=kx
- kyr(i)=ky
-1 continue
-c initial conditions for u.
- call setd(nnu, 0.d0,ws(iu))
-c since idumb places the meshes in the port stack, the name of
-c the port stack, ws, is used as the x and y arrays
- call dttgu(ws(iu),nu,nr,kxr,ws,nxr,ixb,kyr,ws,nyr,iyb,tstart,
- 1 tstop, dt, af, bc, errpar, handlu)
- call leave
- call wrapup
- stop
- end
- subroutine af(t, x, nx, y, ny, nu, u, ut, ux, uy, uxt, uyt
- 1 , a, au, aut, aux, auy, auxt, auyt, f, fu, fut, fux, fuy, fuxt,
- 2 fuyt)
- integer nu, nx, ny
- double precision t, x(nx), y(ny), u(nx, ny, nu), ut(nx, ny, nu),
- 1 ux(nx, ny, nu)
- double precision uy(nx, ny, nu), uxt(nx, ny, nu), uyt(nx, ny, nu),
- 1 a(nx, ny, nu, 2), au(nx, ny, nu, nu, 2), aut(nx, ny, nu, nu, 2)
- double precision aux(nx, ny, nu, nu, 2), auy(nx, ny, nu, nu, 2),
- 1 auxt(nx, ny, nu, nu, 2), auyt(nx, ny, nu, nu, 2), f(nx, ny, nu)
- 2 , fu(nx, ny, nu, nu)
- double precision fut(nx, ny, nu, nu), fux(nx, ny, nu, nu), fuy(nx,
- 1 ny, nu, nu), fuxt(nx, ny, nu, nu), fuyt(nx, ny, nu, nu)
- integer i, p, q
- do 3 i = 1, nu
- do 2 q = 1, ny
- do 1 p = 1, nx
- a(p, q, i, 1) = ux(p, q, i)+.1*uy(p, q, i)+u(p, q, i)
- a(p, q, i, 2) = uy(p, q, i)+.1*ux(p, q, i)+u(p, q, i)
- aux(p, q, i, i, 1) = 1
- auy(p, q, i, i, 2) = 1
- auy(p, q, i, i, 1) = .1
- aux(p, q, i, i, 2) = .1
- au(p, q, i, i, 1) = 1
- au(p, q, i, i, 2) = 1
- f(p, q, i) = ut(p, q, i)+ux(p, q, i)+uy(p, q, i)
- fut(p, q, i, i) = 1
- fux(p, q, i, i) = 1
- fuy(p, q, i, i) = 1
- f(p, q, i) = f(p, q, i)+.2*t-x(p)*y(q)
- 1 continue
- 2 continue
- 3 continue
- return
- end
- subroutine bc(t, x, nx, y, ny, lx, rx, ly, ry, u, ut, ux,
- 1 uy, uxt, uyt, nu, b, bu, but, bux, buy, buxt, buyt)
- integer nu, nx, ny
- double precision t, x(nx), y(ny), lx, rx, ly
- double precision ry, u(nx, ny, nu), ut(nx, ny, nu), ux(nx, ny, nu)
- 1 , uy(nx, ny, nu), uxt(nx, ny, nu)
- double precision uyt(nx, ny, nu), b(nx, ny, nu), bu(nx, ny, nu,
- 1 nu), but(nx, ny, nu, nu), bux(nx, ny, nu, nu), buy(nx, ny, nu
- 2 , nu)
- double precision buxt(nx, ny, nu, nu), buyt(nx, ny, nu, nu)
- integer i, j
- do 2 j = 1, ny
- do 1 i = 1, nx
- bu(i, j, 1, 1) = 1
- b(i, j, 1) = u(i, j, 1)-t*x(i)*y(j)
- 1 continue
- 2 continue
- return
- end
- subroutine handlu(t0, u0, t, u, nv, dt, tstop)
- integer nv
- double precision t0, u0(nv), t, u(nv), dt, tstop
- common /d7tgup/ errpar, nu, mxp, myp
- integer nu
- real errpar(2)
- common /d7tgum/ kxp,ix,nxp,kyp,iy,nyp,nxnyt,nr,iup
- integer kx, ix, nx, ky, iy, ny
- common /cstak/is
- integer is(1000)
- iwrite=i1mach(2)
- if (t0 .ne. t) goto 2
- write (iwrite, 1) t
- 1 format (16h restart for t =, 1pe10.2)
- return
-c get and print the error.
- 2 continue
- write(iwrite, 3)t
- 3 format(6h at t=,1pe10.2)
- ius=1
- do 5 inu = 1, nu
- iyr=iy
- ixr=ix
- do 4 ir=1,nr
- ir1=ir-1
- nx=is(nxp+ir1)
- ny=is(nyp+ir1)
- kx=is(kxp+ir1)
- ky=is(kyp+ir1)
- call gerr(kx, ixr, nx, ky, iyr, ny, u(ius), inu, t, ir)
- ixr=ixr+nx
- iyr=iyr+ny
- ius=ius+(nx-kx)*(ny-ky)
- 4 continue
- 5 continue
- return
- end
- subroutine gerr(kx, ix, nx, ky, iy, ny, u, inu, t, ir)
- integer kx, ix, nx, ky, iy, ny, inu, ir
- double precision u(1), t
- common /cstak/ ds
- double precision ds(500)
- integer ifa, ita(2), ixa(2), nta(2), nxa(2), idlumd
- integer ixs, iys, nxs, nys, istkgt, i
- integer iewe, ka(2), ma(2), is(1000), i1mach
- real rs(1000)
- logical ls(1000)
- complex cs(500)
- double precision dabs, erru, dmax1, ws(500)
- integer temp, temp1, temp2
- equivalence (ds(1), cs(1), ws(1), rs(1), is(1), ls(1))
-c to get and print the error at each time-step.
-c for variable inu for rectangle ir
-c u(nx-kx,ny-ky).
-c the port library stack and its aliases.
- call enter(1)
-c find the error in the solution at 2*kx * 2*ky points / mesh rectangle.
-c x search grid.
- ixs = idlumd(ws(ix), nx, 2*kx, nxs)
-c y search grid.
- iys = idlumd(ws(iy), ny, 2*ky, nys)
-c u search grid values.
- iewe = istkgt(nxs*nys, 4)
-c the exact solution.
- call ewe2(t, ws(ixs), nxs, ws(iys), nys, ws(iewe), inu, ir)
- ka(1) = kx
- ka(2) = ky
- ita(1) = ix
- ita(2) = iy
- nta(1) = nx
- nta(2) = ny
- ixa(1) = ixs
- ixa(2) = iys
- nxa(1) = nxs
- nxa(2) = nys
- ma(1) = 0
-c get solution.
- ma(2) = 0
-c approximate solution values.
- ifa = istkgt(nxs*nys, 4)
-c evaluate them.
- call dtsd1(2, ka, ws, ita, nta, u, ws, ixa, nxa, ma, ws(ifa))
-c error in solution values.
- erru = 0
- temp = nxs*nys
- do 1 i = 1, temp
- temp2 = iewe+i
- temp1 = ifa+i
- erru = dmax1(erru, dabs(ws(temp2-1)-ws(temp1-1)))
- 1 continue
- temp = i1mach(2)
- write (temp, 2) ir, inu, erru
- 2 format(9h for rect,i3,14h error in u(.,, i2,
- 1 3h) =, 1pe10.2)
- call leave
- return
- end
- subroutine ewe2(t, x, nx, y, ny, u, inu, ir)
- integer inu, ir, nx, ny
- double precision t, x(nx), y(ny), u(nx, ny)
- integer i, j
-c the exact solution.
- do 2 i = 1, nx
- do 1 j = 1, ny
- u(i, j) = t*x(i)*y(j)
- 1 continue
- 2 continue
- return
- end
diff --git a/CEP/PyBDSM/src/port3/dttgux1p.f b/CEP/PyBDSM/src/port3/dttgux1p.f
deleted file mode 100644
index e6a737fc1809127f61ec822d9b88ea12c1cae6af..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/dttgux1p.f
+++ /dev/null
@@ -1,213 +0,0 @@
-C$TEST DTTGU1P
-c main program
-c to solve the heat equation with solution u == t*x*y,
-c grad . ( u + ux + .1 * uy, u + uy + .1 * ux ) = ut + ux + uy +g(x,t)
- common /cstak/ ds
- double precision ds(350000)
- integer ixb(4), iyb(4), nxr(4), nyr(4), kxr(4), kyr(4)
- external handlu, bc, af
- integer ndx, ndy, istkgt, is(1000), iu, nu, kx, ky, idumb
- real errpar(2), rs(1000)
- logical ls(1000)
- complex cs(500)
- double precision tstart, dt, tstop, ws(500)
-c the port library stack and its aliases.
- equivalence (ds(1), cs(1), ws(1), rs(1), is(1), ls(1))
-c initialize the port library stack length.
- call istkin(350000, 4)
- call enter(1)
- nu = 1
- kx = 2
- ky = 2
- ndx = 3
- ndy = 3
- nr=4
- tstart = 0.d0
- tstop = 1.d0
- dt = 1
- errpar(1) = 1e-2
- errpar(2) = 1e-4
-c uniform grid.
-c
-c make grid for t-shaped region
-c
- ixb(1) = idumb(-1.0d0, 0.0d0, ndx, kx, nxr(1))
- ixb(2) = idumb(0.0d0, 1.0d0, ndx, kx, nxr(2))
- ixb(3) = idumb(1.0d0, 2.0d0, ndx, kx, nxr(3))
- ixb(4) = idumb(0.0d0, 1.0d0, ndx, kx, nxr(4))
- iyb(1) = idumb(0.0d0, 1.0d0, ndy, ky, nyr(1))
- iyb(2) = idumb(0.0d0, 1.0d0, ndy, ky, nyr(2))
- iyb(3) = idumb(0.0d0, 1.0d0, ndy, ky, nyr(3))
- iyb(4) = idumb(-1.0d0, 0.0d0, ndy, ky, nyr(4))
- nnu =nu*((nxr(1)-kx)*(nyr(1)+nyr(3)-2*ky)+
- 1 (nxr(2)-kx)*(nyr(2)-ky)+
- 4 (nxr(4)-kx)*(nyr(4)-ky))
- nr=4
-c space for the solution.
- iu = istkgt(nnu, 4)
- do 1 i=1,nr
- kxr(i)=kx
- kyr(i)=ky
-1 continue
-c initial conditions for u.
- call setd(nnu, 0.d0,ws(iu))
- call dttgu(ws(iu),nu,nr,kxr,ws,nxr,ixb,kyr,ws,nyr,iyb,tstart,
- 1 tstop, dt, af, bc, errpar, handlu)
- call leave
- call wrapup
- stop
- end
- subroutine af(t, x, nx, y, ny, nu, u, ut, ux, uy, uxt, uyt
- 1 , a, au, aut, aux, auy, auxt, auyt, f, fu, fut, fux, fuy, fuxt,
- 2 fuyt)
- integer nu, nx, ny
- double precision t, x(nx), y(ny), u(nx, ny, nu), ut(nx, ny, nu),
- 1 ux(nx, ny, nu)
- double precision uy(nx, ny, nu), uxt(nx, ny, nu), uyt(nx, ny, nu),
- 1 a(nx, ny, nu, 2), au(nx, ny, nu, nu, 2), aut(nx, ny, nu, nu, 2)
- double precision aux(nx, ny, nu, nu, 2), auy(nx, ny, nu, nu, 2),
- 1 auxt(nx, ny, nu, nu, 2), auyt(nx, ny, nu, nu, 2), f(nx, ny, nu)
- 2 , fu(nx, ny, nu, nu)
- double precision fut(nx, ny, nu, nu), fux(nx, ny, nu, nu), fuy(nx,
- 1 ny, nu, nu), fuxt(nx, ny, nu, nu), fuyt(nx, ny, nu, nu)
- integer i, p, q
- do 3 i = 1, nu
- do 2 q = 1, ny
- do 1 p = 1, nx
- a(p, q, i, 1) = ux(p, q, i)+.1*uy(p, q, i)+u(p, q, i)
- a(p, q, i, 2) = uy(p, q, i)+.1*ux(p, q, i)+u(p, q, i)
- aux(p, q, i, i, 1) = 1
- auy(p, q, i, i, 2) = 1
- auy(p, q, i, i, 1) = .1
- aux(p, q, i, i, 2) = .1
- au(p, q, i, i, 1) = 1
- au(p, q, i, i, 2) = 1
- f(p, q, i) = ut(p, q, i)+ux(p, q, i)+uy(p, q, i)
- fut(p, q, i, i) = 1
- fux(p, q, i, i) = 1
- fuy(p, q, i, i) = 1
- f(p, q, i) = f(p, q, i)+.2*t-x(p)*y(q)
- 1 continue
- 2 continue
- 3 continue
- return
- end
- subroutine bc(t, x, nx, y, ny, lx, rx, ly, ry, u, ut, ux,
- 1 uy, uxt, uyt, nu, b, bu, but, bux, buy, buxt, buyt)
- integer nu, nx, ny
- double precision t, x(nx), y(ny), lx, rx, ly
- double precision ry, u(nx, ny, nu), ut(nx, ny, nu), ux(nx, ny, nu)
- 1 , uy(nx, ny, nu), uxt(nx, ny, nu)
- double precision uyt(nx, ny, nu), b(nx, ny, nu), bu(nx, ny, nu,
- 1 nu), but(nx, ny, nu, nu), bux(nx, ny, nu, nu), buy(nx, ny, nu
- 2 , nu)
- double precision buxt(nx, ny, nu, nu), buyt(nx, ny, nu, nu)
- integer i, j
- do 2 j = 1, ny
- do 1 i = 1, nx
- bu(i, j, 1, 1) = 1
- b(i, j, 1) = u(i, j, 1)-t*x(i)*y(j)
- 1 continue
- 2 continue
- return
- end
- subroutine handlu(t0, u0, t, u, nv, dt, tstop)
- integer nv
- double precision t0, u0(nv), t, u(nv), dt, tstop
- common /d7tgup/ errpar, nu, mxp, myp
- integer nu
- real errpar(2)
- common /d7tgum/ kxp,ix,nxp,kyp,iy,nyp,nxnyt,nr,iup
- integer kx, ix, nx, ky, iy, ny
- common /cstak/is
- integer is(1000)
- iwrite=i1mach(2)
- if (t0 .ne. t) goto 2
- write (iwrite, 1) t
- 1 format (16h restart for t =, 1pe10.2)
- return
-c get and print the error.
- 2 continue
- write(iwrite, 3)t
- 3 format(6h at t=,1pe10.2)
- ius=1
- do 5 inu = 1, nu
- iyr=iy
- ixr=ix
- do 4 ir=1,nr
- ir1=ir-1
- nx=is(nxp+ir1)
- ny=is(nyp+ir1)
- kx=is(kxp+ir1)
- ky=is(kyp+ir1)
- call gerr(kx, ixr, nx, ky, iyr, ny, u(ius), inu, t, ir)
- ixr=ixr+nx
- iyr=iyr+ny
- ius=ius+(nx-kx)*(ny-ky)
- 4 continue
- 5 continue
- return
- end
- subroutine gerr(kx, ix, nx, ky, iy, ny, u, inu, t, ir)
-c to print the solution at each time-step
- integer kx, ix, nx, ky, iy, ny
- integer inu, ir
- double precision u(1), t
- common /cstak/ ds
- double precision ds(500)
- integer ifa, ita(2), ixa(2), nta(2), nxa(2), idlumd
- integer ixs, iys, nxs, nys, istkgt, i
- integer ka(2), ma(2), is(1000), i1mach
- real rs(1000)
- logical ls(1000)
- complex cs(500)
- double precision ws(500)
- integer temp
- equivalence (ds(1), cs(1), ws(1), rs(1), is(1), ls(1))
-c u(nx-kx,ny-ky).
-c the port library stack and its aliases.
- call enter(1)
-c x search grid.
-c find the solution at 2 * 2 points / mesh rectangle.
- ixs = idlumd(ws(ix), nx, 2, nxs)
-c y search grid.
- iys = idlumd(ws(iy), ny, 2, nys)
-c u search grid values.
- ka(1) = kx
- ka(2) = ky
- ita(1) = ix
- ita(2) = iy
- nta(1) = nx
- nta(2) = ny
- ixa(1) = ixs
- ixa(2) = iys
- nxa(1) = nxs
- nxa(2) = nys
- ma(1) = 0
- ma(2) = 0
-c get solution.
-c approximate solution values.
- ifa = istkgt(nxs*nys, 4)
-c evaluate them.
- call dtsd1(2, ka, ws, ita, nta, u, ws, ixa, nxa, ma, ws(ifa))
- temp = i1mach(2)
- write(temp,9001)ir,inu,(ws(i),i=iFA,IFa+nxs*nys-1)
-9001 format(" for rect",i3," u(.,",i2,")=",
- 1((1p5e10.2/20x,1p4d10.2)))
- call leave
- return
- end
- subroutine ewe(t, x, nx, y, ny, u, nu)
- integer nu, nx, ny
- double precision t, x(nx), y(ny), u(nx, ny, nu)
- integer i, j, p
-c the exact solution.
- do 3 p = 1, nu
- do 2 i = 1, nx
- do 1 j = 1, ny
- u(i, j, p) = t*x(i)*y(j)
- 1 continue
- 2 continue
- 3 continue
- return
- end
diff --git a/CEP/PyBDSM/src/port3/dttgux2.f b/CEP/PyBDSM/src/port3/dttgux2.f
deleted file mode 100644
index e8acae77b535f356ba4e7c6c1dcf529c5e3a3456..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/dttgux2.f
+++ /dev/null
@@ -1,232 +0,0 @@
-C$TEST DTTGU2
-c main program
- common /cstak/ ds
- double precision ds(350000)
- external handlu, bc, af
- integer ndx, ndy, istkgt, is(1000), iu
- integer nu, nr, iyb(3), ixb(3), kx, ky
- integer nxr(3), nyr(3), kxr(3), kyr(3)
- integer idumb
- real errpar(2), rs(1000)
- logical ls(1000)
- complex cs(500)
- double precision tstart, dt
- double precision ws(500), tstop
- equivalence (ds(1), cs(1), ws(1), rs(1), is(1), ls(1))
-c to solve two coupled, nonlinear heat equations.
-c u1 sub t = div . ( u1x, u1y ) - u1*u2 + g1
-c u2 sub t = div . ( u2x, u2y ) - u1*u2 + g2
-c the port library stack and its aliases.
-c initialize the port library stack length.
- call istkin(350000, 4)
- call enter(1)
- nu = 2
- kx = 4
- ky = 4
- ndx = 3
- ndy = 3
- nr = 3
- tstart = 0
- dt = 1e-2
- tstop =1.d0
- errpar(1) = 1e-2
- errpar(2) = 1e-4
-c uniform grid.
- ixb(1) = idumb(0.0d0, 1.0d0, ndx, kx, nxr(1))
- ixb(2) = idumb(0.0d0, 1.0d0, ndx, kx, nxr(2))
- ixb(3) = idumb(1.0d0, 2.0d0, ndx, kx, nxr(3))
- iyb(1) = idumb(0.0d0, 1.0d0, ndy, ky, nyr(1))
- iyb(2) = idumb(1.0d0, 2.0d0, ndy, ky, nyr(2))
- iyb(3) = idumb(0.0d0, 1.0d0, ndy, ky, nyr(3))
-c uniform grid.
-c space for the solution.
- nnu=0
- do 1 i=1,nr
- nnu=nnu+nu*((nxr(i)-kx)*(nyr(i)-ky))
- 1 continue
- iu = istkgt(nnu, 4)
- do 2 i=1,nr
- kxr(i)=kx
- kyr(i)=ky
- 2 continue
- call setd(nnu, 1.d0,ws(iu))
- call dttgu(ws(iu),nu,nr,kxr,ws,nxr,ixb,kyr,ws,nyr,iyb,tstart,
- 1 tstop, dt, af, bc, errpar, handlu)
- call leave
- call wrapup
- stop
- end
- subroutine handlu(t0, u0, t, u, nv, dt, tstop)
- integer nv
- double precision t0, u0(nv), t, u(nv), dt, tstop
- common /d7tgup/ errpar, nu, mxp, myp
- integer nu
- real errpar(2)
- common /d7tgum/ kxp,ix,nxp,kyp,iy,nyp,nxnyt,nr,iup
- integer kx, ix, nx, ky, iy, ny
- common /cstak/is
- integer is(1000)
- iwrite=i1mach(2)
- if (t0 .ne. t) goto 2
- write (iwrite, 1) t
- 1 format (16h restart for t =, 1pe10.2)
- return
-c get and print the error.
- 2 continue
- write(iwrite, 3)t
- 3 format(6h at t=,1pe10.2)
- ius=1
- do 5 inu = 1, nu
- iyr=iy
- ixr=ix
- do 4 ir=1,nr
- ir1=ir-1
- nx=is(nxp+ir1)
- ny=is(nyp+ir1)
- kx=is(kxp+ir1)
- ky=is(kyp+ir1)
- call gerr(kx, ixr, nx, ky, iyr, ny, u(ius), inu, t, ir)
- ixr=ixr+nx
- iyr=iyr+ny
- ius=ius+(nx-kx)*(ny-ky)
- 4 continue
- 5 continue
- return
- end
- subroutine gerr(kx, ix, nx, ky, iy, ny, u, inu, t, ir)
- integer kx, ix, nx, ky, iy, ny, inu, ir
- double precision u(1), t
- common /cstak/ ds
- double precision ds(500)
- integer ifa, ita(2), ixa(2), nta(2), nxa(2), idlumd
- integer ixs, iys, nxs, nys, istkgt, i
- integer iewe, ka(2), ma(2), is(1000), i1mach
- real rs(1000)
- logical ls(1000)
- complex cs(500)
- double precision dabs, erru, dmax1, ws(500)
- integer temp, temp1, temp2
- equivalence (ds(1), cs(1), ws(1), rs(1), is(1), ls(1))
-c to get and print the error at each time-step.
-c for variable inu for rectangle ir
-c u(nx-kx,ny-ky).
-c the port library stack and its aliases.
- call enter(1)
-c find the error in the solution at 2*kx * 2*ky points / mesh rectangle.
-c x search grid.
- ixs = idlumd(ws(ix), nx, 2*kx, nxs)
-c y search grid.
- iys = idlumd(ws(iy), ny, 2*ky, nys)
-c u search grid values.
- iewe = istkgt(nxs*nys, 4)
-c the exact solution.
- call ewe2(t, ws(ixs), nxs, ws(iys), nys, ws(iewe), inu, ir)
- ka(1) = kx
- ka(2) = ky
- ita(1) = ix
- ita(2) = iy
- nta(1) = nx
- nta(2) = ny
- ixa(1) = ixs
- ixa(2) = iys
- nxa(1) = nxs
- nxa(2) = nys
- ma(1) = 0
-c get solution.
- ma(2) = 0
-c approximate solution values.
- ifa = istkgt(nxs*nys, 4)
-c evaluate them.
- call dtsd1(2, ka, ws, ita, nta, u, ws, ixa, nxa, ma, ws(ifa))
-c error in solution values.
- erru = 0
- temp = nxs*nys
- do 1 i = 1, temp
- temp2 = iewe+i
- temp1 = ifa+i
- erru = dmax1(erru, dabs(ws(temp2-1)-ws(temp1-1)))
- 1 continue
- temp = i1mach(2)
- write (temp, 2) ir, inu, erru
- 2 format(9h for rect,i3,14h error in u(.,, i2,
- 1 3h) =, 1pe10.2)
- call leave
- return
- end
- subroutine af(t, x, nx, y, ny, nu, u, ut, ux, uy, uxt, uyt
- 1 , a, au, aut, aux, auy, auxt, auyt, f, fu, fut, fux, fuy, fuxt,
- 2 fuyt)
- integer nu, nx, ny
- double precision t, x(nx), y(ny), u(nx, ny, nu), ut(nx, ny, nu),
- 1 ux(nx, ny, nu)
- double precision uy(nx, ny, nu), uxt(nx, ny, nu), uyt(nx, ny, nu),
- 1 a(nx, ny, nu, 2), au(nx, ny, nu, nu, 2), aut(nx, ny, nu, nu, 2)
- double precision aux(nx, ny, nu, nu, 2), auy(nx, ny, nu, nu, 2),
- 1 auxt(nx, ny, nu, nu, 2), auyt(nx, ny, nu, nu, 2), f(nx, ny, nu)
- 2 , fu(nx, ny, nu, nu)
- double precision fut(nx, ny, nu, nu), fux(nx, ny, nu, nu), fuy(nx,
- 1 ny, nu, nu), fuxt(nx, ny, nu, nu), fuyt(nx, ny, nu, nu)
- integer p, q
- double precision dexp
- do 2 q = 1, ny
- do 1 p = 1, nx
- a(p, q, 1, 1) = ux(p, q, 1)
- aux(p, q, 1, 1, 1) = 1
- a(p, q, 1, 2) = uy(p, q, 1)
- auy(p, q, 1, 1, 2) = 1
- f(p, q, 1) = ut(p, q, 1)+u(p, q, 1)*u(p, q, 2)
- fu(p, q, 1, 1) = u(p, q, 2)
- fu(p, q, 1, 2) = u(p, q, 1)
- fut(p, q, 1, 1) = 1
- a(p, q, 2, 1) = ux(p, q, 2)
- aux(p, q, 2, 2, 1) = 1
- a(p, q, 2, 2) = uy(p, q, 2)
- auy(p, q, 2, 2, 2) = 1
- f(p, q, 2) = ut(p, q, 2)+u(p, q, 1)*u(p, q, 2)
- fu(p, q, 2, 1) = u(p, q, 2)
- fu(p, q, 2, 2) = u(p, q, 1)
- fut(p, q, 2, 2) = 1
- f(p, q, 1) = f(p, q, 1)-(dexp(t*(x(p)-y(q)))*(x(p)-y(q)-2d0*
- 1 t*t)+1d0)
- f(p, q, 2) = f(p, q, 2)-(dexp(t*(y(q)-x(p)))*(y(q)-x(p)-2d0*
- 1 t*t)+1d0)
- 1 continue
- 2 continue
- return
- end
- subroutine bc(t, x, nx, y, ny, lx, rx, ly, ry, u, ut, ux,
- 1 uy, uxt, uyt, nu, b, bu, but, bux, buy, buxt, buyt)
- integer nu, nx, ny
- double precision t, x(nx), y(ny), lx, rx, ly
- double precision ry, u(nx, ny, nu), ut(nx, ny, nu), ux(nx, ny, nu)
- 1 , uy(nx, ny, nu), uxt(nx, ny, nu)
- double precision uyt(nx, ny, nu), b(nx, ny, nu), bu(nx, ny, nu,
- 1 nu), but(nx, ny, nu, nu), bux(nx, ny, nu, nu), buy(nx, ny, nu
- 2 , nu)
- double precision buxt(nx, ny, nu, nu), buyt(nx, ny, nu, nu)
- integer i, j
- double precision dexp
- do 2 j = 1, ny
- do 1 i = 1, nx
- bu(i, j, 1, 1) = 1
- b(i, j, 1) = u(i, j, 1)-dexp(t*(x(i)-y(j)))
- bu(i, j, 2, 2) = 1
- b(i, j, 2) = u(i, j, 2)-dexp(t*(y(j)-x(i)))
- 1 continue
- 2 continue
- return
- end
- subroutine ewe2(t, x, nx, y, ny, u, inu, ir)
- integer inu, ir, nx, ny
- double precision t, x(nx), y(ny), u(nx, ny)
- integer i, j
- real float
- double precision dble, dexp
-c the exact solution.
- do 2 i = 1, nx
- do 1 j = 1, ny
- u(i, j) = dexp(dble(float((-1)**(inu+1)))*t*(x(i)-y(j)))
- 1 continue
- 2 continue
- return
- end
diff --git a/CEP/PyBDSM/src/port3/dttgux3.f b/CEP/PyBDSM/src/port3/dttgux3.f
deleted file mode 100644
index b90c7651698ba6926e95b1b20d9a0c130c0a3f3e..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/dttgux3.f
+++ /dev/null
@@ -1,247 +0,0 @@
-C$TEST DTTGU3
-c main program
- common /cstak/ ds
- double precision ds(350000)
- external handlu, bc, af
- integer ndx, ndy, istkgt, is(1000), iu
- integer nu, nr, iyb(3), ixb(3), kx, ky
- integer nxr(3), nyr(3), kxr(3), kyr(3)
- integer idumb
- real errpar(2), rs(1000)
- logical ls(1000)
- complex cs(500)
- double precision tstart, dt, ws(500)
- double precision tstop
- equivalence (ds(1), cs(1), ws(1), rs(1), is(1), ls(1))
-c to solve the layered heat equation, with kappa = 1, 1/2, 1/3,
-c div . ( kappa(x,y) * grad u ) = ut + g
-c the port library stack and its aliases.
-c initialize the port library stack length.
- call istkin(350000, 4)
- call enter(1)
- nu = 1
- nr = 3
- kx = 2
- ky = 2
- ndx = 3
- ndy = 3
- tstart = 0
- tstop = 1
- dt = 1
- errpar(1) = 1e-2
- errpar(2) = 1e-4
-c uniform grid.
- ixb(1) = idumb(0.0d0, 1.0d0, ndx, kx, nxr(1))
- ixb(2) = idumb(0.0d0, 1.0d0, ndx, kx, nxr(2))
- ixb(3) = idumb(0.0d0, 1.0d0, ndx, kx, nxr(3))
- iyb(1) = idumb(0.0d0, 1.0d0, ndy, ky, nyr(1))
- iyb(2) = idumb(1.0d0, 2.0d0, ndy, ky, nyr(2))
- iyb(3) = idumb(2.0d0, 3.0d0, ndy, ky, nyr(3))
-c space for the solution.
- nnu=0
- do 1 i=1,nr
- nnu=nnu+nu*((nxr(i)-kx)*(nyr(i)-ky))
- 1 continue
- iu = istkgt(nnu, 4)
- do 2 i=1,nr
- kxr(i)=kx
- kyr(i)=ky
- 2 continue
- call setd(nnu, 0.d0,ws(iu))
- call dttgu(ws(iu),nu,nr,kxr,ws,nxr,ixb,kyr,ws,nyr,iyb,tstart,
- 1 tstop, dt, af, bc, errpar, handlu)
- call leave
- call wrapup
- stop
- end
- subroutine af(t, x, nx, y, ny, nu, u, ut, ux, uy, uxt, uyt
- 1 , a, au, aut, aux, auy, auxt, auyt, f, fu, fut, fux, fuy, fuxt,
- 2 fuyt)
- integer nu, nx, ny
- double precision t, x(nx), y(ny), u(nx, ny, nu), ut(nx, ny, nu),
- 1 ux(nx, ny, nu)
- double precision uy(nx, ny, nu), uxt(nx, ny, nu), uyt(nx, ny, nu),
- 1 a(nx, ny, nu, 2), au(nx, ny, nu, nu, 2), aut(nx, ny, nu, nu, 2)
- double precision aux(nx, ny, nu, nu, 2), auy(nx, ny, nu, nu, 2),
- 1 auxt(nx, ny, nu, nu, 2), auyt(nx, ny, nu, nu, 2), f(nx, ny, nu)
- 2 , fu(nx, ny, nu, nu)
- double precision fut(nx, ny, nu, nu), fux(nx, ny, nu, nu), fuy(nx,
- 1 ny, nu, nu), fuxt(nx, ny, nu, nu), fuyt(nx, ny, nu, nu)
- integer i, p, q
- double precision kappa
- logical temp
- do 7 i = 1, nu
- do 6 q = 1, ny
- do 5 p = 1, nx
- if (y(q) .ge. 1d0) goto 1
- kappa = 1
- goto 4
- 1 if (y(q) .ge. 2d0) goto 2
- kappa = 0.5
- goto 3
- 2 kappa = 1d0/3d0
- 3 continue
- 4 a(p, q, i, 1) = kappa*ux(p, q, i)
- aux(p, q, i, i, 1) = kappa
- a(p, q, i, 2) = kappa*uy(p, q, i)
- auy(p, q, i, i, 2) = kappa
- f(p, q, i) = ut(p, q, i)
- fut(p, q, i, i) = 1
- f(p, q, i) = f(p, q, i)-y(q)/kappa
- temp = 1d0 .lt. y(q)
- if (temp) temp = y(q) .lt. 2d0
- if (temp) f(p, q, i) = f(p, q, i)+1d0
- temp = 2d0 .lt. y(q)
- if (temp) temp = y(q) .lt. 3d0
- if (temp) f(p, q, i) = f(p, q, i)+3d0
- 5 continue
- 6 continue
- 7 continue
- return
- end
- subroutine bc(t, x, nx, y, ny, lx, rx, ly, ry, u, ut, ux,
- 1 uy, uxt, uyt, nu, b, bu, but, bux, buy, buxt, buyt)
- integer nu, nx, ny
- double precision t, x(nx), y(ny), lx, rx, ly
- double precision ry, u(nx, ny, nu), ut(nx, ny, nu), ux(nx, ny, nu)
- 1 , uy(nx, ny, nu), uxt(nx, ny, nu)
- double precision uyt(nx, ny, nu), b(nx, ny, nu), bu(nx, ny, nu,
- 1 nu), but(nx, ny, nu, nu), bux(nx, ny, nu, nu), buy(nx, ny, nu
- 2 , nu)
- double precision buxt(nx, ny, nu, nu), buyt(nx, ny, nu, nu)
- integer i, j
- logical temp
- do 6 j = 1, ny
- do 5 i = 1, nx
- temp = x(i) .eq. lx
- if (.not. temp) temp = x(i) .eq. rx
- if (.not. temp) goto 1
- bux(i, j, 1, 1) = 1
-c left or right.
-c neumann bcs.
- b(i, j, 1) = ux(i, j, 1)
- goto 4
- 1 if (y(j) .ne. ly) goto 2
- b(i, j, 1) = u(i, j, 1)
-c bottom.
- bu(i, j, 1, 1) = 1
- goto 3
- 2 b(i, j, 1) = u(i, j, 1)-6d0*t
-c top.
- bu(i, j, 1, 1) = 1
- 3 continue
- 4 continue
- 5 continue
- 6 continue
- return
- end
- subroutine handlu(t0, u0, t, u, nv, dt, tstop)
- integer nv
- double precision t0, u0(nv), t, u(nv), dt, tstop
- common /d7tgup/ errpar, nu, mxp, myp
- integer nu
- real errpar(2)
- common /d7tgum/ kxp,ix,nxp,kyp,iy,nyp,nxnyt,nr,iup
- integer kx, ix, nx, ky, iy, ny
- common /cstak/is
- integer is(1000)
- iwrite=i1mach(2)
- if (t0 .ne. t) goto 2
- write (iwrite, 1) t
- 1 format (16h restart for t =, 1pe10.2)
- return
-c get and print the error.
- 2 continue
- write(iwrite, 3)t
- 3 format(6h at t=,1pe10.2)
- ius=1
- do 5 inu = 1, nu
- iyr=iy
- ixr=ix
- do 4 ir=1,nr
- ir1=ir-1
- nx=is(nxp+ir1)
- ny=is(nyp+ir1)
- kx=is(kxp+ir1)
- ky=is(kyp+ir1)
- call gerr(kx, ixr, nx, ky, iyr, ny, u(ius), inu, t, ir)
- ixr=ixr+nx
- iyr=iyr+ny
- ius=ius+(nx-kx)*(ny-ky)
- 4 continue
- 5 continue
- return
- end
- subroutine gerr(kx, ix, nx, ky, iy, ny, u, inu, t, ir)
- integer kx, ix, nx, ky, iy, ny, inu, ir
- double precision u(1), t
- common /cstak/ ds
- double precision ds(500)
- integer ifa, ita(2), ixa(2), nta(2), nxa(2), idlumd
- integer ixs, iys, nxs, nys, istkgt, i
- integer iewe, ka(2), ma(2), is(1000), i1mach
- real rs(1000)
- logical ls(1000)
- complex cs(500)
- double precision dabs, erru, dmax1, ws(500)
- integer temp, temp1, temp2
- equivalence (ds(1), cs(1), ws(1), rs(1), is(1), ls(1))
-c to get and print the error at each time-step.
-c for variable inu for rectangle ir
-c u(nx-kx,ny-ky).
-c the port library stack and its aliases.
- call enter(1)
-c find the error in the solution at 2*kx * 2*ky points / mesh rectangle.
-c x search grid.
- ixs = idlumd(ws(ix), nx, 2*kx, nxs)
-c y search grid.
- iys = idlumd(ws(iy), ny, 2*ky, nys)
-c u search grid values.
- iewe = istkgt(nxs*nys, 4)
-c the exact solution.
- call ewe2(t, ws(ixs), nxs, ws(iys), nys, ws(iewe), inu, ir)
- ka(1) = kx
- ka(2) = ky
- ita(1) = ix
- ita(2) = iy
- nta(1) = nx
- nta(2) = ny
- ixa(1) = ixs
- ixa(2) = iys
- nxa(1) = nxs
- nxa(2) = nys
- ma(1) = 0
-c get solution.
- ma(2) = 0
-c approximate solution values.
- ifa = istkgt(nxs*nys, 4)
-c evaluate them.
- call dtsd1(2, ka, ws, ita, nta, u, ws, ixa, nxa, ma, ws(ifa))
-c error in solution values.
- erru = 0
- temp = nxs*nys
- do 1 i = 1, temp
- temp2 = iewe+i
- temp1 = ifa+i
- erru = dmax1(erru, dabs(ws(temp2-1)-ws(temp1-1)))
- 1 continue
- temp = i1mach(2)
- write (temp, 2) ir, inu, erru
- 2 format(9h for rect,i3,14h error in u(.,, i2,
- 1 3h) =, 1pe10.2)
- call leave
- return
- end
- subroutine ewe2(t, x, nx, y, ny, u, inu, ir)
- integer inu, ir, nx, ny
- double precision t, x(nx), y(ny), u(nx, ny), dble
- integer i, j
-c the exact solution.
- do 6 i = 1, nx
- do 5 j = 1, ny
- u(i, j) = dble(float(ir))*t*y(j)-dble(float(ir-1))*t
- if(ir.eq.3) u(i,j)=u(i,j)-t
- 5 continue
- 6 continue
- return
- end
diff --git a/CEP/PyBDSM/src/port3/dttgux4.f b/CEP/PyBDSM/src/port3/dttgux4.f
deleted file mode 100644
index b96fbf64ad57434c45df12cdeb64c9be1872fc42..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/dttgux4.f
+++ /dev/null
@@ -1,257 +0,0 @@
-C$TEST DTTGU4
-c main program
- common /cstak/ ds
- double precision ds(350000)
- external handlu, bc, af, ic
- integer ndx, ndy, istkgt, is(1000), iu
- integer nu, nr, iyb(3), ixb(3), kx, ky
- integer nxr(3), nyr(3), kxr(3), kyr(3)
- integer idumb
- real errpar(2), rs(1000)
- logical ls(1000)
- complex cs(500)
- double precision tstart, dt
- double precision ws(500), tstop
- equivalence (ds(1), cs(1), ws(1), rs(1), is(1), ls(1))
-c to solve two coupled, nonlinear heat equations.
-c u1 sub t = div . ( u1x, u1y ) - u1*u2 + g1
-c u2 sub t = div . ( u2x, u2y ) - u1*u2 + g2
-c the port library stack and its aliases.
-c initialize the port library stack length.
- call istkin(350000, 4)
- call enter(1)
- nu = 2
- kx = 4
- ky = 4
- ndx = 3
- ndy = 3
- nr = 3
- tstart = 1.0d0
- dt = 1e-2
- tstop =1.01d0
- errpar(1) = 1e-2
- errpar(2) = 1e-4
-c uniform grid.
- ixb(1) = idumb(0.0d0, 1.0d0, ndx, kx, nxr(1))
- ixb(2) = idumb(0.0d0, 1.0d0, ndx, kx, nxr(2))
- ixb(3) = idumb(1.0d0, 2.0d0, ndx, kx, nxr(3))
- iyb(1) = idumb(0.0d0, 1.0d0, ndy, ky, nyr(1))
- iyb(2) = idumb(1.0d0, 2.0d0, ndy, ky, nyr(2))
- iyb(3) = idumb(0.0d0, 1.0d0, ndy, ky, nyr(3))
-c uniform grid.
-c space for the solution.
- nnu=0
- do 1 i=1,nr
- nnu=nnu+nu*((nxr(i)-kx)*(nyr(i)-ky))
- 1 continue
- iu = istkgt(nnu, 4)
- do 2 i=1,nr
- kxr(i)=kx
- kyr(i)=ky
- 2 continue
- call dicon(ws(iu),nu,nr,kxr,ws,nxr,ixb,kyr,ws,nyr,iyb,ic)
- iu1=iu
- iwrite=i1mach(2)
- write(iwrite,3)
-3 format(10h initially)
- do 5 inu=1,nu
- do 4 i=1,nr
- call gerr(kxr(i),ixb(i),nxr(i),kyr(i),iyb(i),nyr(i),
- 1 ws(iu1),inu,1.0d0,i)
- iu1=iu1+(nxr(i)-kxr(i))*(nyr(i)-kyr(i))
-4 continue
-5 continue
- call dttgu(ws(iu),nu,nr,kxr,ws,nxr,ixb,kyr,ws,nyr,iyb,tstart,
- 1 tstop, dt, af, bc, errpar, handlu)
- call leave
- call wrapup
- stop
- end
- subroutine af(t, x, nx, y, ny, nu, u, ut, ux, uy, uxt, uyt
- 1 , a, au, aut, aux, auy, auxt, auyt, f, fu, fut, fux, fuy, fuxt,
- 2 fuyt)
- integer nu, nx, ny
- double precision t, x(nx), y(ny), u(nx, ny, nu), ut(nx, ny, nu),
- 1 ux(nx, ny, nu)
- double precision uy(nx, ny, nu), uxt(nx, ny, nu), uyt(nx, ny, nu),
- 1 a(nx, ny, nu, 2), au(nx, ny, nu, nu, 2), aut(nx, ny, nu, nu, 2)
- double precision aux(nx, ny, nu, nu, 2), auy(nx, ny, nu, nu, 2),
- 1 auxt(nx, ny, nu, nu, 2), auyt(nx, ny, nu, nu, 2), f(nx, ny, nu)
- 2 , fu(nx, ny, nu, nu)
- double precision fut(nx, ny, nu, nu), fux(nx, ny, nu, nu), fuy(nx,
- 1 ny, nu, nu), fuxt(nx, ny, nu, nu), fuyt(nx, ny, nu, nu)
- integer p, q
- double precision dexp
- do 2 q = 1, ny
- do 1 p = 1, nx
- a(p, q, 1, 1) = ux(p, q, 1)
- aux(p, q, 1, 1, 1) = 1
- a(p, q, 1, 2) = uy(p, q, 1)
- auy(p, q, 1, 1, 2) = 1
- f(p, q, 1) = ut(p, q, 1)+u(p, q, 1)*u(p, q, 2)
- fu(p, q, 1, 1) = u(p, q, 2)
- fu(p, q, 1, 2) = u(p, q, 1)
- fut(p, q, 1, 1) = 1
- a(p, q, 2, 1) = ux(p, q, 2)
- aux(p, q, 2, 2, 1) = 1
- a(p, q, 2, 2) = uy(p, q, 2)
- auy(p, q, 2, 2, 2) = 1
- f(p, q, 2) = ut(p, q, 2)+u(p, q, 1)*u(p, q, 2)
- fu(p, q, 2, 1) = u(p, q, 2)
- fu(p, q, 2, 2) = u(p, q, 1)
- fut(p, q, 2, 2) = 1
- f(p, q, 1) = f(p, q, 1)-(dexp(t*(x(p)-y(q)))*(x(p)-y(q)-2d0*
- 1 t*t)+1d0)
- f(p, q, 2) = f(p, q, 2)-(dexp(t*(y(q)-x(p)))*(y(q)-x(p)-2d0*
- 1 t*t)+1d0)
- 1 continue
- 2 continue
- return
- end
- subroutine bc(t, x, nx, y, ny, lx, rx, ly, ry, u, ut, ux,
- 1 uy, uxt, uyt, nu, b, bu, but, bux, buy, buxt, buyt)
- integer nu, nx, ny
- double precision t, x(nx), y(ny), lx, rx, ly
- double precision ry, u(nx, ny, nu), ut(nx, ny, nu), ux(nx, ny, nu)
- 1 , uy(nx, ny, nu), uxt(nx, ny, nu)
- double precision uyt(nx, ny, nu), b(nx, ny, nu), bu(nx, ny, nu,
- 1 nu), but(nx, ny, nu, nu), bux(nx, ny, nu, nu), buy(nx, ny, nu
- 2 , nu)
- double precision buxt(nx, ny, nu, nu), buyt(nx, ny, nu, nu)
- integer i, j
- double precision dexp
- do 2 j = 1, ny
- do 1 i = 1, nx
- bu(i, j, 1, 1) = 1
- b(i, j, 1) = u(i, j, 1)-dexp(t*(x(i)-y(j)))
- bu(i, j, 2, 2) = 1
- b(i, j, 2) = u(i, j, 2)-dexp(t*(y(j)-x(i)))
- 1 continue
- 2 continue
- return
- end
- subroutine ic(nu,ir,xq,nxq,yq,nyq,ui)
- integer nu, ir, nxq, nyq
- double precision xq(nxq), yq(nyq), ui(nxq, nyq,nu)
- double precision dble, dexp
- integer p
- do 30 p=1,nu
- do 20 j=1,nyq
- do 10 i=1, nxq
- ui(i, j, p) = dexp(dble(float((-1)**(p+1)))*(xq(i)-yq(j)))
-10 continue
-20 continue
-30 continue
- return
- end
- subroutine ewe2(t, x, nx, y, ny, u, inu, ir)
- integer inu, nx, ny, ir
- double precision t, x(nx), y(ny), u(nx, ny)
- integer i, j
- real float
- double precision dble, dexp
-c the exact solution.
- do 2 i = 1, nx
- do 1 j = 1, ny
- u(i, j) = dexp(dble(float((-1)**(inu+1)))*t*(x(i)-y(j)))
-1 continue
- 2 continue
- return
- end
- subroutine handlu(t0, u0, t, u, nv, dt, tstop)
- integer nv
- double precision t0, u0(nv), t, u(nv), dt, tstop
- common /d7tgup/ errpar, nu, mxp, myp
- integer nu
- real errpar(2)
- common /d7tgum/ kxp,ix,nxp,kyp,iy,nyp,nxnyt,nr,iup
- integer kx, ix, nx, ky, iy, ny
- common /cstak/is
- integer is(1000)
- iwrite=i1mach(2)
- if (t0 .ne. t) goto 2
- write (iwrite, 1) t
- 1 format (16h restart for t =, 1pe10.2)
- return
-c get and print the error.
- 2 continue
- write(iwrite, 3)t
- 3 format(6h at t=,1pe10.2)
- ius=1
- do 5 inu = 1, nu
- iyr=iy
- ixr=ix
- do 4 ir=1,nr
- ir1=ir-1
- nx=is(nxp+ir1)
- ny=is(nyp+ir1)
- kx=is(kxp+ir1)
- ky=is(kyp+ir1)
- call gerr(kx, ixr, nx, ky, iyr, ny, u(ius), inu, t, ir)
- ixr=ixr+nx
- iyr=iyr+ny
- ius=ius+(nx-kx)*(ny-ky)
- 4 continue
- 5 continue
- return
- end
- subroutine gerr(kx, ix, nx, ky, iy, ny, u, inu, t, ir)
- integer kx, ix, nx, ky, iy, ny, inu, ir
- double precision u(1), t
- common /cstak/ ds
- double precision ds(500)
- integer ifa, ita(2), ixa(2), nta(2), nxa(2), idlumd
- integer ixs, iys, nxs, nys, istkgt, i
- integer iewe, ka(2), ma(2), is(1000), i1mach
- real rs(1000)
- logical ls(1000)
- complex cs(500)
- double precision dabs, erru, dmax1, ws(500)
- integer temp, temp1, temp2
- equivalence (ds(1), cs(1), ws(1), rs(1), is(1), ls(1))
-c to get and print the error at each time-step.
-c for variable inu for rectangle ir
-c u(nx-kx,ny-ky).
-c the port library stack and its aliases.
- call enter(1)
-c find the error in the solution at 2*kx * 2*ky points / mesh rectangle.
-c x search grid.
- ixs = idlumd(ws(ix), nx, 2*kx, nxs)
-c y search grid.
- iys = idlumd(ws(iy), ny, 2*ky, nys)
-c u search grid values.
- iewe = istkgt(nxs*nys, 4)
-c the exact solution.
- call ewe2(t, ws(ixs), nxs, ws(iys), nys, ws(iewe), inu, ir)
- ka(1) = kx
- ka(2) = ky
- ita(1) = ix
- ita(2) = iy
- nta(1) = nx
- nta(2) = ny
- ixa(1) = ixs
- ixa(2) = iys
- nxa(1) = nxs
- nxa(2) = nys
- ma(1) = 0
-c get solution.
- ma(2) = 0
-c approximate solution values.
- ifa = istkgt(nxs*nys, 4)
-c evaluate them.
- call dtsd1(2, ka, ws, ita, nta, u, ws, ixa, nxa, ma, ws(ifa))
-c error in solution values.
- erru = 0
- temp = nxs*nys
- do 1 i = 1, temp
- temp2 = iewe+i
- temp1 = ifa+i
- erru = dmax1(erru, dabs(ws(temp2-1)-ws(temp1-1)))
- 1 continue
- temp = i1mach(2)
- write (temp, 2) ir, inu, erru
- 2 format(9h for rect,i3,14h error in u(.,, i2,
- 1 3h) =, 1pe10.2)
- call leave
- return
- end
diff --git a/CEP/PyBDSM/src/port3/dttgux5.f b/CEP/PyBDSM/src/port3/dttgux5.f
deleted file mode 100644
index a2f91b65aba2ebf9d6977219c950e5f328b6376e..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/dttgux5.f
+++ /dev/null
@@ -1,267 +0,0 @@
-C$TEST DTTGU5
-c main program5
- common /cstak/ ds
- double precision ds(350000)
- external handlu, bc, af
- integer ndx, ndy, istkgt, is(1000), iu, ix, temp, temp1
- integer nu, nr, iyb(5), ixb(5), kx, ky
- integer nxr(5), nyr(5), kxr(5), kyr(5)
- integer idumb
- real errpar(2), rs(1000)
- logical ls(1000)
- complex cs(500)
- double precision tstart, dt, rx
- double precision ws(500), tstop
- equivalence (ds(1), cs(1), ws(1), rs(1), is(1), ls(1))
-c to solve laplaces equation with real ( z*log(z) ) as solution.
-c the port library stack and its aliases.
-c initialize the port library stack length.
- call istkin(350000, 4)
- call enter(1)
- nu = 1
- kx = 4
- ky = 4
- ndx = 3
- ndy = 3
- nr = 5
- tstart = 0
- dt = 1.d0
- tstop =1.d0
- errpar(1) = 1e-2
- errpar(2) = 1e-4
- nx = ndx+2*(kx-1)
- rx=1.0d0
-c space for x mesh for rectangle 1
- ix = istkgt(nx, 4)
-c 0 and rx mult = kx.
- ixb(1)=ix
- do 1 i = 1, kx
- temp = ix+i
- ws(temp-1) = 0
- temp = ix+nx-i
- ws(temp) = rx
- 1 continue
- temp = ndx-1
- do 2 i = 1, temp
- temp1 = ix+kx-2+i
- ws(temp1) = rx*(dble(float(i-1))/(dble(float(ndx))-1d0))**kx
- 2 continue
-c rectangle 2 has same grid in x direction as rectanlge 1
- ixb(2)=istkgt(nx, 4)
- call dcopy(nx, ws(ix), 1, ws(ixb(2)), 1)
-c uniform grid for rectanlges 3,4, and 5 in x direction
- ixb(3) = idumb(1.0d0, 2.0d0, ndx, kx, nxr(3))
- ixb(4) = idumb(2.0d0, 3.0d0, ndx, kx, nxr(4))
- ixb(5) = idumb(2.0d0, 3.0d0, ndx, kx, nxr(5))
- ny = ndy+2*(ky-1)
-c rectangles 1,3, and 4 use the same grid in the y direction as
-c is used for the x direction in rectangle 1
-c space for y mesh.
- iyb(1) = istkgt(ny, 4)
- call dcopy( nx, ws(ix), 1, ws(iyb(1)), 1)
- iyb(3) =istkgt(ny, 4)
- call dcopy( nx, ws(ix), 1, ws(iyb(3)), 1)
- iyb(4) =istkgt(ny, 4)
- call dcopy( nx, ws(ix), 1, ws(iyb(4)), 1)
-c rectangles 2 and 5 use uniform mesh in y direction
- iyb(2) = idumb(1.0d0, 2.0d0, ndy, ky, nyr(2))
- iyb(5) = idumb(1.0d0, 2.0d0, ndy, ky, nyr(5))
-c space for the solution.
- nnu=0
- do 3 i=1,nr
- nxr(i)=nx
- nyr(i)=ny
- nnu=nnu+nu*((nxr(i)-kx)*(nyr(i)-ky))
- 3 continue
- iu = istkgt(nnu, 4)
- do 4 i=1,nr
- kxr(i)=kx
- kyr(i)=ky
- 4 continue
- call setd(nnu, 0.0d0,ws(iu))
- call dttgu(ws(iu),nu,nr,kxr,ws,nxr,ixb,kyr,ws,nyr,iyb,tstart,
- 1 tstop, dt, af, bc, errpar, handlu)
- call leave
- call wrapup
- stop
- end
- subroutine af(t, xi, nx, yi, ny, nu, u, ut, ux, uy, uxt,
- 1 uyt, a, au, aut, aux, auy, auxt, auyt, f, fu, fut, fux, fuy,
- 2 fuxt, fuyt)
- integer nu, nx, ny
- double precision t, xi(nx), yi(ny), u(nx, ny, nu), ut(nx, ny, nu),
- 1 ux(nx, ny, nu)
- double precision uy(nx, ny, nu), uxt(nx, ny, nu), uyt(nx, ny, nu),
- 1 a(nx, ny, nu, 2), au(nx, ny, nu, nu, 2), aut(nx, ny, nu, nu, 2)
- double precision aux(nx, ny, nu, nu, 2), auy(nx, ny, nu, nu, 2),
- 1 auxt(nx, ny, nu, nu, 2), auyt(nx, ny, nu, nu, 2), f(nx, ny, nu)
- 2 , fu(nx, ny, nu, nu)
- double precision fut(nx, ny, nu, nu), fux(nx, ny, nu, nu), fuy(nx,
- 1 ny, nu, nu), fuxt(nx, ny, nu, nu), fuyt(nx, ny, nu, nu)
- integer i, p, q
- do 3 i = 1, nu
- do 2 q = 1, ny
- do 1 p = 1, nx
- a(p, q, i, 1) = ux(p, q, i)
- a(p, q, i, 2) = uy(p, q, i)
- aux(p, q, i, i, 1) = 1
- auy(p, q, i, i, 2) = 1
- 1 continue
- 2 continue
- 3 continue
- return
- end
- subroutine bc(t, x, nx, y, ny, lx, rx, ly, ry, u, ut, ux,
- 1 uy, uxt, uyt, nu, b, bu, but, bux, buy, buxt, buyt)
- integer nu, nx, ny
- double precision t, x(nx), y(ny), lx, rx, ly
- double precision ry, u(nx, ny, nu), ut(nx, ny, nu), ux(nx, ny, nu)
- 1 , uy(nx, ny, nu), uxt(nx, ny, nu)
- double precision uyt(nx, ny, nu), b(nx, ny, nu), bu(nx, ny, nu,
- 1 nu), but(nx, ny, nu, nu), bux(nx, ny, nu, nu), buy(nx, ny, nu
- 2 , nu)
- double precision buxt(nx, ny, nu, nu), buyt(nx, ny, nu, nu)
- integer i, j
- double precision r, dcos, dlog, dsin, datan, theta
- double precision dsqrt
- do 6 j = 1, ny
- do 5 i = 1, nx
- if (y(j) .ne. ly) goto 1
- b(i, j, 1) = uy(i, j, 1)
-c neumann data on bottom.
- buy(i, j, 1, 1) = 1
- goto 4
- 1 r = dsqrt(x(i)**2+y(j)**2)
-c dirichlet data.
- if (x(i) .le. 0d0) goto 2
- theta = datan(y(j)/x(i))
- goto 3
- 2 theta = 2d0*datan(1d0)
- 3 b(i, j, 1) = u(i, j, 1)-r*(dcos(theta)*dlog(r)-theta*
- 1 dsin(theta))
- bu(i, j, 1, 1) = 1
- 4 continue
- 5 continue
- 6 continue
- return
- end
- subroutine ewe2(t, x, nx, y, ny, u, inu, ir)
- integer inu,ir, nx, ny
- double precision t, x(nx), y(ny), u(nx, ny)
- integer i, j
- double precision r, dcos, dlog, dsin, datan, theta
- double precision dsqrt
-c the exact solution.
- do 6 i = 1, nx
- do 5 j = 1, ny
- r = dsqrt(x(i)**2+y(j)**2)
- if (x(i) .le. 0d0) goto 1
- theta = datan(y(j)/x(i))
- goto 2
- 1 theta = 2d0*datan(1d0)
- 2 if (r .le. 0d0) goto 3
- u(i, j) = r*(dcos(theta)*dlog(r)-theta*dsin(theta))
- goto 4
- 3 u(i, j) = 0
- 4 continue
- 5 continue
- 6 continue
- return
- end
- subroutine handlu(t0, u0, t, u, nv, dt, tstop)
- integer nv
- double precision t0, u0(nv), t, u(nv), dt, tstop
- common /d7tgup/ errpar, nu, mxp, myp
- integer nu
- real errpar(2)
- common /d7tgum/ kxp,ix,nxp,kyp,iy,nyp,nxnyt,nr,iup
- integer kx, ix, nx, ky, iy, ny
- common /cstak/is
- integer is(1000)
- iwrite=i1mach(2)
- if (t0 .ne. t) goto 2
- write (iwrite, 1) t
- 1 format (16h restart for t =, 1pe10.2)
- return
-c get and print the error.
- 2 continue
- write(iwrite, 3)t
- 3 format(6h at t=,1pe10.2)
- ius=1
- do 5 inu = 1, nu
- iyr=iy
- ixr=ix
- do 4 ir=1,nr
- ir1=ir-1
- nx=is(nxp+ir1)
- ny=is(nyp+ir1)
- kx=is(kxp+ir1)
- ky=is(kyp+ir1)
- call gerr(kx, ixr, nx, ky, iyr, ny, u(ius), inu, t, ir)
- ixr=ixr+nx
- iyr=iyr+ny
- ius=ius+(nx-kx)*(ny-ky)
- 4 continue
- 5 continue
- return
- end
- subroutine gerr(kx, ix, nx, ky, iy, ny, u, inu, t, ir)
- integer kx, ix, nx, ky, iy, ny, inu, ir
- double precision u(1), t
- common /cstak/ ds
- double precision ds(500)
- integer ifa, ita(2), ixa(2), nta(2), nxa(2), idlumd
- integer ixs, iys, nxs, nys, istkgt, i
- integer iewe, ka(2), ma(2), is(1000), i1mach
- real rs(1000)
- logical ls(1000)
- complex cs(500)
- double precision dabs, erru, dmax1, ws(500)
- integer temp, temp1, temp2
- equivalence (ds(1), cs(1), ws(1), rs(1), is(1), ls(1))
-c to get and print the error at each time-step.
-c for variable inu for rectangle ir
-c u(nx-kx,ny-ky).
-c the port library stack and its aliases.
- call enter(1)
-c find the error in the solution at 2*kx * 2*ky points / mesh rectangle.
-c x search grid.
- ixs = idlumd(ws(ix), nx, 2*kx, nxs)
-c y search grid.
- iys = idlumd(ws(iy), ny, 2*ky, nys)
-c u search grid values.
- iewe = istkgt(nxs*nys, 4)
-c the exact solution.
- call ewe2(t, ws(ixs), nxs, ws(iys), nys, ws(iewe), inu, ir)
- ka(1) = kx
- ka(2) = ky
- ita(1) = ix
- ita(2) = iy
- nta(1) = nx
- nta(2) = ny
- ixa(1) = ixs
- ixa(2) = iys
- nxa(1) = nxs
- nxa(2) = nys
- ma(1) = 0
-c get solution.
- ma(2) = 0
-c approximate solution values.
- ifa = istkgt(nxs*nys, 4)
-c evaluate them.
- call dtsd1(2, ka, ws, ita, nta, u, ws, ixa, nxa, ma, ws(ifa))
-c error in solution values.
- erru = 0
- temp = nxs*nys
- do 1 i = 1, temp
- temp2 = iewe+i
- temp1 = ifa+i
- erru = dmax1(erru, dabs(ws(temp2-1)-ws(temp1-1)))
- 1 continue
- temp = i1mach(2)
- write (temp, 2) ir, inu, erru
- 2 format(9h for rect,i3,14h error in u(.,, i2,
- 1 3h) =, 1pe10.2)
- call leave
- return
- end
diff --git a/CEP/PyBDSM/src/port3/dv2axy.f b/CEP/PyBDSM/src/port3/dv2axy.f
deleted file mode 100644
index 476ecc556776ff91da01296c6dd6d92d6ba85528..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/dv2axy.f
+++ /dev/null
@@ -1,13 +0,0 @@
- SUBROUTINE DV2AXY(P, W, A, X, Y)
-C
-C *** SET W = A*X + Y -- W, X, Y = P-VECTORS, A = SCALAR ***
-C
- INTEGER P
- DOUBLE PRECISION A, W(P), X(P), Y(P)
-C
- INTEGER I
-C
- DO 10 I = 1, P
- 10 W(I) = A*X(I) + Y(I)
- RETURN
- END
diff --git a/CEP/PyBDSM/src/port3/dv2nrm.f b/CEP/PyBDSM/src/port3/dv2nrm.f
deleted file mode 100644
index f36739c33af50b3098c3d5b956a697755af8b0bb..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/dv2nrm.f
+++ /dev/null
@@ -1,61 +0,0 @@
- DOUBLE PRECISION FUNCTION DV2NRM(P, X)
-C
-C *** RETURN THE 2-NORM OF THE P-VECTOR X, TAKING ***
-C *** CARE TO AVOID THE MOST LIKELY UNDERFLOWS. ***
-C
- INTEGER P
- DOUBLE PRECISION X(P)
-C
- INTEGER I, J
- DOUBLE PRECISION ONE, R, SCALE, SQTETA, T, XI, ZERO
-C/+
- DOUBLE PRECISION DSQRT
-C/
- DOUBLE PRECISION DR7MDC
- EXTERNAL DR7MDC
-C
-C/6
-C DATA ONE/1.D+0/, ZERO/0.D+0/
-C/7
- PARAMETER (ONE=1.D+0, ZERO=0.D+0)
- SAVE SQTETA
-C/
- DATA SQTETA/0.D+0/
-C
- IF (P .GT. 0) GO TO 10
- DV2NRM = ZERO
- GO TO 999
- 10 DO 20 I = 1, P
- IF (X(I) .NE. ZERO) GO TO 30
- 20 CONTINUE
- DV2NRM = ZERO
- GO TO 999
-C
- 30 SCALE = DABS(X(I))
- IF (I .LT. P) GO TO 40
- DV2NRM = SCALE
- GO TO 999
- 40 T = ONE
- IF (SQTETA .EQ. ZERO) SQTETA = DR7MDC(2)
-C
-C *** SQTETA IS (SLIGHTLY LARGER THAN) THE SQUARE ROOT OF THE
-C *** SMALLEST POSITIVE FLOATING POINT NUMBER ON THE MACHINE.
-C *** THE TESTS INVOLVING SQTETA ARE DONE TO PREVENT UNDERFLOWS.
-C
- J = I + 1
- DO 60 I = J, P
- XI = DABS(X(I))
- IF (XI .GT. SCALE) GO TO 50
- R = XI / SCALE
- IF (R .GT. SQTETA) T = T + R*R
- GO TO 60
- 50 R = SCALE / XI
- IF (R .LE. SQTETA) R = ZERO
- T = ONE + T * R*R
- SCALE = XI
- 60 CONTINUE
-C
- DV2NRM = SCALE * DSQRT(T)
- 999 RETURN
-C *** LAST LINE OF DV2NRM FOLLOWS ***
- END
diff --git a/CEP/PyBDSM/src/port3/dv7cpy.f b/CEP/PyBDSM/src/port3/dv7cpy.f
deleted file mode 100644
index 9d8834632e7b23ca08df76bc8799dba44ebf4236..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/dv7cpy.f
+++ /dev/null
@@ -1,13 +0,0 @@
- SUBROUTINE DV7CPY(P, Y, X)
-C
-C *** SET Y = X, WHERE X AND Y ARE P-VECTORS ***
-C
- INTEGER P
- DOUBLE PRECISION X(P), Y(P)
-C
- INTEGER I
-C
- DO 10 I = 1, P
- 10 Y(I) = X(I)
- RETURN
- END
diff --git a/CEP/PyBDSM/src/port3/dv7dfl.f b/CEP/PyBDSM/src/port3/dv7dfl.f
deleted file mode 100644
index 219ec9ab175659e44fa0eb739103f799245bc6f4..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/dv7dfl.f
+++ /dev/null
@@ -1,104 +0,0 @@
- SUBROUTINE DV7DFL(ALG, LV, V)
-C
-C *** SUPPLY ***SOL (VERSION 2.3) DEFAULT VALUES TO V ***
-C
-C *** ALG = 1 MEANS REGRESSION CONSTANTS.
-C *** ALG = 2 MEANS GENERAL UNCONSTRAINED OPTIMIZATION CONSTANTS.
-C
- INTEGER ALG, LV
- DOUBLE PRECISION V(LV)
-C
- DOUBLE PRECISION DR7MDC
- EXTERNAL DR7MDC
-C DR7MDC... RETURNS MACHINE-DEPENDENT CONSTANTS
-C
- DOUBLE PRECISION MACHEP, MEPCRT, ONE, SQTEPS, THREE
-C
-C *** SUBSCRIPTS FOR V ***
-C
- INTEGER AFCTOL, BIAS, COSMIN, DECFAC, DELTA0, DFAC, DINIT, DLTFDC,
- 1 DLTFDJ, DTINIT, D0INIT, EPSLON, ETA0, FUZZ, HUBERC,
- 2 INCFAC, LMAX0, LMAXS, PHMNFC, PHMXFC, RDFCMN, RDFCMX,
- 3 RFCTOL, RLIMIT, RSPTOL, SCTOL, SIGMIN, TUNER1, TUNER2,
- 4 TUNER3, TUNER4, TUNER5, XCTOL, XFTOL
-C
-C/6
-C DATA ONE/1.D+0/, THREE/3.D+0/
-C/7
- PARAMETER (ONE=1.D+0, THREE=3.D+0)
-C/
-C
-C *** V SUBSCRIPT VALUES ***
-C
-C/6
-C DATA AFCTOL/31/, BIAS/43/, COSMIN/47/, DECFAC/22/, DELTA0/44/,
-C 1 DFAC/41/, DINIT/38/, DLTFDC/42/, DLTFDJ/43/, DTINIT/39/,
-C 2 D0INIT/40/, EPSLON/19/, ETA0/42/, FUZZ/45/, HUBERC/48/,
-C 3 INCFAC/23/, LMAX0/35/, LMAXS/36/, PHMNFC/20/, PHMXFC/21/,
-C 4 RDFCMN/24/, RDFCMX/25/, RFCTOL/32/, RLIMIT/46/, RSPTOL/49/,
-C 5 SCTOL/37/, SIGMIN/50/, TUNER1/26/, TUNER2/27/, TUNER3/28/,
-C 6 TUNER4/29/, TUNER5/30/, XCTOL/33/, XFTOL/34/
-C/7
- PARAMETER (AFCTOL=31, BIAS=43, COSMIN=47, DECFAC=22, DELTA0=44,
- 1 DFAC=41, DINIT=38, DLTFDC=42, DLTFDJ=43, DTINIT=39,
- 2 D0INIT=40, EPSLON=19, ETA0=42, FUZZ=45, HUBERC=48,
- 3 INCFAC=23, LMAX0=35, LMAXS=36, PHMNFC=20, PHMXFC=21,
- 4 RDFCMN=24, RDFCMX=25, RFCTOL=32, RLIMIT=46, RSPTOL=49,
- 5 SCTOL=37, SIGMIN=50, TUNER1=26, TUNER2=27, TUNER3=28,
- 6 TUNER4=29, TUNER5=30, XCTOL=33, XFTOL=34)
-C/
-C
-C------------------------------- BODY --------------------------------
-C
- MACHEP = DR7MDC(3)
- V(AFCTOL) = 1.D-20
- IF (MACHEP .GT. 1.D-10) V(AFCTOL) = MACHEP**2
- V(DECFAC) = 0.5D+0
- SQTEPS = DR7MDC(4)
- V(DFAC) = 0.6D+0
- V(DTINIT) = 1.D-6
- MEPCRT = MACHEP ** (ONE/THREE)
- V(D0INIT) = 1.D+0
- V(EPSLON) = 0.1D+0
- V(INCFAC) = 2.D+0
- V(LMAX0) = 1.D+0
- V(LMAXS) = 1.D+0
- V(PHMNFC) = -0.1D+0
- V(PHMXFC) = 0.1D+0
- V(RDFCMN) = 0.1D+0
- V(RDFCMX) = 4.D+0
- V(RFCTOL) = DMAX1(1.D-10, MEPCRT**2)
- V(SCTOL) = V(RFCTOL)
- V(TUNER1) = 0.1D+0
- V(TUNER2) = 1.D-4
- V(TUNER3) = 0.75D+0
- V(TUNER4) = 0.5D+0
- V(TUNER5) = 0.75D+0
- V(XCTOL) = SQTEPS
- V(XFTOL) = 1.D+2 * MACHEP
-C
- IF (ALG .GE. 2) GO TO 10
-C
-C *** REGRESSION VALUES
-C
- V(COSMIN) = DMAX1(1.D-6, 1.D+2 * MACHEP)
- V(DINIT) = 0.D+0
- V(DELTA0) = SQTEPS
- V(DLTFDC) = MEPCRT
- V(DLTFDJ) = SQTEPS
- V(FUZZ) = 1.5D+0
- V(HUBERC) = 0.7D+0
- V(RLIMIT) = DR7MDC(5)
- V(RSPTOL) = 1.D-3
- V(SIGMIN) = 1.D-4
- GO TO 999
-C
-C *** GENERAL OPTIMIZATION VALUES
-C
- 10 V(BIAS) = 0.8D+0
- V(DINIT) = -1.0D+0
- V(ETA0) = 1.0D+3 * MACHEP
-C
- 999 RETURN
-C *** LAST CARD OF DV7DFL FOLLOWS ***
- END
diff --git a/CEP/PyBDSM/src/port3/dv7ipr.f b/CEP/PyBDSM/src/port3/dv7ipr.f
deleted file mode 100644
index 62edb222d6ed7c13fee010b1df435f424ab8b32e..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/dv7ipr.f
+++ /dev/null
@@ -1,29 +0,0 @@
- SUBROUTINE DV7IPR(N, IP, X)
-C
-C PERMUTE X SO THAT X.OUTPUT(I) = X.INPUT(IP(I)).
-C IP IS UNCHANGED ON OUTPUT.
-C
- INTEGER N
- INTEGER IP(N)
- DOUBLE PRECISION X(N)
-C
- INTEGER I, J, K
- DOUBLE PRECISION T
- DO 30 I = 1, N
- J = IP(I)
- IF (J .EQ. I) GO TO 30
- IF (J .GT. 0) GO TO 10
- IP(I) = -J
- GO TO 30
- 10 T = X(I)
- K = I
- 20 X(K) = X(J)
- K = J
- J = IP(K)
- IP(K) = -J
- IF (J .GT. I) GO TO 20
- X(K) = T
- 30 CONTINUE
- 999 RETURN
-C *** LAST LINE OF DV7IPR FOLLOWS ***
- END
diff --git a/CEP/PyBDSM/src/port3/dv7prm.f b/CEP/PyBDSM/src/port3/dv7prm.f
deleted file mode 100644
index 5a3c2ff860ab300974ba4060c5dba1259f80c393..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/dv7prm.f
+++ /dev/null
@@ -1,30 +0,0 @@
- SUBROUTINE DV7PRM(N, IP, X)
-C
-C PERMUTE X SO THAT X.OUTPUT(IP(I)) = X.INPUT(I).
-C IP IS UNCHANGED ON OUTPUT.
-C
- INTEGER N
- INTEGER IP(N)
- DOUBLE PRECISION X(N)
-C
- INTEGER I, J, K
- DOUBLE PRECISION S, T
- DO 30 I = 1, N
- J = IP(I)
- IF (J .EQ. I) GO TO 30
- IF (J .GT. 0) GO TO 10
- IP(I) = -J
- GO TO 30
- 10 T = X(I)
- 20 S = X(J)
- X(J) = T
- T = S
- K = J
- J = IP(K)
- IP(K) = -J
- IF (J .GT. I) GO TO 20
- X(J) = T
- 30 CONTINUE
- 999 RETURN
-C *** LAST LINE OF DV7PRM FOLLOWS ***
- END
diff --git a/CEP/PyBDSM/src/port3/dv7scl.f b/CEP/PyBDSM/src/port3/dv7scl.f
deleted file mode 100644
index ea0b5d147409f8429a07cd40de1e9051846e212d..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/dv7scl.f
+++ /dev/null
@@ -1,14 +0,0 @@
- SUBROUTINE DV7SCL(N, X, A, Y)
-C
-C *** SET X(I) = A*Y(I), I = 1(1)N ***
-C
- INTEGER N
- DOUBLE PRECISION A, X(N), Y(N)
-C
- INTEGER I
-C
- DO 10 I = 1, N
- 10 X(I) = A * Y(I)
- 999 RETURN
-C *** LAST LINE OF DV7SCL FOLLOWS ***
- END
diff --git a/CEP/PyBDSM/src/port3/dv7scp.f b/CEP/PyBDSM/src/port3/dv7scp.f
deleted file mode 100644
index 442e73ddec6610a94f5d77e618bf2ac1f198c1d5..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/dv7scp.f
+++ /dev/null
@@ -1,13 +0,0 @@
- SUBROUTINE DV7SCP(P, Y, S)
-C
-C *** SET P-VECTOR Y TO SCALAR S ***
-C
- INTEGER P
- DOUBLE PRECISION S, Y(P)
-C
- INTEGER I
-C
- DO 10 I = 1, P
- 10 Y(I) = S
- RETURN
- END
diff --git a/CEP/PyBDSM/src/port3/dv7shf.f b/CEP/PyBDSM/src/port3/dv7shf.f
deleted file mode 100644
index 21ed93f5e976163eac19214bf522624242133775..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/dv7shf.f
+++ /dev/null
@@ -1,18 +0,0 @@
- SUBROUTINE DV7SHF(N, K, X)
-C
-C *** SHIFT X(K),...,X(N) LEFT CIRCULARLY ONE POSITION ***
-C
- INTEGER N, K
- DOUBLE PRECISION X(N)
-C
- INTEGER I, NM1
- DOUBLE PRECISION T
-C
- IF (K .GE. N) GO TO 999
- NM1 = N - 1
- T = X(K)
- DO 10 I = K, NM1
- 10 X(I) = X(I+1)
- X(N) = T
- 999 RETURN
- END
diff --git a/CEP/PyBDSM/src/port3/dv7swp.f b/CEP/PyBDSM/src/port3/dv7swp.f
deleted file mode 100644
index 2fbe07af3e44d850fd03a84aaef6408202277eed..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/dv7swp.f
+++ /dev/null
@@ -1,18 +0,0 @@
- SUBROUTINE DV7SWP(N, X, Y)
-C
-C *** INTERCHANGE N-VECTORS X AND Y. ***
-C
- INTEGER N
- DOUBLE PRECISION X(N), Y(N)
-C
- INTEGER I
- DOUBLE PRECISION T
-C
- DO 10 I = 1, N
- T = X(I)
- X(I) = Y(I)
- Y(I) = T
- 10 CONTINUE
- 999 RETURN
-C *** LAST CARD OF DV7SWP FOLLOWS ***
- END
diff --git a/CEP/PyBDSM/src/port3/dv7vmp.f b/CEP/PyBDSM/src/port3/dv7vmp.f
deleted file mode 100644
index 3745b020a57b07952e5ec8884240754dc4a051ab..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/dv7vmp.f
+++ /dev/null
@@ -1,18 +0,0 @@
- SUBROUTINE DV7VMP(N, X, Y, Z, K)
-C
-C *** SET X(I) = Y(I) * Z(I)**K, 1 .LE. I .LE. N (FOR K = 1 OR -1) ***
-C
- INTEGER N, K
- DOUBLE PRECISION X(N), Y(N), Z(N)
- INTEGER I
-C
- IF (K .GE. 0) GO TO 20
- DO 10 I = 1, N
- 10 X(I) = Y(I) / Z(I)
- GO TO 999
-C
- 20 DO 30 I = 1, N
- 30 X(I) = Y(I) * Z(I)
- 999 RETURN
-C *** LAST CARD OF DV7VMP FOLLOWS ***
- END
diff --git a/CEP/PyBDSM/src/port3/dw7zbf.f b/CEP/PyBDSM/src/port3/dw7zbf.f
deleted file mode 100644
index a9ce50575d4a2a756d1236b00d97be6e73172e67..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/dw7zbf.f
+++ /dev/null
@@ -1,84 +0,0 @@
- SUBROUTINE DW7ZBF (L, N, S, W, Y, Z)
-C
-C *** COMPUTE Y AND Z FOR DL7UPD CORRESPONDING TO BFGS UPDATE.
-C
- INTEGER N
- DOUBLE PRECISION L(1), S(N), W(N), Y(N), Z(N)
-C DIMENSION L(N*(N+1)/2)
-C
-C-------------------------- PARAMETER USAGE --------------------------
-C
-C L (I/O) CHOLESKY FACTOR OF HESSIAN, A LOWER TRIANG. MATRIX STORED
-C COMPACTLY BY ROWS.
-C N (INPUT) ORDER OF L AND LENGTH OF S, W, Y, Z.
-C S (INPUT) THE STEP JUST TAKEN.
-C W (OUTPUT) RIGHT SINGULAR VECTOR OF RANK 1 CORRECTION TO L.
-C Y (INPUT) CHANGE IN GRADIENTS CORRESPONDING TO S.
-C Z (OUTPUT) LEFT SINGULAR VECTOR OF RANK 1 CORRECTION TO L.
-C
-C------------------------------- NOTES -------------------------------
-C
-C *** ALGORITHM NOTES ***
-C
-C WHEN S IS COMPUTED IN CERTAIN WAYS, E.G. BY GQTSTP OR
-C DBLDOG, IT IS POSSIBLE TO SAVE N**2/2 OPERATIONS SINCE (L**T)*S
-C OR L*(L**T)*S IS THEN KNOWN.
-C IF THE BFGS UPDATE TO L*(L**T) WOULD REDUCE ITS DETERMINANT TO
-C LESS THAN EPS TIMES ITS OLD VALUE, THEN THIS ROUTINE IN EFFECT
-C REPLACES Y BY THETA*Y + (1 - THETA)*L*(L**T)*S, WHERE THETA
-C (BETWEEN 0 AND 1) IS CHOSEN TO MAKE THE REDUCTION FACTOR = EPS.
-C
-C *** GENERAL ***
-C
-C CODED BY DAVID M. GAY (FALL 1979).
-C THIS SUBROUTINE WAS WRITTEN IN CONNECTION WITH RESEARCH SUPPORTED
-C BY THE NATIONAL SCIENCE FOUNDATION UNDER GRANTS MCS-7600324 AND
-C MCS-7906671.
-C
-C------------------------ EXTERNAL QUANTITIES ------------------------
-C
-C *** FUNCTIONS AND SUBROUTINES CALLED ***
-C
- DOUBLE PRECISION DD7TPR
- EXTERNAL DD7TPR, DL7IVM, DL7TVM
-C DD7TPR RETURNS INNER PRODUCT OF TWO VECTORS.
-C DL7IVM MULTIPLIES L**-1 TIMES A VECTOR.
-C DL7TVM MULTIPLIES L**T TIMES A VECTOR.
-C
-C *** INTRINSIC FUNCTIONS ***
-C/+
- DOUBLE PRECISION DSQRT
-C/
-C-------------------------- LOCAL VARIABLES --------------------------
-C
- INTEGER I
- DOUBLE PRECISION CS, CY, EPS, EPSRT, ONE, SHS, YS, THETA
-C
-C *** DATA INITIALIZATIONS ***
-C
-C/6
-C DATA EPS/0.1D+0/, ONE/1.D+0/
-C/7
- PARAMETER (EPS=0.1D+0, ONE=1.D+0)
-C/
-C
-C+++++++++++++++++++++++++++++++ BODY ++++++++++++++++++++++++++++++++
-C
- CALL DL7TVM(N, W, L, S)
- SHS = DD7TPR(N, W, W)
- YS = DD7TPR(N, Y, S)
- IF (YS .GE. EPS*SHS) GO TO 10
- THETA = (ONE - EPS) * SHS / (SHS - YS)
- EPSRT = DSQRT(EPS)
- CY = THETA / (SHS * EPSRT)
- CS = (ONE + (THETA-ONE)/EPSRT) / SHS
- GO TO 20
- 10 CY = ONE / (DSQRT(YS) * DSQRT(SHS))
- CS = ONE / SHS
- 20 CALL DL7IVM(N, Z, L, Y)
- DO 30 I = 1, N
- 30 Z(I) = CY * Z(I) - CS * W(I)
-C
- 999 RETURN
-C *** LAST CARD OF DW7ZBF FOLLOWS ***
- END
diff --git a/CEP/PyBDSM/src/port3/dxtrap.f b/CEP/PyBDSM/src/port3/dxtrap.f
deleted file mode 100644
index 1c39b491c3c395b99dd44d26c01162d3a28e0e8b..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/dxtrap.f
+++ /dev/null
@@ -1,129 +0,0 @@
- SUBROUTINE DXTRAP(TM,M,NVAR,NG,KMAX,XPOLY,T,ERROR,EBEST)
-C
-C ASSUME AN EXPANSION FOR THE VECTOR VALUED FUNCTION T(H) OF THE FORM
-C
-C T(H) = T(0) + SUM(J=1,2,3,...)(A(J)*H**(J*GAMMA))
-C
-C WHERE THE A(J) ARE CONSTANT VECTORS AND GAMMA IS A POSITIVE CONSTANT.
-C
-C GIVEN T(H(M)), WHERE H(M)=H0/N(M), M=1,2,3,..., THIS ROUTINE USES
-C POLYNOMIAL (XPOLY), OR RATIONAL (.NOT.XPOLY), EXTRAPOLATION TO
-C SEQUENTIALLY APPROXIMATE T(0).
-C
-C INPUT
-C
-C TM - TM = T(H(M)) FOR THIS CALL.
-C M - H(M) WAS USED TO OBTAIN TM.
-C NVAR - THE LENGTH OF THE VECTOR TM.
-C NG - THE DOUBLE PRECISION VALUES
-C
-C NG(I) = N(I)**GAMMA
-C
-C FOR I=1,...,M. NG MUST BE A MONOTONE INCREASING ARRAY.
-C KMAX - THE MAXIMUM NUMBER OF COLUMNS TO BE USED IN THE
-C EXTRAPOLATION PROCESS.
-C XPOLY - IF XPOLY=.TRUE., THEN _USE_ POLYNOMIAL EXTRAPOLATION.
-C IF XPOLY=.FALSE., THEN _USE_ RATIONAL EXTRAPOLATION.
-C T - THE BOTTOM EDGE OF THE EXTRAPOLATION LOZENGE.
-C T(I,J) SHOULD CONTAIN THE J-TH EXTRAPOLATE OF THE I-TH
-C COMPONENT OF T(H) BASED ON THE SEQUENCE H(1),...,H(M-1),
-C FOR I=1,...,NVAR AND J=1,...,MIN(M-1,KMAX).
-C
-C WHEN M=1, T MAY CONTAIN ANYTHING.
-C
-C FOR M.GT.1, NOTE THAT THE OUTPUT VALUE OF T AT THE
-C (M-1)-ST CALL IS THE INPUT FOR THE M-TH CALL.
-C THUS, THE USER NEED NEVER PUT ANYTHING INTO T,
-C BUT HE CAN NOT ALTER ANY ELEMENT OF T BETWEEN
-C CALLS TO DXTRAP.
-C
-C OUTPUT
-C
-C TM - TM(I)=THE MOST ACCURATE APPROXIMATION IN THE LOZENGE
-C FOR THE I-TH VARIABLE, I=1,...,NVAR.
-C T - T(I,J) CONTAINS THE J-TH EXTRAPOLATE OF THE I-TH
-C COMPONENT OF T(H) BASED ON THE SEQUENCE H(1),...,H(M),
-C FOR I=1,...,NVAR AND J=1,...,MIN(M,KMAX).
-C ERROR - ERROR(I,J) GIVES THE SIGNED BULIRSCH-STOER ESTIMATE OF THE
-C ERROR IN THE J-TH EXTRAPOLATE OF THE I-TH COMPONENT OF
-C T(H) BASED ON THE SEQUENCE H(1),...,H(M-1),
-C FOR I=1,...,NVAR AND J=1,...,MIN(M-1,KMAX).
-C IF ERROR=EBEST AS ARRAYS, THEN THE ABOVE ELEMENTS
-C ARE NOT STORED. RATHER, EBEST=ERROR IS LOADED AS DESCRIBED
-C BELOW.
-C EBEST - EBEST(I)=THE ABSOLUTE VALUE OF THE ERROR IN TM(I),
-C I=1,...,NVAR. THIS ARRAY IS FULL OF GARBAGE WHEN M=1.
-C
-C SCRATCH SPACE ALLOCATED - MIN(M-1,KMAX) DOUBLE PRECISION WORDS +
-C
-C MIN(M-1,KMAX) INTEGER WORDS.
-C
-C ERROR STATES -
-C
-C 1 - M.LT.1.
-C 2 - NVAR.LT.1.
-C 3 - NG(1).LT.1.
-C 4 - KMAX.LT.1.
-C 5 - NG IS NOT MONOTONE INCREASING.
-C
- DOUBLE PRECISION TM(NVAR),NG(M),T(NVAR,1)
-C DOUBLE PRECISION T(NVAR,MIN(M,KMAX))
- REAL ERROR(NVAR,1),EBEST(NVAR)
-C REAL ERROR(NVAR,MIN(M-1,KMAX))
- LOGICAL XPOLY
-C
- LOGICAL ESAVE
-C
- COMMON /CSTAK/DS
- DOUBLE PRECISION DS(500)
- DOUBLE PRECISION WS(1)
- REAL RS(1000)
- EQUIVALENCE (DS(1),WS(1)),(DS(1),RS(1))
-C
-C ... CHECK THE INPUT.
-C
-C/6S
-C IF (M.LT.1) CALL SETERR(15HDXTRAP - M.LT.1,15,1,2)
-C IF (NVAR.LT.1) CALL SETERR(18HDXTRAP - NVAR.LT.1,18,2,2)
-C IF (NG(1).LT.1.0D0) CALL SETERR(19HDXTRAP - NG(1).LT.1,19,3,2)
-C IF (KMAX.LT.1) CALL SETERR(18HDXTRAP - KMAX.LT.1,18,4,2)
-C/7S
- IF (M.LT.1) CALL SETERR('DXTRAP - M.LT.1',15,1,2)
- IF (NVAR.LT.1) CALL SETERR('DXTRAP - NVAR.LT.1',18,2,2)
- IF (NG(1).LT.1.0D0) CALL SETERR('DXTRAP - NG(1).LT.1',19,3,2)
- IF (KMAX.LT.1) CALL SETERR('DXTRAP - KMAX.LT.1',18,4,2)
-C/
-C
- IF (M.EQ.1) GO TO 20
-C
- DO 10 I=2,M
-C/6S
-C IF (NG(I-1).GE.NG(I)) CALL SETERR
-C 1 (38HDXTRAP - NG IS NOT MONOTONE INCREASING,38,5,2)
-C/7S
- IF (NG(I-1).GE.NG(I)) CALL SETERR
- 1 ('DXTRAP - NG IS NOT MONOTONE INCREASING',38,5,2)
-C/
- 10 CONTINUE
-C
-C ... SEE IF ERROR=EBEST AS ARRAYS. IF (ESAVE), THEN LOAD ERROR.
-C
- 20 ERROR(1,1)=1.0E0
- EBEST(1)=2.0E0
- ESAVE=ERROR(1,1).NE.EBEST(1)
-C
-C ... ALLOCATE SCRATCH SPACE.
-C
- IRHG=1
- IEMAG=1
- IF (M.GT.1) IRHG=ISTKGT(MIN0(M-1,KMAX),4)
- IF (M.GT.1) IEMAG=ISTKGT(MIN0(M-1,KMAX),3)
-C
- CALL D0XTRP(TM,M,NVAR,NG,KMAX,XPOLY,T,ERROR,EBEST,WS(IRHG),
- 1 RS(IEMAG),ESAVE)
-C
- IF (M.GT.1) CALL ISTKRL(2)
-C
- RETURN
-C
- END
diff --git a/CEP/PyBDSM/src/port3/dzero.f b/CEP/PyBDSM/src/port3/dzero.f
deleted file mode 100644
index ff10a212d2ecd2a7064405ca486659c4705e050e..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/dzero.f
+++ /dev/null
@@ -1,144 +0,0 @@
- DOUBLE PRECISION FUNCTION DZERO(F,A,B,T)
-C
-C FINDS THE REAL ROOT OF THE FUNCTION F LYING BETWEEN A AND B
-C TO WITHIN A TOLERANCE OF
-C
-C 6*D1MACH(3) * DABS(DZERO) + 2 * T
-C
-C F(A) AND F(B) MUST HAVE OPPOSITE SIGNS
-C
-C THIS IS BRENTS ALGORITHM
-C
-C A, STORED IN SA, IS THE PREVIOUS BEST APPROXIMATION (I.E. THE OLD B)
-C B, STORED IN SB, IS THE CURRENT BEST APPROXIMATION
-C C IS THE MOST RECENTLY COMPUTED POINT SATISFYING F(B)*F(C) .LT. 0
-C D CONTAINS THE CORRECTION TO THE APPROXIMATION
-C E CONTAINS THE PREVIOUS VALUE OF D
-C M CONTAINS THE BISECTION QUANTITY (C-B)/2
-C
- DOUBLE PRECISION F,A,B,T,TT,SA,SB,C,D,E,FA,FB,FC,TOL,M,P,Q,R,S
- EXTERNAL F
- DOUBLE PRECISION D1MACH
-C
- TT = T
- IF (T .LE. 0.0D0) TT = 10.D0*D1MACH(1)
-C
- SA = A
- SB = B
- FA = F(SA)
- FB = F(SB)
- IF (FA .NE. 0.0D0) GO TO 5
- DZERO = SA
- RETURN
- 5 IF (FB .EQ. 0.0D0) GO TO 140
-C/6S
-C IF (DSIGN(FA,FB) .EQ. FA) CALL SETERR(
-C 1 47H DZERO - F(A) AND F(B) ARE NOT OF OPPOSITE SIGN, 47, 1, 1)
-C/7S
- IF (DSIGN(FA,FB) .EQ. FA) CALL SETERR(
- 1 ' DZERO - F(A) AND F(B) ARE NOT OF OPPOSITE SIGN', 47, 1, 1)
-C/
-C
- 10 C = SA
- FC = FA
- E = SB-SA
- D = E
-C
-C INTERCHANGE B AND C IF DABS F(C) .LT. DABS F(B)
-C
- 20 IF (DABS(FC).GE.DABS(FB)) GO TO 30
- SA = SB
- SB = C
- C = SA
- FA = FB
- FB = FC
- FC = FA
-C
- 30 TOL = 2.0D0*D1MACH(4)*DABS(SB)+TT
- M = 0.5D0*(C-SB)
-C
-C SUCCESS INDICATED BY M REDUCES TO UNDER TOLERANCE OR
-C BY F(B) = 0
-C
- IF ((DABS(M).LE.TOL).OR.(FB.EQ.0.0D0)) GO TO 140
-C
-C A BISECTION IS FORCED IF E, THE NEXT-TO-LAST CORRECTION
-C WAS LESS THAN THE TOLERANCE OR IF THE PREVIOUS B GAVE
-C A SMALLER F(B). OTHERWISE GO TO 40.
-C
- IF ((DABS(E).GE.TOL).AND.(DABS(FA).GE.DABS(FB))) GO TO 40
- E = M
- D = E
- GO TO 100
- 40 S = FB/FA
-C
-C QUADRATIC INTERPOLATION CAN ONLY BE DONE IF A (IN SA)
-C AND C ARE DIFFERENT POINTS.
-C OTHERWISE DO THE FOLLOWING LINEAR INTERPOLATION
-C
- IF (SA.NE.C) GO TO 50
- P = 2.0D0*M*S
- Q = 1.0D0-S
- GO TO 60
-C
-C INVERSE QUADRATIC INTERPOLATION
-C
- 50 Q = FA/FC
- R = FB/FC
- P = S*(2.0D0*M*Q*(Q-R)-(SB-SA)*(R-1.0D0))
- Q = (Q-1.0D0)*(R-1.0D0)*(S-1.0D0)
- 60 IF (P.LE.0.0D0) GO TO 70
- Q = -Q
- GO TO 80
- 70 P = -P
-C
-C UPDATE THE QUANTITIES USING THE NEWLY COMPUTED
-C INTERPOLATE UNLESS IT WOULD EITHER FORCE THE
-C NEW POINT TOO FAR TO ONE SIDE OF THE INTERVAL
-C OR WOULD REPRESENT A CORRECTION GREATER THAN
-C HALF THE PREVIOUS CORRECTION.
-C
-C IN THESE LAST TWO CASES - DO THE BISECTION
-C BELOW (FROM STATEMENT 90 TO 100)
-C
- 80 S = E
- E = D
- IF ((2.0D0*P.GE.3.0D0*M*Q-DABS(TOL*Q)).OR.
- 1 (P.GE.DABS(0.5D0*S*Q))) GO TO 90
- D = P/Q
- GO TO 100
- 90 E = M
- D = E
-C
-C SET A TO THE PREVIOUS B
-C
- 100 SA = SB
- FA = FB
-C
-C IF THE CORRECTION TO BE MADE IS SMALLER THAN
-C THE TOLERANCE, JUST TAKE A DELTA STEP (DELTA=TOLERANCE)
-C B = B + DELTA * SIGN(M)
-C
- IF (DABS(D).LE.TOL) GO TO 110
- SB = SB+D
- GO TO 130
-C
- 110 IF (M.LE.0.0D0) GO TO 120
- SB = SB+TOL
- GO TO 130
-C
- 120 SB = SB-TOL
- 130 FB = F(SB)
-C
-C IF F(B) AND F(C) HAVE THE SAME SIGN ONLY
-C LINEAR INTERPOLATION (NOT INVERSE QUADRATIC)
-C CAN BE DONE
-C
- IF ((FB.GT.0.0D0).AND.(FC.GT.0.0D0)) GO TO 10
- IF ((FB.LE.0.0D0).AND.(FC.LE.0.0D0)) GO TO 10
- GO TO 20
-C
-C***SUCCESS***
- 140 DZERO = SB
- RETURN
- END
diff --git a/CEP/PyBDSM/src/port3/e9rint.f b/CEP/PyBDSM/src/port3/e9rint.f
deleted file mode 100644
index dd0ae310acd5059d382e80f3b88af1edd7f4ec44..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/e9rint.f
+++ /dev/null
@@ -1,117 +0,0 @@
- SUBROUTINE E9RINT(MESSG,NW,NERR,SAVE)
-C
-C THIS ROUTINE STORES THE CURRENT ERROR MESSAGE OR PRINTS THE OLD ONE,
-C IF ANY, DEPENDING ON WHETHER OR NOT SAVE = .TRUE. .
-C
-C CHANGED, BY P.FOX, MAY 18, 1983, FROM THE ORIGINAL VERSION IN ORDER
-C TO GET RID OF THE FORTRAN CARRIAGE CONTROL LINE OVERWRITE
-C CHARACTER +, WHICH HAS ALWAYS CAUSED TROUBLE.
-C FOR THE RECORD, THE PREVIOUS VERSION HAD THE FOLLOWING ARRAY
-C AND CALLS - (WHERE CCPLUS WAS DECLARED OF TYPE INTEGER)
-C
-C DATA CCPLUS / 1H+ /
-C
-C DATA FMT( 1) / 1H( /
-C DATA FMT( 2) / 1HA /
-C DATA FMT( 3) / 1H1 /
-C DATA FMT( 4) / 1H, /
-C DATA FMT( 5) / 1H1 /
-C DATA FMT( 6) / 1H4 /
-C DATA FMT( 7) / 1HX /
-C DATA FMT( 8) / 1H, /
-C DATA FMT( 9) / 1H7 /
-C DATA FMT(10) / 1H2 /
-C DATA FMT(11) / 1HA /
-C DATA FMT(12) / 1HX /
-C DATA FMT(13) / 1HX /
-C DATA FMT(14) / 1H) /
-C
-C CALL S88FMT(2,I1MACH(6),FMT(12))
-C WRITE(IWUNIT,FMT) CCPLUS,(MESSGP(I),I=1,NWP)
-C
-C/6S
-C INTEGER MESSG(NW)
-C/7S
- CHARACTER*1 MESSG(NW)
-C/
- LOGICAL SAVE
-C
-C MESSGP STORES AT LEAST THE FIRST 72 CHARACTERS OF THE PREVIOUS
-C MESSAGE. ITS LENGTH IS MACHINE DEPENDENT AND MUST BE AT LEAST
-C
-C 1 + 71/(THE NUMBER OF CHARACTERS STORED PER INTEGER WORD).
-C
-C/6S
-C INTEGER MESSGP(36),FMT(10), FMT10(10)
-C EQUIVALENCE (FMT(1),FMT10(1))
-C/7S
- CHARACTER*1 MESSGP(72),FMT(10)
- CHARACTER*10 FMT10
- EQUIVALENCE (FMT(1),FMT10)
-C/
-C
-C START WITH NO PREVIOUS MESSAGE.
-C
-C/6S
-C DATA MESSGP(1)/1H1/, NWP/0/, NERRP/0/
-C/7S
- DATA MESSGP(1)/'1'/, NWP/0/, NERRP/0/
-C/
-C
-C SET UP THE FORMAT FOR PRINTING THE ERROR MESSAGE.
-C THE FORMAT IS SIMPLY (A1,14X,72AXX) WHERE XX=I1MACH(6) IS THE
-C NUMBER OF CHARACTERS STORED PER INTEGER WORD.
-C
-C/6S
-C DATA FMT( 1) / 1H( /
-C DATA FMT( 2) / 1H3 /
-C DATA FMT( 3) / 1HX /
-C DATA FMT( 4) / 1H, /
-C DATA FMT( 5) / 1H7 /
-C DATA FMT( 6) / 1H2 /
-C DATA FMT( 7) / 1HA /
-C DATA FMT( 8) / 1HX /
-C DATA FMT( 9) / 1HX /
-C DATA FMT(10) / 1H) /
-C/7S
- DATA FMT( 1) / '(' /
- DATA FMT( 2) / '3' /
- DATA FMT( 3) / 'X' /
- DATA FMT( 4) / ',' /
- DATA FMT( 5) / '7' /
- DATA FMT( 6) / '2' /
- DATA FMT( 7) / 'A' /
- DATA FMT( 8) / 'X' /
- DATA FMT( 9) / 'X' /
- DATA FMT(10) / ')' /
-C/
-C
- IF (.NOT.SAVE) GO TO 20
-C
-C SAVE THE MESSAGE.
-C
- NWP=NW
- NERRP=NERR
- DO 10 I=1,NW
- 10 MESSGP(I)=MESSG(I)
-C
- GO TO 30
-C
- 20 IF (I8SAVE(1,0,.FALSE.).EQ.0) GO TO 30
-C
-C PRINT THE MESSAGE.
-C
- IWUNIT=I1MACH(4)
- WRITE(IWUNIT,9000) NERRP
- 9000 FORMAT(7H ERROR ,I4,4H IN )
-C
-C/6S
-C CALL S88FMT(2,I1MACH(6),FMT( 8))
-C/7S
- CALL S88FMT(2, 1, FMT(8))
-C/
- WRITE(IWUNIT,FMT10) (MESSGP(I),I=1,NWP)
-C
- 30 RETURN
-C
- END
diff --git a/CEP/PyBDSM/src/port3/eigen.f b/CEP/PyBDSM/src/port3/eigen.f
deleted file mode 100644
index 0004ca4ca601888456c6080b2c9999169b997500..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/eigen.f
+++ /dev/null
@@ -1,111 +0,0 @@
- SUBROUTINE EIGEN(NM,N,A,WR,WI,Z)
- COMMON/CSTAK/DSTAK(500)
-C
- REAL A(NM,N),WR(N),WI(N),Z(NM,N)
- REAL RSTAK(1000)
-C
- EQUIVALENCE (DSTAK(1),RSTAK(1))
-C
-C EIGEN FINDS THE EIGENVALUES AND EIGENVECTORS
-C OF A REAL MATRIX (NOT IMAGINARY) BY
-C CALLING THE SEQUENCE OF SUBROUTINES
-C ORTHE,ORTRA, AND HQR2, WHICH, IN TURN, ARE
-C THE EISPACK ROUTINES ORTHES, ORTRAN, AND HQR2,
-C ADJUSTED FOR _USE_ IN THE PORT LIBRARY.
-C
-C ON INPUT -
-C
-C NM - AN INTEGER INPUT VARIABLE SET EQUAL TO
-C THE ROW DIMENSION OF THE TWO-DIMENSIONAL ARRAYS
-C A AND Z AS SPECIFIED IN THE DIMENSION STATEMENTS
-C FOR A AND Z IN THE CALLING PROGRAM.
-C
-C N - AN INTEGER INPUT VARIABLE SET EQUAL TO THE
-C ORDER OF THE MATRIX A.
-C
-C N MUST NOT BE GREATER THAN NM.
-C
-C A - THE MATRIX, A REAL TWO-DIMENSIONAL
-C ARRAY WITH ROW DIMENSION NM AND COLUMN
-C DIMENSION AT LEAST N.
-C
-C A IS OVERWRITTEN.
-C
-C
-C
-C ON OUTPUT -
-C
-C WR - A REAL ARRAY OF DIMENSION
-C AT LEAST N CONTAINING THE REAL PARTS OF THE EIGENVALUES
-C
-C WI - A REAL ARRAY OF DIMENSION
-C AT LEAST N CONTAINING THE IMAGINARY PARTS OF THE EIGENVALUES.
-C
-C THE EIGENVALUES ARE UNORDERED EXCEPT THAT
-C COMPLEX CONJUGATE PAIRS OF EIGENVALUES
-C APPEAR CONSECUTIVELY WITH THE EIGENVALUE HAVING
-C THE POSITIVE IMAGINARY PART FIRST.
-C
-C Z - A REAL TWO-DIMENSIONAL ARRAY
-C WITH ROW DIMENSION NM AND COLUMN DIMENSION
-C AT LEAST N CONTAINING THE REAL AND IMAGINARY PARTS
-C OF THE EIGENVECTORS.
-C
-C IF THE J-TH EIGENVALUE IS REAL, THE J-TH
-C COLUMN OF Z CONTAINS ITS EIGENVECTOR.
-C
-C IF THE J-TH EIGENVALUE IS COMPLEX WITH
-C POSITIVE REAL PART, THE J-TH AND (J+1)-TH
-C COLUMNS OF Z CONTAIN THE REAL AND IMAGINARY
-C PARTS OF ITS EIGENVECTOR.
-C
-C THE CONJUGATE OF THIS VECTOR IS THE
-C EIGENVECTOR FOR THE CONJUGATE EIGENVALUE.
-C THE EIGENVECTORS ARE NOT NORMALIZED.
-C
-C
-C ERROR STATES -
-C
-C 1 - N IS GREATER THAN NM
-C
-C K - THE K-TH EIGENVALUE COULD NOT BE COMPUTED
-C WITHIN 30 ITERATIONS.
-C
-C THE EIGENVALUES IN THE WR AND WRI ARRAYS
-C SHOULD BE CORRECT FOR INDICES
-C K+1, K+2,...,N, BUT NO EIGENVECTORS ARE COMPUTED.
-C
-C
-C
-C
-C CHECK FOR INPUT ERROR IN N
-C
-C/6S
-C IF (N .GT. NM) CALL SETERR(
-C 1 29H EIGEN - N IS GREATER THAN NM,29,1,2)
-C/7S
- IF (N .GT. NM) CALL SETERR(
- 1 ' EIGEN - N IS GREATER THAN NM',29,1,2)
-C/
-C
-C ALLOCATE A SCRATCH VECTOR
- IORT = ISTKGT(N,3)
-C
- CALL ORTHE (NM,N,1,N,A,RSTAK(IORT))
- CALL ORTRA (NM,N,1,N,A,RSTAK(IORT),Z)
- CALL HQR2 (NM,N,1,N,A,WR,WI,Z,IERR)
-C
- IF (IERR .NE. 0) GO TO 10
- CALL ISTKRL(1)
- RETURN
-C/6S
-C 10 CALL SETERR(
-C 1 34H EIGEN - FAILED ON THAT EIGENVALUE,34,IERR,1)
-C/7S
- 10 CALL SETERR(
- 1 ' EIGEN - FAILED ON THAT EIGENVALUE',34,IERR,1)
-C/
-C
- CALL ISTKRL(1)
- RETURN
- END
diff --git a/CEP/PyBDSM/src/port3/enter.f b/CEP/PyBDSM/src/port3/enter.f
deleted file mode 100644
index dc8a094a00f861bc2bbe2960fcff6715ee556890..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/enter.f
+++ /dev/null
@@ -1,52 +0,0 @@
- SUBROUTINE ENTER(IRNEW)
-C
-C THIS ROUTINE SAVES
-C
-C 1) THE CURRENT NUMBER OF OUTSTANDING STORAGE ALLOCATIONS, LOUT, AND
-C 2) THE CURRENT RECOVERY LEVEL, LRECOV,
-C
-C IN AN ENTER-BLOCK IN THE STACK.
-C
-C IT ALSO SETS LRECOV = IRNEW IF IRNEW = 1 OR 2.
-C IF IRNEW = 0, THEN THE RECOVERY LEVEL IS NOT ALTERED.
-C
-C SCRATCH SPACE ALLOCATED - 3 INTEGER WORDS ARE LEFT ON THE STACK.
-C
-C ERROR STATES -
-C
-C 1 - MUST HAVE IRNEW = 0, 1 OR 2.
-C
- COMMON /CSTAK/DSTACK
- DOUBLE PRECISION DSTACK(500)
- INTEGER ISTACK(1000)
- EQUIVALENCE (DSTACK(1),ISTACK(1))
- EQUIVALENCE (ISTACK(1),LOUT)
-C
-C/6S
-C IF (0.GT.IRNEW .OR. IRNEW.GT.2)
-C 1 CALL SETERR(35HENTER - MUST HAVE IRNEW = 0, 1 OR 2,35,1,2)
-C/7S
- IF (0.GT.IRNEW .OR. IRNEW.GT.2)
- 1 CALL SETERR('ENTER - MUST HAVE IRNEW = 0, 1 OR 2',35,1,2)
-C/
-C
-C ALLOCATE SPACE FOR SAVING THE ABOVE 2 ITEMS
-C AND A BACK-POINTER FOR CHAINING THE ENTER-BLOCKS TOGETHER.
-C
- INOW=ISTKGT(3,2)
-C
-C SAVE THE CURRENT NUMBER OF OUTSTANDING ALLOCATIONS.
-C
- ISTACK(INOW)=LOUT
-C
-C SAVE THE CURRENT RECOVERY LEVEL.
-C
- CALL ENTSRC(ISTACK(INOW+1),IRNEW)
-C
-C SAVE A BACK-POINTER TO THE START OF THE PREVIOUS ENTER-BLOCK.
-C
- ISTACK(INOW+2)=I8TSEL(INOW)
-C
- RETURN
-C
- END
diff --git a/CEP/PyBDSM/src/port3/entsrc.f b/CEP/PyBDSM/src/port3/entsrc.f
deleted file mode 100644
index 51cae7230d549cc159fc11fe356e8a2fb68be995..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/entsrc.f
+++ /dev/null
@@ -1,39 +0,0 @@
- SUBROUTINE ENTSRC(IROLD,IRNEW)
-C
-C THIS ROUTINE RETURNS IROLD = LRECOV AND SETS LRECOV = IRNEW.
-C
-C IF THERE IS AN ACTIVE ERROR STATE, THE MESSAGE IS PRINTED
-C AND EXECUTION STOPS.
-C
-C IRNEW = 0 LEAVES LRECOV UNCHANGED, WHILE
-C IRNEW = 1 GIVES RECOVERY AND
-C IRNEW = 2 TURNS RECOVERY OFF.
-C
-C ERROR STATES -
-C
-C 1 - ILLEGAL VALUE OF IRNEW.
-C 2 - CALLED WHILE IN AN ERROR STATE.
-C
-C/6S
-C IF (IRNEW.LT.0 .OR. IRNEW.GT.2)
-C 1 CALL SETERR(31HENTSRC - ILLEGAL VALUE OF IRNEW,31,1,2)
-C/7S
- IF (IRNEW.LT.0 .OR. IRNEW.GT.2)
- 1 CALL SETERR('ENTSRC - ILLEGAL VALUE OF IRNEW',31,1,2)
-C/
-C
- IROLD=I8SAVE(2,IRNEW,IRNEW.NE.0)
-C
-C IF HAVE AN ERROR STATE, STOP EXECUTION.
-C
-C/6S
-C IF (I8SAVE(1,0,.FALSE.) .NE. 0) CALL SETERR
-C 1 (39HENTSRC - CALLED WHILE IN AN ERROR STATE,39,2,2)
-C/7S
- IF (I8SAVE(1,0,.FALSE.) .NE. 0) CALL SETERR
- 1 ('ENTSRC - CALLED WHILE IN AN ERROR STATE',39,2,2)
-C/
-C
- RETURN
-C
- END
diff --git a/CEP/PyBDSM/src/port3/eprint.f b/CEP/PyBDSM/src/port3/eprint.f
deleted file mode 100644
index bde566af6c35c2b3ee733063293be4ba7fa93203..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/eprint.f
+++ /dev/null
@@ -1,14 +0,0 @@
- SUBROUTINE EPRINT
-C
-C THIS SUBROUTINE PRINTS THE LAST ERROR MESSAGE, IF ANY.
-C
-C/6S
-C INTEGER MESSG(1)
-C/7S
- CHARACTER*1 MESSG(1)
-C/
-C
- CALL E9RINT(MESSG,1,1,.FALSE.)
- RETURN
-C
- END
diff --git a/CEP/PyBDSM/src/port3/erroff.f b/CEP/PyBDSM/src/port3/erroff.f
deleted file mode 100644
index 06b20c0f94457bb7e67e799a59222411493dd3f9..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/erroff.f
+++ /dev/null
@@ -1,8 +0,0 @@
- SUBROUTINE ERROFF
-C
-C TURNS OFF THE ERROR STATE OFF BY SETTING LERROR=0.
-C
- I=I8SAVE(1,0,.TRUE.)
- RETURN
-C
- END
diff --git a/CEP/PyBDSM/src/port3/ex/README b/CEP/PyBDSM/src/port3/ex/README
deleted file mode 100644
index 0c9a27674bc85edd5686094adb801e1e04284d28..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ex/README
+++ /dev/null
@@ -1,5 +0,0 @@
-File links added so "send dpostx1 from port" works as described
-in Norm's memos.
-
-These files are compiled into /usr/local/lib/libportP/ex.a, so that
-the ldM and lib programs will work properly. What a hack!
diff --git a/CEP/PyBDSM/src/port3/ex/apnr.f b/CEP/PyBDSM/src/port3/ex/apnr.f
deleted file mode 100644
index ab9f0e78bad45904f730c0f31c78a9ff43821815..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ex/apnr.f
+++ /dev/null
@@ -1,42 +0,0 @@
-C$TEST APNR
-C TO RUN AS A MAIN PROGRAM REMOVE NEXT LINE
- SUBROUTINE APNR
-C***********************************************************************
-C
-C EXAMPLE OF USE OF THE PORT APRNTX ROUTINES
-C
-C***********************************************************************
- LOGICAL A(25)
- INTEGER B(25), IWRITE, I1MACH
- REAL C(25)
- DOUBLE PRECISION D(25)
- COMPLEX E(25)
-C
- IWRITE = I1MACH(2)
- WRITE(IWRITE, 10)
- 10 FORMAT(14H0LOGICAL ARRAY )
- CALL SETL(25, .FALSE., A)
- CALL APRNTL(A, 25, IWRITE, 80)
-C
- WRITE(IWRITE, 20)
- 20 FORMAT(14H0INTEGER ARRAY )
- CALL SETI(25, -1, B)
- CALL APRNTI(B, 25, IWRITE, 80, 4)
-C
- WRITE(IWRITE, 30)
- 30 FORMAT(11H0REAL ARRAY )
- CALL SETR(25, 1.0, C)
- CALL APRNTR(C, 25, IWRITE, 80, 12, 4)
-C
- WRITE(IWRITE, 40)
- 40 FORMAT(23H0DOUBLE PRECISION ARRAY )
- CALL SETD(25, 1.0D0, D)
- CALL APRNTD(D, 25, IWRITE, 80, 12, 4)
-C
- WRITE(IWRITE, 50)
- 50 FORMAT(14H0COMPLEX ARRAY )
- CALL SETC(25, CMPLX(1.0, -1.0), E)
- CALL APRNTC(E, 25, IWRITE, 80, 12, 4)
-C
- STOP
- END
diff --git a/CEP/PyBDSM/src/port3/ex/bura.f b/CEP/PyBDSM/src/port3/ex/bura.f
deleted file mode 100644
index 96ee6aa5475701ffee86c2e91cc8765cbfd9078a..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ex/bura.f
+++ /dev/null
@@ -1,48 +0,0 @@
-C$TEST BURA
-C TO RUN AS A MAIN PROGRAM REMOVE NEXT LINE
- SUBROUTINE BURA
-C***********************************************************************
-C
-C EXAMPLE OF USE OF THE PORT PROGRAM BURAM
-C
-C***********************************************************************
- INTEGER IWRITE,I,M,N,NPTS
- REAL XMESH(11), F(11), P(3), Q(3), DELTA, STEP, X, XL, XR,
- 1 ERROR(11), TCHBP
-C
- IWRITE = I1MACH(2)
-C
- NPTS = 11
- M = 2
- N = 2
- XL = -1.0E0
- XR = 1.0E0
- STEP = (XR-XL)/FLOAT(10)
-C
- DO 10 I=1,11
- XMESH(I) = XL + FLOAT(I-1)*STEP
- F(I) = EXP(XMESH(I))
- 10 CONTINUE
-C
-C
-C COMPUTE THE APPROXIMATION.
-C
- CALL BURAM(NPTS, XMESH, F, M, N, P, Q, DELTA)
-C
-C PRINT OUT THE ERRORS.
-C
- WRITE (IWRITE,99)
- 99 FORMAT (7H MESH, 4X, 3HEXP, 7X, 5HERROR)
- DO 20 I=1,NPTS
- X = XMESH(I)
-C
-C NOTE THAT TO EVALUATE THE APPROXIMATION WE MUST USE THE
-C FUNCTION TCHBP, WHICH EVALUATES A POLYNOMIAL GIVEN IN
-C TERMS OF ITS TCHEBYCHEFF EXPANSION.
-C
- ERROR(I) = F(I) - TCHBP(M,P,X,XL,XR)/TCHBP(N,Q,X,XL,XR)
- WRITE (IWRITE,98) XMESH(I), F(I), ERROR(I)
- 98 FORMAT (2F8.4,1PE12.2)
- 20 CONTINUE
- STOP
- END
diff --git a/CEP/PyBDSM/src/port3/ex/burb.f b/CEP/PyBDSM/src/port3/ex/burb.f
deleted file mode 100644
index 944c5972d943dff7e2b9b9fb9c60187d2c4a28d2..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ex/burb.f
+++ /dev/null
@@ -1,52 +0,0 @@
-C$TEST BURB
-C TO RUN AS A MAIN PROGRAM REMOVE NEXT LINE
- SUBROUTINE BURB
-C***********************************************************************
-C
-C EXAMPLE OF USE OF THE PORT PROGRAM BURM1
-C
-C***********************************************************************
- INTEGER IWRITE,I,ITOL,MAXITR
- REAL XMESH(11), F(11), P(3), Q(3), DELTA, STEP, X, XL, XR,
- 1 ERR1(11), ERR2(11), TCHBP
-C
- DATAP(1)/ 25.0/, P(2)/ 12.0/, P(3)/ 1.0/
- DATAQ(1)/ 25.0/, Q(2)/-12.0/, Q(3)/ 1.0/
-C
- IWRITE = I1MACH(2)
-C
- XL = -1.0E0
- XR = 1.0E0
- STEP = (XR-XL)/FLOAT(10)
- DO 10 I=1,11
- XMESH(I) = XL + FLOAT(I-1)*STEP
- F(I) = EXP(XMESH(I))
- 10 CONTINUE
-C
-C COMPUTE THE ERROR IN THE INITIAL APPROXIMATION.
-C USE THE FUNCTION TCHBP TO EVALUATE A POLYNOMIAL
-C GIVEN IN TERMS OF ITS TCHEBYCHEFF EXPANSION.
-C
- DO 20 I=1,11
- X = XMESH(I)
- 20 ERR1(I) = F(I) - TCHBP(2,P,X,XL,XR)/TCHBP(2,Q,X,XL,XR)
-C
-C COMPUTE THE APPROXIMATION. USE NO MORE THAN 10 ITERATIONS
-C AND STOP WHEN THE EXTREMALS AGREE TO 10 PER CENT.
-C
- MAXITR = 10
- ITOL = 1
- CALL BURM1(11, XMESH, F, MAXITR, ITOL, 2, 2, P, Q, DELTA)
-C
-C PRINT OUT THE ERRORS.
-C
- WRITE (IWRITE,99)
- 99 FORMAT (7H MESH, 4X, 3HEXP, 7X, 4HERR1, 8X, 4HERR2)
- DO 30 I=1,11
- X = XMESH(I)
- ERR2(I) = F(I) - TCHBP(2,P,X,XL,XR)/TCHBP(2,Q,X,XL,XR)
- WRITE (IWRITE,98) XMESH(I), F(I), ERR1(I), ERR2(I)
- 98 FORMAT (2F8.4,1P2E12.2)
- 30 CONTINUE
- STOP
- END
diff --git a/CEP/PyBDSM/src/port3/ex/cdex.f b/CEP/PyBDSM/src/port3/ex/cdex.f
deleted file mode 100644
index bd4219f4b15f2480f19e3f20135ddc8cb2cbea61..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ex/cdex.f
+++ /dev/null
@@ -1,21 +0,0 @@
-C$TEST CDEX
-C TO RUN AS A MAIN PROGRAM REMOVE NEXT LINE
- SUBROUTINE CDEX
-C***********************************************************************
-C
-C EXAMPLE OF USE OF THE PORT PROGRAM CDEXP
-C
-C***********************************************************************
- DOUBLE PRECISION A(2),EXPON(2)
- IWRITE = I1MACH(2)
-C
- A(1) = 3.D0
- A(2) = -1.D0
- CALL CDEXP(A,EXPON)
-C
- WRITE(IWRITE,9999) A, EXPON
- 9999 FORMAT (18H THE EXPONENTIAL (,1PD10.4,2H, ,1PD11.4,8H) IS //
- 1 4H (,2PD25.18,2H, ,2PD26.18,1H))
-C
- STOP
- END
diff --git a/CEP/PyBDSM/src/port3/ex/cdlg.f b/CEP/PyBDSM/src/port3/ex/cdlg.f
deleted file mode 100644
index 81843d3c043690607f6e7658305ee8ee71d1a49b..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ex/cdlg.f
+++ /dev/null
@@ -1,21 +0,0 @@
-C$TEST CDLG
-C TO RUN AS A MAIN PROGRAM REMOVE NEXT LINE
- SUBROUTINE CDLG
-C***********************************************************************
-C
-C EXAMPLE OF USE OF THE PORT PROGRAM CDLOG
-C
-C***********************************************************************
- DOUBLE PRECISION A(2),LOG(2)
- IWRITE = I1MACH(2)
-C
- A(1) = 2.D0
- A(2) = -1.D0
- CALL CDLOG(A,LOG)
-C
- WRITE(IWRITE,9999) A, LOG
- 9999 FORMAT (13H THE LOG OF (,1PD10.4,2H, ,1PD11.4,8H) IS //
- 1 4H (,1PD24.18,2H, ,1PD25.18,1H))
-C
- STOP
- END
diff --git a/CEP/PyBDSM/src/port3/ex/cpla.f b/CEP/PyBDSM/src/port3/ex/cpla.f
deleted file mode 100644
index 2d009bff41f36083bcc972ae1398acbf15da2eed..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ex/cpla.f
+++ /dev/null
@@ -1,31 +0,0 @@
-C$TEST CPLA
-C TO RUN AS A MAIN PROGRAM REMOVE NEXT LINE
- SUBROUTINE CPLA
-C***********************************************************************
-C
-C EXAMPLE OF USE OF THE PORT PROGRAM CPOLY
-C
-C***********************************************************************
- INTEGER IWRITE,I1MACH,K
- REAL CR(4), CI(4), ZR(3), ZI(3)
-C
- CR(1) = 2.0
- CI(1) = 0.0
-C
- CR(2) = -8.0
- CI(2) = 13.0
-C
- CR(3) = 3.0
- CI(3) = 74.0
-C
- CR(4) = 135.0
- CI(4) = 105.0
-C
- CALL CPOLY(3, CR, CI, ZR, ZI)
-C
- IWRITE = I1MACH(2)
- WRITE(IWRITE,99) (ZR(K),ZI(K),K = 1,3)
- 99 FORMAT(1H ,1P2E15.7)
-C
- STOP
- END
diff --git a/CEP/PyBDSM/src/port3/ex/cspa.f b/CEP/PyBDSM/src/port3/ex/cspa.f
deleted file mode 100644
index 73b0bd9cc3233560fb8ab7af584c983ce81d12de..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ex/cspa.f
+++ /dev/null
@@ -1,42 +0,0 @@
-C$TEST CSPA
-C TO RUN AS A MAIN PROGRAM REMOVE NEXT LINE
- SUBROUTINE CSPA
-C***********************************************************************
-C
-C EXAMPLE OF USE OF THE PORT PROGRAM CSPQU
-C
-C***********************************************************************
- INTEGER NPTS,J,IWRITE,I1MACH
- REAL PI,X(65),Y(65),ANS,ZZI
- PI=3.14159265
-C
- NPTS=9
-C
-C COMPUTE THE POINTS AT WHICH THE SPLINE IS TO BE FITTED
-C
- DO 10 J=1,NPTS
- X(J)=FLOAT(J-1)/FLOAT(NPTS-1)
- Y(J)=SIN(X(J)*PI/2.)
- 10 CONTINUE
-C
-C THE INTEGRATION:
-C
- CALL CSPQU(X,Y,NPTS,X(1),X(NPTS),ANS)
-C
-C ERROR IN INTEGRATION
-C
- ZZI=ANS-2./PI
-C
-C
-C SET THE OUTPUT UNIT
-C
- IWRITE=I1MACH(2)
-C
- WRITE (IWRITE,9998) ANS
- 9998 FORMAT(48H THE INTEGRAL OF SINE(X*PI/2) FROM X=0 TO X=1 IS,E16.8)
-C
- WRITE (IWRITE,9999) ZZI
- 9999 FORMAT(17H WITH AN ERROR OF,1PE10.2)
-C
- STOP
- END
diff --git a/CEP/PyBDSM/src/port3/ex/cspe.f b/CEP/PyBDSM/src/port3/ex/cspe.f
deleted file mode 100644
index 74fdf1e76676456f1a05a74c98eae836ea1df179..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ex/cspe.f
+++ /dev/null
@@ -1,63 +0,0 @@
-C$TEST CSPE
-C TO RUN AS A MAIN PROGRAM REMOVE NEXT LINE
- SUBROUTINE CSPE
-C***********************************************************************
-C
-C EXAMPLE OF USE OF THE PORT PROGRAM CSPDI
-C
-C***********************************************************************
- INTEGER IWRITE,I1MACH,J,K
- REAL PI,X(9),Y(9),YY(9),XX(4),YYP(4),ZZ(4),ZZD(4)
-C
- PI=3.14159265
-C
-C COMPUTE THE POINTS AT WHICH THE SPLINE IS TO BE FITTED
-C
- DO 10 J=1,9
- X(J)=FLOAT(J-1)/8.
- Y(J)=SIN(X(J)*PI/2.)
- 10 CONTINUE
-C
-C
-C SET THE POINTS AT WHICH THE INTERPOLATION AND
-C DIFFERENTIATION ARE TO BE DONE
-C
- XX(1)=.1
- XX(2)=.3
- XX(3)=.6
- XX(4)=.9
-C
-C THE INTERPOLATION:
-C
- CALL CSPIN(X,Y,9,XX,YY,4)
-C
-C COMPUTE THE INTERPOLATION ERROR
-C
- DO 20 K=1,4
- 20 ZZ(K)=YY(K)-SIN(XX(K)*PI/2.)
-C
-C THE DIFFERENTIATION:
-C
- CALL CSPDI(X,Y,9,XX,YY,YYP,4)
-C
-C COMPUTE THE DIFFERENTIATION ERROR
-C
- DO 30 K=1,4
- 30 ZZD(K)=(2./PI)*YYP(K)-COS(XX(K)*PI/2.)
-C
-C
-C SET THE OUTPUT UNIT
-C
- IWRITE=I1MACH(2)
-C
- WRITE (IWRITE,9997)
- 9997 FORMAT(2X,2HXX,10X,13HINTERPOLATION,9X,15HDIFFERENTIATION/)
-C
- WRITE (IWRITE,9998)
- 9998 FORMAT(12X,5HVALUE,6X,5HERROR,7X,5HVALUE,6X,6H ERROR//)
-C
- WRITE (IWRITE,9999)(XX(K),YY(K),ZZ(K),YYP(K),ZZD(K), K=1,4)
- 9999 FORMAT(0PF6.3,0PF12.6,1PE12.3,0PF12.6,1PE12.3/)
-C
- STOP
- END
diff --git a/CEP/PyBDSM/src/port3/ex/cspg.f b/CEP/PyBDSM/src/port3/ex/cspg.f
deleted file mode 100644
index 51d61f1007bf8741dda27245786662e50943b624..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ex/cspg.f
+++ /dev/null
@@ -1,41 +0,0 @@
-C$TEST CSPG
-C TO RUN AS A MAIN PROGRAM REMOVE NEXT LINE
- SUBROUTINE CSPG
-C***********************************************************************
-C
-C EXAMPLE OF USE OF THE PORT PROGRAM CSPIN
-C
-C***********************************************************************
-C
- INTEGER IWRITE,I1MACH,I
- REAL X(9),Y(9),YY(9),XX(9)
-C
-C COMPUTED THE POINTS AT WHICH THE SPLINE IS TO BE FITTED
-C
- DO 10 J=1,9
- X(J)=FLOAT(J-1)/8.
- Y(J)=X(J)**3
- 10 CONTINUE
-C
-C SET THE POINTS AT WHICH INTERPOLATION IS TO BE DONE
-C
- XX(1)=.3
- XX(2)=.6
- XX(3)=.9
-C
-C PERFORM THE INTERPOLATION
-C
- CALL CSPIN(X,Y,9,XX,YY,3)
-C
-C SET THE OUTPUT UNIT
-C
- IWRITE=I1MACH(2)
-C
- WRITE (IWRITE,9998)
- 9998 FORMAT(2X,2HXX,5X,11HINTERPOLATE//)
-C
- WRITE (IWRITE,9999) (XX(J), YY(J), J=1,3)
- 9999 FORMAT(F6.3,F12.6)
-C
- STOP
- END
diff --git a/CEP/PyBDSM/src/port3/ex/cspq.f b/CEP/PyBDSM/src/port3/ex/cspq.f
deleted file mode 100644
index efc8d0092e2b0ea798e13481834550c96cbdf055..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ex/cspq.f
+++ /dev/null
@@ -1,63 +0,0 @@
-C$TEST CSPQ
-C TO RUN AS A MAIN PROGRAM REMOVE NEXT LINE
- SUBROUTINE CSPQ
-C***********************************************************************
-C
-C EXAMPLE OF USE OF THE PORT PROGRAM CSPFE
-C
-C***********************************************************************
- INTEGER I1MACH,J,IWRITE
- REAL X(9),Y(9),YP(9),YPP(9),BC(6),XX(4),YY(4),ERR(4),PI
-C
- PI=4.0*ATAN(1.0)
-C
-C COMPUTE THE POINTS AT WHICH THE SPLINE IS TO BE FITTED
-C
- DO 10 J=1,9
- X(J)=FLOAT(J-1)/8.0
- 10 Y(J)=SIN(X(J)*PI/2.0)
-C
-C SET THE END CONDITIONS FOR THE INTERPOLATION
-C (SPECIFY FIRST DERIVATIVE AT X=0, SECOND AT X=1)
-C
- BC(1)=1.0
- BC(2)=0.0
- BC(3)=PI/2.0
- BC(4)=0.0
- BC(5)=1.0
- BC(6)=-X(9)*(PI/2.0)**2
-C
-C DO THE CUBIC SPLINE FIT
-C
- CALL CSPFI(X,Y,9,BC,YP,YPP)
-C
-C SET THE POINTS AT WHICH TO INTERPOLATE
-C
- XX(1)=0.1
- XX(2)=0.3
- XX(3)=0.6
- XX(4)=0.9
-C
-C DO THE INTERPOLATION
-C
- CALL CSPFE(X,Y,YP,YPP,9,XX,YY,4)
-C
-C COMPUTE THE INTERPOLATION ERROR
-C
- DO 20 K=1,4
- 20 ERR(K)=YY(K)-SIN(XX(K)*PI/2.0)
-C
-C SET THE OUTPUT UNIT
-C
- IWRITE=I1MACH(2)
-C
- WRITE(IWRITE,9997)
- 9997 FORMAT(2X,2HXX,10X,13HINTERPOLATION)
- WRITE(IWRITE,9998)
- 9998 FORMAT(12X,5HVALUE,6X,5HERROR//)
-C
- WRITE(IWRITE,9999) (XX(K),YY(K),ERR(K),K=1,4)
- 9999 FORMAT(0PF6.3,0PF12.6,1PE12.3/)
-C
- STOP
- END
diff --git a/CEP/PyBDSM/src/port3/ex/ddea.f b/CEP/PyBDSM/src/port3/ex/ddea.f
deleted file mode 100644
index 6a4d266e7146d1fd656e3960949b89886ec902b8..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ex/ddea.f
+++ /dev/null
@@ -1,82 +0,0 @@
-C$TEST DDEA
-C TO RUN AS A MAIN PROGRAM REMOVE NEXT LINE
- SUBROUTINE DDEA
-C***********************************************************************
-C
-C EXAMPLE OF USE OF THE PORT PROGRAM IODE
-C
-C***********************************************************************
- REAL TSTOP,V(2),DT
- REAL ERRPAR(2)
- INTEGER NV
- EXTERNAL DEE,HANDLE
-C
- NV = 2
-C
-C SET FOR 1E-2 ABSOLUTE ERROR.
-C
- ERRPAR(1) = 0
- ERRPAR(2) = 1E-2
-C
- TSTOP = 1E+20
- DT = 1E-7
-C
-C INITIAL CONDITIONS FOR V.
-C
- V(1) = 1
- V(2) = 1
-C
- CALL IODE (V,NV,
- * 0E0,TSTOP,DT,
- * DEE,
- * ERRPAR,
- * HANDLE)
-C
- STOP
-C
- END
- SUBROUTINE DEE(T,
- * V,VT,NV,
- * D,DV,DVT)
-C
- REAL T,V(NV),VT(NV),D(NV),DV(NV,NV),DVT(NV,NV)
- INTEGER NV
-C
- D(1) = VT(1)+2E0*VT(2) + V(1) + 2E+6*V(2)
- D(2) = 3E0*VT(1)+VT(2) + 3E0*V(1) + 1E+6*V(2)
-C
- DVT(1,1) = 1
- DVT(1,2) = 2
- DV(1,1) = 1
- DV(1,2) = 2E+6
-C
- DVT(2,1) = 3
- DVT(2,2) = 1
- DV(2,1) = 3
- DV(2,2) = 1E+6
-C
- RETURN
-C
- END
- SUBROUTINE HANDLE(T0,V0,T,V,NV,DT,TSTOP)
-C
-C OUTPUT AND CHECKING ROUTINE.
-C
- REAL T0,V0(NV),T,V(NV),DT,TSTOP
- INTEGER NV
-C
- REAL EV(2)
- INTEGER I1MACH
-C
- IF ( T0 .EQ. T ) RETURN
-C
- EV(1) = V(1) - EXP(-T)
- EV(2) = V(2) - EXP(-1E+6*T)
-C
- IWUNIT = I1MACH(2)
- WRITE(IWUNIT,9000) T,EV(1),EV(2)
- 9000 FORMAT(13H ERROR IN V( ,1P1E10.2,4H ) =,1P2E10.2)
-C
- RETURN
-C
- END
diff --git a/CEP/PyBDSM/src/port3/ex/desa.f b/CEP/PyBDSM/src/port3/ex/desa.f
deleted file mode 100644
index 8358379ca2ad5e9a4ccefc14ec590eba69239e1f..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ex/desa.f
+++ /dev/null
@@ -1,105 +0,0 @@
-C$TEST DESA
-C TO RUN AS A MAIN PROGRAM REMOVE NEXT LINE
- SUBROUTINE DESA
-C***********************************************************************
-C
-C EXAMPLE OF USE OF THE PORT PROGRAM ODES
-C
-C***********************************************************************
- EXTERNAL EQNS, PRINT
- COMMON /NMBR/NMFNS
- COMMON /DATA/ERRPAR,DT,X,TSTART
-C
- INTEGER KASE,NMFNS
- REAL X(2),DX,DT,TSTART
- REAL ERRPAR(2)
-C
- DO 1 KASE=1,3
- X(1) = 1.E0
- X(2) = -1.E0
- CALL CASE(KASE)
-C
- CALL ODES (EQNS, X, 2, TSTART, 2.0E0, DT, ERRPAR, PRINT)
-C
- 1 CONTINUE
-C
- STOP
- END
- SUBROUTINE EQNS (T, X, N, DX)
- COMMON /NMBR/NMFNS
-C
- INTEGER NMFNS,N
- REAL T,X(2),DX(2)
-C
- DX(1) = X(2)
- DX(2) = X(1)
- NMFNS = NMFNS + 1
-C
- RETURN
- END
- SUBROUTINE CASE(KASE)
- COMMON /NMBR/NMFNS
- COMMON /DATA/ERRPAR,DT,X,TSTART
-C
- INTEGER IWRITE,I1MACH,NMFNS,KASE
- REAL X(2),DT,TSTART
- REAL ERRPAR(2)
-C
- IWRITE = I1MACH(2)
- NMFNS = 0
- TSTART = 0.0E0
- GO TO (10, 20, 30), KASE
-C
-C SET UP CASE 1
- 10 ERRPAR(1) = 1.E-2
- ERRPAR(2) = 1.E-3
- DT = 1.E0
- GO TO 40
-C
-C SET UP CASE 2
- 20 ERRPAR(1) = 1.E-4
- ERRPAR(2) = 1.E-6
- DT = 1.E-7
- GO TO 40
-C
-C SET UP CASE 3
- 30 ERRPAR(1) = 1.E-4
- ERRPAR(2) = 1.E-6
- DT = 1.E0
-C
-C WRITE OUT ERRPAR AND DT
- 40 WRITE (IWRITE, 9997) ERRPAR(1), ERRPAR(2), DT
- 9997 FORMAT(15X,28H FOR THE VALUES, ERRPAR(1) =, 1PE9.2,
- * 16H AND ERRPAR(2) =,1PE9.2 //16X,22HWITH INITIAL DT SET TO,
- * 1PE10.2//)
-C
-C WRITE OUT COLUMN HEADINGS FOR THE SOLUTION
- WRITE (IWRITE,9998)
- 9998 FORMAT(12X, 5H TIME,14X, 5H X(1),15X, 5H X(2),14X, 3H DT//)
-C
-C WRITE OUT THE INITIAL VALUES OF T AND X
- WRITE (IWRITE,9999) TSTART, X(1), X(2), DT
- 9999 FORMAT(2X,1P3E20.8,1PE14.2)
-C
- RETURN
- END
- SUBROUTINE PRINT (T0, X0, T1, X1, N, DT, TSTOP, E)
- COMMON /NMBR/NMFNS
-C
- INTEGER IWRITE,I1MACH,N,NMFNS
- REAL T0,X0(N),T1,X1(N),DT,TSTOP,E(N)
-C
- IF(T0 .EQ. T1) RETURN
-C
- IWRITE = I1MACH(2)
- WRITE (IWRITE,9998) T1,X1(1),X1(2),DT
- 9998 FORMAT (2X,1P3E20.8,1PE14.2)
-C
- IF (T1 .LT. TSTOP) RETURN
-C
- WRITE (IWRITE,9999) NMFNS
- 9999 FORMAT (1H0,15X, 39H THE NUMBER OF FUNCTION EVALUATIONS WAS,I4)
-C
- RETURN
-C
- END
diff --git a/CEP/PyBDSM/src/port3/ex/dpostx1.f b/CEP/PyBDSM/src/port3/ex/dpostx1.f
deleted file mode 100644
index c647e1b14bc5773453bb69368ef673f512af1b49..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ex/dpostx1.f
+++ /dev/null
@@ -1,113 +0,0 @@
-C$TEST DPT1
-C TO RUN AS A MAIN PROGRAM REMOVE NEXT LINE
- SUBROUTINE DPT1
-C***********************************************************************
-C
-C EXAMPLE OF USE OF PORT PROGRAM DPOST
-C
-C***********************************************************************
- COMMON /CSTAK/ DS
- DOUBLE PRECISION DS(1000)
- EXTERNAL HANDLE, DPOSTD, BC, AF
- INTEGER NDX, K, IS(1000), NU, NV, NMESH
- REAL ERRPAR(2), RS(1000)
- LOGICAL LS(1000)
- COMPLEX CS(500)
- DOUBLE PRECISION U(100), V(1), MESH(100), DT, WS(500), TSTOP
- EQUIVALENCE (DS(1), CS(1), WS(1), RS(1), IS(1), LS(1))
-C TO TEST DPOST ON
-C U SUB T = U SUB XX + F ON (0,1)
-C WHERE F IS CHOSEN SO THAT THE SOLUTION IS
-C U(X,T) = EXP(XT).
-C THE PORT LIBRARY STACK AND ITS ALIASES.
-C INITIALIZE THE PORT LIBRARY STACK LENGTH.
- CALL ISTKIN(1000, 4)
- NU = 1
- NV = 0
- ERRPAR(1) = 0
-C ABSOLUTE ERROR.
- ERRPAR(2) = 1E-2
- TSTOP = 1
- DT = 1D-2
- K = 4
-C NDX UNIFORM MESH POINTS ON (0,1).
- NDX = 4
- CALL DUMB(0D0, 1D0, NDX, K, MESH, NMESH)
-C INITIAL CONDITIONS FOR U.
- CALL SETD(NMESH-K, 1D0, U)
- CALL DPOST(U, NU, K, MESH, NMESH, V, NV, 0D0, TSTOP, DT, AF, BC,
- 1 DPOSTD, ERRPAR, HANDLE)
-C CHECK FOR ERRORS AND STACK USAGE STATISTICS.
- CALL WRAPUP
- STOP
- END
- SUBROUTINE AF(T, X, NX, U, UX, UT, UTX, NU, V, VT, NV, A,
- 1 AU, AUX, AUT, AUTX, AV, AVT, F, FU, FUX, FUT, FUTX, FV, FVT)
- INTEGER NU, NX
- INTEGER NV
- DOUBLE PRECISION T, X(NX), U(NX, NU), UX(NX, NU), UT(NX, NU), UTX(
- 1 NX, NU)
- DOUBLE PRECISION V(1), VT(1), A(NX, NU), AU(NX, NU, NU), AUX(NX,
- 1 NU, NU), AUT(NX, NU, NU)
- DOUBLE PRECISION AUTX(NX, NU, NU), AV(1), AVT(1), F(NX, NU), FU(
- 1 NX, NU, NU), FUX(NX, NU, NU)
- DOUBLE PRECISION FUT(NX, NU, NU), FUTX(NX, NU, NU), FV(1), FVT(1)
- INTEGER I
- DOUBLE PRECISION DEXP
- DO 1 I = 1, NX
- A(I, 1) = -UX(I, 1)
- AUX(I, 1, 1) = -1
- F(I, 1) = (X(I)-T**2)*DEXP(X(I)*T)-UT(I, 1)
- FUT(I, 1, 1) = -1
- 1 CONTINUE
- RETURN
- END
- SUBROUTINE BC(T, L, R, U, UX, UT, UTX, NU, V, VT, NV, B, BU,
- 1 BUX, BUT, BUTX, BV, BVT)
- INTEGER NU
- INTEGER NV
- DOUBLE PRECISION T, L, R, U(NU, 2), UX(NU, 2), UT(NU, 2)
- DOUBLE PRECISION UTX(NU, 2), V(1), VT(1), B(NU, 2), BU(NU, NU, 2),
- 1 BUX(NU, NU, 2)
- DOUBLE PRECISION BUT(NU, NU, 2), BUTX(NU, NU, 2), BV(1), BVT(1)
- DOUBLE PRECISION DEXP
- B(1, 1) = U(1, 1)-1D0
- B(1, 2) = U(1, 2)-DEXP(T)
- BU(1, 1, 1) = 1
- BU(1, 1, 2) = 1
- RETURN
- END
- SUBROUTINE HANDLE(T0, U0, V0, T, U, V, NU, NXMK, NV, K, X,
- 1 NX, DT, TSTOP)
- INTEGER NXMK, NU, NX
- INTEGER NV, K
- DOUBLE PRECISION T0, U0(NXMK, NU), V0(1), T, U(NXMK, NU), V(1)
- DOUBLE PRECISION X(NX), DT, TSTOP
- COMMON /TIME/ TT
- DOUBLE PRECISION TT
- EXTERNAL UOFX
- INTEGER I1MACH
- DOUBLE PRECISION DEESFF, EU
- INTEGER TEMP
-C OUTPUT AND CHECKING ROUTINE.
- IF (T0 .EQ. T) RETURN
-C UOFX NEEDS TIME.
- TT = T
- EU = DEESFF(K, X, NX, U, UOFX)
- TEMP = I1MACH(2)
- WRITE (TEMP, 1) T, EU
- 1 FORMAT (14H ERROR IN U(X,, 1PE10.2, 4H ) =, 1PE10.2)
- RETURN
- END
- SUBROUTINE UOFX(X, NX, U, W)
- INTEGER NX
- DOUBLE PRECISION X(NX), U(NX), W(NX)
- COMMON /TIME/ T
- DOUBLE PRECISION T
- INTEGER I
- DOUBLE PRECISION DEXP
- DO 1 I = 1, NX
- U(I) = DEXP(X(I)*T)
- 1 CONTINUE
- RETURN
- END
diff --git a/CEP/PyBDSM/src/port3/ex/dpostx10.f b/CEP/PyBDSM/src/port3/ex/dpostx10.f
deleted file mode 100644
index 6082f6955127e1238028dc74e1f8dfe6a048c994..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ex/dpostx10.f
+++ /dev/null
@@ -1,157 +0,0 @@
-C$TEST DPTT
-C TO RUN AS A MAIN PROGRAM REMOVE NEXT LINE
- SUBROUTINE DPTT
-C***********************************************************************
-C
-C EXAMPLE OF USE OF PORT PROGRAM DPOST
-C
-C***********************************************************************
- COMMON /CSTAK/ DS
- DOUBLE PRECISION DS(2000)
- EXTERNAL HANDLE, DPOSTD, BC, AF
- INTEGER NDX, NXH, I, K, IS(1000), NU
- INTEGER NV, NX, I1MACH
- REAL ERRPAR(2), RS(1000)
- LOGICAL LS(1000)
- COMPLEX CS(500)
- DOUBLE PRECISION DEEBSF, ERR, DABS, U(100), V(1), X(100)
- DOUBLE PRECISION DMAX1, DT, UE(100), UH(100), XH(100), WS(500)
- DOUBLE PRECISION TSTOP
- INTEGER TEMP
- EQUIVALENCE (DS(1), CS(1), WS(1), RS(1), IS(1), LS(1))
-C TO ESTIMATE X AND T ERROR AS SUM.
-C U SUB T = U SUB XX + F ON (0,1)
-C WHERE F IS CHOSEN SO THAT THE SOLUTION IS
-C U(X,T) = EXP(XT).
-C THE PORT LIBRARY STACK AND ITS ALIASES.
-C INITIALIZE THE PORT LIBRARY STACK LENGTH.
- CALL ISTKIN(2000, 4)
- NU = 1
- NV = 0
- ERRPAR(1) = 0
- ERRPAR(2) = 1E-2
- K = 4
- NDX = 4
- TSTOP = 1
- DT = 1D-2
-C CRUDE MESH.
- CALL DUMB(0D0, 1D0, NDX, K, X, NX)
-C INITIAL CONDITIONS FOR U.
- CALL SETD(NX-K, 1D0, U)
- TEMP = I1MACH(2)
- WRITE (TEMP, 1)
- 1 FORMAT (36H SOLVING ON CRUDE MESH USING ERRPAR.)
- CALL DPOST(U, NU, K, X, NX, V, NV, 0D0, TSTOP, DT, AF, BC, DPOSTD,
- 1 ERRPAR, HANDLE)
-C GET RUN-TIME STATISTICS.
- CALL DPOSTX
-C HALVE THE MESH SPACING.
- CALL DUMB(0D0, 1D0, 2*NDX-1, K, XH, NXH)
-C INITIAL CONDITIONS FOR UH.
- CALL SETD(NXH-K, 1D0, UH)
- DT = 1D-2
- TEMP = I1MACH(2)
- WRITE (TEMP, 2)
- 2 FORMAT (38H SOLVING ON REFINED MESH USING ERRPAR.)
- CALL DPOST(UH, NU, K, XH, NXH, V, NV, 0D0, TSTOP, DT, AF, BC,
- 1 DPOSTD, ERRPAR, HANDLE)
-C GET RUN-TIME STATISTICS.
- CALL DPOSTX
-C ESTIMATE U ERROR.
- ERR = DEEBSF(K, X, NX, U, XH, NXH, UH)
- WRITE (6, 3) ERR
- 3 FORMAT (24H U ERROR FROM U AND UH =, 1PE10.2)
-C INITIAL CONDITIONS FOR UE.
- CALL SETD(NX-K, 1D0, UE)
- DT = 1D-2
- ERRPAR(1) = ERRPAR(1)/10.
- ERRPAR(2) = ERRPAR(2)/10.
- TEMP = I1MACH(2)
- WRITE (TEMP, 4)
- 4 FORMAT (39H SOLVING ON CRUDE MESH USING ERRPAR/10.)
- CALL DPOST(UE, NU, K, X, NX, V, NV, 0D0, TSTOP, DT, AF, BC,
- 1 DPOSTD, ERRPAR, HANDLE)
-C GET RUN-TIME STATISTICS.
- CALL DPOSTX
- ERR = 0
- TEMP = NX-K
- DO 5 I = 1, TEMP
- ERR = DMAX1(ERR, DABS(U(I)-UE(I)))
- 5 CONTINUE
- WRITE (6, 6) ERR
- 6 FORMAT (24H U ERROR FROM U AND UE =, 1PE10.2)
- STOP
- END
- SUBROUTINE AF(T, X, NX, U, UX, UT, UTX, NU, V, VT, NV, A,
- 1 AU, AUX, AUT, AUTX, AV, AVT, F, FU, FUX, FUT, FUTX, FV, FVT)
- INTEGER NU, NX
- INTEGER NV
- DOUBLE PRECISION T, X(NX), U(NX, NU), UX(NX, NU), UT(NX, NU), UTX(
- 1 NX, NU)
- DOUBLE PRECISION V(1), VT(1), A(NX, NU), AU(NX, NU, NU), AUX(NX,
- 1 NU, NU), AUT(NX, NU, NU)
- DOUBLE PRECISION AUTX(NX, NU, NU), AV(1), AVT(1), F(NX, NU), FU(
- 1 NX, NU, NU), FUX(NX, NU, NU)
- DOUBLE PRECISION FUT(NX, NU, NU), FUTX(NX, NU, NU), FV(1), FVT(1)
- INTEGER I
- DOUBLE PRECISION DEXP
- DO 1 I = 1, NX
- A(I, 1) = -UX(I, 1)
- AUX(I, 1, 1) = -1
- F(I, 1) = (X(I)-T**2)*DEXP(X(I)*T)-UT(I, 1)
- FUT(I, 1, 1) = -1
- 1 CONTINUE
- RETURN
- END
- SUBROUTINE BC(T, L, R, U, UX, UT, UTX, NU, V, VT, NV, B, BU,
- 1 BUX, BUT, BUTX, BV, BVT)
- INTEGER NU
- INTEGER NV
- DOUBLE PRECISION T, L, R, U(NU, 2), UX(NU, 2), UT(NU, 2)
- DOUBLE PRECISION UTX(NU, 2), V(1), VT(1), B(NU, 2), BU(NU, NU, 2),
- 1 BUX(NU, NU, 2)
- DOUBLE PRECISION BUT(NU, NU, 2), BUTX(NU, NU, 2), BV(1), BVT(1)
- DOUBLE PRECISION DEXP
- B(1, 1) = U(1, 1)-1D0
- B(1, 2) = U(1, 2)-DEXP(T)
- BU(1, 1, 1) = 1
- BU(1, 1, 2) = 1
- RETURN
- END
- SUBROUTINE HANDLE(T0, U0, V0, T, U, V, NU, NXMK, NV, K, X,
- 1 NX, DT, TSTOP)
- INTEGER NXMK, NU, NX
- INTEGER NV, K
- DOUBLE PRECISION T0, U0(NXMK, NU), V0(1), T, U(NXMK, NU), V(1)
- DOUBLE PRECISION X(NX), DT, TSTOP
- COMMON /TIME/ TT
- DOUBLE PRECISION TT
- EXTERNAL UOFX
- INTEGER I1MACH
- DOUBLE PRECISION DEESFF, EU
- INTEGER TEMP
-C OUTPUT AND CHECKING ROUTINE.
- IF (T0 .NE. T) GOTO 2
- TEMP = I1MACH(2)
- WRITE (TEMP, 1) T
- 1 FORMAT (16H RESTART FOR T =, 1PE10.2)
- RETURN
- 2 TT = T
- EU = DEESFF(K, X, NX, U, UOFX)
- TEMP = I1MACH(2)
- WRITE (TEMP, 3) T, EU
- 3 FORMAT (14H ERROR IN U(X,, 1PE10.2, 4H ) =, 1PE10.2)
- RETURN
- END
- SUBROUTINE UOFX(X, NX, U, W)
- INTEGER NX
- DOUBLE PRECISION X(NX), U(NX), W(NX)
- COMMON /TIME/ T
- DOUBLE PRECISION T
- INTEGER I
- DOUBLE PRECISION DEXP
- DO 1 I = 1, NX
- U(I) = DEXP(X(I)*T)
- 1 CONTINUE
- RETURN
- END
diff --git a/CEP/PyBDSM/src/port3/ex/dpostx2.f b/CEP/PyBDSM/src/port3/ex/dpostx2.f
deleted file mode 100644
index 7a3f642e408e5b61e05016233f1ad0ee2970635f..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ex/dpostx2.f
+++ /dev/null
@@ -1,138 +0,0 @@
-C$TEST DPT2
-C TO RUN AS A MAIN PROGRAM REMOVE NEXT LINE
- SUBROUTINE DPT2
-C***********************************************************************
-C
-C EXAMPLE OF USE OF PORT PROGRAM DPOST
-C
-C***********************************************************************
- COMMON /CSTAK/ DS
- DOUBLE PRECISION DS(1100)
- EXTERNAL HANDLE, DPOSTD, BC, AF
- INTEGER NDX, K, IS(1000), NU, NV, NMESH
- REAL ERRPAR(2), RS(1000)
- LOGICAL LS(1000)
- COMPLEX CS(500)
- DOUBLE PRECISION U(200), V(1), MESH(100), DT, WS(500), TSTOP
- INTEGER TEMP
- EQUIVALENCE (DS(1), CS(1), WS(1), RS(1), IS(1), LS(1))
-C TO TEST DPOST ON
-C U SUB T = U SUB XX + F ON (0,1)
-C BY SETTING U1 = U AND U2 = U1 SUB X AND SOLVING
-C U1 SUB T = U1 SUB XX + F
-C ON (0,1)
-C U1 SUB X = U2
-C WHERE F IS CHOSEN SO THAT THE SOLUTION IS
-C U(X,T) = EXP(XT).
-C THE PORT LIBRARY STACK AND ITS ALIASES.
-C INITIALIZE THE PORT LIBRARY STACK LENGTH.
- CALL ISTKIN(1100, 4)
- NU = 2
- NV = 0
- ERRPAR(1) = 0
-C ABSOLUTE ERROR.
- ERRPAR(2) = 1E-2
- TSTOP = 1
- DT = 1D-2
- K = 4
-C NDX UNIFORM MESH POINTS ON (0,1).
- NDX = 4
- CALL DUMB(0D0, 1D0, NDX, K, MESH, NMESH)
-C INITIAL CONDITIONS FOR U1.
- CALL SETD(NMESH-K, 1D0, U)
-C INITIAL CONDITIONS FOR U2.
- TEMP = NMESH-K
- CALL SETD(NMESH-K, 0D0, U(TEMP+1))
- CALL DPOST(U, NU, K, MESH, NMESH, V, NV, 0D0, TSTOP, DT, AF, BC,
- 1 DPOSTD, ERRPAR, HANDLE)
-C CHECK FOR ERRORS AND STACK USAGE STATISTICS.
- CALL WRAPUP
- STOP
- END
- SUBROUTINE AF(T, X, NX, U, UX, UT, UTX, NU, V, VT, NV, A,
- 1 AU, AUX, AUT, AUTX, AV, AVT, F, FU, FUX, FUT, FUTX, FV, FVT)
- INTEGER NU, NX
- INTEGER NV
- DOUBLE PRECISION T, X(NX), U(NX, NU), UX(NX, NU), UT(NX, NU), UTX(
- 1 NX, NU)
- DOUBLE PRECISION V(1), VT(1), A(NX, NU), AU(NX, NU, NU), AUX(NX,
- 1 NU, NU), AUT(NX, NU, NU)
- DOUBLE PRECISION AUTX(NX, NU, NU), AV(1), AVT(1), F(NX, NU), FU(
- 1 NX, NU, NU), FUX(NX, NU, NU)
- DOUBLE PRECISION FUT(NX, NU, NU), FUTX(NX, NU, NU), FV(1), FVT(1)
- INTEGER I
- DOUBLE PRECISION DEXP
- DO 1 I = 1, NX
- A(I, 1) = -U(I, 2)
- AU(I, 1, 2) = -1
- F(I, 1) = (X(I)-T**2)*DEXP(X(I)*T)-UT(I, 1)
- FUT(I, 1, 1) = -1
- A(I, 2) = U(I, 1)
- AU(I, 2, 1) = 1
- F(I, 2) = U(I, 2)
- FU(I, 2, 2) = 1
- 1 CONTINUE
- RETURN
- END
- SUBROUTINE BC(T, L, R, U, UX, UT, UTX, NU, V, VT, NV, B, BU,
- 1 BUX, BUT, BUTX, BV, BVT)
- INTEGER NU
- INTEGER NV
- DOUBLE PRECISION T, L, R, U(NU, 2), UX(NU, 2), UT(NU, 2)
- DOUBLE PRECISION UTX(NU, 2), V(1), VT(1), B(NU, 2), BU(NU, NU, 2),
- 1 BUX(NU, NU, 2)
- DOUBLE PRECISION BUT(NU, NU, 2), BUTX(NU, NU, 2), BV(1), BVT(1)
- DOUBLE PRECISION DEXP
- B(1, 1) = U(1, 1)-1D0
- B(1, 2) = U(1, 2)-DEXP(T)
- BU(1, 1, 1) = 1
- BU(1, 1, 2) = 1
- RETURN
- END
- SUBROUTINE HANDLE(T0, U0, V0, T, U, V, NU, NXMK, NV, K, X,
- 1 NX, DT, TSTOP)
- INTEGER NXMK, NU, NX
- INTEGER NV, K
- DOUBLE PRECISION T0, U0(NXMK, NU), V0(1), T, U(NXMK, NU), V(1)
- DOUBLE PRECISION X(NX), DT, TSTOP
- COMMON /TIME/ TT
- DOUBLE PRECISION TT
- EXTERNAL U1OFX, U2OFX
- INTEGER I1MACH
- DOUBLE PRECISION DEESFF, EU(2)
- INTEGER TEMP
-C OUTPUT AND CHECKING ROUTINE.
- IF (T0 .EQ. T) RETURN
-C U1OFX AND U2OFX NEED TIME.
- TT = T
- EU(1) = DEESFF(K, X, NX, U, U1OFX)
- EU(2) = DEESFF(K, X, NX, U(1, 2), U2OFX)
- TEMP = I1MACH(2)
- WRITE (TEMP, 1) T, EU
- 1 FORMAT (14H ERROR IN U(X,, 1PE10.2, 4H ) =, 2(1PE10.2))
- RETURN
- END
- SUBROUTINE U1OFX(X, NX, U, W)
- INTEGER NX
- DOUBLE PRECISION X(NX), U(NX), W(NX)
- COMMON /TIME/ T
- DOUBLE PRECISION T
- INTEGER I
- DOUBLE PRECISION DEXP
- DO 1 I = 1, NX
- U(I) = DEXP(X(I)*T)
- 1 CONTINUE
- RETURN
- END
- SUBROUTINE U2OFX(X, NX, U, W)
- INTEGER NX
- DOUBLE PRECISION X(NX), U(NX), W(NX)
- COMMON /TIME/ T
- DOUBLE PRECISION T
- INTEGER I
- DOUBLE PRECISION DEXP
- DO 1 I = 1, NX
- U(I) = T*DEXP(X(I)*T)
- 1 CONTINUE
- RETURN
- END
diff --git a/CEP/PyBDSM/src/port3/ex/dpostx3.f b/CEP/PyBDSM/src/port3/ex/dpostx3.f
deleted file mode 100644
index a0c407b70c39fb6abc47169412be0b01eaf6582f..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ex/dpostx3.f
+++ /dev/null
@@ -1,149 +0,0 @@
-C$TEST DPT3
-C TO RUN AS A MAIN PROGRAM REMOVE NEXT LINE
- SUBROUTINE DPT3
-C***********************************************************************
-C
-C EXAMPLE OF USE OF PORT PROGRAM DPOST
-C
-C***********************************************************************
- COMMON /CSTAK/ DS
- DOUBLE PRECISION DS(2000)
- EXTERNAL DEE, HANDLE, BC, AF
- INTEGER NDX, K, IS(1000), NU, NV, NMESH
- REAL ERRPAR(2), RS(1000)
- LOGICAL LS(1000)
- COMPLEX CS(500)
- DOUBLE PRECISION U(100), V(1), MESH(100), DT, WS(500), TSTOP
- EQUIVALENCE (DS(1), CS(1), WS(1), RS(1), IS(1), LS(1))
-C TO TEST DPOST ON
-C U SUB T = U SUB XX + V + F ON (0,1)
-C V SUB T = U( 1/2, T )
-C WHERE F IS CHOSEN SO THAT THE SOLUTION IS
-C U(X,T) = COS(XT) AND V(T) = 2 SIN(T/2).
-C THE PORT LIBRARY STACK AND ITS ALIASES.
-C INITIALIZE THE PORT LIBRARY STACK LENGTH.
- CALL ISTKIN(2000, 4)
- NU = 1
- NV = 1
- ERRPAR(1) = 1E-2
-C ESSENTIALLY RELATIVE ERROR.
- ERRPAR(2) = 1E-6
- TSTOP = 1
- DT = 1D-6
- K = 4
- NDX = 4
-C NDX UNIFORM MESH POINTS ON (0,1).
- CALL DUMB(0D0, 1D0, NDX, K, MESH, NMESH)
-C INITIAL CONDITIONS FOR U.
- CALL SETD(NMESH-K, 1D0, U)
-C INITIAL VALUE FOR V.
- V(1) = 0
- CALL DPOST(U, NU, K, MESH, NMESH, V, NV, 0D0, TSTOP, DT, AF, BC,
- 1 DEE, ERRPAR, HANDLE)
-C CHECK FOR ERRORS AND STACK USAGE STATISTICS.
- CALL WRAPUP
- STOP
- END
- SUBROUTINE AF(T, X, NX, U, UX, UT, UTX, NU, V, VT, NV, A,
- 1 AU, AUX, AUT, AUTX, AV, AVT, F, FU, FUX, FUT, FUTX, FV, FVT)
- INTEGER NU, NV, NX
- DOUBLE PRECISION T, X(NX), U(NX, NU), UX(NX, NU), UT(NX, NU), UTX(
- 1 NX, NU)
- DOUBLE PRECISION V(NV), VT(NV), A(NX, NU), AU(NX, NU, NU), AUX(NX,
- 1 NU, NU), AUT(NX, NU, NU)
- DOUBLE PRECISION AUTX(NX, NU, NU), AV(NX, NU, NV), AVT(NX, NU, NV)
- 1 , F(NX, NU), FU(NX, NU, NU), FUX(NX, NU, NU)
- DOUBLE PRECISION FUT(NX, NU, NU), FUTX(NX, NU, NU), FV(NX, NU, NV)
- 1 , FVT(NX, NU, NV)
- INTEGER I
- DOUBLE PRECISION DCOS, DSIN
- DO 1 I = 1, NX
- A(I, 1) = -UX(I, 1)
- AUX(I, 1, 1) = -1
- F(I, 1) = V(1)-UT(I, 1)-X(I)*DSIN(X(I)*T)+T**2*DCOS(X(I)*T)-
- 1 2D0*DSIN(T/2D0)
- FUT(I, 1, 1) = -1
- FV(I, 1, 1) = 1
- 1 CONTINUE
- RETURN
- END
- SUBROUTINE BC(T, L, R, U, UX, UT, UTX, NU, V, VT, NV, B, BU,
- 1 BUX, BUT, BUTX, BV, BVT)
- INTEGER NU, NV
- DOUBLE PRECISION T, L, R, U(NU, 2), UX(NU, 2), UT(NU, 2)
- DOUBLE PRECISION UTX(NU, 2), V(NV), VT(NV), B(NU, 2), BU(NU, NU, 2
- 1 ), BUX(NU, NU, 2)
- DOUBLE PRECISION BUT(NU, NU, 2), BUTX(NU, NU, 2), BV(NU, NV, 2),
- 1 BVT(NU, NV, 2)
- DOUBLE PRECISION DCOS
- B(1, 1) = U(1, 1)-1D0
- B(1, 2) = U(1, 2)-DCOS(T)
- BU(1, 1, 1) = 1
- BU(1, 1, 2) = 1
- RETURN
- END
- SUBROUTINE DEE(T, K, X, NX, U, UT, NU, NXMK, V, VT, NV, D,
- 1 DU, DUT, DV, DVT)
- INTEGER NXMK, NU, NV, NX
- INTEGER K
- DOUBLE PRECISION T, X(NX), U(NXMK, NU), UT(NXMK, NU), V(NV), VT(
- 1 NV)
- DOUBLE PRECISION D(NV), DU(NV, NXMK, NU), DUT(NV, NXMK, NU), DV(
- 1 NV, NV), DVT(NV, NV)
- INTEGER INTRVD, I, ILEFT
- DOUBLE PRECISION XI(1), BASIS(10)
- INTEGER TEMP
- XI(1) = 0.5D0
-C FIND 0.5 IN MESH.
- ILEFT = INTRVD(NX, X, XI(1))
- IF (K .GT. 10) CALL SETERR(
- 1 41HDEE - K .GT. 10, NEED MORE SPACE IN BASIS, 41, 1, 2)
-C B-SPLINE BASIS AT XI(1).
- CALL DBSPLN(K, X, NX, XI, 1, ILEFT, BASIS)
- D(1) = VT(1)
- DVT(1, 1) = 1
-C VT(1) - U(0.5,T) = 0.
- DO 1 I = 1, K
- TEMP = ILEFT+I-K
- D(1) = D(1)-U(TEMP, 1)*BASIS(I)
- TEMP = ILEFT+I-K
- DU(1, TEMP, 1) = DU(1, TEMP, 1)-BASIS(I)
- 1 CONTINUE
- RETURN
- END
- SUBROUTINE HANDLE(T0, U0, V0, T, U, V, NU, NXMK, NV, K, X,
- 1 NX, DT, TSTOP)
- INTEGER NXMK, NU, NV, NX
- INTEGER K
- DOUBLE PRECISION T0, U0(NXMK, NU), V0(NV), T, U(NXMK, NU), V(NV)
- DOUBLE PRECISION X(NX), DT, TSTOP
- COMMON /TIME/ TT
- DOUBLE PRECISION TT
- EXTERNAL UOFX
- INTEGER I1MACH
- DOUBLE PRECISION DEESFF, DABS, DSIN, EU, EV
- INTEGER TEMP
-C OUTPUT AND CHECKING ROUTINE.
- IF (T0 .EQ. T) RETURN
-C UOFX NEEDS TIME.
- TT = T
- EU = DEESFF(K, X, NX, U, UOFX)
- EV = DABS(V(1)-2D0*DSIN(T/2D0))
- TEMP = I1MACH(2)
- WRITE (TEMP, 1) T, EU, EV
- 1 FORMAT (14H ERROR IN U(X,, 1PE10.2, 4H ) =, 1PE10.2, 6H V =, 1P
- 1 E10.2)
- RETURN
- END
- SUBROUTINE UOFX(X, NX, U, W)
- INTEGER NX
- DOUBLE PRECISION X(NX), U(NX), W(NX)
- COMMON /TIME/ T
- DOUBLE PRECISION T
- INTEGER I
- DOUBLE PRECISION DCOS
- DO 1 I = 1, NX
- U(I) = DCOS(X(I)*T)
- 1 CONTINUE
- RETURN
- END
diff --git a/CEP/PyBDSM/src/port3/ex/dpostx4.f b/CEP/PyBDSM/src/port3/ex/dpostx4.f
deleted file mode 100644
index f191ef85b65d1f811c66ac3f037d4633ad1eb87f..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ex/dpostx4.f
+++ /dev/null
@@ -1,139 +0,0 @@
-C$TEST DPT4
-C TO RUN AS A MAIN PROGRAM REMOVE NEXT LINE
- SUBROUTINE DPT4
-C***********************************************************************
-C
-C EXAMPLE OF USE OF PORT PROGRAM DPOST
-C
-C***********************************************************************
- COMMON /CSTAK/ DS
- DOUBLE PRECISION DS(2000)
- EXTERNAL DEE, HANDLE, BC, AF
- INTEGER NDX, K, IS(1000), NU, NV, NMESH
- REAL ERRPAR(2), RS(1000)
- LOGICAL LS(1000)
- COMPLEX CS(500)
- DOUBLE PRECISION U(100), V(1), MESH(100), DT, DATAN, WS(500)
- DOUBLE PRECISION TSTOP
- EQUIVALENCE (DS(1), CS(1), WS(1), RS(1), IS(1), LS(1))
-C TO TEST DPOST ON
-C U SUB T = U SUB XX - U**3 + F ON (-PI,+PI)
-C SUBJECT TO PERIODIC BOUNDARY CONDITIONS,
-C WHERE F IS CHOSEN SO THAT THE SOLUTION IS
-C U(X,T) = COS(X)*SIN(T).
-C THE PORT LIBRARY STACK AND ITS ALIASES.
-C INITIALIZE THE PORT LIBRARY STACK LENGTH.
- CALL ISTKIN(2000, 4)
- NU = 1
- NV = 1
- ERRPAR(1) = 0
-C ABSOLUTE ERROR.
- ERRPAR(2) = 1E-2
- TSTOP = 8D0*DATAN(1D0)
- DT = 0.4
-C MAKE A MESH OF NDX UNIFORM POINTS ON (-PI,+PI).
- K = 4
- NDX = 7
- CALL DUMB((-4D0)*DATAN(1D0), 4D0*DATAN(1D0), NDX, K, MESH, NMESH)
-C INITIAL CONDITIONS FOR U.
- CALL SETD(NMESH-K, 0D0, U)
-C INITIAL CONDITIONS FOR V.
- V(1) = 0
- CALL DPOST(U, NU, K, MESH, NMESH, V, NV, 0D0, TSTOP, DT, AF, BC,
- 1 DEE, ERRPAR, HANDLE)
-C CHECK FOR ERRORS AND STACK USAGE STATISTICS.
- CALL WRAPUP
- STOP
- END
- SUBROUTINE AF(T, X, NX, U, UX, UT, UTX, NU, V, VT, NV, A,
- 1 AU, AUX, AUT, AUTX, AV, AVT, F, FU, FUX, FUT, FUTX, FV, FVT)
- INTEGER NU, NV, NX
- DOUBLE PRECISION T, X(NX), U(NX, NU), UX(NX, NU), UT(NX, NU), UTX(
- 1 NX, NU)
- DOUBLE PRECISION V(NV), VT(NV), A(NX, NU), AU(NX, NU, NU), AUX(NX,
- 1 NU, NU), AUT(NX, NU, NU)
- DOUBLE PRECISION AUTX(NX, NU, NU), AV(NX, NU, NV), AVT(NX, NU, NV)
- 1 , F(NX, NU), FU(NX, NU, NU), FUX(NX, NU, NU)
- DOUBLE PRECISION FUT(NX, NU, NU), FUTX(NX, NU, NU), FV(NX, NU, NV)
- 1 , FVT(NX, NU, NV)
- INTEGER I
- DOUBLE PRECISION DCOS, DSIN
- DO 1 I = 1, NX
- A(I, 1) = -UX(I, 1)
- AUX(I, 1, 1) = -1
- F(I, 1) = (-UT(I, 1))-U(I, 1)**3+DCOS(X(I))*(DCOS(T)+DSIN(T)+
- 1 DCOS(X(I))**2*DSIN(T)**3)
- FUT(I, 1, 1) = -1
- FU(I, 1, 1) = (-3D0)*U(I, 1)**2
- 1 CONTINUE
- RETURN
- END
- SUBROUTINE BC(T, L, R, U, UX, UT, UTX, NU, V, VT, NV, B, BU,
- 1 BUX, BUT, BUTX, BV, BVT)
- INTEGER NU, NV
- DOUBLE PRECISION T, L, R, U(NU, 2), UX(NU, 2), UT(NU, 2)
- DOUBLE PRECISION UTX(NU, 2), V(NV), VT(NV), B(NU, 2), BU(NU, NU, 2
- 1 ), BUX(NU, NU, 2)
- DOUBLE PRECISION BUT(NU, NU, 2), BUTX(NU, NU, 2), BV(NU, NV, 2),
- 1 BVT(NU, NV, 2)
- B(1, 1) = UX(1, 1)-V(1)
- B(1, 2) = UX(1, 2)-V(1)
- BUX(1, 1, 1) = 1
- BV(1, 1, 1) = -1
- BUX(1, 1, 2) = 1
- BV(1, 1, 2) = -1
- RETURN
- END
- SUBROUTINE DEE(T, K, X, NX, U, UT, NU, NXMK, V, VT, NV, D,
- 1 DU, DUT, DV, DVT)
- INTEGER NXMK, NU, NV, NX
- INTEGER K
- DOUBLE PRECISION T, X(NX), U(NXMK, NU), UT(NXMK, NU), V(NV), VT(
- 1 NV)
- DOUBLE PRECISION D(NV), DU(NV, NXMK, NU), DUT(NV, NXMK, NU), DV(
- 1 NV, NV), DVT(NV, NV)
- INTEGER TEMP
-C U(-PI,T) - U(+PI,T) = 0.
- TEMP = NX-K
- D(1) = U(1, 1)-U(TEMP, 1)
- DU(1, 1, 1) = 1
- TEMP = NX-K
- DU(1, TEMP, 1) = -1
- RETURN
- END
- SUBROUTINE HANDLE(T0, U0, V0, T, U, V, NU, NXMK, NV, K, X,
- 1 NX, DT, TSTOP)
- INTEGER NXMK, NU, NV, NX
- INTEGER K
- DOUBLE PRECISION T0, U0(NXMK, NU), V0(NV), T, U(NXMK, NU), V(NV)
- DOUBLE PRECISION X(NX), DT, TSTOP
- COMMON /TIME/ TT
- DOUBLE PRECISION TT
- EXTERNAL UOFX
- INTEGER I1MACH
- DOUBLE PRECISION DEESFF, EU, EV
- INTEGER TEMP
-C OUTPUT AND CHECKING ROUTINE.
- IF (T0 .EQ. T) RETURN
-C UOFX NEEDS TIME.
- TT = T
- EU = DEESFF(K, X, NX, U, UOFX)
- EV = V(1)
- TEMP = I1MACH(2)
- WRITE (TEMP, 1) T, EU, EV
- 1 FORMAT (14H ERROR IN U(X,, 1PE10.2, 4H ) =, 1PE10.2, 6H V =, 1P
- 1 E10.2)
- RETURN
- END
- SUBROUTINE UOFX(X, NX, U, W)
- INTEGER NX
- DOUBLE PRECISION X(NX), U(NX), W(NX)
- COMMON /TIME/ T
- DOUBLE PRECISION T
- INTEGER I
- DOUBLE PRECISION DCOS, DSIN
- DO 1 I = 1, NX
- U(I) = DCOS(X(I))*DSIN(T)
- 1 CONTINUE
- RETURN
- END
diff --git a/CEP/PyBDSM/src/port3/ex/dpostx5.f b/CEP/PyBDSM/src/port3/ex/dpostx5.f
deleted file mode 100644
index b990a8a47721d3f0a5aa438e2406c090b0e5a7fe..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ex/dpostx5.f
+++ /dev/null
@@ -1,249 +0,0 @@
-C$TEST DPT5
-C TO RUN AS A MAIN PROGRAM REMOVE NEXT LINE
- SUBROUTINE DPT5
-C***********************************************************************
-C
-C EXAMPLE OF USE OF PORT PROGRAM DPOST
-C
-C***********************************************************************
- COMMON /CSTAK/ DS
- DOUBLE PRECISION DS(4000)
- COMMON /TIME/ T
- DOUBLE PRECISION T
- COMMON /PARAM/ VC, X
- DOUBLE PRECISION VC(3), X(3)
- EXTERNAL DEE, HANDLE, UOFX, BC, AF
- INTEGER NDX, IDLUMB, ISTKGT, K, IU, IS(1000)
- INTEGER NU, NV, IMMMD, IMESH, NMESH
- REAL ERRPAR(2), RS(1000)
- LOGICAL LS(1000)
- COMPLEX CS(500)
- DOUBLE PRECISION TSTART, V(3), DT, XB(3), WS(500), TSTOP
- EQUIVALENCE (DS(1), CS(1), WS(1), RS(1), IS(1), LS(1))
-C TO TEST DPOST ON
-C U SUB T = ( K(T,X) * U SUB X ) SUB X + G ON (-1,+2) * (0,+1)
-C WITH A MOVING FRONT X(T) CHARACTERIZED BY U(X(T),T) == 1 AND
-C JUMP ACROSS X(T) OF K(T,X) U SUB X = - 3 * X'(T).
-C WHERE K(T,X) IS PIECEWISE CONSTANT, SAY
-C 1 FOR X < X(T)
-C K(T,X) =
-C 2 FOR X > X(T)
-C AND G IS CHOSEN SO THAT THE SOLUTION IS
-C EXP(X-X(T)) FOR X < X(T)
-C U(X,T) =
-C EXP(X(T)-X) FOR X > X(T)
-C AND X(1,T) = T. THE MOVING FRONT IS TRACKED
-C IMPLICITLY BY FORCING U(X(1,T),T) = 1 AS A PSEUDO-RANKINE-HEUGONIOT RE
-CLATION.
-C V(1,2,3) GIVES THE MOVING MESH.
-C THE PORT LIBRARY STACK AND ITS ALIASES.
-C INITIALIZE THE PORT LIBRARY STACK LENGTH.
- CALL ISTKIN(4000, 4)
- CALL ENTER(1)
- NU = 1
- NV = 3
- ERRPAR(1) = 0
-C ABSOLUTE ERROR.
- ERRPAR(2) = 1E-2
- TSTART = 0
- TSTOP = 1
- DT = 0.1
- K = 4
-C NDX UNIFORM MESH POINTS ON EACH INTERVAL OF XB ARRAY.
- NDX = 6
- XB(1) = 0
- XB(2) = 1
- XB(3) = 2
-C GET MESH ON PORT STACK.
- IMESH = IDLUMB(XB, 3, NDX, K, NMESH)
-C MAKE 1 OF MULTIPLICITY K-1.
- IMESH = IMMMD(IMESH, NMESH, 1D0, K-1)
- X(1) = -1
- X(2) = 0
- X(3) = 2
-C INITIAL VALUES FOR V.
- CALL DLPLMG(3, X, VC)
-C GET U ON THE PORT STACK.
- IU = ISTKGT(NMESH-K, 4)
-C UOFX NEEDS TIME.
- T = TSTART
-C UOFX NEEDS V FOR MAPPING.
- CALL MOVEFD(NV, VC, V)
-C INITIAL CONDITIONS FOR U.
- CALL DL2SFF(UOFX, K, WS(IMESH), NMESH, WS(IU))
-C OUTPUT THE ICS.
- CALL HANDLE(T-1D0, WS(IU), V, T, WS(IU), V, NU, NMESH-K, NV, K,
- 1 WS(IMESH), NMESH, DT, TSTOP)
- CALL DPOST(WS(IU), NU, K, WS(IMESH), NMESH, V, NV, TSTART, TSTOP
- 1 , DT, AF, BC, DEE, ERRPAR, HANDLE)
- CALL LEAVE
- CALL WRAPUP
- STOP
- END
- SUBROUTINE AF(T, XI, NX, U, UX, UT, UTX, NU, V, VT, NV, A,
- 1 AU, AUX, AUT, AUTX, AV, AVT, F, FU, FUX, FUT, FUTX, FV, FVT)
- INTEGER NU, NV, NX
- DOUBLE PRECISION T, XI(NX), U(NX, NU), UX(NX, NU), UT(NX, NU),
- 1 UTX(NX, NU)
- DOUBLE PRECISION V(NV), VT(NV), A(NX, NU), AU(NX, NU, NU), AUX(NX,
- 1 NU, NU), AUT(NX, NU, NU)
- DOUBLE PRECISION AUTX(NX, NU, NU), AV(NX, NU, NV), AVT(NX, NU, NV)
- 1 , F(NX, NU), FU(NX, NU, NU), FUX(NX, NU, NU)
- DOUBLE PRECISION FUT(NX, NU, NU), FUTX(NX, NU, NU), FV(NX, NU, NV)
- 1 , FVT(NX, NU, NV)
- COMMON /DPOSTF/ FAILED
- LOGICAL FAILED
- INTEGER I
- DOUBLE PRECISION KAY, XXI(99), XTV(99), XVV(99), X(99), DEXP
- DOUBLE PRECISION XXIV(99), AX(99), FX(99), XT(99), XV(99)
- LOGICAL TEMP
- TEMP = V(2) .LE. V(1)
- IF (.NOT. TEMP) TEMP = V(2) .GE. V(3)
- IF (.NOT. TEMP) GOTO 1
- FAILED = .TRUE.
- RETURN
-C MAP XI INTO X.
- 1 CALL DLPLM(XI, NX, V, 3, X, XXI, XXIV, XV, XVV, XT, XTV)
-C MAP U INTO X SYSTEM.
- CALL DPOSTU(XI, X, XT, XXI, XV, VT, NX, 3, UX, UT, NU, AX, FX)
- DO 7 I = 1, NX
- IF (XI(I) .GT. 1D0) GOTO 2
- KAY = 1
- GOTO 3
- 2 KAY = 2
- 3 A(I, 1) = KAY*UX(I, 1)
- AUX(I, 1, 1) = KAY
- IF (XI(I) .GT. 1D0) GOTO 4
- A(I, 1) = A(I, 1)-3D0*VT(2)
- AVT(I, 1, 2) = -3
- 4 F(I, 1) = UT(I, 1)
- FUT(I, 1, 1) = 1
- IF (XI(I) .GT. 1D0) GOTO 5
- F(I, 1) = F(I, 1)+2D0*DEXP(X(I)-T)
- FX(I) = 2D0*DEXP(X(I)-T)
- GOTO 6
- 5 F(I, 1) = F(I, 1)+DEXP(T-X(I))
- FX(I) = -DEXP(T-X(I))
- 6 CONTINUE
- 7 CONTINUE
-C MAP A AND F INTO XI SYSTEM.
- CALL DPOSTI(XI, X, XT, XXI, XV, XTV, XXIV, XVV, NX, UX, UT, NU, V,
- 1 VT, NV, 1, 3, A, AX, AU, AUX, AUT, AUTX, AV, AVT, F, FX, FU,
- 2 FUX, FUT, FUTX, FV, FVT)
- RETURN
- END
- SUBROUTINE BC(T, L, R, U, UX, UT, UTX, NU, V, VT, NV, B, BU,
- 1 BUX, BUT, BUTX, BV, BVT)
- INTEGER NU, NV
- DOUBLE PRECISION T, L, R, U(NU, 2), UX(NU, 2), UT(NU, 2)
- DOUBLE PRECISION UTX(NU, 2), V(NV), VT(NV), B(NU, 2), BU(NU, NU, 2
- 1 ), BUX(NU, NU, 2)
- DOUBLE PRECISION BUT(NU, NU, 2), BUTX(NU, NU, 2), BV(NU, NV, 2),
- 1 BVT(NU, NV, 2)
- DOUBLE PRECISION DEXP
- B(1, 1) = U(1, 1)-DEXP((-1D0)-T)
- B(1, 2) = U(1, 2)-DEXP(T-2D0)
- BU(1, 1, 1) = 1
- BU(1, 1, 2) = 1
- RETURN
- END
- SUBROUTINE DEE(T, K, X, NX, U, UT, NU, NXMK, V, VT, NV, D,
- 1 DU, DUT, DV, DVT)
- INTEGER NXMK, NU, NV, NX
- INTEGER K
- DOUBLE PRECISION T, X(NX), U(NXMK, NU), UT(NXMK, NU), V(NV), VT(
- 1 NV)
- DOUBLE PRECISION D(NV), DU(NV, NXMK, NU), DUT(NV, NXMK, NU), DV(
- 1 NV, NV), DVT(NV, NV)
- INTEGER INTRVD, I, ILEFT
- DOUBLE PRECISION BX(10), XX(1)
- INTEGER TEMP
- D(1) = V(1)+1D0
-C X(0,V) = -1.
- DV(1, 1) = 1
- XX(1) = 1
-C FIND 1 IN THE MESH.
- ILEFT = INTRVD(NX, X, XX(1))
-C GET THE B-SPLINE BASIS AT XX.
- CALL DBSPLN(K, X, NX, XX, 1, ILEFT, BX)
-C U(X(1,V),T) = 1.
- D(2) = -1
- DO 1 I = 1, K
- TEMP = ILEFT+I-K
- D(2) = D(2)+U(TEMP, 1)*BX(I)
- TEMP = ILEFT+I-K
- DU(2, TEMP, 1) = BX(I)
- 1 CONTINUE
- D(3) = V(3)-2D0
-C X(2,V) = +2.
- DV(3, 3) = 1
- RETURN
- END
- SUBROUTINE HANDLE(T0, U0, V0, T, U, V, NU, NXMK, NV, K, X,
- 1 NX, DT, TSTOP)
- INTEGER NXMK, NU, NV, NX
- INTEGER K
- DOUBLE PRECISION T0, U0(NXMK, NU), V0(NV), T, U(NXMK, NU), V(NV)
- DOUBLE PRECISION X(NX), DT, TSTOP
- COMMON /PARAM/ VC, XX
- DOUBLE PRECISION VC(3), XX(3)
- COMMON /TIME/ TT
- DOUBLE PRECISION TT
- EXTERNAL UOFX
- INTEGER I1MACH
- DOUBLE PRECISION DEESFF, EU, EV(3)
- INTEGER TEMP
-C OUTPUT AND CHECKING ROUTINE.
- IF (T0 .NE. T) GOTO 2
- TEMP = I1MACH(2)
- WRITE (TEMP, 1) T
- 1 FORMAT (16H RESTART FOR T =, 1PE10.2)
- RETURN
- 2 TT = T
-C UOFX NEEDS V FOR MAPPING.
- CALL MOVEFD(NV, V, VC)
- EU = DEESFF(K, X, NX, U, UOFX)
- EV(1) = V(1)+1D0
- EV(2) = V(2)-T
- EV(3) = V(3)-2D0
- TEMP = I1MACH(2)
- WRITE (TEMP, 3) T, EU, EV
- 3 FORMAT (14H ERROR IN U(X,, 1PE10.2, 4H ) =, 1PE10.2, 6H V =, 3(
- 1 1PE10.2))
- RETURN
- END
- SUBROUTINE UOFX(XI, NX, U, W)
- INTEGER NX
- DOUBLE PRECISION XI(NX), U(NX), W(NX)
- COMMON /CSTAK/ DS
- DOUBLE PRECISION DS(500)
- COMMON /PARAM/ VC, X
- DOUBLE PRECISION VC(3), X(3)
- COMMON /TIME/ T
- DOUBLE PRECISION T
- INTEGER IXV, IXX, ISTKGT, I, IS(1000)
- REAL RS(1000)
- LOGICAL LS(1000)
- COMPLEX CS(500)
- DOUBLE PRECISION DEXP, WS(500), XOFXI
- INTEGER TEMP
- EQUIVALENCE (DS(1), CS(1), WS(1), RS(1), IS(1), LS(1))
-C THE PORT LIBRARY STACK AND ITS ALIASES.
- CALL ENTER(1)
- IXX = ISTKGT(NX, 4)
-C SPACE FOR X AND XV.
- IXV = ISTKGT(3*NX, 4)
-C MAP INTO USER SYSTEM.
- CALL DLPLMX(XI, NX, VC, 3, WS(IXX), WS(IXV))
- DO 3 I = 1, NX
- TEMP = IXX+I
- XOFXI = WS(TEMP-1)
- IF (XI(I) .GT. 1D0) GOTO 1
- U(I) = DEXP(XOFXI-T)
- GOTO 2
- 1 U(I) = DEXP(T-XOFXI)
- 2 CONTINUE
- 3 CONTINUE
- CALL LEAVE
- RETURN
- END
diff --git a/CEP/PyBDSM/src/port3/ex/dpostx6.f b/CEP/PyBDSM/src/port3/ex/dpostx6.f
deleted file mode 100644
index ef3473bc3a42950f53fb95330984f40b164f433b..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ex/dpostx6.f
+++ /dev/null
@@ -1,255 +0,0 @@
-C$TEST DPT6
-C TO RUN AS A MAIN PROGRAM REMOVE NEXT LINE
- SUBROUTINE DPT6
-C***********************************************************************
-C
-C EXAMPLE OF USE OF PORT PROGRAM DPOST
-C
-C***********************************************************************
- COMMON /CSTAK/ DS
- DOUBLE PRECISION DS(4000)
- COMMON /TIME/ T
- DOUBLE PRECISION T
- COMMON /PARAM/ VC, X
- DOUBLE PRECISION VC(4), X(3)
- EXTERNAL DEE, HANDLE, UOFX, BC, AF
- INTEGER NDX, IDLUMB, ISTKGT, K, IU, IS(1000)
- INTEGER NU, NV, IMMMD, IMESH, NMESH
- REAL ERRPAR(2), RS(1000)
- LOGICAL LS(1000)
- COMPLEX CS(500)
- DOUBLE PRECISION TSTART, V(4), DT, XB(3), WS(500), TSTOP
- EQUIVALENCE (DS(1), CS(1), WS(1), RS(1), IS(1), LS(1))
-C TO TEST DPOST ON THE HYPERBOLIC PROBLEM
-C U SUB T = - U SUB X + G ON (-PI,+PI) * (0,PI)
-C WITH A MOVING SHOCK X(T) CHARACTERIZED BY
-C U(X(T)+,T) = 0 AND
-C U(X(T)+,T) - U(X(T)-,T) = X'(T)
-C WHERE G IS CHOSEN SO THAT THE SOLUTION IS
-C SIN(X+T) FOR X < X(T)
-C U(X,T) =
-C COS(X+T) FOR X > X(T)
-C WITH X(T) = PI/2 -T .
-C V(1,2,3) GIVES THE MOVING MESH AND V(4) IS THE HEIGHT OF THE JUMP.
-C THE PORT LIBRARY STACK AND ITS ALIASES.
-C INITIALIZE THE PORT LIBRARY STACK LENGTH.
- CALL ISTKIN(4000, 4)
- CALL ENTER(1)
- NU = 1
- NV = 4
- ERRPAR(1) = 0
-C ABSOLUTE ERROR.
- ERRPAR(2) = 1E-2
- TSTART = 0
- TSTOP = 3.14
- DT = 0.4
- K = 4
-C NDX UNIFORM MESH POINTS ON EACH INTERVAL OF XB.
- NDX = 6
- XB(1) = 0
- XB(2) = 1
- XB(3) = 2
-C GET MESH ON PORT STACK.
- IMESH = IDLUMB(XB, 3, NDX, K, NMESH)
-C MAKE 1 OF MULTIPLICITY K-1.
- IMESH = IMMMD(IMESH, NMESH, 1D0, K-1)
- X(1) = -3.14
- X(2) = 3.14/2.
- X(3) = 3.14
-C INITIAL VALUES FOR V.
- CALL DLPLMG(3, X, VC)
-C GET U ON THE PORT STACK.
- IU = ISTKGT(NMESH-K, 4)
-C UOFX NEEDS TIME.
- T = TSTART
-C THE INITIAL HEIGHT OF THE JUMP.
- VC(4) = 1
-C UOFX NEEDS V FOR MAPPING.
- CALL MOVEFD(NV, VC, V)
-C INITIAL CONDITIONS FOR U.
- CALL DL2SFF(UOFX, K, WS(IMESH), NMESH, WS(IU))
-C OUTPUT ICS.
- CALL HANDLE(T-1D0, WS(IU), V, T, WS(IU), V, NU, NMESH-K, NV, K,
- 1 WS(IMESH), NMESH, DT, TSTOP)
- CALL DPOST(WS(IU), NU, K, WS(IMESH), NMESH, V, NV, TSTART, TSTOP
- 1 , DT, AF, BC, DEE, ERRPAR, HANDLE)
- CALL LEAVE
- CALL WRAPUP
- STOP
- END
- SUBROUTINE AF(T, XI, NX, U, UX, UT, UTX, NU, V, VT, NV, A,
- 1 AU, AUX, AUT, AUTX, AV, AVT, F, FU, FUX, FUT, FUTX, FV, FVT)
- INTEGER NU, NV, NX
- DOUBLE PRECISION T, XI(NX), U(NX, NU), UX(NX, NU), UT(NX, NU),
- 1 UTX(NX, NU)
- DOUBLE PRECISION V(NV), VT(NV), A(NX, NU), AU(NX, NU, NU), AUX(NX,
- 1 NU, NU), AUT(NX, NU, NU)
- DOUBLE PRECISION AUTX(NX, NU, NU), AV(NX, NU, NV), AVT(NX, NU, NV)
- 1 , F(NX, NU), FU(NX, NU, NU), FUX(NX, NU, NU)
- DOUBLE PRECISION FUT(NX, NU, NU), FUTX(NX, NU, NU), FV(NX, NU, NV)
- 1 , FVT(NX, NU, NV)
- COMMON /DPOSTF/ FAILED
- LOGICAL FAILED
- INTEGER I
- DOUBLE PRECISION XXI(99), XTV(99), XVV(99), X(99), DCOS, DSIN
- DOUBLE PRECISION XXIV(99), AX(99), FX(99), XT(99), XV(99)
- LOGICAL TEMP
- TEMP = V(2) .LE. V(1)
- IF (.NOT. TEMP) TEMP = V(2) .GE. V(3)
- IF (.NOT. TEMP) GOTO 1
- FAILED = .TRUE.
- RETURN
-C MAP XI INTO X.
- 1 CALL DLPLM(XI, NX, V, 3, X, XXI, XXIV, XV, XVV, XT, XTV)
-C MAP U INTO X SYSTEM.
- CALL DPOSTU(XI, X, XT, XXI, XV, VT, NX, 3, UX, UT, NU, AX, FX)
- DO 4 I = 1, NX
- A(I, 1) = -U(I, 1)
- AU(I, 1, 1) = -1
- F(I, 1) = UT(I, 1)
- FUT(I, 1, 1) = 1
- IF (XI(I) .GT. 1D0) GOTO 2
- F(I, 1) = F(I, 1)-2D0*DCOS(X(I)+T)
- FX(I) = 2D0*DSIN(X(I)+T)
- GOTO 3
- 2 F(I, 1) = F(I, 1)-VT(4)
- FVT(I, 1, 4) = -1
- F(I, 1) = F(I, 1)+2D0*DSIN(X(I)+T)
- FX(I) = 2D0*DCOS(X(I)+T)
- 3 CONTINUE
- 4 CONTINUE
-C MAP A AND F INTO XI SYSTEM.
- CALL DPOSTI(XI, X, XT, XXI, XV, XTV, XXIV, XVV, NX, UX, UT, NU, V,
- 1 VT, NV, 1, 3, A, AX, AU, AUX, AUT, AUTX, AV, AVT, F, FX, FU,
- 2 FUX, FUT, FUTX, FV, FVT)
- RETURN
- END
- SUBROUTINE BC(T, L, R, U, UX, UT, UTX, NU, V, VT, NV, B, BU,
- 1 BUX, BUT, BUTX, BV, BVT)
- INTEGER NU, NV
- DOUBLE PRECISION T, L, R, U(NU, 2), UX(NU, 2), UT(NU, 2)
- DOUBLE PRECISION UTX(NU, 2), V(NV), VT(NV), B(NU, 2), BU(NU, NU, 2
- 1 ), BUX(NU, NU, 2)
- DOUBLE PRECISION BUT(NU, NU, 2), BUTX(NU, NU, 2), BV(NU, NV, 2),
- 1 BVT(NU, NV, 2)
- DOUBLE PRECISION DSIN
- B(1, 1) = U(1, 1)-DSIN(T-3.14)
-C U(-PI,T) = SIN(-PI+T).
- BU(1, 1, 1) = 1
- RETURN
- END
- SUBROUTINE DEE(T, K, X, NX, U, UT, NU, NXMK, V, VT, NV, D,
- 1 DU, DUT, DV, DVT)
- INTEGER NXMK, NU, NV, NX
- INTEGER K
- DOUBLE PRECISION T, X(NX), U(NXMK, NU), UT(NXMK, NU), V(NV), VT(
- 1 NV)
- DOUBLE PRECISION D(NV), DU(NV, NXMK, NU), DUT(NV, NXMK, NU), DV(
- 1 NV, NV), DVT(NV, NV)
- INTEGER INTRVD, I, ILEFT
- DOUBLE PRECISION BX(10), XX(1), D1MACH
- INTEGER TEMP
- D(1) = V(1)+3.14
-C X(0,V) = -PI.
- DV(1, 1) = 1
-C XX(1) = 1 + A ROUNDING ERROR.
- XX(1) = D1MACH(4)+1D0
- ILEFT = INTRVD(NX, X, XX(1))
-C GET THE B-SPLINE BASIS AT XX.
- CALL DBSPLN(K, X, NX, XX, 1, ILEFT, BX)
- D(2) = -V(4)
-C U(X(T)+,T) - JUMP = 0.
- DV(2, 4) = -1
- DO 1 I = 1, K
- TEMP = ILEFT+I-K
- D(2) = D(2)+U(TEMP, 1)*BX(I)
- TEMP = ILEFT+I-K
- DU(2, TEMP, 1) = BX(I)
- 1 CONTINUE
- D(3) = V(3)-3.14
-C X(2,V) = +PI.
- DV(3, 3) = 1
-C JUMP + D( X(1,V(T)) )/DT = 0.
- D(4) = VT(2)+V(4)
- DVT(4, 2) = 1
- DV(4, 4) = 1
- RETURN
- END
- SUBROUTINE HANDLE(T0, U0, V0, T, U, V, NU, NXMK, NV, K, X,
- 1 NX, DT, TSTOP)
- INTEGER NXMK, NU, NV, NX
- INTEGER K
- DOUBLE PRECISION T0, U0(NXMK, NU), V0(NV), T, U(NXMK, NU), V(NV)
- DOUBLE PRECISION X(NX), DT, TSTOP
- COMMON /PARAM/ VC, XX
- DOUBLE PRECISION VC(4), XX(3)
- COMMON /TIME/ TT
- DOUBLE PRECISION TT
- EXTERNAL UOFX
- INTEGER I1MACH
- DOUBLE PRECISION DEESFF, EU, EV(2)
- INTEGER TEMP
-C OUTPUT AND CHECKING ROUTINE.
- IF (T0 .NE. T) GOTO 2
- TEMP = I1MACH(2)
- WRITE (TEMP, 1) T, DT
- 1 FORMAT (16H RESTART FOR T =, 1PE10.2, 7H DT =, 1PE10.2)
- RETURN
- 2 TT = T
-C UOFX NEEDS V FOR MAPPING.
- CALL MOVEFD(NV, V, VC)
- EU = DEESFF(K, X, NX, U, UOFX)
-C ERROR IN POSITION OF SHOCK.
- EV(1) = V(2)-(3.14/2.-T)
-C ERROR IN HEIGHT OF SHOCK.
- EV(2) = V(4)-1D0
- TEMP = I1MACH(2)
- WRITE (TEMP, 3) T, EU, EV
- 3 FORMAT (14H ERROR IN U(X,, 1PE10.2, 4H ) =, 1PE10.2, 6H V =, 2(
- 1 1PE10.2))
- RETURN
- END
- SUBROUTINE UOFX(XI, NX, U, W)
- INTEGER NX
- DOUBLE PRECISION XI(NX), U(NX), W(NX)
- COMMON /CSTAK/ DS
- DOUBLE PRECISION DS(500)
- COMMON /PARAM/ VC, X
- DOUBLE PRECISION VC(4), X(3)
- COMMON /TIME/ T
- DOUBLE PRECISION T
- INTEGER IXV, IXX, ISTKGT, I, IS(1000)
- REAL RS(1000)
- LOGICAL LS(1000)
- COMPLEX CS(500)
- DOUBLE PRECISION EWE, WS(500)
- INTEGER TEMP
- EQUIVALENCE (DS(1), CS(1), WS(1), RS(1), IS(1), LS(1))
-C THE PORT LIBRARY STACK AND ITS ALIASES.
- CALL ENTER(1)
- IXX = ISTKGT(NX, 4)
-C SPACE FOR X AND XV.
- IXV = ISTKGT(3*NX, 4)
-C MAP INTO USER SYSTEM.
- CALL DLPLMX(XI, NX, VC, 3, WS(IXX), WS(IXV))
- DO 1 I = 1, NX
- TEMP = IXX+I
- U(I) = EWE(T, WS(TEMP-1), VC(2))
- IF (XI(I) .GT. 1D0) U(I) = U(I)+1D0
- 1 CONTINUE
- CALL LEAVE
- RETURN
- END
- DOUBLE PRECISION FUNCTION EWE(T, X, XBREAK)
- DOUBLE PRECISION T, X, XBREAK
- DOUBLE PRECISION DCOS, DSIN
- IF (X .GE. XBREAK) GOTO 1
- EWE = DSIN(X+T)
- RETURN
- 1 IF (X .LE. XBREAK) GOTO 2
- EWE = DCOS(X+T)
- RETURN
- 2 CALL SETERR(17HEWE - X == XBREAK, 17, 1, 2)
- 3 CONTINUE
- 4 STOP
- END
diff --git a/CEP/PyBDSM/src/port3/ex/dpostx7.f b/CEP/PyBDSM/src/port3/ex/dpostx7.f
deleted file mode 100644
index d49cd13f98b3d64a1b513402b9223acc1b39bab7..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ex/dpostx7.f
+++ /dev/null
@@ -1,239 +0,0 @@
-C$TEST DPT7
-C TO RUN AS A MAIN PROGRAM REMOVE NEXT LINE
- SUBROUTINE DPT7
-C***********************************************************************
-C
-C EXAMPLE OF USE OF PORT PROGRAM DPOST
-C
-C***********************************************************************
- COMMON /CSTAK/ DS
- DOUBLE PRECISION DS(4000)
- COMMON /TIME/ T
- DOUBLE PRECISION T
- COMMON /PARAM/ VC, X, XI0
- DOUBLE PRECISION VC(4), X(3), XI0
- EXTERNAL DEE, HANDLE, UOFX, BC, AF
- INTEGER NDX, IDLUMB, ISTKGT, K, IU, IS(1000)
- INTEGER NU, NV, IMMMD, IMESH, NMESH
- REAL ERRPAR(2), RS(1000)
- LOGICAL LS(1000)
- COMPLEX CS(500)
- DOUBLE PRECISION TSTART, D, V(4), DT, XB(3), WS(500)
- DOUBLE PRECISION TSTOP
- EQUIVALENCE (DS(1), CS(1), WS(1), RS(1), IS(1), LS(1))
-C TO TEST DPOST ON
-C U SUB T = U SUB XX + F ON (20,10**6)
-C WHERE F IS CHOSEN SO THAT THE SOLUTION IS
-C U(X,T) = EXP(-X*T),
-C AND X(1,T) IS CHOSEN SO THAT THE BOUNDARY-LAYER IS TRACKED
-C IMPLICITLY BY FORCING U(X(1,T)/2.3/D,T) = 1/E.
-C THIS IS THE SAME AS REQUIRING THE EXACT SOLUTION TO HAVE
-C U(X(1,T),T) = 10 ** -D.
-C V(1,2,3) GIVES THE MOVING MESH, V(4) IS TIME.
-C THE PORT LIBRARY STACK AND ITS ALIASES.
-C INITIALIZE THE PORT LIBRARY STACK LENGTH.
- CALL ISTKIN(4000, 4)
- CALL ENTER(1)
- NU = 1
- NV = 4
- ERRPAR(1) = 1E-2
-C MIXED RELATIVE AND ABSOLUTE ERROR.
- ERRPAR(2) = 1E-2
- D = 3
-C W(XI0,T) = 1/E.
- XI0 = 1./2.3/D
- TSTART = 20
- TSTOP = 1D+6
- DT = 1D-2
- K = 4
-C NDX UNIFORM MESH POINTS ON EACH INTERVAL OF XB.
- NDX = 6
- XB(1) = 0
- XB(2) = 1
- XB(3) = 2
-C GET MESH ON PORT STACK.
- IMESH = IDLUMB(XB, 3, NDX, K, NMESH)
-C MAKE 1D0 OF MULTIPLICITY K-1.
- IMESH = IMMMD(IMESH, NMESH, 1D0, K-1)
- X(1) = 0
- X(2) = 2.3*D/TSTART
- X(3) = 1
-C INITIAL VALUES FOR V.
- CALL DLPLMG(3, X, VC)
-C GET U ON PORT STACK.
- IU = ISTKGT(NMESH-K, 4)
-C UOFX NEEDS TIME.
- T = TSTART
- VC(4) = TSTART
-C UOFX NEEDS V FOR MAPPING.
- CALL MOVEFD(NV, VC, V)
-C INITIAL CONDITIONS FOR U.
- CALL DL2SFF(UOFX, K, WS(IMESH), NMESH, WS(IU))
-C OUTPUT ICS.
- CALL HANDLE(T-1D0, WS(IU), V, T, WS(IU), V, NU, NMESH-K, NV, K,
- 1 WS(IMESH), NMESH, DT, TSTOP)
- CALL DPOST(WS(IU), NU, K, WS(IMESH), NMESH, V, NV, TSTART, TSTOP
- 1 , DT, AF, BC, DEE, ERRPAR, HANDLE)
- CALL LEAVE
- CALL WRAPUP
- STOP
- END
- SUBROUTINE AF(T, XI, NX, U, UX, UT, UTX, NU, V, VT, NV, A,
- 1 AU, AUX, AUT, AUTX, AV, AVT, F, FU, FUX, FUT, FUTX, FV, FVT)
- INTEGER NU, NV, NX
- DOUBLE PRECISION T, XI(NX), U(NX, NU), UX(NX, NU), UT(NX, NU),
- 1 UTX(NX, NU)
- DOUBLE PRECISION V(NV), VT(NV), A(NX, NU), AU(NX, NU, NU), AUX(NX,
- 1 NU, NU), AUT(NX, NU, NU)
- DOUBLE PRECISION AUTX(NX, NU, NU), AV(NX, NU, NV), AVT(NX, NU, NV)
- 1 , F(NX, NU), FU(NX, NU, NU), FUX(NX, NU, NU)
- DOUBLE PRECISION FUT(NX, NU, NU), FUTX(NX, NU, NU), FV(NX, NU, NV)
- 1 , FVT(NX, NU, NV)
- COMMON /DPOSTF/ FAILED
- LOGICAL FAILED
- INTEGER I
- DOUBLE PRECISION XXI(99), XTV(99), XVV(99), X(99), XXIV(99), AX(
- 1 99)
- DOUBLE PRECISION FX(99), XT(99), XV(99), DEXPL
- LOGICAL TEMP
- TEMP = V(2) .LE. V(1)
- IF (.NOT. TEMP) TEMP = V(2) .GE. V(3)
- IF (.NOT. TEMP) GOTO 1
- FAILED = .TRUE.
- RETURN
-C MAP XI INTO X.
- 1 CALL DLPLM(XI, NX, V, 3, X, XXI, XXIV, XV, XVV, XT, XTV)
-C MAP U INTO X SYSTEM.
- CALL DPOSTU(XI, X, XT, XXI, XV, VT, NX, 3, UX, UT, NU, AX, FX)
- DO 2 I = 1, NX
- A(I, 1) = -UX(I, 1)
- AUX(I, 1, 1) = -1
- F(I, 1) = (-UT(I, 1))-DEXPL((-X(I))*V(4))*(X(I)+V(4)**2)
- FUT(I, 1, 1) = -1
- FV(I, 1, 4) = (-DEXPL((-X(I))*V(4)))*(2D0*V(4)+(X(I)+V(4)**2)*(
- 1 -X(I)))
- FX(I) = (-DEXPL((-X(I))*V(4)))*(1D0-V(4)*X(I)-V(4)**3)
- 2 CONTINUE
-C MAP A AND F INTO XI SYSTEM.
- CALL DPOSTI(XI, X, XT, XXI, XV, XTV, XXIV, XVV, NX, UX, UT, NU, V,
- 1 VT, NV, 1, 3, A, AX, AU, AUX, AUT, AUTX, AV, AVT, F, FX, FU,
- 2 FUX, FUT, FUTX, FV, FVT)
- RETURN
- END
- SUBROUTINE BC(T, L, R, U, UX, UT, UTX, NU, V, VT, NV, B, BU,
- 1 BUX, BUT, BUTX, BV, BVT)
- INTEGER NU, NV
- DOUBLE PRECISION T, L, R, U(NU, 2), UX(NU, 2), UT(NU, 2)
- DOUBLE PRECISION UTX(NU, 2), V(NV), VT(NV), B(NU, 2), BU(NU, NU, 2
- 1 ), BUX(NU, NU, 2)
- DOUBLE PRECISION BUT(NU, NU, 2), BUTX(NU, NU, 2), BV(NU, NV, 2),
- 1 BVT(NU, NV, 2)
- DOUBLE PRECISION DEXPL
-C U(0,T) = 1
- B(1, 1) = U(1, 1)-1D0
-C U(1,T) = EXP(-T)
- B(1, 2) = U(1, 2)-DEXPL(-V(4))
- BU(1, 1, 1) = 1
- BU(1, 1, 2) = 1
- BV(1, 4, 2) = DEXPL(-V(4))
- RETURN
- END
- SUBROUTINE DEE(T, K, X, NX, U, UT, NU, NXMK, V, VT, NV, D,
- 1 DU, DUT, DV, DVT)
- INTEGER NXMK, NU, NV, NX
- INTEGER K
- DOUBLE PRECISION T, X(NX), U(NXMK, NU), UT(NXMK, NU), V(NV), VT(
- 1 NV)
- DOUBLE PRECISION D(NV), DU(NV, NXMK, NU), DUT(NV, NXMK, NU), DV(
- 1 NV, NV), DVT(NV, NV)
- COMMON /PARAM/ VC, XC, XI0
- DOUBLE PRECISION VC(4), XC(3), XI0
- INTEGER INTRVD, I, ILEFT
- DOUBLE PRECISION DEXP, BX(10), XX(1)
- INTEGER TEMP
- D(1) = V(1)
-C X(0,V) = 0.
- DV(1, 1) = 1
- XX(1) = XI0
- ILEFT = INTRVD(NX, X, XX(1))
-C GET THE B-SPLINE BASIS AT XX.
- CALL DBSPLN(K, X, NX, XX, 1, ILEFT, BX)
- D(2) = -DEXP(-1D0)
-C D(2) = W(XI0,T) - EXP(-1).
- DO 1 I = 1, K
- TEMP = ILEFT+I-K
- D(2) = D(2)+U(TEMP, 1)*BX(I)
- TEMP = ILEFT+I-K
- DU(2, TEMP, 1) = BX(I)
- 1 CONTINUE
- D(3) = V(3)-1D0
-C X(2,V) = 1.
- DV(3, 3) = 1
- D(4) = VT(4)-1D0
- DVT(4, 4) = 1
- RETURN
- END
- SUBROUTINE HANDLE(T0, U0, V0, T, U, V, NU, NXMK, NV, K, X,
- 1 NX, DT, TSTOP)
- INTEGER NXMK, NU, NV, NX
- INTEGER K
- DOUBLE PRECISION T0, U0(NXMK, NU), V0(NV), T, U(NXMK, NU), V(NV)
- DOUBLE PRECISION X(NX), DT, TSTOP
- COMMON /PARAM/ VC, XX, XI0
- DOUBLE PRECISION VC(4), XX(3), XI0
- COMMON /TIME/ TT
- DOUBLE PRECISION TT
- EXTERNAL UOFX
- INTEGER I1MACH
- DOUBLE PRECISION DEESFF, DLPLMT, EU, EV
- INTEGER TEMP
-C OUTPUT AND CHECKING ROUTINE.
- IF (T0 .NE. T) GOTO 2
- TEMP = I1MACH(2)
- WRITE (TEMP, 1) T, DT
- 1 FORMAT (16H RESTART FOR T =, 1PE10.2, 7H DT =, 1PE10.2)
- RETURN
-C LET DT CARRY V(2) DOWN BY NO MORE THAN A FACTOR OF 10.
- 2 DT = DLPLMT(T, V, NV, T0, V0, 1D-1, DT)
- TT = T
-C UOFX NEEDS V FOR MAPPING.
- CALL MOVEFD(NV, V, VC)
- EU = DEESFF(K, X, NX, U, UOFX)
-C ERROR IN POSITION OF BOUNDARY LAYER.
- EV = V(2)-1D0/XI0/T
- TEMP = I1MACH(2)
- WRITE (TEMP, 3) T, EU, EV
- 3 FORMAT (14H ERROR IN U(X,, 1PE10.2, 4H ) =, 1PE10.2, 6H V =, 1P
- 1 E10.2)
- RETURN
- END
- SUBROUTINE UOFX(XI, NX, U, W)
- INTEGER NX
- DOUBLE PRECISION XI(NX), U(NX), W(NX)
- COMMON /CSTAK/ DS
- DOUBLE PRECISION DS(500)
- COMMON /PARAM/ VC, X, XI0
- DOUBLE PRECISION VC(4), X(3), XI0
- COMMON /TIME/ T
- DOUBLE PRECISION T
- INTEGER IXV, IXX, ISTKGT, I, IS(1000)
- REAL RS(1000)
- LOGICAL LS(1000)
- COMPLEX CS(500)
- DOUBLE PRECISION WS(500), DEXPL
- INTEGER TEMP
- EQUIVALENCE (DS(1), CS(1), WS(1), RS(1), IS(1), LS(1))
-C THE PORT LIBRARY STACK AND ITS ALIASES.
- CALL ENTER(1)
- IXX = ISTKGT(NX, 4)
-C SPACE FOR X AND XV.
- IXV = ISTKGT(3*NX, 4)
-C MAP INTO USER SYSTEM.
- CALL DLPLMX(XI, NX, VC, 3, WS(IXX), WS(IXV))
- DO 1 I = 1, NX
- TEMP = IXX+I
- U(I) = DEXPL((-WS(TEMP-1))*T)
- 1 CONTINUE
- CALL LEAVE
- RETURN
- END
diff --git a/CEP/PyBDSM/src/port3/ex/dpostx8.f b/CEP/PyBDSM/src/port3/ex/dpostx8.f
deleted file mode 100644
index 3d31d53503655fa798b688f8339d80ddeebde3ed..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ex/dpostx8.f
+++ /dev/null
@@ -1,219 +0,0 @@
-C$TEST DPT8
-C TO RUN AS A MAIN PROGRAM REMOVE NEXT LINE
- SUBROUTINE DPT8
-C***********************************************************************
-C
-C EXAMPLE OF USE OF PORT PROGRAM DPOST
-C
-C***********************************************************************
- COMMON /CSTAK/ DS
- DOUBLE PRECISION DS(5000)
- COMMON /TIME/ T
- DOUBLE PRECISION T
- COMMON /KMESH/ K, NMESH
- INTEGER K, NMESH
- COMMON /CMESH/ MESH
- DOUBLE PRECISION MESH(100)
- EXTERNAL DEE, HANDLE, UOFX, BC, AF
- INTEGER NDX, I, IS(1000), NU, NV
- REAL ERRPAR(2), RS(1000)
- LOGICAL LS(1000)
- COMPLEX CS(500)
- DOUBLE PRECISION U(100), V(100), DT, WS(500), TSTOP
- INTEGER TEMP
- EQUIVALENCE (DS(1), CS(1), WS(1), RS(1), IS(1), LS(1))
-C TO TEST DPOST ON THE INTEGRO-PDE
-C U SUB T = 2 * U SUB XX - INT(0,1) EXP(X-Y)*U(Y) DY ON (0,1)
-C SUBJECT TO GIVEN DIRICHLET BCS, CHOSEN SO THAT THE SOLUTION IS
-C U(X,T) = EXP(T+X).
-C THE PORT LIBRARY STACK AND ITS ALIASES.
-C INITIALIZE THE PORT LIBRARY STACK LENGTH.
- CALL ISTKIN(5000, 4)
- NU = 1
- ERRPAR(1) = 0
-C ABSOLUTE ERROR.
- ERRPAR(2) = 1E-2
- TSTOP = 1
- DT = 1D-2
- K = 4
-C NDX UNIFORM MESH POINTS ON (0,1).
- NDX = 7
- CALL DUMB(0D0, 1D0, NDX, K, MESH, NMESH)
- NV = NMESH-K
-C UOFX NEEDS T.
- T = 0
-C ICS FOR U.
- CALL DL2SFF(UOFX, K, MESH, NMESH, U)
- TEMP = NMESH-K
- DO 1 I = 1, TEMP
- V(I) = U(I)
- 1 CONTINUE
-C ICS FOR V.
- CALL DPOST(U, NU, K, MESH, NMESH, V, NV, 0D0, TSTOP, DT, AF, BC,
- 1 DEE, ERRPAR, HANDLE)
- CALL WRAPUP
- STOP
- END
- SUBROUTINE AF(T, X, NX, U, UX, UT, UTX, NU, V, VT, NV, A,
- 1 AU, AUX, AUT, AUTX, AV, AVT, F, FU, FUX, FUT, FUTX, FV, FVT)
- INTEGER NU, NV, NX
- DOUBLE PRECISION T, X(NX), U(NX, NU), UX(NX, NU), UT(NX, NU), UTX(
- 1 NX, NU)
- DOUBLE PRECISION V(NV), VT(NV), A(NX, NU), AU(NX, NU, NU), AUX(NX,
- 1 NU, NU), AUT(NX, NU, NU)
- DOUBLE PRECISION AUTX(NX, NU, NU), AV(NX, NU, NV), AVT(NX, NU, NV)
- 1 , F(NX, NU), FU(NX, NU, NU), FUX(NX, NU, NU)
- DOUBLE PRECISION FUT(NX, NU, NU), FUTX(NX, NU, NU), FV(NX, NU, NV)
- 1 , FVT(NX, NU, NV)
- COMMON /KMESH/ K, NMESH
- INTEGER K, NMESH
- COMMON /CMESH/ MESH
- DOUBLE PRECISION MESH(100)
- INTEGER I
- DO 1 I = 1, NX
- A(I, 1) = 2D0*UX(I, 1)
- AUX(I, 1, 1) = 2
- F(I, 1) = UT(I, 1)
- FUT(I, 1, 1) = 1
- 1 CONTINUE
-C GET THE INTEGRAL.
- CALL INTGRL(K, MESH, NMESH, V, X, NX, F, FV)
- RETURN
- END
- SUBROUTINE BC(T, L, R, U, UX, UT, UTX, NU, V, VT, NV, B, BU,
- 1 BUX, BUT, BUTX, BV, BVT)
- INTEGER NU, NV
- DOUBLE PRECISION T, L, R, U(NU, 2), UX(NU, 2), UT(NU, 2)
- DOUBLE PRECISION UTX(NU, 2), V(NV), VT(NV), B(NU, 2), BU(NU, NU, 2
- 1 ), BUX(NU, NU, 2)
- DOUBLE PRECISION BUT(NU, NU, 2), BUTX(NU, NU, 2), BV(NU, NV, 2),
- 1 BVT(NU, NV, 2)
- DOUBLE PRECISION DEXP
- B(1, 1) = U(1, 1)-DEXP(T)
- B(1, 2) = U(1, 2)-DEXP(T+1D0)
- BU(1, 1, 1) = 1
- BU(1, 1, 2) = 1
- RETURN
- END
- SUBROUTINE DEE(T, K, X, NX, U, UT, NU, NXMK, V, VT, NV, D,
- 1 DU, DUT, DV, DVT)
- INTEGER NXMK, NU, NV, NX
- INTEGER K
- DOUBLE PRECISION T, X(NX), U(NXMK, NU), UT(NXMK, NU), V(NV), VT(
- 1 NV)
- DOUBLE PRECISION D(NV), DU(NV, NXMK, NU), DUT(NV, NXMK, NU), DV(
- 1 NV, NV), DVT(NV, NV)
- INTEGER I
- DO 1 I = 1, NXMK
- D(I) = U(I, 1)-V(I)
- DU(I, I, 1) = 1
- DV(I, I) = -1
- 1 CONTINUE
- RETURN
- END
- SUBROUTINE HANDLE(T0, U0, V0, T, U, V, NU, NXMK, NV, K, X,
- 1 NX, DT, TSTOP)
- INTEGER NXMK, NU, NV, NX
- INTEGER K
- DOUBLE PRECISION T0, U0(NXMK, NU), V0(NV), T, U(NXMK, NU), V(NV)
- DOUBLE PRECISION X(NX), DT, TSTOP
- COMMON /TIME/ TT
- DOUBLE PRECISION TT
- EXTERNAL UOFX
- INTEGER I1MACH
- DOUBLE PRECISION DEESFF, EU
- INTEGER TEMP
-C OUTPUT AND CHECKING ROUTINE.
- IF (T0 .NE. T) GOTO 2
- TEMP = I1MACH(2)
- WRITE (TEMP, 1) T0, DT
- 1 FORMAT (16H RESTART FOR T =, 1PE10.2, 7H DT =, 1PE10.2)
- RETURN
- 2 TT = T
- EU = DEESFF(K, X, NX, U, UOFX)
- TEMP = I1MACH(2)
- WRITE (TEMP, 3) T, EU
- 3 FORMAT (14H ERROR IN U(X,, 1PE10.2, 4H ) =, 1PE10.2)
- RETURN
- END
- SUBROUTINE UOFX(X, NX, U, W)
- INTEGER NX
- DOUBLE PRECISION X(NX), U(NX), W(NX)
- COMMON /TIME/ T
- DOUBLE PRECISION T
- INTEGER I
- DOUBLE PRECISION DEXP
- DO 1 I = 1, NX
- U(I) = DEXP(T+X(I))
- 1 CONTINUE
- RETURN
- END
- SUBROUTINE INTGRL(K, MESH, NMESH, V, X, NX, F, FV)
- INTEGER NX, NMESH
- INTEGER K
- DOUBLE PRECISION MESH(NMESH), V(1), X(NX), F(NX), FV(NX, 1)
- INTEGER MGQ, I, J, L, IX
- LOGICAL FIRST
- DOUBLE PRECISION EWE, KER, WGQ(3), XGQ(3), B(3, 4, 200), KERU
- DOUBLE PRECISION XX(3)
- INTEGER TEMP, TEMP1
- DATA FIRST/.TRUE./
-C TO COMPUTE
-C F = INTEGRAL FROM MESH(1) TO MESH(NMESH)
-C KERNEL(X,Y,SUM(I=1,...,NMESH-K) V(I)*B(I,Y)) DY
-C AND
-C FV = D(F)/D(V).
-C ASSUME THAT CALL KERNEL(X,Y,U,KER,KERU) RETURNS
-C KER = KERNEL(X,Y,U) AND
-C KERU = PARTIAL KERNEL / PARTIAL U.
-C V(NMESH-K),FV(NX,NMESH-K)
-C THE FOLLOWING DECLARATION IS SPECIFIC TO K = 4 SPLINES.
- IF (NMESH-K .GT. 200) CALL SETERR(27HINTGRL - NMESH-K .GT. NXMAX
- 1 , 27, 1, 2)
-C NEED MORE LOCAL SPACE.
- IF (K .NE. 4) CALL SETERR(17HINTGRL - K .NE. 4, 17, 2, 2)
-C USE K-1 POINT GAUSSIAN-QUADRATURE RULE ON EACH INTERVAL.
- MGQ = K-1
- IF (FIRST) CALL DGQM11(MGQ, XGQ, WGQ)
-C ONLY GET GQ RULE ONCE, ITS EXPENSIVE.
-C THE GAUSSIAN QUADRATURE RULE.
-C DO INTEGRAL INTERVAL BY INTERVAL.
- TEMP = NMESH-K
- DO 6 I = K, TEMP
-C G.Q. POINTS ON (MESH(I), MESH(I+1)).
- DO 1 J = 1, MGQ
- XX(J) = 0.5*(MESH(I+1)+MESH(I))+0.5*(MESH(I+1)-MESH(I))*XGQ(
- 1 J)
- 1 CONTINUE
- IF (FIRST) CALL DBSPLN(K, MESH, NMESH, XX, MGQ, I, B(1, 1, I))
-C ONLY GET B-SPLINE BASIS ONCE, ITS EXPENSIVE.
- DO 5 J = 1, MGQ
-C GET SUM() V()*B()(XX).
- EWE = 0
- DO 2 L = 1, K
- TEMP1 = I+L-K
- EWE = EWE+V(TEMP1)*B(J, L, I)
- 2 CONTINUE
- DO 4 IX = 1, NX
-C GET KERNEL AND PARTIAL.
- CALL KERNEL(X(IX), XX(J), EWE, KER, KERU)
- F(IX) = F(IX)+0.5*KER*(MESH(I+1)-MESH(I))*WGQ(J)
- DO 3 L = 1, K
- TEMP1 = I+L-K
- FV(IX, TEMP1) = FV(IX, TEMP1)+0.5*B(J, L, I)*KERU*(
- 1 MESH(I+1)-MESH(I))*WGQ(J)
- 3 CONTINUE
- 4 CONTINUE
- 5 CONTINUE
- 6 CONTINUE
- FIRST = .FALSE.
- RETURN
- END
- SUBROUTINE KERNEL(X, Y, U, KER, KERU)
- DOUBLE PRECISION X, Y, U, KER, KERU
- DOUBLE PRECISION DEXP
-C TO EVALUATE THE KERNEL EXP(X-Y)*U(Y) AND ITS PARTIAL WRT. U.
- KERU = DEXP(X-Y)
- KER = KERU*U
- RETURN
- END
diff --git a/CEP/PyBDSM/src/port3/ex/dpostx9.f b/CEP/PyBDSM/src/port3/ex/dpostx9.f
deleted file mode 100644
index f4b1c4a634ebdc9e78bf8d0b70987dba685a2987..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ex/dpostx9.f
+++ /dev/null
@@ -1,159 +0,0 @@
-C$TEST DPT9
-C TO RUN AS A MAIN PROGRAM REMOVE NEXT LINE
- SUBROUTINE DPT9
-C***********************************************************************
-C
-C EXAMPLE OF USE OF PORT PROGRAM DPOST
-C
-C***********************************************************************
- COMMON /CSTAK/ DS
- DOUBLE PRECISION DS(2000)
- COMMON /PARAM/ C
- DOUBLE PRECISION C
- EXTERNAL HANDLE, DPOSTD, BC, AF
- INTEGER NDX, NXC, NXX, I, K, IS(1000)
- INTEGER NU, NV, NX, I1MACH
- REAL ERRPAR(2), RS(1000)
- LOGICAL LS(1000)
- COMPLEX CS(500)
- DOUBLE PRECISION DEEBSF, EWE(1000), ERR, U(100), V(1), X(100)
- DOUBLE PRECISION ERRR, DT, XC(100), UC(100), WS(500), XX(1000)
- DOUBLE PRECISION D1MACH, TSTOP
- INTEGER TEMP
- EQUIVALENCE (DS(1), CS(1), WS(1), RS(1), IS(1), LS(1))
-C TO TEST DPOST ON AUTOMATIC, STATIC MESH REFINEMENT.
-C U SUB T = U SUB XX + C * U SUB X ON (0,1)
-C THE SOLUTION IS
-C U(X,T) = EXP(-C*X).
-C THE PORT LIBRARY STACK AND ITS ALIASES.
-C INITIALIZE THE PORT LIBRARY STACK LENGTH.
- CALL ISTKIN(2000, 4)
- C = 50
- NU = 1
- NV = 0
- ERRPAR(1) = 1E-1
- ERRPAR(2) = 1E-1
- K = 4
- NDX = 8
- CALL DUMB(0D0, 1D0, NDX, K, XC, NXC)
-C INITIAL CONDITIONS FOR UC.
- CALL SETD(NXC-K, 0D0, UC)
-C INFINITY.
- ERR = D1MACH(2)
- 1 IF (ERR .LE. 1D-2) GOTO 6
-C HALVE THE CRUDE X.
- CALL DLUMB(XC, NXC, 3, K, X, NX)
-C FITTING POINTS FOR REFINEMENT.
- CALL DLUMD(X, NX, K, XX, NXX)
-C UC ON XX.
- CALL DSPLNE(K, XC, NXC, UC, XX, NXX, EWE)
-C FIT U TO UC ON MESH.
- CALL DDL2SF(XX, EWE, NXX, K, X, NX, U)
- TSTOP = 1D0/D1MACH(4)
- DT = 1D-6
- I = NX-2*(K-1)
- TEMP = I1MACH(2)
- WRITE (TEMP, 2) I
- 2 FORMAT (18H SOLVING FOR NDX =, I3)
- CALL DPOST(U, NU, K, X, NX, V, NV, 0D0, TSTOP, DT, AF, BC,
- 1 DPOSTD, ERRPAR, HANDLE)
-C GET RUN-TIME STATISTICS.
- CALL DPOSTX
-C ERROR ESTIMATE FOR UC.
- ERR = DEEBSF(K, XC, NXC, UC, X, NX, U)
-C ERROR ESTIMATE FOR U.
- ERRR = ERR/16D0
- TEMP = I1MACH(2)
- WRITE (TEMP, 3) ERR, ERRR
- 3 FORMAT (21H ERROR ESTIMATES UC =, 1PE10.2, 9H AND U =, 1P
- 1 E10.2)
- NXC = NX
- DO 4 I = 1, NX
- XC(I) = X(I)
- 4 CONTINUE
- TEMP = NX-K
- DO 5 I = 1, TEMP
- UC(I) = U(I)
- 5 CONTINUE
- GOTO 1
- 6 STOP
- END
- SUBROUTINE AF(T, X, NX, U, UX, UT, UTX, NU, V, VT, NV, A,
- 1 AU, AUX, AUT, AUTX, AV, AVT, F, FU, FUX, FUT, FUTX, FV, FVT)
- INTEGER NU, NX
- INTEGER NV
- DOUBLE PRECISION T, X(NX), U(NX, NU), UX(NX, NU), UT(NX, NU), UTX(
- 1 NX, NU)
- DOUBLE PRECISION V(1), VT(1), A(NX, NU), AU(NX, NU, NU), AUX(NX,
- 1 NU, NU), AUT(NX, NU, NU)
- DOUBLE PRECISION AUTX(NX, NU, NU), AV(1), AVT(1), F(NX, NU), FU(
- 1 NX, NU, NU), FUX(NX, NU, NU)
- DOUBLE PRECISION FUT(NX, NU, NU), FUTX(NX, NU, NU), FV(1), FVT(1)
- COMMON /PARAM/ C
- DOUBLE PRECISION C
- INTEGER I
- DO 1 I = 1, NX
- A(I, 1) = UX(I, 1)+C*U(I, 1)
- AUX(I, 1, 1) = 1
- AU(I, 1, 1) = C
- F(I, 1) = UT(I, 1)
- FUT(I, 1, 1) = 1
- 1 CONTINUE
- RETURN
- END
- SUBROUTINE BC(T, L, R, U, UX, UT, UTX, NU, V, VT, NV, B, BU,
- 1 BUX, BUT, BUTX, BV, BVT)
- INTEGER NU
- INTEGER NV
- DOUBLE PRECISION T, L, R, U(NU, 2), UX(NU, 2), UT(NU, 2)
- DOUBLE PRECISION UTX(NU, 2), V(1), VT(1), B(NU, 2), BU(NU, NU, 2),
- 1 BUX(NU, NU, 2)
- DOUBLE PRECISION BUT(NU, NU, 2), BUTX(NU, NU, 2), BV(1), BVT(1)
- COMMON /PARAM/ C
- DOUBLE PRECISION C
- DOUBLE PRECISION DEXP
- B(1, 1) = U(1, 1)-1D0
- B(1, 2) = U(1, 2)-DEXP(-C)
- BU(1, 1, 1) = 1
- BU(1, 1, 2) = 1
- RETURN
- END
- SUBROUTINE HANDLE(T0, U0, V0, T, U, V, NU, NXMK, NV, K, X,
- 1 NX, DT, TSTOP)
- INTEGER NXMK, NU, NX
- INTEGER NV, K
- DOUBLE PRECISION T0, U0(NXMK, NU), V0(1), T, U(NXMK, NU), V(1)
- DOUBLE PRECISION X(NX), DT, TSTOP
- COMMON /TIME/ TT
- DOUBLE PRECISION TT
- EXTERNAL UOFX
- INTEGER I1MACH
- DOUBLE PRECISION DEESFF, EU
- INTEGER TEMP
-C OUTPUT AND CHECKING ROUTINE.
- IF (T0 .NE. T) GOTO 2
- TEMP = I1MACH(2)
- WRITE (TEMP, 1) T
- 1 FORMAT (16H RESTART FOR T =, 1PE10.2)
- RETURN
- 2 TT = T
- EU = DEESFF(K, X, NX, U, UOFX)
- TEMP = I1MACH(2)
- WRITE (TEMP, 3) T, EU
- 3 FORMAT (15H ERROR IN U(X, , 1PE10.2, 4H ) =, 1PE10.2)
- RETURN
- END
- SUBROUTINE UOFX(X, NX, U, W)
- INTEGER NX
- DOUBLE PRECISION X(NX), U(NX), W(NX)
- COMMON /PARAM/ C
- DOUBLE PRECISION C
- COMMON /TIME/ T
- DOUBLE PRECISION T
- INTEGER I
- DOUBLE PRECISION DEXP
- DO 1 I = 1, NX
- U(I) = DEXP((-C)*X(I))
- 1 CONTINUE
- RETURN
- END
diff --git a/CEP/PyBDSM/src/port3/ex/dpt1.f b/CEP/PyBDSM/src/port3/ex/dpt1.f
deleted file mode 100644
index c647e1b14bc5773453bb69368ef673f512af1b49..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ex/dpt1.f
+++ /dev/null
@@ -1,113 +0,0 @@
-C$TEST DPT1
-C TO RUN AS A MAIN PROGRAM REMOVE NEXT LINE
- SUBROUTINE DPT1
-C***********************************************************************
-C
-C EXAMPLE OF USE OF PORT PROGRAM DPOST
-C
-C***********************************************************************
- COMMON /CSTAK/ DS
- DOUBLE PRECISION DS(1000)
- EXTERNAL HANDLE, DPOSTD, BC, AF
- INTEGER NDX, K, IS(1000), NU, NV, NMESH
- REAL ERRPAR(2), RS(1000)
- LOGICAL LS(1000)
- COMPLEX CS(500)
- DOUBLE PRECISION U(100), V(1), MESH(100), DT, WS(500), TSTOP
- EQUIVALENCE (DS(1), CS(1), WS(1), RS(1), IS(1), LS(1))
-C TO TEST DPOST ON
-C U SUB T = U SUB XX + F ON (0,1)
-C WHERE F IS CHOSEN SO THAT THE SOLUTION IS
-C U(X,T) = EXP(XT).
-C THE PORT LIBRARY STACK AND ITS ALIASES.
-C INITIALIZE THE PORT LIBRARY STACK LENGTH.
- CALL ISTKIN(1000, 4)
- NU = 1
- NV = 0
- ERRPAR(1) = 0
-C ABSOLUTE ERROR.
- ERRPAR(2) = 1E-2
- TSTOP = 1
- DT = 1D-2
- K = 4
-C NDX UNIFORM MESH POINTS ON (0,1).
- NDX = 4
- CALL DUMB(0D0, 1D0, NDX, K, MESH, NMESH)
-C INITIAL CONDITIONS FOR U.
- CALL SETD(NMESH-K, 1D0, U)
- CALL DPOST(U, NU, K, MESH, NMESH, V, NV, 0D0, TSTOP, DT, AF, BC,
- 1 DPOSTD, ERRPAR, HANDLE)
-C CHECK FOR ERRORS AND STACK USAGE STATISTICS.
- CALL WRAPUP
- STOP
- END
- SUBROUTINE AF(T, X, NX, U, UX, UT, UTX, NU, V, VT, NV, A,
- 1 AU, AUX, AUT, AUTX, AV, AVT, F, FU, FUX, FUT, FUTX, FV, FVT)
- INTEGER NU, NX
- INTEGER NV
- DOUBLE PRECISION T, X(NX), U(NX, NU), UX(NX, NU), UT(NX, NU), UTX(
- 1 NX, NU)
- DOUBLE PRECISION V(1), VT(1), A(NX, NU), AU(NX, NU, NU), AUX(NX,
- 1 NU, NU), AUT(NX, NU, NU)
- DOUBLE PRECISION AUTX(NX, NU, NU), AV(1), AVT(1), F(NX, NU), FU(
- 1 NX, NU, NU), FUX(NX, NU, NU)
- DOUBLE PRECISION FUT(NX, NU, NU), FUTX(NX, NU, NU), FV(1), FVT(1)
- INTEGER I
- DOUBLE PRECISION DEXP
- DO 1 I = 1, NX
- A(I, 1) = -UX(I, 1)
- AUX(I, 1, 1) = -1
- F(I, 1) = (X(I)-T**2)*DEXP(X(I)*T)-UT(I, 1)
- FUT(I, 1, 1) = -1
- 1 CONTINUE
- RETURN
- END
- SUBROUTINE BC(T, L, R, U, UX, UT, UTX, NU, V, VT, NV, B, BU,
- 1 BUX, BUT, BUTX, BV, BVT)
- INTEGER NU
- INTEGER NV
- DOUBLE PRECISION T, L, R, U(NU, 2), UX(NU, 2), UT(NU, 2)
- DOUBLE PRECISION UTX(NU, 2), V(1), VT(1), B(NU, 2), BU(NU, NU, 2),
- 1 BUX(NU, NU, 2)
- DOUBLE PRECISION BUT(NU, NU, 2), BUTX(NU, NU, 2), BV(1), BVT(1)
- DOUBLE PRECISION DEXP
- B(1, 1) = U(1, 1)-1D0
- B(1, 2) = U(1, 2)-DEXP(T)
- BU(1, 1, 1) = 1
- BU(1, 1, 2) = 1
- RETURN
- END
- SUBROUTINE HANDLE(T0, U0, V0, T, U, V, NU, NXMK, NV, K, X,
- 1 NX, DT, TSTOP)
- INTEGER NXMK, NU, NX
- INTEGER NV, K
- DOUBLE PRECISION T0, U0(NXMK, NU), V0(1), T, U(NXMK, NU), V(1)
- DOUBLE PRECISION X(NX), DT, TSTOP
- COMMON /TIME/ TT
- DOUBLE PRECISION TT
- EXTERNAL UOFX
- INTEGER I1MACH
- DOUBLE PRECISION DEESFF, EU
- INTEGER TEMP
-C OUTPUT AND CHECKING ROUTINE.
- IF (T0 .EQ. T) RETURN
-C UOFX NEEDS TIME.
- TT = T
- EU = DEESFF(K, X, NX, U, UOFX)
- TEMP = I1MACH(2)
- WRITE (TEMP, 1) T, EU
- 1 FORMAT (14H ERROR IN U(X,, 1PE10.2, 4H ) =, 1PE10.2)
- RETURN
- END
- SUBROUTINE UOFX(X, NX, U, W)
- INTEGER NX
- DOUBLE PRECISION X(NX), U(NX), W(NX)
- COMMON /TIME/ T
- DOUBLE PRECISION T
- INTEGER I
- DOUBLE PRECISION DEXP
- DO 1 I = 1, NX
- U(I) = DEXP(X(I)*T)
- 1 CONTINUE
- RETURN
- END
diff --git a/CEP/PyBDSM/src/port3/ex/dpt2.f b/CEP/PyBDSM/src/port3/ex/dpt2.f
deleted file mode 100644
index 7a3f642e408e5b61e05016233f1ad0ee2970635f..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ex/dpt2.f
+++ /dev/null
@@ -1,138 +0,0 @@
-C$TEST DPT2
-C TO RUN AS A MAIN PROGRAM REMOVE NEXT LINE
- SUBROUTINE DPT2
-C***********************************************************************
-C
-C EXAMPLE OF USE OF PORT PROGRAM DPOST
-C
-C***********************************************************************
- COMMON /CSTAK/ DS
- DOUBLE PRECISION DS(1100)
- EXTERNAL HANDLE, DPOSTD, BC, AF
- INTEGER NDX, K, IS(1000), NU, NV, NMESH
- REAL ERRPAR(2), RS(1000)
- LOGICAL LS(1000)
- COMPLEX CS(500)
- DOUBLE PRECISION U(200), V(1), MESH(100), DT, WS(500), TSTOP
- INTEGER TEMP
- EQUIVALENCE (DS(1), CS(1), WS(1), RS(1), IS(1), LS(1))
-C TO TEST DPOST ON
-C U SUB T = U SUB XX + F ON (0,1)
-C BY SETTING U1 = U AND U2 = U1 SUB X AND SOLVING
-C U1 SUB T = U1 SUB XX + F
-C ON (0,1)
-C U1 SUB X = U2
-C WHERE F IS CHOSEN SO THAT THE SOLUTION IS
-C U(X,T) = EXP(XT).
-C THE PORT LIBRARY STACK AND ITS ALIASES.
-C INITIALIZE THE PORT LIBRARY STACK LENGTH.
- CALL ISTKIN(1100, 4)
- NU = 2
- NV = 0
- ERRPAR(1) = 0
-C ABSOLUTE ERROR.
- ERRPAR(2) = 1E-2
- TSTOP = 1
- DT = 1D-2
- K = 4
-C NDX UNIFORM MESH POINTS ON (0,1).
- NDX = 4
- CALL DUMB(0D0, 1D0, NDX, K, MESH, NMESH)
-C INITIAL CONDITIONS FOR U1.
- CALL SETD(NMESH-K, 1D0, U)
-C INITIAL CONDITIONS FOR U2.
- TEMP = NMESH-K
- CALL SETD(NMESH-K, 0D0, U(TEMP+1))
- CALL DPOST(U, NU, K, MESH, NMESH, V, NV, 0D0, TSTOP, DT, AF, BC,
- 1 DPOSTD, ERRPAR, HANDLE)
-C CHECK FOR ERRORS AND STACK USAGE STATISTICS.
- CALL WRAPUP
- STOP
- END
- SUBROUTINE AF(T, X, NX, U, UX, UT, UTX, NU, V, VT, NV, A,
- 1 AU, AUX, AUT, AUTX, AV, AVT, F, FU, FUX, FUT, FUTX, FV, FVT)
- INTEGER NU, NX
- INTEGER NV
- DOUBLE PRECISION T, X(NX), U(NX, NU), UX(NX, NU), UT(NX, NU), UTX(
- 1 NX, NU)
- DOUBLE PRECISION V(1), VT(1), A(NX, NU), AU(NX, NU, NU), AUX(NX,
- 1 NU, NU), AUT(NX, NU, NU)
- DOUBLE PRECISION AUTX(NX, NU, NU), AV(1), AVT(1), F(NX, NU), FU(
- 1 NX, NU, NU), FUX(NX, NU, NU)
- DOUBLE PRECISION FUT(NX, NU, NU), FUTX(NX, NU, NU), FV(1), FVT(1)
- INTEGER I
- DOUBLE PRECISION DEXP
- DO 1 I = 1, NX
- A(I, 1) = -U(I, 2)
- AU(I, 1, 2) = -1
- F(I, 1) = (X(I)-T**2)*DEXP(X(I)*T)-UT(I, 1)
- FUT(I, 1, 1) = -1
- A(I, 2) = U(I, 1)
- AU(I, 2, 1) = 1
- F(I, 2) = U(I, 2)
- FU(I, 2, 2) = 1
- 1 CONTINUE
- RETURN
- END
- SUBROUTINE BC(T, L, R, U, UX, UT, UTX, NU, V, VT, NV, B, BU,
- 1 BUX, BUT, BUTX, BV, BVT)
- INTEGER NU
- INTEGER NV
- DOUBLE PRECISION T, L, R, U(NU, 2), UX(NU, 2), UT(NU, 2)
- DOUBLE PRECISION UTX(NU, 2), V(1), VT(1), B(NU, 2), BU(NU, NU, 2),
- 1 BUX(NU, NU, 2)
- DOUBLE PRECISION BUT(NU, NU, 2), BUTX(NU, NU, 2), BV(1), BVT(1)
- DOUBLE PRECISION DEXP
- B(1, 1) = U(1, 1)-1D0
- B(1, 2) = U(1, 2)-DEXP(T)
- BU(1, 1, 1) = 1
- BU(1, 1, 2) = 1
- RETURN
- END
- SUBROUTINE HANDLE(T0, U0, V0, T, U, V, NU, NXMK, NV, K, X,
- 1 NX, DT, TSTOP)
- INTEGER NXMK, NU, NX
- INTEGER NV, K
- DOUBLE PRECISION T0, U0(NXMK, NU), V0(1), T, U(NXMK, NU), V(1)
- DOUBLE PRECISION X(NX), DT, TSTOP
- COMMON /TIME/ TT
- DOUBLE PRECISION TT
- EXTERNAL U1OFX, U2OFX
- INTEGER I1MACH
- DOUBLE PRECISION DEESFF, EU(2)
- INTEGER TEMP
-C OUTPUT AND CHECKING ROUTINE.
- IF (T0 .EQ. T) RETURN
-C U1OFX AND U2OFX NEED TIME.
- TT = T
- EU(1) = DEESFF(K, X, NX, U, U1OFX)
- EU(2) = DEESFF(K, X, NX, U(1, 2), U2OFX)
- TEMP = I1MACH(2)
- WRITE (TEMP, 1) T, EU
- 1 FORMAT (14H ERROR IN U(X,, 1PE10.2, 4H ) =, 2(1PE10.2))
- RETURN
- END
- SUBROUTINE U1OFX(X, NX, U, W)
- INTEGER NX
- DOUBLE PRECISION X(NX), U(NX), W(NX)
- COMMON /TIME/ T
- DOUBLE PRECISION T
- INTEGER I
- DOUBLE PRECISION DEXP
- DO 1 I = 1, NX
- U(I) = DEXP(X(I)*T)
- 1 CONTINUE
- RETURN
- END
- SUBROUTINE U2OFX(X, NX, U, W)
- INTEGER NX
- DOUBLE PRECISION X(NX), U(NX), W(NX)
- COMMON /TIME/ T
- DOUBLE PRECISION T
- INTEGER I
- DOUBLE PRECISION DEXP
- DO 1 I = 1, NX
- U(I) = T*DEXP(X(I)*T)
- 1 CONTINUE
- RETURN
- END
diff --git a/CEP/PyBDSM/src/port3/ex/dpt3.f b/CEP/PyBDSM/src/port3/ex/dpt3.f
deleted file mode 100644
index a0c407b70c39fb6abc47169412be0b01eaf6582f..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ex/dpt3.f
+++ /dev/null
@@ -1,149 +0,0 @@
-C$TEST DPT3
-C TO RUN AS A MAIN PROGRAM REMOVE NEXT LINE
- SUBROUTINE DPT3
-C***********************************************************************
-C
-C EXAMPLE OF USE OF PORT PROGRAM DPOST
-C
-C***********************************************************************
- COMMON /CSTAK/ DS
- DOUBLE PRECISION DS(2000)
- EXTERNAL DEE, HANDLE, BC, AF
- INTEGER NDX, K, IS(1000), NU, NV, NMESH
- REAL ERRPAR(2), RS(1000)
- LOGICAL LS(1000)
- COMPLEX CS(500)
- DOUBLE PRECISION U(100), V(1), MESH(100), DT, WS(500), TSTOP
- EQUIVALENCE (DS(1), CS(1), WS(1), RS(1), IS(1), LS(1))
-C TO TEST DPOST ON
-C U SUB T = U SUB XX + V + F ON (0,1)
-C V SUB T = U( 1/2, T )
-C WHERE F IS CHOSEN SO THAT THE SOLUTION IS
-C U(X,T) = COS(XT) AND V(T) = 2 SIN(T/2).
-C THE PORT LIBRARY STACK AND ITS ALIASES.
-C INITIALIZE THE PORT LIBRARY STACK LENGTH.
- CALL ISTKIN(2000, 4)
- NU = 1
- NV = 1
- ERRPAR(1) = 1E-2
-C ESSENTIALLY RELATIVE ERROR.
- ERRPAR(2) = 1E-6
- TSTOP = 1
- DT = 1D-6
- K = 4
- NDX = 4
-C NDX UNIFORM MESH POINTS ON (0,1).
- CALL DUMB(0D0, 1D0, NDX, K, MESH, NMESH)
-C INITIAL CONDITIONS FOR U.
- CALL SETD(NMESH-K, 1D0, U)
-C INITIAL VALUE FOR V.
- V(1) = 0
- CALL DPOST(U, NU, K, MESH, NMESH, V, NV, 0D0, TSTOP, DT, AF, BC,
- 1 DEE, ERRPAR, HANDLE)
-C CHECK FOR ERRORS AND STACK USAGE STATISTICS.
- CALL WRAPUP
- STOP
- END
- SUBROUTINE AF(T, X, NX, U, UX, UT, UTX, NU, V, VT, NV, A,
- 1 AU, AUX, AUT, AUTX, AV, AVT, F, FU, FUX, FUT, FUTX, FV, FVT)
- INTEGER NU, NV, NX
- DOUBLE PRECISION T, X(NX), U(NX, NU), UX(NX, NU), UT(NX, NU), UTX(
- 1 NX, NU)
- DOUBLE PRECISION V(NV), VT(NV), A(NX, NU), AU(NX, NU, NU), AUX(NX,
- 1 NU, NU), AUT(NX, NU, NU)
- DOUBLE PRECISION AUTX(NX, NU, NU), AV(NX, NU, NV), AVT(NX, NU, NV)
- 1 , F(NX, NU), FU(NX, NU, NU), FUX(NX, NU, NU)
- DOUBLE PRECISION FUT(NX, NU, NU), FUTX(NX, NU, NU), FV(NX, NU, NV)
- 1 , FVT(NX, NU, NV)
- INTEGER I
- DOUBLE PRECISION DCOS, DSIN
- DO 1 I = 1, NX
- A(I, 1) = -UX(I, 1)
- AUX(I, 1, 1) = -1
- F(I, 1) = V(1)-UT(I, 1)-X(I)*DSIN(X(I)*T)+T**2*DCOS(X(I)*T)-
- 1 2D0*DSIN(T/2D0)
- FUT(I, 1, 1) = -1
- FV(I, 1, 1) = 1
- 1 CONTINUE
- RETURN
- END
- SUBROUTINE BC(T, L, R, U, UX, UT, UTX, NU, V, VT, NV, B, BU,
- 1 BUX, BUT, BUTX, BV, BVT)
- INTEGER NU, NV
- DOUBLE PRECISION T, L, R, U(NU, 2), UX(NU, 2), UT(NU, 2)
- DOUBLE PRECISION UTX(NU, 2), V(NV), VT(NV), B(NU, 2), BU(NU, NU, 2
- 1 ), BUX(NU, NU, 2)
- DOUBLE PRECISION BUT(NU, NU, 2), BUTX(NU, NU, 2), BV(NU, NV, 2),
- 1 BVT(NU, NV, 2)
- DOUBLE PRECISION DCOS
- B(1, 1) = U(1, 1)-1D0
- B(1, 2) = U(1, 2)-DCOS(T)
- BU(1, 1, 1) = 1
- BU(1, 1, 2) = 1
- RETURN
- END
- SUBROUTINE DEE(T, K, X, NX, U, UT, NU, NXMK, V, VT, NV, D,
- 1 DU, DUT, DV, DVT)
- INTEGER NXMK, NU, NV, NX
- INTEGER K
- DOUBLE PRECISION T, X(NX), U(NXMK, NU), UT(NXMK, NU), V(NV), VT(
- 1 NV)
- DOUBLE PRECISION D(NV), DU(NV, NXMK, NU), DUT(NV, NXMK, NU), DV(
- 1 NV, NV), DVT(NV, NV)
- INTEGER INTRVD, I, ILEFT
- DOUBLE PRECISION XI(1), BASIS(10)
- INTEGER TEMP
- XI(1) = 0.5D0
-C FIND 0.5 IN MESH.
- ILEFT = INTRVD(NX, X, XI(1))
- IF (K .GT. 10) CALL SETERR(
- 1 41HDEE - K .GT. 10, NEED MORE SPACE IN BASIS, 41, 1, 2)
-C B-SPLINE BASIS AT XI(1).
- CALL DBSPLN(K, X, NX, XI, 1, ILEFT, BASIS)
- D(1) = VT(1)
- DVT(1, 1) = 1
-C VT(1) - U(0.5,T) = 0.
- DO 1 I = 1, K
- TEMP = ILEFT+I-K
- D(1) = D(1)-U(TEMP, 1)*BASIS(I)
- TEMP = ILEFT+I-K
- DU(1, TEMP, 1) = DU(1, TEMP, 1)-BASIS(I)
- 1 CONTINUE
- RETURN
- END
- SUBROUTINE HANDLE(T0, U0, V0, T, U, V, NU, NXMK, NV, K, X,
- 1 NX, DT, TSTOP)
- INTEGER NXMK, NU, NV, NX
- INTEGER K
- DOUBLE PRECISION T0, U0(NXMK, NU), V0(NV), T, U(NXMK, NU), V(NV)
- DOUBLE PRECISION X(NX), DT, TSTOP
- COMMON /TIME/ TT
- DOUBLE PRECISION TT
- EXTERNAL UOFX
- INTEGER I1MACH
- DOUBLE PRECISION DEESFF, DABS, DSIN, EU, EV
- INTEGER TEMP
-C OUTPUT AND CHECKING ROUTINE.
- IF (T0 .EQ. T) RETURN
-C UOFX NEEDS TIME.
- TT = T
- EU = DEESFF(K, X, NX, U, UOFX)
- EV = DABS(V(1)-2D0*DSIN(T/2D0))
- TEMP = I1MACH(2)
- WRITE (TEMP, 1) T, EU, EV
- 1 FORMAT (14H ERROR IN U(X,, 1PE10.2, 4H ) =, 1PE10.2, 6H V =, 1P
- 1 E10.2)
- RETURN
- END
- SUBROUTINE UOFX(X, NX, U, W)
- INTEGER NX
- DOUBLE PRECISION X(NX), U(NX), W(NX)
- COMMON /TIME/ T
- DOUBLE PRECISION T
- INTEGER I
- DOUBLE PRECISION DCOS
- DO 1 I = 1, NX
- U(I) = DCOS(X(I)*T)
- 1 CONTINUE
- RETURN
- END
diff --git a/CEP/PyBDSM/src/port3/ex/dpt4.f b/CEP/PyBDSM/src/port3/ex/dpt4.f
deleted file mode 100644
index f191ef85b65d1f811c66ac3f037d4633ad1eb87f..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ex/dpt4.f
+++ /dev/null
@@ -1,139 +0,0 @@
-C$TEST DPT4
-C TO RUN AS A MAIN PROGRAM REMOVE NEXT LINE
- SUBROUTINE DPT4
-C***********************************************************************
-C
-C EXAMPLE OF USE OF PORT PROGRAM DPOST
-C
-C***********************************************************************
- COMMON /CSTAK/ DS
- DOUBLE PRECISION DS(2000)
- EXTERNAL DEE, HANDLE, BC, AF
- INTEGER NDX, K, IS(1000), NU, NV, NMESH
- REAL ERRPAR(2), RS(1000)
- LOGICAL LS(1000)
- COMPLEX CS(500)
- DOUBLE PRECISION U(100), V(1), MESH(100), DT, DATAN, WS(500)
- DOUBLE PRECISION TSTOP
- EQUIVALENCE (DS(1), CS(1), WS(1), RS(1), IS(1), LS(1))
-C TO TEST DPOST ON
-C U SUB T = U SUB XX - U**3 + F ON (-PI,+PI)
-C SUBJECT TO PERIODIC BOUNDARY CONDITIONS,
-C WHERE F IS CHOSEN SO THAT THE SOLUTION IS
-C U(X,T) = COS(X)*SIN(T).
-C THE PORT LIBRARY STACK AND ITS ALIASES.
-C INITIALIZE THE PORT LIBRARY STACK LENGTH.
- CALL ISTKIN(2000, 4)
- NU = 1
- NV = 1
- ERRPAR(1) = 0
-C ABSOLUTE ERROR.
- ERRPAR(2) = 1E-2
- TSTOP = 8D0*DATAN(1D0)
- DT = 0.4
-C MAKE A MESH OF NDX UNIFORM POINTS ON (-PI,+PI).
- K = 4
- NDX = 7
- CALL DUMB((-4D0)*DATAN(1D0), 4D0*DATAN(1D0), NDX, K, MESH, NMESH)
-C INITIAL CONDITIONS FOR U.
- CALL SETD(NMESH-K, 0D0, U)
-C INITIAL CONDITIONS FOR V.
- V(1) = 0
- CALL DPOST(U, NU, K, MESH, NMESH, V, NV, 0D0, TSTOP, DT, AF, BC,
- 1 DEE, ERRPAR, HANDLE)
-C CHECK FOR ERRORS AND STACK USAGE STATISTICS.
- CALL WRAPUP
- STOP
- END
- SUBROUTINE AF(T, X, NX, U, UX, UT, UTX, NU, V, VT, NV, A,
- 1 AU, AUX, AUT, AUTX, AV, AVT, F, FU, FUX, FUT, FUTX, FV, FVT)
- INTEGER NU, NV, NX
- DOUBLE PRECISION T, X(NX), U(NX, NU), UX(NX, NU), UT(NX, NU), UTX(
- 1 NX, NU)
- DOUBLE PRECISION V(NV), VT(NV), A(NX, NU), AU(NX, NU, NU), AUX(NX,
- 1 NU, NU), AUT(NX, NU, NU)
- DOUBLE PRECISION AUTX(NX, NU, NU), AV(NX, NU, NV), AVT(NX, NU, NV)
- 1 , F(NX, NU), FU(NX, NU, NU), FUX(NX, NU, NU)
- DOUBLE PRECISION FUT(NX, NU, NU), FUTX(NX, NU, NU), FV(NX, NU, NV)
- 1 , FVT(NX, NU, NV)
- INTEGER I
- DOUBLE PRECISION DCOS, DSIN
- DO 1 I = 1, NX
- A(I, 1) = -UX(I, 1)
- AUX(I, 1, 1) = -1
- F(I, 1) = (-UT(I, 1))-U(I, 1)**3+DCOS(X(I))*(DCOS(T)+DSIN(T)+
- 1 DCOS(X(I))**2*DSIN(T)**3)
- FUT(I, 1, 1) = -1
- FU(I, 1, 1) = (-3D0)*U(I, 1)**2
- 1 CONTINUE
- RETURN
- END
- SUBROUTINE BC(T, L, R, U, UX, UT, UTX, NU, V, VT, NV, B, BU,
- 1 BUX, BUT, BUTX, BV, BVT)
- INTEGER NU, NV
- DOUBLE PRECISION T, L, R, U(NU, 2), UX(NU, 2), UT(NU, 2)
- DOUBLE PRECISION UTX(NU, 2), V(NV), VT(NV), B(NU, 2), BU(NU, NU, 2
- 1 ), BUX(NU, NU, 2)
- DOUBLE PRECISION BUT(NU, NU, 2), BUTX(NU, NU, 2), BV(NU, NV, 2),
- 1 BVT(NU, NV, 2)
- B(1, 1) = UX(1, 1)-V(1)
- B(1, 2) = UX(1, 2)-V(1)
- BUX(1, 1, 1) = 1
- BV(1, 1, 1) = -1
- BUX(1, 1, 2) = 1
- BV(1, 1, 2) = -1
- RETURN
- END
- SUBROUTINE DEE(T, K, X, NX, U, UT, NU, NXMK, V, VT, NV, D,
- 1 DU, DUT, DV, DVT)
- INTEGER NXMK, NU, NV, NX
- INTEGER K
- DOUBLE PRECISION T, X(NX), U(NXMK, NU), UT(NXMK, NU), V(NV), VT(
- 1 NV)
- DOUBLE PRECISION D(NV), DU(NV, NXMK, NU), DUT(NV, NXMK, NU), DV(
- 1 NV, NV), DVT(NV, NV)
- INTEGER TEMP
-C U(-PI,T) - U(+PI,T) = 0.
- TEMP = NX-K
- D(1) = U(1, 1)-U(TEMP, 1)
- DU(1, 1, 1) = 1
- TEMP = NX-K
- DU(1, TEMP, 1) = -1
- RETURN
- END
- SUBROUTINE HANDLE(T0, U0, V0, T, U, V, NU, NXMK, NV, K, X,
- 1 NX, DT, TSTOP)
- INTEGER NXMK, NU, NV, NX
- INTEGER K
- DOUBLE PRECISION T0, U0(NXMK, NU), V0(NV), T, U(NXMK, NU), V(NV)
- DOUBLE PRECISION X(NX), DT, TSTOP
- COMMON /TIME/ TT
- DOUBLE PRECISION TT
- EXTERNAL UOFX
- INTEGER I1MACH
- DOUBLE PRECISION DEESFF, EU, EV
- INTEGER TEMP
-C OUTPUT AND CHECKING ROUTINE.
- IF (T0 .EQ. T) RETURN
-C UOFX NEEDS TIME.
- TT = T
- EU = DEESFF(K, X, NX, U, UOFX)
- EV = V(1)
- TEMP = I1MACH(2)
- WRITE (TEMP, 1) T, EU, EV
- 1 FORMAT (14H ERROR IN U(X,, 1PE10.2, 4H ) =, 1PE10.2, 6H V =, 1P
- 1 E10.2)
- RETURN
- END
- SUBROUTINE UOFX(X, NX, U, W)
- INTEGER NX
- DOUBLE PRECISION X(NX), U(NX), W(NX)
- COMMON /TIME/ T
- DOUBLE PRECISION T
- INTEGER I
- DOUBLE PRECISION DCOS, DSIN
- DO 1 I = 1, NX
- U(I) = DCOS(X(I))*DSIN(T)
- 1 CONTINUE
- RETURN
- END
diff --git a/CEP/PyBDSM/src/port3/ex/dpt5.f b/CEP/PyBDSM/src/port3/ex/dpt5.f
deleted file mode 100644
index b990a8a47721d3f0a5aa438e2406c090b0e5a7fe..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ex/dpt5.f
+++ /dev/null
@@ -1,249 +0,0 @@
-C$TEST DPT5
-C TO RUN AS A MAIN PROGRAM REMOVE NEXT LINE
- SUBROUTINE DPT5
-C***********************************************************************
-C
-C EXAMPLE OF USE OF PORT PROGRAM DPOST
-C
-C***********************************************************************
- COMMON /CSTAK/ DS
- DOUBLE PRECISION DS(4000)
- COMMON /TIME/ T
- DOUBLE PRECISION T
- COMMON /PARAM/ VC, X
- DOUBLE PRECISION VC(3), X(3)
- EXTERNAL DEE, HANDLE, UOFX, BC, AF
- INTEGER NDX, IDLUMB, ISTKGT, K, IU, IS(1000)
- INTEGER NU, NV, IMMMD, IMESH, NMESH
- REAL ERRPAR(2), RS(1000)
- LOGICAL LS(1000)
- COMPLEX CS(500)
- DOUBLE PRECISION TSTART, V(3), DT, XB(3), WS(500), TSTOP
- EQUIVALENCE (DS(1), CS(1), WS(1), RS(1), IS(1), LS(1))
-C TO TEST DPOST ON
-C U SUB T = ( K(T,X) * U SUB X ) SUB X + G ON (-1,+2) * (0,+1)
-C WITH A MOVING FRONT X(T) CHARACTERIZED BY U(X(T),T) == 1 AND
-C JUMP ACROSS X(T) OF K(T,X) U SUB X = - 3 * X'(T).
-C WHERE K(T,X) IS PIECEWISE CONSTANT, SAY
-C 1 FOR X < X(T)
-C K(T,X) =
-C 2 FOR X > X(T)
-C AND G IS CHOSEN SO THAT THE SOLUTION IS
-C EXP(X-X(T)) FOR X < X(T)
-C U(X,T) =
-C EXP(X(T)-X) FOR X > X(T)
-C AND X(1,T) = T. THE MOVING FRONT IS TRACKED
-C IMPLICITLY BY FORCING U(X(1,T),T) = 1 AS A PSEUDO-RANKINE-HEUGONIOT RE
-CLATION.
-C V(1,2,3) GIVES THE MOVING MESH.
-C THE PORT LIBRARY STACK AND ITS ALIASES.
-C INITIALIZE THE PORT LIBRARY STACK LENGTH.
- CALL ISTKIN(4000, 4)
- CALL ENTER(1)
- NU = 1
- NV = 3
- ERRPAR(1) = 0
-C ABSOLUTE ERROR.
- ERRPAR(2) = 1E-2
- TSTART = 0
- TSTOP = 1
- DT = 0.1
- K = 4
-C NDX UNIFORM MESH POINTS ON EACH INTERVAL OF XB ARRAY.
- NDX = 6
- XB(1) = 0
- XB(2) = 1
- XB(3) = 2
-C GET MESH ON PORT STACK.
- IMESH = IDLUMB(XB, 3, NDX, K, NMESH)
-C MAKE 1 OF MULTIPLICITY K-1.
- IMESH = IMMMD(IMESH, NMESH, 1D0, K-1)
- X(1) = -1
- X(2) = 0
- X(3) = 2
-C INITIAL VALUES FOR V.
- CALL DLPLMG(3, X, VC)
-C GET U ON THE PORT STACK.
- IU = ISTKGT(NMESH-K, 4)
-C UOFX NEEDS TIME.
- T = TSTART
-C UOFX NEEDS V FOR MAPPING.
- CALL MOVEFD(NV, VC, V)
-C INITIAL CONDITIONS FOR U.
- CALL DL2SFF(UOFX, K, WS(IMESH), NMESH, WS(IU))
-C OUTPUT THE ICS.
- CALL HANDLE(T-1D0, WS(IU), V, T, WS(IU), V, NU, NMESH-K, NV, K,
- 1 WS(IMESH), NMESH, DT, TSTOP)
- CALL DPOST(WS(IU), NU, K, WS(IMESH), NMESH, V, NV, TSTART, TSTOP
- 1 , DT, AF, BC, DEE, ERRPAR, HANDLE)
- CALL LEAVE
- CALL WRAPUP
- STOP
- END
- SUBROUTINE AF(T, XI, NX, U, UX, UT, UTX, NU, V, VT, NV, A,
- 1 AU, AUX, AUT, AUTX, AV, AVT, F, FU, FUX, FUT, FUTX, FV, FVT)
- INTEGER NU, NV, NX
- DOUBLE PRECISION T, XI(NX), U(NX, NU), UX(NX, NU), UT(NX, NU),
- 1 UTX(NX, NU)
- DOUBLE PRECISION V(NV), VT(NV), A(NX, NU), AU(NX, NU, NU), AUX(NX,
- 1 NU, NU), AUT(NX, NU, NU)
- DOUBLE PRECISION AUTX(NX, NU, NU), AV(NX, NU, NV), AVT(NX, NU, NV)
- 1 , F(NX, NU), FU(NX, NU, NU), FUX(NX, NU, NU)
- DOUBLE PRECISION FUT(NX, NU, NU), FUTX(NX, NU, NU), FV(NX, NU, NV)
- 1 , FVT(NX, NU, NV)
- COMMON /DPOSTF/ FAILED
- LOGICAL FAILED
- INTEGER I
- DOUBLE PRECISION KAY, XXI(99), XTV(99), XVV(99), X(99), DEXP
- DOUBLE PRECISION XXIV(99), AX(99), FX(99), XT(99), XV(99)
- LOGICAL TEMP
- TEMP = V(2) .LE. V(1)
- IF (.NOT. TEMP) TEMP = V(2) .GE. V(3)
- IF (.NOT. TEMP) GOTO 1
- FAILED = .TRUE.
- RETURN
-C MAP XI INTO X.
- 1 CALL DLPLM(XI, NX, V, 3, X, XXI, XXIV, XV, XVV, XT, XTV)
-C MAP U INTO X SYSTEM.
- CALL DPOSTU(XI, X, XT, XXI, XV, VT, NX, 3, UX, UT, NU, AX, FX)
- DO 7 I = 1, NX
- IF (XI(I) .GT. 1D0) GOTO 2
- KAY = 1
- GOTO 3
- 2 KAY = 2
- 3 A(I, 1) = KAY*UX(I, 1)
- AUX(I, 1, 1) = KAY
- IF (XI(I) .GT. 1D0) GOTO 4
- A(I, 1) = A(I, 1)-3D0*VT(2)
- AVT(I, 1, 2) = -3
- 4 F(I, 1) = UT(I, 1)
- FUT(I, 1, 1) = 1
- IF (XI(I) .GT. 1D0) GOTO 5
- F(I, 1) = F(I, 1)+2D0*DEXP(X(I)-T)
- FX(I) = 2D0*DEXP(X(I)-T)
- GOTO 6
- 5 F(I, 1) = F(I, 1)+DEXP(T-X(I))
- FX(I) = -DEXP(T-X(I))
- 6 CONTINUE
- 7 CONTINUE
-C MAP A AND F INTO XI SYSTEM.
- CALL DPOSTI(XI, X, XT, XXI, XV, XTV, XXIV, XVV, NX, UX, UT, NU, V,
- 1 VT, NV, 1, 3, A, AX, AU, AUX, AUT, AUTX, AV, AVT, F, FX, FU,
- 2 FUX, FUT, FUTX, FV, FVT)
- RETURN
- END
- SUBROUTINE BC(T, L, R, U, UX, UT, UTX, NU, V, VT, NV, B, BU,
- 1 BUX, BUT, BUTX, BV, BVT)
- INTEGER NU, NV
- DOUBLE PRECISION T, L, R, U(NU, 2), UX(NU, 2), UT(NU, 2)
- DOUBLE PRECISION UTX(NU, 2), V(NV), VT(NV), B(NU, 2), BU(NU, NU, 2
- 1 ), BUX(NU, NU, 2)
- DOUBLE PRECISION BUT(NU, NU, 2), BUTX(NU, NU, 2), BV(NU, NV, 2),
- 1 BVT(NU, NV, 2)
- DOUBLE PRECISION DEXP
- B(1, 1) = U(1, 1)-DEXP((-1D0)-T)
- B(1, 2) = U(1, 2)-DEXP(T-2D0)
- BU(1, 1, 1) = 1
- BU(1, 1, 2) = 1
- RETURN
- END
- SUBROUTINE DEE(T, K, X, NX, U, UT, NU, NXMK, V, VT, NV, D,
- 1 DU, DUT, DV, DVT)
- INTEGER NXMK, NU, NV, NX
- INTEGER K
- DOUBLE PRECISION T, X(NX), U(NXMK, NU), UT(NXMK, NU), V(NV), VT(
- 1 NV)
- DOUBLE PRECISION D(NV), DU(NV, NXMK, NU), DUT(NV, NXMK, NU), DV(
- 1 NV, NV), DVT(NV, NV)
- INTEGER INTRVD, I, ILEFT
- DOUBLE PRECISION BX(10), XX(1)
- INTEGER TEMP
- D(1) = V(1)+1D0
-C X(0,V) = -1.
- DV(1, 1) = 1
- XX(1) = 1
-C FIND 1 IN THE MESH.
- ILEFT = INTRVD(NX, X, XX(1))
-C GET THE B-SPLINE BASIS AT XX.
- CALL DBSPLN(K, X, NX, XX, 1, ILEFT, BX)
-C U(X(1,V),T) = 1.
- D(2) = -1
- DO 1 I = 1, K
- TEMP = ILEFT+I-K
- D(2) = D(2)+U(TEMP, 1)*BX(I)
- TEMP = ILEFT+I-K
- DU(2, TEMP, 1) = BX(I)
- 1 CONTINUE
- D(3) = V(3)-2D0
-C X(2,V) = +2.
- DV(3, 3) = 1
- RETURN
- END
- SUBROUTINE HANDLE(T0, U0, V0, T, U, V, NU, NXMK, NV, K, X,
- 1 NX, DT, TSTOP)
- INTEGER NXMK, NU, NV, NX
- INTEGER K
- DOUBLE PRECISION T0, U0(NXMK, NU), V0(NV), T, U(NXMK, NU), V(NV)
- DOUBLE PRECISION X(NX), DT, TSTOP
- COMMON /PARAM/ VC, XX
- DOUBLE PRECISION VC(3), XX(3)
- COMMON /TIME/ TT
- DOUBLE PRECISION TT
- EXTERNAL UOFX
- INTEGER I1MACH
- DOUBLE PRECISION DEESFF, EU, EV(3)
- INTEGER TEMP
-C OUTPUT AND CHECKING ROUTINE.
- IF (T0 .NE. T) GOTO 2
- TEMP = I1MACH(2)
- WRITE (TEMP, 1) T
- 1 FORMAT (16H RESTART FOR T =, 1PE10.2)
- RETURN
- 2 TT = T
-C UOFX NEEDS V FOR MAPPING.
- CALL MOVEFD(NV, V, VC)
- EU = DEESFF(K, X, NX, U, UOFX)
- EV(1) = V(1)+1D0
- EV(2) = V(2)-T
- EV(3) = V(3)-2D0
- TEMP = I1MACH(2)
- WRITE (TEMP, 3) T, EU, EV
- 3 FORMAT (14H ERROR IN U(X,, 1PE10.2, 4H ) =, 1PE10.2, 6H V =, 3(
- 1 1PE10.2))
- RETURN
- END
- SUBROUTINE UOFX(XI, NX, U, W)
- INTEGER NX
- DOUBLE PRECISION XI(NX), U(NX), W(NX)
- COMMON /CSTAK/ DS
- DOUBLE PRECISION DS(500)
- COMMON /PARAM/ VC, X
- DOUBLE PRECISION VC(3), X(3)
- COMMON /TIME/ T
- DOUBLE PRECISION T
- INTEGER IXV, IXX, ISTKGT, I, IS(1000)
- REAL RS(1000)
- LOGICAL LS(1000)
- COMPLEX CS(500)
- DOUBLE PRECISION DEXP, WS(500), XOFXI
- INTEGER TEMP
- EQUIVALENCE (DS(1), CS(1), WS(1), RS(1), IS(1), LS(1))
-C THE PORT LIBRARY STACK AND ITS ALIASES.
- CALL ENTER(1)
- IXX = ISTKGT(NX, 4)
-C SPACE FOR X AND XV.
- IXV = ISTKGT(3*NX, 4)
-C MAP INTO USER SYSTEM.
- CALL DLPLMX(XI, NX, VC, 3, WS(IXX), WS(IXV))
- DO 3 I = 1, NX
- TEMP = IXX+I
- XOFXI = WS(TEMP-1)
- IF (XI(I) .GT. 1D0) GOTO 1
- U(I) = DEXP(XOFXI-T)
- GOTO 2
- 1 U(I) = DEXP(T-XOFXI)
- 2 CONTINUE
- 3 CONTINUE
- CALL LEAVE
- RETURN
- END
diff --git a/CEP/PyBDSM/src/port3/ex/dpt6.f b/CEP/PyBDSM/src/port3/ex/dpt6.f
deleted file mode 100644
index ef3473bc3a42950f53fb95330984f40b164f433b..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ex/dpt6.f
+++ /dev/null
@@ -1,255 +0,0 @@
-C$TEST DPT6
-C TO RUN AS A MAIN PROGRAM REMOVE NEXT LINE
- SUBROUTINE DPT6
-C***********************************************************************
-C
-C EXAMPLE OF USE OF PORT PROGRAM DPOST
-C
-C***********************************************************************
- COMMON /CSTAK/ DS
- DOUBLE PRECISION DS(4000)
- COMMON /TIME/ T
- DOUBLE PRECISION T
- COMMON /PARAM/ VC, X
- DOUBLE PRECISION VC(4), X(3)
- EXTERNAL DEE, HANDLE, UOFX, BC, AF
- INTEGER NDX, IDLUMB, ISTKGT, K, IU, IS(1000)
- INTEGER NU, NV, IMMMD, IMESH, NMESH
- REAL ERRPAR(2), RS(1000)
- LOGICAL LS(1000)
- COMPLEX CS(500)
- DOUBLE PRECISION TSTART, V(4), DT, XB(3), WS(500), TSTOP
- EQUIVALENCE (DS(1), CS(1), WS(1), RS(1), IS(1), LS(1))
-C TO TEST DPOST ON THE HYPERBOLIC PROBLEM
-C U SUB T = - U SUB X + G ON (-PI,+PI) * (0,PI)
-C WITH A MOVING SHOCK X(T) CHARACTERIZED BY
-C U(X(T)+,T) = 0 AND
-C U(X(T)+,T) - U(X(T)-,T) = X'(T)
-C WHERE G IS CHOSEN SO THAT THE SOLUTION IS
-C SIN(X+T) FOR X < X(T)
-C U(X,T) =
-C COS(X+T) FOR X > X(T)
-C WITH X(T) = PI/2 -T .
-C V(1,2,3) GIVES THE MOVING MESH AND V(4) IS THE HEIGHT OF THE JUMP.
-C THE PORT LIBRARY STACK AND ITS ALIASES.
-C INITIALIZE THE PORT LIBRARY STACK LENGTH.
- CALL ISTKIN(4000, 4)
- CALL ENTER(1)
- NU = 1
- NV = 4
- ERRPAR(1) = 0
-C ABSOLUTE ERROR.
- ERRPAR(2) = 1E-2
- TSTART = 0
- TSTOP = 3.14
- DT = 0.4
- K = 4
-C NDX UNIFORM MESH POINTS ON EACH INTERVAL OF XB.
- NDX = 6
- XB(1) = 0
- XB(2) = 1
- XB(3) = 2
-C GET MESH ON PORT STACK.
- IMESH = IDLUMB(XB, 3, NDX, K, NMESH)
-C MAKE 1 OF MULTIPLICITY K-1.
- IMESH = IMMMD(IMESH, NMESH, 1D0, K-1)
- X(1) = -3.14
- X(2) = 3.14/2.
- X(3) = 3.14
-C INITIAL VALUES FOR V.
- CALL DLPLMG(3, X, VC)
-C GET U ON THE PORT STACK.
- IU = ISTKGT(NMESH-K, 4)
-C UOFX NEEDS TIME.
- T = TSTART
-C THE INITIAL HEIGHT OF THE JUMP.
- VC(4) = 1
-C UOFX NEEDS V FOR MAPPING.
- CALL MOVEFD(NV, VC, V)
-C INITIAL CONDITIONS FOR U.
- CALL DL2SFF(UOFX, K, WS(IMESH), NMESH, WS(IU))
-C OUTPUT ICS.
- CALL HANDLE(T-1D0, WS(IU), V, T, WS(IU), V, NU, NMESH-K, NV, K,
- 1 WS(IMESH), NMESH, DT, TSTOP)
- CALL DPOST(WS(IU), NU, K, WS(IMESH), NMESH, V, NV, TSTART, TSTOP
- 1 , DT, AF, BC, DEE, ERRPAR, HANDLE)
- CALL LEAVE
- CALL WRAPUP
- STOP
- END
- SUBROUTINE AF(T, XI, NX, U, UX, UT, UTX, NU, V, VT, NV, A,
- 1 AU, AUX, AUT, AUTX, AV, AVT, F, FU, FUX, FUT, FUTX, FV, FVT)
- INTEGER NU, NV, NX
- DOUBLE PRECISION T, XI(NX), U(NX, NU), UX(NX, NU), UT(NX, NU),
- 1 UTX(NX, NU)
- DOUBLE PRECISION V(NV), VT(NV), A(NX, NU), AU(NX, NU, NU), AUX(NX,
- 1 NU, NU), AUT(NX, NU, NU)
- DOUBLE PRECISION AUTX(NX, NU, NU), AV(NX, NU, NV), AVT(NX, NU, NV)
- 1 , F(NX, NU), FU(NX, NU, NU), FUX(NX, NU, NU)
- DOUBLE PRECISION FUT(NX, NU, NU), FUTX(NX, NU, NU), FV(NX, NU, NV)
- 1 , FVT(NX, NU, NV)
- COMMON /DPOSTF/ FAILED
- LOGICAL FAILED
- INTEGER I
- DOUBLE PRECISION XXI(99), XTV(99), XVV(99), X(99), DCOS, DSIN
- DOUBLE PRECISION XXIV(99), AX(99), FX(99), XT(99), XV(99)
- LOGICAL TEMP
- TEMP = V(2) .LE. V(1)
- IF (.NOT. TEMP) TEMP = V(2) .GE. V(3)
- IF (.NOT. TEMP) GOTO 1
- FAILED = .TRUE.
- RETURN
-C MAP XI INTO X.
- 1 CALL DLPLM(XI, NX, V, 3, X, XXI, XXIV, XV, XVV, XT, XTV)
-C MAP U INTO X SYSTEM.
- CALL DPOSTU(XI, X, XT, XXI, XV, VT, NX, 3, UX, UT, NU, AX, FX)
- DO 4 I = 1, NX
- A(I, 1) = -U(I, 1)
- AU(I, 1, 1) = -1
- F(I, 1) = UT(I, 1)
- FUT(I, 1, 1) = 1
- IF (XI(I) .GT. 1D0) GOTO 2
- F(I, 1) = F(I, 1)-2D0*DCOS(X(I)+T)
- FX(I) = 2D0*DSIN(X(I)+T)
- GOTO 3
- 2 F(I, 1) = F(I, 1)-VT(4)
- FVT(I, 1, 4) = -1
- F(I, 1) = F(I, 1)+2D0*DSIN(X(I)+T)
- FX(I) = 2D0*DCOS(X(I)+T)
- 3 CONTINUE
- 4 CONTINUE
-C MAP A AND F INTO XI SYSTEM.
- CALL DPOSTI(XI, X, XT, XXI, XV, XTV, XXIV, XVV, NX, UX, UT, NU, V,
- 1 VT, NV, 1, 3, A, AX, AU, AUX, AUT, AUTX, AV, AVT, F, FX, FU,
- 2 FUX, FUT, FUTX, FV, FVT)
- RETURN
- END
- SUBROUTINE BC(T, L, R, U, UX, UT, UTX, NU, V, VT, NV, B, BU,
- 1 BUX, BUT, BUTX, BV, BVT)
- INTEGER NU, NV
- DOUBLE PRECISION T, L, R, U(NU, 2), UX(NU, 2), UT(NU, 2)
- DOUBLE PRECISION UTX(NU, 2), V(NV), VT(NV), B(NU, 2), BU(NU, NU, 2
- 1 ), BUX(NU, NU, 2)
- DOUBLE PRECISION BUT(NU, NU, 2), BUTX(NU, NU, 2), BV(NU, NV, 2),
- 1 BVT(NU, NV, 2)
- DOUBLE PRECISION DSIN
- B(1, 1) = U(1, 1)-DSIN(T-3.14)
-C U(-PI,T) = SIN(-PI+T).
- BU(1, 1, 1) = 1
- RETURN
- END
- SUBROUTINE DEE(T, K, X, NX, U, UT, NU, NXMK, V, VT, NV, D,
- 1 DU, DUT, DV, DVT)
- INTEGER NXMK, NU, NV, NX
- INTEGER K
- DOUBLE PRECISION T, X(NX), U(NXMK, NU), UT(NXMK, NU), V(NV), VT(
- 1 NV)
- DOUBLE PRECISION D(NV), DU(NV, NXMK, NU), DUT(NV, NXMK, NU), DV(
- 1 NV, NV), DVT(NV, NV)
- INTEGER INTRVD, I, ILEFT
- DOUBLE PRECISION BX(10), XX(1), D1MACH
- INTEGER TEMP
- D(1) = V(1)+3.14
-C X(0,V) = -PI.
- DV(1, 1) = 1
-C XX(1) = 1 + A ROUNDING ERROR.
- XX(1) = D1MACH(4)+1D0
- ILEFT = INTRVD(NX, X, XX(1))
-C GET THE B-SPLINE BASIS AT XX.
- CALL DBSPLN(K, X, NX, XX, 1, ILEFT, BX)
- D(2) = -V(4)
-C U(X(T)+,T) - JUMP = 0.
- DV(2, 4) = -1
- DO 1 I = 1, K
- TEMP = ILEFT+I-K
- D(2) = D(2)+U(TEMP, 1)*BX(I)
- TEMP = ILEFT+I-K
- DU(2, TEMP, 1) = BX(I)
- 1 CONTINUE
- D(3) = V(3)-3.14
-C X(2,V) = +PI.
- DV(3, 3) = 1
-C JUMP + D( X(1,V(T)) )/DT = 0.
- D(4) = VT(2)+V(4)
- DVT(4, 2) = 1
- DV(4, 4) = 1
- RETURN
- END
- SUBROUTINE HANDLE(T0, U0, V0, T, U, V, NU, NXMK, NV, K, X,
- 1 NX, DT, TSTOP)
- INTEGER NXMK, NU, NV, NX
- INTEGER K
- DOUBLE PRECISION T0, U0(NXMK, NU), V0(NV), T, U(NXMK, NU), V(NV)
- DOUBLE PRECISION X(NX), DT, TSTOP
- COMMON /PARAM/ VC, XX
- DOUBLE PRECISION VC(4), XX(3)
- COMMON /TIME/ TT
- DOUBLE PRECISION TT
- EXTERNAL UOFX
- INTEGER I1MACH
- DOUBLE PRECISION DEESFF, EU, EV(2)
- INTEGER TEMP
-C OUTPUT AND CHECKING ROUTINE.
- IF (T0 .NE. T) GOTO 2
- TEMP = I1MACH(2)
- WRITE (TEMP, 1) T, DT
- 1 FORMAT (16H RESTART FOR T =, 1PE10.2, 7H DT =, 1PE10.2)
- RETURN
- 2 TT = T
-C UOFX NEEDS V FOR MAPPING.
- CALL MOVEFD(NV, V, VC)
- EU = DEESFF(K, X, NX, U, UOFX)
-C ERROR IN POSITION OF SHOCK.
- EV(1) = V(2)-(3.14/2.-T)
-C ERROR IN HEIGHT OF SHOCK.
- EV(2) = V(4)-1D0
- TEMP = I1MACH(2)
- WRITE (TEMP, 3) T, EU, EV
- 3 FORMAT (14H ERROR IN U(X,, 1PE10.2, 4H ) =, 1PE10.2, 6H V =, 2(
- 1 1PE10.2))
- RETURN
- END
- SUBROUTINE UOFX(XI, NX, U, W)
- INTEGER NX
- DOUBLE PRECISION XI(NX), U(NX), W(NX)
- COMMON /CSTAK/ DS
- DOUBLE PRECISION DS(500)
- COMMON /PARAM/ VC, X
- DOUBLE PRECISION VC(4), X(3)
- COMMON /TIME/ T
- DOUBLE PRECISION T
- INTEGER IXV, IXX, ISTKGT, I, IS(1000)
- REAL RS(1000)
- LOGICAL LS(1000)
- COMPLEX CS(500)
- DOUBLE PRECISION EWE, WS(500)
- INTEGER TEMP
- EQUIVALENCE (DS(1), CS(1), WS(1), RS(1), IS(1), LS(1))
-C THE PORT LIBRARY STACK AND ITS ALIASES.
- CALL ENTER(1)
- IXX = ISTKGT(NX, 4)
-C SPACE FOR X AND XV.
- IXV = ISTKGT(3*NX, 4)
-C MAP INTO USER SYSTEM.
- CALL DLPLMX(XI, NX, VC, 3, WS(IXX), WS(IXV))
- DO 1 I = 1, NX
- TEMP = IXX+I
- U(I) = EWE(T, WS(TEMP-1), VC(2))
- IF (XI(I) .GT. 1D0) U(I) = U(I)+1D0
- 1 CONTINUE
- CALL LEAVE
- RETURN
- END
- DOUBLE PRECISION FUNCTION EWE(T, X, XBREAK)
- DOUBLE PRECISION T, X, XBREAK
- DOUBLE PRECISION DCOS, DSIN
- IF (X .GE. XBREAK) GOTO 1
- EWE = DSIN(X+T)
- RETURN
- 1 IF (X .LE. XBREAK) GOTO 2
- EWE = DCOS(X+T)
- RETURN
- 2 CALL SETERR(17HEWE - X == XBREAK, 17, 1, 2)
- 3 CONTINUE
- 4 STOP
- END
diff --git a/CEP/PyBDSM/src/port3/ex/dpt7.f b/CEP/PyBDSM/src/port3/ex/dpt7.f
deleted file mode 100644
index d49cd13f98b3d64a1b513402b9223acc1b39bab7..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ex/dpt7.f
+++ /dev/null
@@ -1,239 +0,0 @@
-C$TEST DPT7
-C TO RUN AS A MAIN PROGRAM REMOVE NEXT LINE
- SUBROUTINE DPT7
-C***********************************************************************
-C
-C EXAMPLE OF USE OF PORT PROGRAM DPOST
-C
-C***********************************************************************
- COMMON /CSTAK/ DS
- DOUBLE PRECISION DS(4000)
- COMMON /TIME/ T
- DOUBLE PRECISION T
- COMMON /PARAM/ VC, X, XI0
- DOUBLE PRECISION VC(4), X(3), XI0
- EXTERNAL DEE, HANDLE, UOFX, BC, AF
- INTEGER NDX, IDLUMB, ISTKGT, K, IU, IS(1000)
- INTEGER NU, NV, IMMMD, IMESH, NMESH
- REAL ERRPAR(2), RS(1000)
- LOGICAL LS(1000)
- COMPLEX CS(500)
- DOUBLE PRECISION TSTART, D, V(4), DT, XB(3), WS(500)
- DOUBLE PRECISION TSTOP
- EQUIVALENCE (DS(1), CS(1), WS(1), RS(1), IS(1), LS(1))
-C TO TEST DPOST ON
-C U SUB T = U SUB XX + F ON (20,10**6)
-C WHERE F IS CHOSEN SO THAT THE SOLUTION IS
-C U(X,T) = EXP(-X*T),
-C AND X(1,T) IS CHOSEN SO THAT THE BOUNDARY-LAYER IS TRACKED
-C IMPLICITLY BY FORCING U(X(1,T)/2.3/D,T) = 1/E.
-C THIS IS THE SAME AS REQUIRING THE EXACT SOLUTION TO HAVE
-C U(X(1,T),T) = 10 ** -D.
-C V(1,2,3) GIVES THE MOVING MESH, V(4) IS TIME.
-C THE PORT LIBRARY STACK AND ITS ALIASES.
-C INITIALIZE THE PORT LIBRARY STACK LENGTH.
- CALL ISTKIN(4000, 4)
- CALL ENTER(1)
- NU = 1
- NV = 4
- ERRPAR(1) = 1E-2
-C MIXED RELATIVE AND ABSOLUTE ERROR.
- ERRPAR(2) = 1E-2
- D = 3
-C W(XI0,T) = 1/E.
- XI0 = 1./2.3/D
- TSTART = 20
- TSTOP = 1D+6
- DT = 1D-2
- K = 4
-C NDX UNIFORM MESH POINTS ON EACH INTERVAL OF XB.
- NDX = 6
- XB(1) = 0
- XB(2) = 1
- XB(3) = 2
-C GET MESH ON PORT STACK.
- IMESH = IDLUMB(XB, 3, NDX, K, NMESH)
-C MAKE 1D0 OF MULTIPLICITY K-1.
- IMESH = IMMMD(IMESH, NMESH, 1D0, K-1)
- X(1) = 0
- X(2) = 2.3*D/TSTART
- X(3) = 1
-C INITIAL VALUES FOR V.
- CALL DLPLMG(3, X, VC)
-C GET U ON PORT STACK.
- IU = ISTKGT(NMESH-K, 4)
-C UOFX NEEDS TIME.
- T = TSTART
- VC(4) = TSTART
-C UOFX NEEDS V FOR MAPPING.
- CALL MOVEFD(NV, VC, V)
-C INITIAL CONDITIONS FOR U.
- CALL DL2SFF(UOFX, K, WS(IMESH), NMESH, WS(IU))
-C OUTPUT ICS.
- CALL HANDLE(T-1D0, WS(IU), V, T, WS(IU), V, NU, NMESH-K, NV, K,
- 1 WS(IMESH), NMESH, DT, TSTOP)
- CALL DPOST(WS(IU), NU, K, WS(IMESH), NMESH, V, NV, TSTART, TSTOP
- 1 , DT, AF, BC, DEE, ERRPAR, HANDLE)
- CALL LEAVE
- CALL WRAPUP
- STOP
- END
- SUBROUTINE AF(T, XI, NX, U, UX, UT, UTX, NU, V, VT, NV, A,
- 1 AU, AUX, AUT, AUTX, AV, AVT, F, FU, FUX, FUT, FUTX, FV, FVT)
- INTEGER NU, NV, NX
- DOUBLE PRECISION T, XI(NX), U(NX, NU), UX(NX, NU), UT(NX, NU),
- 1 UTX(NX, NU)
- DOUBLE PRECISION V(NV), VT(NV), A(NX, NU), AU(NX, NU, NU), AUX(NX,
- 1 NU, NU), AUT(NX, NU, NU)
- DOUBLE PRECISION AUTX(NX, NU, NU), AV(NX, NU, NV), AVT(NX, NU, NV)
- 1 , F(NX, NU), FU(NX, NU, NU), FUX(NX, NU, NU)
- DOUBLE PRECISION FUT(NX, NU, NU), FUTX(NX, NU, NU), FV(NX, NU, NV)
- 1 , FVT(NX, NU, NV)
- COMMON /DPOSTF/ FAILED
- LOGICAL FAILED
- INTEGER I
- DOUBLE PRECISION XXI(99), XTV(99), XVV(99), X(99), XXIV(99), AX(
- 1 99)
- DOUBLE PRECISION FX(99), XT(99), XV(99), DEXPL
- LOGICAL TEMP
- TEMP = V(2) .LE. V(1)
- IF (.NOT. TEMP) TEMP = V(2) .GE. V(3)
- IF (.NOT. TEMP) GOTO 1
- FAILED = .TRUE.
- RETURN
-C MAP XI INTO X.
- 1 CALL DLPLM(XI, NX, V, 3, X, XXI, XXIV, XV, XVV, XT, XTV)
-C MAP U INTO X SYSTEM.
- CALL DPOSTU(XI, X, XT, XXI, XV, VT, NX, 3, UX, UT, NU, AX, FX)
- DO 2 I = 1, NX
- A(I, 1) = -UX(I, 1)
- AUX(I, 1, 1) = -1
- F(I, 1) = (-UT(I, 1))-DEXPL((-X(I))*V(4))*(X(I)+V(4)**2)
- FUT(I, 1, 1) = -1
- FV(I, 1, 4) = (-DEXPL((-X(I))*V(4)))*(2D0*V(4)+(X(I)+V(4)**2)*(
- 1 -X(I)))
- FX(I) = (-DEXPL((-X(I))*V(4)))*(1D0-V(4)*X(I)-V(4)**3)
- 2 CONTINUE
-C MAP A AND F INTO XI SYSTEM.
- CALL DPOSTI(XI, X, XT, XXI, XV, XTV, XXIV, XVV, NX, UX, UT, NU, V,
- 1 VT, NV, 1, 3, A, AX, AU, AUX, AUT, AUTX, AV, AVT, F, FX, FU,
- 2 FUX, FUT, FUTX, FV, FVT)
- RETURN
- END
- SUBROUTINE BC(T, L, R, U, UX, UT, UTX, NU, V, VT, NV, B, BU,
- 1 BUX, BUT, BUTX, BV, BVT)
- INTEGER NU, NV
- DOUBLE PRECISION T, L, R, U(NU, 2), UX(NU, 2), UT(NU, 2)
- DOUBLE PRECISION UTX(NU, 2), V(NV), VT(NV), B(NU, 2), BU(NU, NU, 2
- 1 ), BUX(NU, NU, 2)
- DOUBLE PRECISION BUT(NU, NU, 2), BUTX(NU, NU, 2), BV(NU, NV, 2),
- 1 BVT(NU, NV, 2)
- DOUBLE PRECISION DEXPL
-C U(0,T) = 1
- B(1, 1) = U(1, 1)-1D0
-C U(1,T) = EXP(-T)
- B(1, 2) = U(1, 2)-DEXPL(-V(4))
- BU(1, 1, 1) = 1
- BU(1, 1, 2) = 1
- BV(1, 4, 2) = DEXPL(-V(4))
- RETURN
- END
- SUBROUTINE DEE(T, K, X, NX, U, UT, NU, NXMK, V, VT, NV, D,
- 1 DU, DUT, DV, DVT)
- INTEGER NXMK, NU, NV, NX
- INTEGER K
- DOUBLE PRECISION T, X(NX), U(NXMK, NU), UT(NXMK, NU), V(NV), VT(
- 1 NV)
- DOUBLE PRECISION D(NV), DU(NV, NXMK, NU), DUT(NV, NXMK, NU), DV(
- 1 NV, NV), DVT(NV, NV)
- COMMON /PARAM/ VC, XC, XI0
- DOUBLE PRECISION VC(4), XC(3), XI0
- INTEGER INTRVD, I, ILEFT
- DOUBLE PRECISION DEXP, BX(10), XX(1)
- INTEGER TEMP
- D(1) = V(1)
-C X(0,V) = 0.
- DV(1, 1) = 1
- XX(1) = XI0
- ILEFT = INTRVD(NX, X, XX(1))
-C GET THE B-SPLINE BASIS AT XX.
- CALL DBSPLN(K, X, NX, XX, 1, ILEFT, BX)
- D(2) = -DEXP(-1D0)
-C D(2) = W(XI0,T) - EXP(-1).
- DO 1 I = 1, K
- TEMP = ILEFT+I-K
- D(2) = D(2)+U(TEMP, 1)*BX(I)
- TEMP = ILEFT+I-K
- DU(2, TEMP, 1) = BX(I)
- 1 CONTINUE
- D(3) = V(3)-1D0
-C X(2,V) = 1.
- DV(3, 3) = 1
- D(4) = VT(4)-1D0
- DVT(4, 4) = 1
- RETURN
- END
- SUBROUTINE HANDLE(T0, U0, V0, T, U, V, NU, NXMK, NV, K, X,
- 1 NX, DT, TSTOP)
- INTEGER NXMK, NU, NV, NX
- INTEGER K
- DOUBLE PRECISION T0, U0(NXMK, NU), V0(NV), T, U(NXMK, NU), V(NV)
- DOUBLE PRECISION X(NX), DT, TSTOP
- COMMON /PARAM/ VC, XX, XI0
- DOUBLE PRECISION VC(4), XX(3), XI0
- COMMON /TIME/ TT
- DOUBLE PRECISION TT
- EXTERNAL UOFX
- INTEGER I1MACH
- DOUBLE PRECISION DEESFF, DLPLMT, EU, EV
- INTEGER TEMP
-C OUTPUT AND CHECKING ROUTINE.
- IF (T0 .NE. T) GOTO 2
- TEMP = I1MACH(2)
- WRITE (TEMP, 1) T, DT
- 1 FORMAT (16H RESTART FOR T =, 1PE10.2, 7H DT =, 1PE10.2)
- RETURN
-C LET DT CARRY V(2) DOWN BY NO MORE THAN A FACTOR OF 10.
- 2 DT = DLPLMT(T, V, NV, T0, V0, 1D-1, DT)
- TT = T
-C UOFX NEEDS V FOR MAPPING.
- CALL MOVEFD(NV, V, VC)
- EU = DEESFF(K, X, NX, U, UOFX)
-C ERROR IN POSITION OF BOUNDARY LAYER.
- EV = V(2)-1D0/XI0/T
- TEMP = I1MACH(2)
- WRITE (TEMP, 3) T, EU, EV
- 3 FORMAT (14H ERROR IN U(X,, 1PE10.2, 4H ) =, 1PE10.2, 6H V =, 1P
- 1 E10.2)
- RETURN
- END
- SUBROUTINE UOFX(XI, NX, U, W)
- INTEGER NX
- DOUBLE PRECISION XI(NX), U(NX), W(NX)
- COMMON /CSTAK/ DS
- DOUBLE PRECISION DS(500)
- COMMON /PARAM/ VC, X, XI0
- DOUBLE PRECISION VC(4), X(3), XI0
- COMMON /TIME/ T
- DOUBLE PRECISION T
- INTEGER IXV, IXX, ISTKGT, I, IS(1000)
- REAL RS(1000)
- LOGICAL LS(1000)
- COMPLEX CS(500)
- DOUBLE PRECISION WS(500), DEXPL
- INTEGER TEMP
- EQUIVALENCE (DS(1), CS(1), WS(1), RS(1), IS(1), LS(1))
-C THE PORT LIBRARY STACK AND ITS ALIASES.
- CALL ENTER(1)
- IXX = ISTKGT(NX, 4)
-C SPACE FOR X AND XV.
- IXV = ISTKGT(3*NX, 4)
-C MAP INTO USER SYSTEM.
- CALL DLPLMX(XI, NX, VC, 3, WS(IXX), WS(IXV))
- DO 1 I = 1, NX
- TEMP = IXX+I
- U(I) = DEXPL((-WS(TEMP-1))*T)
- 1 CONTINUE
- CALL LEAVE
- RETURN
- END
diff --git a/CEP/PyBDSM/src/port3/ex/dpt8.f b/CEP/PyBDSM/src/port3/ex/dpt8.f
deleted file mode 100644
index 3d31d53503655fa798b688f8339d80ddeebde3ed..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ex/dpt8.f
+++ /dev/null
@@ -1,219 +0,0 @@
-C$TEST DPT8
-C TO RUN AS A MAIN PROGRAM REMOVE NEXT LINE
- SUBROUTINE DPT8
-C***********************************************************************
-C
-C EXAMPLE OF USE OF PORT PROGRAM DPOST
-C
-C***********************************************************************
- COMMON /CSTAK/ DS
- DOUBLE PRECISION DS(5000)
- COMMON /TIME/ T
- DOUBLE PRECISION T
- COMMON /KMESH/ K, NMESH
- INTEGER K, NMESH
- COMMON /CMESH/ MESH
- DOUBLE PRECISION MESH(100)
- EXTERNAL DEE, HANDLE, UOFX, BC, AF
- INTEGER NDX, I, IS(1000), NU, NV
- REAL ERRPAR(2), RS(1000)
- LOGICAL LS(1000)
- COMPLEX CS(500)
- DOUBLE PRECISION U(100), V(100), DT, WS(500), TSTOP
- INTEGER TEMP
- EQUIVALENCE (DS(1), CS(1), WS(1), RS(1), IS(1), LS(1))
-C TO TEST DPOST ON THE INTEGRO-PDE
-C U SUB T = 2 * U SUB XX - INT(0,1) EXP(X-Y)*U(Y) DY ON (0,1)
-C SUBJECT TO GIVEN DIRICHLET BCS, CHOSEN SO THAT THE SOLUTION IS
-C U(X,T) = EXP(T+X).
-C THE PORT LIBRARY STACK AND ITS ALIASES.
-C INITIALIZE THE PORT LIBRARY STACK LENGTH.
- CALL ISTKIN(5000, 4)
- NU = 1
- ERRPAR(1) = 0
-C ABSOLUTE ERROR.
- ERRPAR(2) = 1E-2
- TSTOP = 1
- DT = 1D-2
- K = 4
-C NDX UNIFORM MESH POINTS ON (0,1).
- NDX = 7
- CALL DUMB(0D0, 1D0, NDX, K, MESH, NMESH)
- NV = NMESH-K
-C UOFX NEEDS T.
- T = 0
-C ICS FOR U.
- CALL DL2SFF(UOFX, K, MESH, NMESH, U)
- TEMP = NMESH-K
- DO 1 I = 1, TEMP
- V(I) = U(I)
- 1 CONTINUE
-C ICS FOR V.
- CALL DPOST(U, NU, K, MESH, NMESH, V, NV, 0D0, TSTOP, DT, AF, BC,
- 1 DEE, ERRPAR, HANDLE)
- CALL WRAPUP
- STOP
- END
- SUBROUTINE AF(T, X, NX, U, UX, UT, UTX, NU, V, VT, NV, A,
- 1 AU, AUX, AUT, AUTX, AV, AVT, F, FU, FUX, FUT, FUTX, FV, FVT)
- INTEGER NU, NV, NX
- DOUBLE PRECISION T, X(NX), U(NX, NU), UX(NX, NU), UT(NX, NU), UTX(
- 1 NX, NU)
- DOUBLE PRECISION V(NV), VT(NV), A(NX, NU), AU(NX, NU, NU), AUX(NX,
- 1 NU, NU), AUT(NX, NU, NU)
- DOUBLE PRECISION AUTX(NX, NU, NU), AV(NX, NU, NV), AVT(NX, NU, NV)
- 1 , F(NX, NU), FU(NX, NU, NU), FUX(NX, NU, NU)
- DOUBLE PRECISION FUT(NX, NU, NU), FUTX(NX, NU, NU), FV(NX, NU, NV)
- 1 , FVT(NX, NU, NV)
- COMMON /KMESH/ K, NMESH
- INTEGER K, NMESH
- COMMON /CMESH/ MESH
- DOUBLE PRECISION MESH(100)
- INTEGER I
- DO 1 I = 1, NX
- A(I, 1) = 2D0*UX(I, 1)
- AUX(I, 1, 1) = 2
- F(I, 1) = UT(I, 1)
- FUT(I, 1, 1) = 1
- 1 CONTINUE
-C GET THE INTEGRAL.
- CALL INTGRL(K, MESH, NMESH, V, X, NX, F, FV)
- RETURN
- END
- SUBROUTINE BC(T, L, R, U, UX, UT, UTX, NU, V, VT, NV, B, BU,
- 1 BUX, BUT, BUTX, BV, BVT)
- INTEGER NU, NV
- DOUBLE PRECISION T, L, R, U(NU, 2), UX(NU, 2), UT(NU, 2)
- DOUBLE PRECISION UTX(NU, 2), V(NV), VT(NV), B(NU, 2), BU(NU, NU, 2
- 1 ), BUX(NU, NU, 2)
- DOUBLE PRECISION BUT(NU, NU, 2), BUTX(NU, NU, 2), BV(NU, NV, 2),
- 1 BVT(NU, NV, 2)
- DOUBLE PRECISION DEXP
- B(1, 1) = U(1, 1)-DEXP(T)
- B(1, 2) = U(1, 2)-DEXP(T+1D0)
- BU(1, 1, 1) = 1
- BU(1, 1, 2) = 1
- RETURN
- END
- SUBROUTINE DEE(T, K, X, NX, U, UT, NU, NXMK, V, VT, NV, D,
- 1 DU, DUT, DV, DVT)
- INTEGER NXMK, NU, NV, NX
- INTEGER K
- DOUBLE PRECISION T, X(NX), U(NXMK, NU), UT(NXMK, NU), V(NV), VT(
- 1 NV)
- DOUBLE PRECISION D(NV), DU(NV, NXMK, NU), DUT(NV, NXMK, NU), DV(
- 1 NV, NV), DVT(NV, NV)
- INTEGER I
- DO 1 I = 1, NXMK
- D(I) = U(I, 1)-V(I)
- DU(I, I, 1) = 1
- DV(I, I) = -1
- 1 CONTINUE
- RETURN
- END
- SUBROUTINE HANDLE(T0, U0, V0, T, U, V, NU, NXMK, NV, K, X,
- 1 NX, DT, TSTOP)
- INTEGER NXMK, NU, NV, NX
- INTEGER K
- DOUBLE PRECISION T0, U0(NXMK, NU), V0(NV), T, U(NXMK, NU), V(NV)
- DOUBLE PRECISION X(NX), DT, TSTOP
- COMMON /TIME/ TT
- DOUBLE PRECISION TT
- EXTERNAL UOFX
- INTEGER I1MACH
- DOUBLE PRECISION DEESFF, EU
- INTEGER TEMP
-C OUTPUT AND CHECKING ROUTINE.
- IF (T0 .NE. T) GOTO 2
- TEMP = I1MACH(2)
- WRITE (TEMP, 1) T0, DT
- 1 FORMAT (16H RESTART FOR T =, 1PE10.2, 7H DT =, 1PE10.2)
- RETURN
- 2 TT = T
- EU = DEESFF(K, X, NX, U, UOFX)
- TEMP = I1MACH(2)
- WRITE (TEMP, 3) T, EU
- 3 FORMAT (14H ERROR IN U(X,, 1PE10.2, 4H ) =, 1PE10.2)
- RETURN
- END
- SUBROUTINE UOFX(X, NX, U, W)
- INTEGER NX
- DOUBLE PRECISION X(NX), U(NX), W(NX)
- COMMON /TIME/ T
- DOUBLE PRECISION T
- INTEGER I
- DOUBLE PRECISION DEXP
- DO 1 I = 1, NX
- U(I) = DEXP(T+X(I))
- 1 CONTINUE
- RETURN
- END
- SUBROUTINE INTGRL(K, MESH, NMESH, V, X, NX, F, FV)
- INTEGER NX, NMESH
- INTEGER K
- DOUBLE PRECISION MESH(NMESH), V(1), X(NX), F(NX), FV(NX, 1)
- INTEGER MGQ, I, J, L, IX
- LOGICAL FIRST
- DOUBLE PRECISION EWE, KER, WGQ(3), XGQ(3), B(3, 4, 200), KERU
- DOUBLE PRECISION XX(3)
- INTEGER TEMP, TEMP1
- DATA FIRST/.TRUE./
-C TO COMPUTE
-C F = INTEGRAL FROM MESH(1) TO MESH(NMESH)
-C KERNEL(X,Y,SUM(I=1,...,NMESH-K) V(I)*B(I,Y)) DY
-C AND
-C FV = D(F)/D(V).
-C ASSUME THAT CALL KERNEL(X,Y,U,KER,KERU) RETURNS
-C KER = KERNEL(X,Y,U) AND
-C KERU = PARTIAL KERNEL / PARTIAL U.
-C V(NMESH-K),FV(NX,NMESH-K)
-C THE FOLLOWING DECLARATION IS SPECIFIC TO K = 4 SPLINES.
- IF (NMESH-K .GT. 200) CALL SETERR(27HINTGRL - NMESH-K .GT. NXMAX
- 1 , 27, 1, 2)
-C NEED MORE LOCAL SPACE.
- IF (K .NE. 4) CALL SETERR(17HINTGRL - K .NE. 4, 17, 2, 2)
-C USE K-1 POINT GAUSSIAN-QUADRATURE RULE ON EACH INTERVAL.
- MGQ = K-1
- IF (FIRST) CALL DGQM11(MGQ, XGQ, WGQ)
-C ONLY GET GQ RULE ONCE, ITS EXPENSIVE.
-C THE GAUSSIAN QUADRATURE RULE.
-C DO INTEGRAL INTERVAL BY INTERVAL.
- TEMP = NMESH-K
- DO 6 I = K, TEMP
-C G.Q. POINTS ON (MESH(I), MESH(I+1)).
- DO 1 J = 1, MGQ
- XX(J) = 0.5*(MESH(I+1)+MESH(I))+0.5*(MESH(I+1)-MESH(I))*XGQ(
- 1 J)
- 1 CONTINUE
- IF (FIRST) CALL DBSPLN(K, MESH, NMESH, XX, MGQ, I, B(1, 1, I))
-C ONLY GET B-SPLINE BASIS ONCE, ITS EXPENSIVE.
- DO 5 J = 1, MGQ
-C GET SUM() V()*B()(XX).
- EWE = 0
- DO 2 L = 1, K
- TEMP1 = I+L-K
- EWE = EWE+V(TEMP1)*B(J, L, I)
- 2 CONTINUE
- DO 4 IX = 1, NX
-C GET KERNEL AND PARTIAL.
- CALL KERNEL(X(IX), XX(J), EWE, KER, KERU)
- F(IX) = F(IX)+0.5*KER*(MESH(I+1)-MESH(I))*WGQ(J)
- DO 3 L = 1, K
- TEMP1 = I+L-K
- FV(IX, TEMP1) = FV(IX, TEMP1)+0.5*B(J, L, I)*KERU*(
- 1 MESH(I+1)-MESH(I))*WGQ(J)
- 3 CONTINUE
- 4 CONTINUE
- 5 CONTINUE
- 6 CONTINUE
- FIRST = .FALSE.
- RETURN
- END
- SUBROUTINE KERNEL(X, Y, U, KER, KERU)
- DOUBLE PRECISION X, Y, U, KER, KERU
- DOUBLE PRECISION DEXP
-C TO EVALUATE THE KERNEL EXP(X-Y)*U(Y) AND ITS PARTIAL WRT. U.
- KERU = DEXP(X-Y)
- KER = KERU*U
- RETURN
- END
diff --git a/CEP/PyBDSM/src/port3/ex/dpt9.f b/CEP/PyBDSM/src/port3/ex/dpt9.f
deleted file mode 100644
index f4b1c4a634ebdc9e78bf8d0b70987dba685a2987..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ex/dpt9.f
+++ /dev/null
@@ -1,159 +0,0 @@
-C$TEST DPT9
-C TO RUN AS A MAIN PROGRAM REMOVE NEXT LINE
- SUBROUTINE DPT9
-C***********************************************************************
-C
-C EXAMPLE OF USE OF PORT PROGRAM DPOST
-C
-C***********************************************************************
- COMMON /CSTAK/ DS
- DOUBLE PRECISION DS(2000)
- COMMON /PARAM/ C
- DOUBLE PRECISION C
- EXTERNAL HANDLE, DPOSTD, BC, AF
- INTEGER NDX, NXC, NXX, I, K, IS(1000)
- INTEGER NU, NV, NX, I1MACH
- REAL ERRPAR(2), RS(1000)
- LOGICAL LS(1000)
- COMPLEX CS(500)
- DOUBLE PRECISION DEEBSF, EWE(1000), ERR, U(100), V(1), X(100)
- DOUBLE PRECISION ERRR, DT, XC(100), UC(100), WS(500), XX(1000)
- DOUBLE PRECISION D1MACH, TSTOP
- INTEGER TEMP
- EQUIVALENCE (DS(1), CS(1), WS(1), RS(1), IS(1), LS(1))
-C TO TEST DPOST ON AUTOMATIC, STATIC MESH REFINEMENT.
-C U SUB T = U SUB XX + C * U SUB X ON (0,1)
-C THE SOLUTION IS
-C U(X,T) = EXP(-C*X).
-C THE PORT LIBRARY STACK AND ITS ALIASES.
-C INITIALIZE THE PORT LIBRARY STACK LENGTH.
- CALL ISTKIN(2000, 4)
- C = 50
- NU = 1
- NV = 0
- ERRPAR(1) = 1E-1
- ERRPAR(2) = 1E-1
- K = 4
- NDX = 8
- CALL DUMB(0D0, 1D0, NDX, K, XC, NXC)
-C INITIAL CONDITIONS FOR UC.
- CALL SETD(NXC-K, 0D0, UC)
-C INFINITY.
- ERR = D1MACH(2)
- 1 IF (ERR .LE. 1D-2) GOTO 6
-C HALVE THE CRUDE X.
- CALL DLUMB(XC, NXC, 3, K, X, NX)
-C FITTING POINTS FOR REFINEMENT.
- CALL DLUMD(X, NX, K, XX, NXX)
-C UC ON XX.
- CALL DSPLNE(K, XC, NXC, UC, XX, NXX, EWE)
-C FIT U TO UC ON MESH.
- CALL DDL2SF(XX, EWE, NXX, K, X, NX, U)
- TSTOP = 1D0/D1MACH(4)
- DT = 1D-6
- I = NX-2*(K-1)
- TEMP = I1MACH(2)
- WRITE (TEMP, 2) I
- 2 FORMAT (18H SOLVING FOR NDX =, I3)
- CALL DPOST(U, NU, K, X, NX, V, NV, 0D0, TSTOP, DT, AF, BC,
- 1 DPOSTD, ERRPAR, HANDLE)
-C GET RUN-TIME STATISTICS.
- CALL DPOSTX
-C ERROR ESTIMATE FOR UC.
- ERR = DEEBSF(K, XC, NXC, UC, X, NX, U)
-C ERROR ESTIMATE FOR U.
- ERRR = ERR/16D0
- TEMP = I1MACH(2)
- WRITE (TEMP, 3) ERR, ERRR
- 3 FORMAT (21H ERROR ESTIMATES UC =, 1PE10.2, 9H AND U =, 1P
- 1 E10.2)
- NXC = NX
- DO 4 I = 1, NX
- XC(I) = X(I)
- 4 CONTINUE
- TEMP = NX-K
- DO 5 I = 1, TEMP
- UC(I) = U(I)
- 5 CONTINUE
- GOTO 1
- 6 STOP
- END
- SUBROUTINE AF(T, X, NX, U, UX, UT, UTX, NU, V, VT, NV, A,
- 1 AU, AUX, AUT, AUTX, AV, AVT, F, FU, FUX, FUT, FUTX, FV, FVT)
- INTEGER NU, NX
- INTEGER NV
- DOUBLE PRECISION T, X(NX), U(NX, NU), UX(NX, NU), UT(NX, NU), UTX(
- 1 NX, NU)
- DOUBLE PRECISION V(1), VT(1), A(NX, NU), AU(NX, NU, NU), AUX(NX,
- 1 NU, NU), AUT(NX, NU, NU)
- DOUBLE PRECISION AUTX(NX, NU, NU), AV(1), AVT(1), F(NX, NU), FU(
- 1 NX, NU, NU), FUX(NX, NU, NU)
- DOUBLE PRECISION FUT(NX, NU, NU), FUTX(NX, NU, NU), FV(1), FVT(1)
- COMMON /PARAM/ C
- DOUBLE PRECISION C
- INTEGER I
- DO 1 I = 1, NX
- A(I, 1) = UX(I, 1)+C*U(I, 1)
- AUX(I, 1, 1) = 1
- AU(I, 1, 1) = C
- F(I, 1) = UT(I, 1)
- FUT(I, 1, 1) = 1
- 1 CONTINUE
- RETURN
- END
- SUBROUTINE BC(T, L, R, U, UX, UT, UTX, NU, V, VT, NV, B, BU,
- 1 BUX, BUT, BUTX, BV, BVT)
- INTEGER NU
- INTEGER NV
- DOUBLE PRECISION T, L, R, U(NU, 2), UX(NU, 2), UT(NU, 2)
- DOUBLE PRECISION UTX(NU, 2), V(1), VT(1), B(NU, 2), BU(NU, NU, 2),
- 1 BUX(NU, NU, 2)
- DOUBLE PRECISION BUT(NU, NU, 2), BUTX(NU, NU, 2), BV(1), BVT(1)
- COMMON /PARAM/ C
- DOUBLE PRECISION C
- DOUBLE PRECISION DEXP
- B(1, 1) = U(1, 1)-1D0
- B(1, 2) = U(1, 2)-DEXP(-C)
- BU(1, 1, 1) = 1
- BU(1, 1, 2) = 1
- RETURN
- END
- SUBROUTINE HANDLE(T0, U0, V0, T, U, V, NU, NXMK, NV, K, X,
- 1 NX, DT, TSTOP)
- INTEGER NXMK, NU, NX
- INTEGER NV, K
- DOUBLE PRECISION T0, U0(NXMK, NU), V0(1), T, U(NXMK, NU), V(1)
- DOUBLE PRECISION X(NX), DT, TSTOP
- COMMON /TIME/ TT
- DOUBLE PRECISION TT
- EXTERNAL UOFX
- INTEGER I1MACH
- DOUBLE PRECISION DEESFF, EU
- INTEGER TEMP
-C OUTPUT AND CHECKING ROUTINE.
- IF (T0 .NE. T) GOTO 2
- TEMP = I1MACH(2)
- WRITE (TEMP, 1) T
- 1 FORMAT (16H RESTART FOR T =, 1PE10.2)
- RETURN
- 2 TT = T
- EU = DEESFF(K, X, NX, U, UOFX)
- TEMP = I1MACH(2)
- WRITE (TEMP, 3) T, EU
- 3 FORMAT (15H ERROR IN U(X, , 1PE10.2, 4H ) =, 1PE10.2)
- RETURN
- END
- SUBROUTINE UOFX(X, NX, U, W)
- INTEGER NX
- DOUBLE PRECISION X(NX), U(NX), W(NX)
- COMMON /PARAM/ C
- DOUBLE PRECISION C
- COMMON /TIME/ T
- DOUBLE PRECISION T
- INTEGER I
- DOUBLE PRECISION DEXP
- DO 1 I = 1, NX
- U(I) = DEXP((-C)*X(I))
- 1 CONTINUE
- RETURN
- END
diff --git a/CEP/PyBDSM/src/port3/ex/dptt.f b/CEP/PyBDSM/src/port3/ex/dptt.f
deleted file mode 100644
index 6082f6955127e1238028dc74e1f8dfe6a048c994..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ex/dptt.f
+++ /dev/null
@@ -1,157 +0,0 @@
-C$TEST DPTT
-C TO RUN AS A MAIN PROGRAM REMOVE NEXT LINE
- SUBROUTINE DPTT
-C***********************************************************************
-C
-C EXAMPLE OF USE OF PORT PROGRAM DPOST
-C
-C***********************************************************************
- COMMON /CSTAK/ DS
- DOUBLE PRECISION DS(2000)
- EXTERNAL HANDLE, DPOSTD, BC, AF
- INTEGER NDX, NXH, I, K, IS(1000), NU
- INTEGER NV, NX, I1MACH
- REAL ERRPAR(2), RS(1000)
- LOGICAL LS(1000)
- COMPLEX CS(500)
- DOUBLE PRECISION DEEBSF, ERR, DABS, U(100), V(1), X(100)
- DOUBLE PRECISION DMAX1, DT, UE(100), UH(100), XH(100), WS(500)
- DOUBLE PRECISION TSTOP
- INTEGER TEMP
- EQUIVALENCE (DS(1), CS(1), WS(1), RS(1), IS(1), LS(1))
-C TO ESTIMATE X AND T ERROR AS SUM.
-C U SUB T = U SUB XX + F ON (0,1)
-C WHERE F IS CHOSEN SO THAT THE SOLUTION IS
-C U(X,T) = EXP(XT).
-C THE PORT LIBRARY STACK AND ITS ALIASES.
-C INITIALIZE THE PORT LIBRARY STACK LENGTH.
- CALL ISTKIN(2000, 4)
- NU = 1
- NV = 0
- ERRPAR(1) = 0
- ERRPAR(2) = 1E-2
- K = 4
- NDX = 4
- TSTOP = 1
- DT = 1D-2
-C CRUDE MESH.
- CALL DUMB(0D0, 1D0, NDX, K, X, NX)
-C INITIAL CONDITIONS FOR U.
- CALL SETD(NX-K, 1D0, U)
- TEMP = I1MACH(2)
- WRITE (TEMP, 1)
- 1 FORMAT (36H SOLVING ON CRUDE MESH USING ERRPAR.)
- CALL DPOST(U, NU, K, X, NX, V, NV, 0D0, TSTOP, DT, AF, BC, DPOSTD,
- 1 ERRPAR, HANDLE)
-C GET RUN-TIME STATISTICS.
- CALL DPOSTX
-C HALVE THE MESH SPACING.
- CALL DUMB(0D0, 1D0, 2*NDX-1, K, XH, NXH)
-C INITIAL CONDITIONS FOR UH.
- CALL SETD(NXH-K, 1D0, UH)
- DT = 1D-2
- TEMP = I1MACH(2)
- WRITE (TEMP, 2)
- 2 FORMAT (38H SOLVING ON REFINED MESH USING ERRPAR.)
- CALL DPOST(UH, NU, K, XH, NXH, V, NV, 0D0, TSTOP, DT, AF, BC,
- 1 DPOSTD, ERRPAR, HANDLE)
-C GET RUN-TIME STATISTICS.
- CALL DPOSTX
-C ESTIMATE U ERROR.
- ERR = DEEBSF(K, X, NX, U, XH, NXH, UH)
- WRITE (6, 3) ERR
- 3 FORMAT (24H U ERROR FROM U AND UH =, 1PE10.2)
-C INITIAL CONDITIONS FOR UE.
- CALL SETD(NX-K, 1D0, UE)
- DT = 1D-2
- ERRPAR(1) = ERRPAR(1)/10.
- ERRPAR(2) = ERRPAR(2)/10.
- TEMP = I1MACH(2)
- WRITE (TEMP, 4)
- 4 FORMAT (39H SOLVING ON CRUDE MESH USING ERRPAR/10.)
- CALL DPOST(UE, NU, K, X, NX, V, NV, 0D0, TSTOP, DT, AF, BC,
- 1 DPOSTD, ERRPAR, HANDLE)
-C GET RUN-TIME STATISTICS.
- CALL DPOSTX
- ERR = 0
- TEMP = NX-K
- DO 5 I = 1, TEMP
- ERR = DMAX1(ERR, DABS(U(I)-UE(I)))
- 5 CONTINUE
- WRITE (6, 6) ERR
- 6 FORMAT (24H U ERROR FROM U AND UE =, 1PE10.2)
- STOP
- END
- SUBROUTINE AF(T, X, NX, U, UX, UT, UTX, NU, V, VT, NV, A,
- 1 AU, AUX, AUT, AUTX, AV, AVT, F, FU, FUX, FUT, FUTX, FV, FVT)
- INTEGER NU, NX
- INTEGER NV
- DOUBLE PRECISION T, X(NX), U(NX, NU), UX(NX, NU), UT(NX, NU), UTX(
- 1 NX, NU)
- DOUBLE PRECISION V(1), VT(1), A(NX, NU), AU(NX, NU, NU), AUX(NX,
- 1 NU, NU), AUT(NX, NU, NU)
- DOUBLE PRECISION AUTX(NX, NU, NU), AV(1), AVT(1), F(NX, NU), FU(
- 1 NX, NU, NU), FUX(NX, NU, NU)
- DOUBLE PRECISION FUT(NX, NU, NU), FUTX(NX, NU, NU), FV(1), FVT(1)
- INTEGER I
- DOUBLE PRECISION DEXP
- DO 1 I = 1, NX
- A(I, 1) = -UX(I, 1)
- AUX(I, 1, 1) = -1
- F(I, 1) = (X(I)-T**2)*DEXP(X(I)*T)-UT(I, 1)
- FUT(I, 1, 1) = -1
- 1 CONTINUE
- RETURN
- END
- SUBROUTINE BC(T, L, R, U, UX, UT, UTX, NU, V, VT, NV, B, BU,
- 1 BUX, BUT, BUTX, BV, BVT)
- INTEGER NU
- INTEGER NV
- DOUBLE PRECISION T, L, R, U(NU, 2), UX(NU, 2), UT(NU, 2)
- DOUBLE PRECISION UTX(NU, 2), V(1), VT(1), B(NU, 2), BU(NU, NU, 2),
- 1 BUX(NU, NU, 2)
- DOUBLE PRECISION BUT(NU, NU, 2), BUTX(NU, NU, 2), BV(1), BVT(1)
- DOUBLE PRECISION DEXP
- B(1, 1) = U(1, 1)-1D0
- B(1, 2) = U(1, 2)-DEXP(T)
- BU(1, 1, 1) = 1
- BU(1, 1, 2) = 1
- RETURN
- END
- SUBROUTINE HANDLE(T0, U0, V0, T, U, V, NU, NXMK, NV, K, X,
- 1 NX, DT, TSTOP)
- INTEGER NXMK, NU, NX
- INTEGER NV, K
- DOUBLE PRECISION T0, U0(NXMK, NU), V0(1), T, U(NXMK, NU), V(1)
- DOUBLE PRECISION X(NX), DT, TSTOP
- COMMON /TIME/ TT
- DOUBLE PRECISION TT
- EXTERNAL UOFX
- INTEGER I1MACH
- DOUBLE PRECISION DEESFF, EU
- INTEGER TEMP
-C OUTPUT AND CHECKING ROUTINE.
- IF (T0 .NE. T) GOTO 2
- TEMP = I1MACH(2)
- WRITE (TEMP, 1) T
- 1 FORMAT (16H RESTART FOR T =, 1PE10.2)
- RETURN
- 2 TT = T
- EU = DEESFF(K, X, NX, U, UOFX)
- TEMP = I1MACH(2)
- WRITE (TEMP, 3) T, EU
- 3 FORMAT (14H ERROR IN U(X,, 1PE10.2, 4H ) =, 1PE10.2)
- RETURN
- END
- SUBROUTINE UOFX(X, NX, U, W)
- INTEGER NX
- DOUBLE PRECISION X(NX), U(NX), W(NX)
- COMMON /TIME/ T
- DOUBLE PRECISION T
- INTEGER I
- DOUBLE PRECISION DEXP
- DO 1 I = 1, NX
- U(I) = DEXP(X(I)*T)
- 1 CONTINUE
- RETURN
- END
diff --git a/CEP/PyBDSM/src/port3/ex/dtg1.f b/CEP/PyBDSM/src/port3/ex/dtg1.f
deleted file mode 100644
index a1ebffdc62234ff54441f9b27598b070bfae211b..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ex/dtg1.f
+++ /dev/null
@@ -1,197 +0,0 @@
-C$TEST DTG1
-C TO RUN AS A MAIN PROGRAM REMOVE NEXT LINE
- SUBROUTINE DTG1
-C***********************************************************************
-C
-C EXAMPLE OF USE OF PORT PROGRAM DTTGR
-C
-C***********************************************************************
- COMMON /CSTAK/ DS
- DOUBLE PRECISION DS(350000)
- EXTERNAL HANDLE, BC, AF
- INTEGER NDX, NDY, ISTKGT, IS(1000), IU, IX
- INTEGER IY, NU, KX, NX, KY, NY
- INTEGER IDUMB
- REAL ERRPAR(2), RS(1000)
- LOGICAL LS(1000)
- COMPLEX CS(500)
- DOUBLE PRECISION TSTART, DT, LX, LY, RX, RY
- DOUBLE PRECISION WS(500), TSTOP
- EQUIVALENCE (DS(1), CS(1), WS(1), RS(1), IS(1), LS(1))
-C TO SOLVE THE HEAT EQUATION WITH SOLUTION U == T*X*Y,
-C GRAD . ( U + UX + .1 * UY, U + UY + .1 * UX ) = UT + UX + UY +G(X,T)
-C THE PORT LIBRARY STACK AND ITS ALIASES.
-C INITIALIZE THE PORT LIBRARY STACK LENGTH.
- CALL ISTKIN(350000, 4)
- CALL ENTER(1)
- NU = 1
- LX = 0
- RX = 1
- LY = 0
- RY = 1
- KX = 2
- KY = 2
- NDX = 3
- NDY = 3
- TSTART = 0
- TSTOP = 1
- DT = 1
- ERRPAR(1) = 1E-2
- ERRPAR(2) = 1E-4
-C UNIFORM GRID.
- IX = IDUMB(LX, RX, NDX, KX, NX)
-C UNIFORM GRID.
- IY = IDUMB(LY, RY, NDY, KY, NY)
-C SPACE FOR THE SOLUTION.
- IU = ISTKGT(NU*(NX-KX)*(NY-KY), 4)
-C INITIAL CONDITIONS FOR U.
- CALL SETD(NU*(NX-KX)*(NY-KY), 0D0, WS(IU))
- CALL DTTGR(WS(IU), NU, KX, WS(IX), NX, KY, WS(IY), NY, TSTART,
- 1 TSTOP, DT, AF, BC, ERRPAR, HANDLE)
- CALL LEAVE
- CALL WRAPUP
- STOP
- END
- SUBROUTINE AF(T, X, NX, Y, NY, NU, U, UT, UX, UY, UXT, UYT
- 1 , A, AU, AUT, AUX, AUY, AUXT, AUYT, F, FU, FUT, FUX, FUY, FUXT,
- 2 FUYT)
- INTEGER NU, NX, NY
- DOUBLE PRECISION T, X(NX), Y(NY), U(NX, NY, NU), UT(NX, NY, NU),
- 1 UX(NX, NY, NU)
- DOUBLE PRECISION UY(NX, NY, NU), UXT(NX, NY, NU), UYT(NX, NY, NU),
- 1 A(NX, NY, NU, 2), AU(NX, NY, NU, NU, 2), AUT(NX, NY, NU, NU, 2)
- DOUBLE PRECISION AUX(NX, NY, NU, NU, 2), AUY(NX, NY, NU, NU, 2),
- 1 AUXT(NX, NY, NU, NU, 2), AUYT(NX, NY, NU, NU, 2), F(NX, NY, NU)
- 2 , FU(NX, NY, NU, NU)
- DOUBLE PRECISION FUT(NX, NY, NU, NU), FUX(NX, NY, NU, NU), FUY(NX,
- 1 NY, NU, NU), FUXT(NX, NY, NU, NU), FUYT(NX, NY, NU, NU)
- INTEGER I, P, Q
- DO 3 I = 1, NU
- DO 2 Q = 1, NY
- DO 1 P = 1, NX
- A(P, Q, I, 1) = UX(P, Q, I)+.1*UY(P, Q, I)+U(P, Q, I)
- A(P, Q, I, 2) = UY(P, Q, I)+.1*UX(P, Q, I)+U(P, Q, I)
- AUX(P, Q, I, I, 1) = 1
- AUY(P, Q, I, I, 2) = 1
- AUY(P, Q, I, I, 1) = .1
- AUX(P, Q, I, I, 2) = .1
- AU(P, Q, I, I, 1) = 1
- AU(P, Q, I, I, 2) = 1
- F(P, Q, I) = UT(P, Q, I)+UX(P, Q, I)+UY(P, Q, I)
- FUT(P, Q, I, I) = 1
- FUX(P, Q, I, I) = 1
- FUY(P, Q, I, I) = 1
- F(P, Q, I) = F(P, Q, I)+.2*T-X(P)*Y(Q)
- 1 CONTINUE
- 2 CONTINUE
- 3 CONTINUE
- RETURN
- END
- SUBROUTINE BC(T, X, NX, Y, NY, LX, RX, LY, RY, U, UT, UX,
- 1 UY, UXT, UYT, NU, B, BU, BUT, BUX, BUY, BUXT, BUYT)
- INTEGER NU, NX, NY
- DOUBLE PRECISION T, X(NX), Y(NY), LX, RX, LY
- DOUBLE PRECISION RY, U(NX, NY, NU), UT(NX, NY, NU), UX(NX, NY, NU)
- 1 , UY(NX, NY, NU), UXT(NX, NY, NU)
- DOUBLE PRECISION UYT(NX, NY, NU), B(NX, NY, NU), BU(NX, NY, NU,
- 1 NU), BUT(NX, NY, NU, NU), BUX(NX, NY, NU, NU), BUY(NX, NY, NU
- 2 , NU)
- DOUBLE PRECISION BUXT(NX, NY, NU, NU), BUYT(NX, NY, NU, NU)
- INTEGER I, J
- DO 2 J = 1, NY
- DO 1 I = 1, NX
- BU(I, J, 1, 1) = 1
- B(I, J, 1) = U(I, J, 1)-T*X(I)*Y(J)
- 1 CONTINUE
- 2 CONTINUE
- RETURN
- END
- SUBROUTINE HANDLE(T0, U0, T, U, NV, DT, TSTOP)
- INTEGER NV
- DOUBLE PRECISION T0, U0(NV), T, U(NV), DT, TSTOP
- COMMON /D7TGRP/ ERRPAR, NU, MXQ, MYQ
- INTEGER NU, MXQ, MYQ
- REAL ERRPAR(2)
- COMMON /D7TGRM/ KX, IX, NX, KY, IY, NY
- INTEGER KX, IX, NX, KY, IY, NY
- IF (T0 .NE. T) GOTO 2
- WRITE (6, 1) T
- 1 FORMAT (16H RESTART FOR T =, 1PE10.2)
- RETURN
-C GET AND PRINT THE ERROR.
- 2 CALL GERR(KX, IX, NX, KY, IY, NY, U, NU, T)
- RETURN
- END
- SUBROUTINE GERR(KX, IX, NX, KY, IY, NY, U, NU, T)
- INTEGER KX, IX, NX, KY, IY, NY
- INTEGER NU
- DOUBLE PRECISION U(1), T
- COMMON /CSTAK/ DS
- DOUBLE PRECISION DS(500)
- INTEGER IFA, ITA(2), IXA(2), NTA(2), NXA(2), IDLUMD
- INTEGER IXS, IYS, NXS, NYS, ISTKGT, I
- INTEGER IEWE, KA(2), MA(2), IS(1000), I1MACH
- REAL RS(1000)
- LOGICAL LS(1000)
- COMPLEX CS(500)
- DOUBLE PRECISION DABS, ERRU, DMAX1, WS(500)
- INTEGER TEMP, TEMP1, TEMP2
- EQUIVALENCE (DS(1), CS(1), WS(1), RS(1), IS(1), LS(1))
-C TO GET AND PRINT THE ERROR AT EACH TIME-STEP.
-C U(NX-KX,NY0KY,NU).
-C THE PORT LIBRARY STACK AND ITS ALIASES.
- CALL ENTER(1)
-C FIND THE ERROR IN THE SOLUTION AT 2*KX * 2*KY POINTS / MESH RECTANGLE.
-C X SEARCH GRID.
- IXS = IDLUMD(WS(IX), NX, 2*KX, NXS)
-C Y SEARCH GRID.
- IYS = IDLUMD(WS(IY), NY, 2*KY, NYS)
-C U SEARCH GRID VALUES.
- IEWE = ISTKGT(NXS*NYS, 4)
-C THE EXACT SOLUTION.
- CALL EWE(T, WS(IXS), NXS, WS(IYS), NYS, WS(IEWE), NU)
- KA(1) = KX
- KA(2) = KY
- ITA(1) = IX
- ITA(2) = IY
- NTA(1) = NX
- NTA(2) = NY
- IXA(1) = IXS
- IXA(2) = IYS
- NXA(1) = NXS
- NXA(2) = NYS
- MA(1) = 0
-C GET SOLUTION.
- MA(2) = 0
-C APPROXIMATE SOLUTION VALUES.
- IFA = ISTKGT(NXS*NYS, 4)
-C EVALUATE THEM.
- CALL DTSD1(2, KA, WS, ITA, NTA, U, WS, IXA, NXA, MA, WS(IFA))
-C ERROR IN SOLUTION VALUES.
- ERRU = 0
- TEMP = NXS*NYS
- DO 1 I = 1, TEMP
- TEMP2 = IEWE+I
- TEMP1 = IFA+I
- ERRU = DMAX1(ERRU, DABS(WS(TEMP2-1)-WS(TEMP1-1)))
- 1 CONTINUE
- TEMP = I1MACH(2)
- WRITE (TEMP, 2) T, ERRU
- 2 FORMAT (14H ERROR IN U(.,, 1PE10.2, 3H) =, 1PE10.2)
- CALL LEAVE
- RETURN
- END
- SUBROUTINE EWE(T, X, NX, Y, NY, U, NU)
- INTEGER NU, NX, NY
- DOUBLE PRECISION T, X(NX), Y(NY), U(NX, NY, NU)
- INTEGER I, J, P
-C THE EXACT SOLUTION.
- DO 3 P = 1, NU
- DO 2 I = 1, NX
- DO 1 J = 1, NY
- U(I, J, P) = T*X(I)*Y(J)
- 1 CONTINUE
- 2 CONTINUE
- 3 CONTINUE
- RETURN
- END
diff --git a/CEP/PyBDSM/src/port3/ex/dtg2.f b/CEP/PyBDSM/src/port3/ex/dtg2.f
deleted file mode 100644
index 69fce80ff121b236196a7b2c36062f59ca145b8b..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ex/dtg2.f
+++ /dev/null
@@ -1,202 +0,0 @@
-C$TEST DTG2
-C TO RUN AS A MAIN PROGRAM REMOVE NEXT LINE
- SUBROUTINE DTG2
-C***********************************************************************
-C
-C EXAMPLE OF USE OF PORT PROGRAM DTTGR
-C
-C***********************************************************************
- COMMON /CSTAK/ DS
- DOUBLE PRECISION DS(350000)
- EXTERNAL HANDLE, BC, AF
- INTEGER NDX, NDY, ISTKGT, IS(1000), IU, IX
- INTEGER IY, NU, KX, NX, KY, NY
- INTEGER IDUMB
- REAL ERRPAR(2), RS(1000)
- LOGICAL LS(1000)
- COMPLEX CS(500)
- DOUBLE PRECISION TSTART, DT, LX, LY, RX, RY
- DOUBLE PRECISION WS(500), TSTOP
- EQUIVALENCE (DS(1), CS(1), WS(1), RS(1), IS(1), LS(1))
-C TO SOLVE TWO COUPLED, NONLINEAR HEAT EQUATIONS.
-C U1 SUB T = DIV . ( U1X, U1Y ) - U1*U2 + G1
-C U2 SUB T = DIV . ( U2X, U2Y ) - U1*U2 + G2
-C THE PORT LIBRARY STACK AND ITS ALIASES.
-C INITIALIZE THE PORT LIBRARY STACK LENGTH.
- CALL ISTKIN(350000, 4)
- CALL ENTER(1)
- NU = 2
- LX = 0
- RX = 1
- LY = 0
- RY = 1
- KX = 4
- KY = 4
- NDX = 3
- NDY = 3
- TSTART = 0
- TSTOP = 1
- DT = 1E-2
- ERRPAR(1) = 1E-2
- ERRPAR(2) = 1E-4
-C UNIFORM GRID.
- IX = IDUMB(LX, RX, NDX, KX, NX)
-C UNIFORM GRID.
- IY = IDUMB(LY, RY, NDY, KY, NY)
-C SPACE FOR THE SOLUTION.
- IU = ISTKGT(NU*(NX-KX)*(NY-KY), 4)
- CALL SETD(NU*(NX-KX)*(NY-KY), 1D0, WS(IU))
- CALL DTTGR(WS(IU), NU, KX, WS(IX), NX, KY, WS(IY), NY, TSTART,
- 1 TSTOP, DT, AF, BC, ERRPAR, HANDLE)
- CALL LEAVE
- CALL WRAPUP
- STOP
- END
- SUBROUTINE AF(T, X, NX, Y, NY, NU, U, UT, UX, UY, UXT, UYT
- 1 , A, AU, AUT, AUX, AUY, AUXT, AUYT, F, FU, FUT, FUX, FUY, FUXT,
- 2 FUYT)
- INTEGER NU, NX, NY
- DOUBLE PRECISION T, X(NX), Y(NY), U(NX, NY, NU), UT(NX, NY, NU),
- 1 UX(NX, NY, NU)
- DOUBLE PRECISION UY(NX, NY, NU), UXT(NX, NY, NU), UYT(NX, NY, NU),
- 1 A(NX, NY, NU, 2), AU(NX, NY, NU, NU, 2), AUT(NX, NY, NU, NU, 2)
- DOUBLE PRECISION AUX(NX, NY, NU, NU, 2), AUY(NX, NY, NU, NU, 2),
- 1 AUXT(NX, NY, NU, NU, 2), AUYT(NX, NY, NU, NU, 2), F(NX, NY, NU)
- 2 , FU(NX, NY, NU, NU)
- DOUBLE PRECISION FUT(NX, NY, NU, NU), FUX(NX, NY, NU, NU), FUY(NX,
- 1 NY, NU, NU), FUXT(NX, NY, NU, NU), FUYT(NX, NY, NU, NU)
- INTEGER P, Q
- DOUBLE PRECISION DEXP
- DO 2 Q = 1, NY
- DO 1 P = 1, NX
- A(P, Q, 1, 1) = UX(P, Q, 1)
- AUX(P, Q, 1, 1, 1) = 1
- A(P, Q, 1, 2) = UY(P, Q, 1)
- AUY(P, Q, 1, 1, 2) = 1
- F(P, Q, 1) = UT(P, Q, 1)+U(P, Q, 1)*U(P, Q, 2)
- FU(P, Q, 1, 1) = U(P, Q, 2)
- FU(P, Q, 1, 2) = U(P, Q, 1)
- FUT(P, Q, 1, 1) = 1
- A(P, Q, 2, 1) = UX(P, Q, 2)
- AUX(P, Q, 2, 2, 1) = 1
- A(P, Q, 2, 2) = UY(P, Q, 2)
- AUY(P, Q, 2, 2, 2) = 1
- F(P, Q, 2) = UT(P, Q, 2)+U(P, Q, 1)*U(P, Q, 2)
- FU(P, Q, 2, 1) = U(P, Q, 2)
- FU(P, Q, 2, 2) = U(P, Q, 1)
- FUT(P, Q, 2, 2) = 1
- F(P, Q, 1) = F(P, Q, 1)-(DEXP(T*(X(P)-Y(Q)))*(X(P)-Y(Q)-2D0*
- 1 T*T)+1D0)
- F(P, Q, 2) = F(P, Q, 2)-(DEXP(T*(Y(Q)-X(P)))*(Y(Q)-X(P)-2D0*
- 1 T*T)+1D0)
- 1 CONTINUE
- 2 CONTINUE
- RETURN
- END
- SUBROUTINE BC(T, X, NX, Y, NY, LX, RX, LY, RY, U, UT, UX,
- 1 UY, UXT, UYT, NU, B, BU, BUT, BUX, BUY, BUXT, BUYT)
- INTEGER NU, NX, NY
- DOUBLE PRECISION T, X(NX), Y(NY), LX, RX, LY
- DOUBLE PRECISION RY, U(NX, NY, NU), UT(NX, NY, NU), UX(NX, NY, NU)
- 1 , UY(NX, NY, NU), UXT(NX, NY, NU)
- DOUBLE PRECISION UYT(NX, NY, NU), B(NX, NY, NU), BU(NX, NY, NU,
- 1 NU), BUT(NX, NY, NU, NU), BUX(NX, NY, NU, NU), BUY(NX, NY, NU
- 2 , NU)
- DOUBLE PRECISION BUXT(NX, NY, NU, NU), BUYT(NX, NY, NU, NU)
- INTEGER I, J
- DOUBLE PRECISION DEXP
- DO 2 J = 1, NY
- DO 1 I = 1, NX
- BU(I, J, 1, 1) = 1
- B(I, J, 1) = U(I, J, 1)-DEXP(T*(X(I)-Y(J)))
- BU(I, J, 2, 2) = 1
- B(I, J, 2) = U(I, J, 2)-DEXP(T*(Y(J)-X(I)))
- 1 CONTINUE
- 2 CONTINUE
- RETURN
- END
- SUBROUTINE HANDLE(T0, U0, T, U, NV, DT, TSTOP)
- INTEGER NV
- DOUBLE PRECISION T0, U0(NV), T, U(NV), DT, TSTOP
- COMMON /CSTAK/ DS
- DOUBLE PRECISION DS(500)
- COMMON /D7TGRP/ ERRPAR, NU, MXQ, MYQ
- INTEGER NU, MXQ, MYQ
- REAL ERRPAR(2)
- COMMON /D7TGRM/ KX, IX, NX, KY, IY, NY
- INTEGER KX, IX, NX, KY, IY, NY
- INTEGER IFA, ITA(2), IXA(2), NTA(2), NXA(2), IDLUMD
- INTEGER IXS, IYS, NXS, NYS, ISTKGT, I
- INTEGER J, IEWE, KA(2), MA(2), IS(1000), I1MACH
- REAL RS(1000)
- LOGICAL LS(1000)
- COMPLEX CS(500)
- DOUBLE PRECISION DABS, ERRU, DMAX1, WS(500)
- INTEGER TEMP, TEMP1, TEMP2
- EQUIVALENCE (DS(1), CS(1), WS(1), RS(1), IS(1), LS(1))
-C THE PORT LIBRARY STACK AND ITS ALIASES.
- IF (T0 .NE. T) GOTO 2
- WRITE (6, 1) T
- 1 FORMAT (16H RESTART FOR T =, 1PE10.2)
- RETURN
- 2 CALL ENTER(1)
-C FIND THE ERROR IN THE SOLUTION AT 2*KX * 2*KY POINTS / MESH RECTANGLE.
-C X SEARCH GRID.
- IXS = IDLUMD(WS(IX), NX, 2*KX, NXS)
-C Y SEARCH GRID.
- IYS = IDLUMD(WS(IY), NY, 2*KY, NYS)
-C U SEARCH GRID VALUES.
- IEWE = ISTKGT(NU*NXS*NYS, 4)
-C THE EXACT SOLUTION.
- CALL EWE(T, WS(IXS), NXS, WS(IYS), NYS, WS(IEWE), NU)
- KA(1) = KX
- KA(2) = KY
- ITA(1) = IX
- ITA(2) = IY
- NTA(1) = NX
- NTA(2) = NY
- IXA(1) = IXS
- IXA(2) = IYS
- NXA(1) = NXS
- NXA(2) = NYS
- MA(1) = 0
-C GET SOLUTION.
- MA(2) = 0
-C APPROXIMATE SOLUTION VALUES.
- IFA = ISTKGT(NXS*NYS, 4)
- DO 5 J = 1, NU
-C EVALUATE THEM.
- TEMP = (J-1)*(NX-KX)*(NY-KY)
- CALL DTSD1(2, KA, WS, ITA, NTA, U(TEMP+1), WS, IXA, NXA, MA,
- 1 WS(IFA))
-C ERROR IN SOLUTION VALUES.
- ERRU = 0
- TEMP = NXS*NYS
- DO 3 I = 1, TEMP
- TEMP2 = IEWE+I-1+(J-1)*NXS*NYS
- TEMP1 = IFA+I
- ERRU = DMAX1(ERRU, DABS(WS(TEMP2)-WS(TEMP1-1)))
- 3 CONTINUE
- TEMP = I1MACH(2)
- WRITE (TEMP, 4) T, J, ERRU
- 4 FORMAT (14H ERROR IN U(.,, 1PE10.2, 1H,, I2, 3H) =, 1PE10.2)
- 5 CONTINUE
- CALL LEAVE
- RETURN
- END
- SUBROUTINE EWE(T, X, NX, Y, NY, U, NU)
- INTEGER NU, NX, NY
- DOUBLE PRECISION T, X(NX), Y(NY), U(NX, NY, NU)
- INTEGER I, J, P
- REAL FLOAT
- DOUBLE PRECISION DBLE, DEXP
-C THE EXACT SOLUTION.
- DO 3 P = 1, NU
- DO 2 I = 1, NX
- DO 1 J = 1, NY
- U(I, J, P) = DEXP(DBLE(FLOAT((-1)**(P+1)))*T*(X(I)-Y(J)))
- 1 CONTINUE
- 2 CONTINUE
- 3 CONTINUE
- RETURN
- END
diff --git a/CEP/PyBDSM/src/port3/ex/dtg3.f b/CEP/PyBDSM/src/port3/ex/dtg3.f
deleted file mode 100644
index 708e737198774ed0c30596d9279d8f65ac01d294..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ex/dtg3.f
+++ /dev/null
@@ -1,235 +0,0 @@
-C$TEST DTG3
-C TO RUN AS A MAIN PROGRAM REMOVE NEXT LINE
- SUBROUTINE DTG3
-C***********************************************************************
-C
-C EXAMPLE OF USE OF PORT PROGRAM DTTGR
-C
-C***********************************************************************
- COMMON /CSTAK/ DS
- DOUBLE PRECISION DS(350000)
- EXTERNAL HANDLE, BC, AF
- INTEGER NDX, NDY, IDLUMB, ISTKGT, I, IS(1000)
- INTEGER IU, IX, IY, NU, KX, NX
- INTEGER KY, NY, IDUMB, IMMMD
- REAL ERRPAR(2), RS(1000)
- LOGICAL LS(1000)
- COMPLEX CS(500)
- DOUBLE PRECISION TSTART, DT, YB(4), LX, RX, WS(500)
- DOUBLE PRECISION TSTOP
- EQUIVALENCE (DS(1), CS(1), WS(1), RS(1), IS(1), LS(1))
-C TO SOLVE THE LAYERED HEAT EQUATION, WITH KAPPA = 1, 1/2, 1/3,
-C DIV . ( KAPPA(X,Y) * GRAD U ) = UT + G
-C THE PORT LIBRARY STACK AND ITS ALIASES.
-C INITIALIZE THE PORT LIBRARY STACK LENGTH.
- CALL ISTKIN(350000, 4)
- CALL ENTER(1)
- NU = 1
- LX = 0
- RX = 1
- DO 1 I = 1, 4
- YB(I) = I-1
- 1 CONTINUE
- KX = 2
- KY = 2
- NDX = 3
- NDY = 3
- TSTART = 0
- TSTOP = 1
- DT = 1
- ERRPAR(1) = 1E-2
- ERRPAR(2) = 1E-4
-C UNIFORM GRID.
- IX = IDUMB(LX, RX, NDX, KX, NX)
-C UNIFORM GRID.
- IY = IDLUMB(YB, 4, NDY, KY, NY)
-C MAKE MULT = KY-1.
- IY = IMMMD(IY, NY, YB(2), KY-1)
-C MAKE MULT = KY-1.
- IY = IMMMD(IY, NY, YB(3), KY-1)
-C SPACE FOR THE SOLUTION.
- IU = ISTKGT(NU*(NX-KX)*(NY-KY), 4)
- CALL SETD(NU*(NX-KX)*(NY-KY), 0D0, WS(IU))
- CALL DTTGR(WS(IU), NU, KX, WS(IX), NX, KY, WS(IY), NY, TSTART,
- 1 TSTOP, DT, AF, BC, ERRPAR, HANDLE)
- CALL LEAVE
- CALL WRAPUP
- STOP
- END
- SUBROUTINE AF(T, X, NX, Y, NY, NU, U, UT, UX, UY, UXT, UYT
- 1 , A, AU, AUT, AUX, AUY, AUXT, AUYT, F, FU, FUT, FUX, FUY, FUXT,
- 2 FUYT)
- INTEGER NU, NX, NY
- DOUBLE PRECISION T, X(NX), Y(NY), U(NX, NY, NU), UT(NX, NY, NU),
- 1 UX(NX, NY, NU)
- DOUBLE PRECISION UY(NX, NY, NU), UXT(NX, NY, NU), UYT(NX, NY, NU),
- 1 A(NX, NY, NU, 2), AU(NX, NY, NU, NU, 2), AUT(NX, NY, NU, NU, 2)
- DOUBLE PRECISION AUX(NX, NY, NU, NU, 2), AUY(NX, NY, NU, NU, 2),
- 1 AUXT(NX, NY, NU, NU, 2), AUYT(NX, NY, NU, NU, 2), F(NX, NY, NU)
- 2 , FU(NX, NY, NU, NU)
- DOUBLE PRECISION FUT(NX, NY, NU, NU), FUX(NX, NY, NU, NU), FUY(NX,
- 1 NY, NU, NU), FUXT(NX, NY, NU, NU), FUYT(NX, NY, NU, NU)
- INTEGER I, P, Q
- DOUBLE PRECISION KAPPA
- LOGICAL TEMP
- DO 7 I = 1, NU
- DO 6 Q = 1, NY
- DO 5 P = 1, NX
- IF (Y(Q) .GE. 1D0) GOTO 1
- KAPPA = 1
- GOTO 4
- 1 IF (Y(Q) .GE. 2D0) GOTO 2
- KAPPA = 0.5
- GOTO 3
- 2 KAPPA = 1D0/3D0
- 3 CONTINUE
- 4 A(P, Q, I, 1) = KAPPA*UX(P, Q, I)
- AUX(P, Q, I, I, 1) = KAPPA
- A(P, Q, I, 2) = KAPPA*UY(P, Q, I)
- AUY(P, Q, I, I, 2) = KAPPA
- F(P, Q, I) = UT(P, Q, I)
- FUT(P, Q, I, I) = 1
- F(P, Q, I) = F(P, Q, I)-Y(Q)/KAPPA
- TEMP = 1D0 .LT. Y(Q)
- IF (TEMP) TEMP = Y(Q) .LT. 2D0
- IF (TEMP) F(P, Q, I) = F(P, Q, I)+1D0
- TEMP = 2D0 .LT. Y(Q)
- IF (TEMP) TEMP = Y(Q) .LT. 3D0
- IF (TEMP) F(P, Q, I) = F(P, Q, I)+3D0
- 5 CONTINUE
- 6 CONTINUE
- 7 CONTINUE
- RETURN
- END
- SUBROUTINE BC(T, X, NX, Y, NY, LX, RX, LY, RY, U, UT, UX,
- 1 UY, UXT, UYT, NU, B, BU, BUT, BUX, BUY, BUXT, BUYT)
- INTEGER NU, NX, NY
- DOUBLE PRECISION T, X(NX), Y(NY), LX, RX, LY
- DOUBLE PRECISION RY, U(NX, NY, NU), UT(NX, NY, NU), UX(NX, NY, NU)
- 1 , UY(NX, NY, NU), UXT(NX, NY, NU)
- DOUBLE PRECISION UYT(NX, NY, NU), B(NX, NY, NU), BU(NX, NY, NU,
- 1 NU), BUT(NX, NY, NU, NU), BUX(NX, NY, NU, NU), BUY(NX, NY, NU
- 2 , NU)
- DOUBLE PRECISION BUXT(NX, NY, NU, NU), BUYT(NX, NY, NU, NU)
- INTEGER I, J
- LOGICAL TEMP
- DO 6 J = 1, NY
- DO 5 I = 1, NX
- TEMP = X(I) .EQ. LX
- IF (.NOT. TEMP) TEMP = X(I) .EQ. RX
- IF (.NOT. TEMP) GOTO 1
- BUX(I, J, 1, 1) = 1
-C LEFT OR RIGHT.
-C NEUMANN BCS.
- B(I, J, 1) = UX(I, J, 1)
- GOTO 4
- 1 IF (Y(J) .NE. LY) GOTO 2
- B(I, J, 1) = U(I, J, 1)
-C BOTTOM.
- BU(I, J, 1, 1) = 1
- GOTO 3
- 2 B(I, J, 1) = U(I, J, 1)-6D0*T
-C TOP.
- BU(I, J, 1, 1) = 1
- 3 CONTINUE
- 4 CONTINUE
- 5 CONTINUE
- 6 CONTINUE
- RETURN
- END
- SUBROUTINE HANDLE(T0, U0, T, U, NV, DT, TSTOP)
- INTEGER NV
- DOUBLE PRECISION T0, U0(NV), T, U(NV), DT, TSTOP
- COMMON /D7TGRP/ ERRPAR, NU, MXQ, MYQ
- INTEGER NU, MXQ, MYQ
- REAL ERRPAR(2)
- COMMON /D7TGRM/ KX, IX, NX, KY, IY, NY
- INTEGER KX, IX, NX, KY, IY, NY
- IF (T0 .NE. T) GOTO 2
- WRITE (6, 1) T
- 1 FORMAT (16H RESTART FOR T =, 1PE10.2)
- RETURN
- 2 CALL GERR(KX, IX, NX, KY, IY, NY, U, NU, T)
- RETURN
- END
- SUBROUTINE GERR(KX, IX, NX, KY, IY, NY, U, NU, T)
- INTEGER KX, IX, NX, KY, IY, NY
- INTEGER NU
- DOUBLE PRECISION U(1), T
- COMMON /CSTAK/ DS
- DOUBLE PRECISION DS(500)
- INTEGER IFA, ITA(2), IXA(2), NTA(2), NXA(2), IDLUMD
- INTEGER IXS, IYS, NXS, NYS, ISTKGT, I
- INTEGER IEWE, KA(2), MA(2), IS(1000), I1MACH
- REAL RS(1000)
- LOGICAL LS(1000)
- COMPLEX CS(500)
- DOUBLE PRECISION DABS, ERRU, DMAX1, WS(500)
- INTEGER TEMP, TEMP1, TEMP2
- EQUIVALENCE (DS(1), CS(1), WS(1), RS(1), IS(1), LS(1))
-C TO GET AND PRINT THE ERROR AT EACH TIME-STEP.
-C U(NX-KX,NY,KY,NU).
-C THE PORT LIBRARY STACK AND ITS ALIASES.
- CALL ENTER(1)
-C FIND THE ERROR IN THE SOLUTION AT 2*KX * 2*KY POINTS / MESH RECTANGLE.
-C X SEARCH GRID.
- IXS = IDLUMD(WS(IX), NX, 2*KX, NXS)
-C Y SEARCH GRID.
- IYS = IDLUMD(WS(IY), NY, 2*KY, NYS)
-C U SEARCH GRID VALUES.
- IEWE = ISTKGT(NXS*NYS, 4)
-C THE EXACT SOLUTION.
- CALL EWE(T, WS(IXS), NXS, WS(IYS), NYS, WS(IEWE), NU)
- KA(1) = KX
- KA(2) = KY
- ITA(1) = IX
- ITA(2) = IY
- NTA(1) = NX
- NTA(2) = NY
- IXA(1) = IXS
- IXA(2) = IYS
- NXA(1) = NXS
- NXA(2) = NYS
- MA(1) = 0
-C GET SOLUTION.
- MA(2) = 0
-C APPROXIMATE SOLUTION VALUES.
- IFA = ISTKGT(NXS*NYS, 4)
-C EVALUATE THEM.
- CALL DTSD1(2, KA, WS, ITA, NTA, U, WS, IXA, NXA, MA, WS(IFA))
-C ERROR IN SOLUTION VALUES.
- ERRU = 0
- TEMP = NXS*NYS
- DO 1 I = 1, TEMP
- TEMP2 = IEWE+I
- TEMP1 = IFA+I
- ERRU = DMAX1(ERRU, DABS(WS(TEMP2-1)-WS(TEMP1-1)))
- 1 CONTINUE
- TEMP = I1MACH(2)
- WRITE (TEMP, 2) T, ERRU
- 2 FORMAT (14H ERROR IN U(.,, 1PE10.2, 3H) =, 1PE10.2)
- CALL LEAVE
- RETURN
- END
- SUBROUTINE EWE(T, X, NX, Y, NY, U, NU)
- INTEGER NU, NX, NY
- DOUBLE PRECISION T, X(NX), Y(NY), U(NX, NY, NU)
- INTEGER I, J, P
-C THE EXACT SOLUTION.
- DO 7 P = 1, NU
- DO 6 I = 1, NX
- DO 5 J = 1, NY
- IF (Y(J) .GE. 1D0) GOTO 1
- U(I, J, P) = T*Y(J)
- GOTO 4
- 1 IF (Y(J) .GE. 2D0) GOTO 2
- U(I, J, P) = 2D0*T*Y(J)-T
- GOTO 3
- 2 U(I, J, P) = 3D0*T*Y(J)-3D0*T
- 3 CONTINUE
- 4 CONTINUE
- 5 CONTINUE
- 6 CONTINUE
- 7 CONTINUE
- RETURN
- END
diff --git a/CEP/PyBDSM/src/port3/ex/dtg4.f b/CEP/PyBDSM/src/port3/ex/dtg4.f
deleted file mode 100644
index e584be21768828186b37afaaea21565a0f083762..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ex/dtg4.f
+++ /dev/null
@@ -1,265 +0,0 @@
-C$TEST DTG4
-C TO RUN AS A MAIN PROGRAM REMOVE NEXT LINE
- SUBROUTINE DTG4
-C***********************************************************************
-C
-C EXAMPLE OF USE OF PORT PROGRAM DTTGR
-C
-C***********************************************************************
- COMMON /CSTAK/ DS
- DOUBLE PRECISION DS(350000)
- EXTERNAL HANDLE, BC, AF
- INTEGER NDX, NDY, ISTKGT, IS(1000), IU, IX
- INTEGER IY, NU, KX, NX, KY, NY
- INTEGER IDUMB
- REAL ERRPAR(2), RS(1000)
- LOGICAL LS(1000)
- COMPLEX CS(500)
- DOUBLE PRECISION TSTART, DT, LX, LY, RX, RY
- DOUBLE PRECISION WS(500), TSTOP
- EQUIVALENCE (DS(1), CS(1), WS(1), RS(1), IS(1), LS(1))
-C TO SOLVE THE LINEAR HEAT EQUATION
-C GRAD . ( UX - 0.1 * UY , 0.1*UX + UY ) = UT - X*Y
-C WITH SOLUTION U == T*X*Y ON [0,+1]**2, EXACT FOR K = 4,
-C WITH TILTED TOP AND BOTTOM, NORMAL BCS THERE.
-C THE PORT LIBRARY STACK AND ITS ALIASES.
-C INITIALIZE THE PORT LIBRARY STACK LENGTH.
- CALL ISTKIN(350000, 4)
- CALL ENTER(1)
- NU = 1
- LX = 0
- RX = 1
- LY = 0
- RY = 1
- KX = 4
- KY = 4
- NDX = 3
- NDY = 3
- TSTART = 0
- TSTOP = 1
- DT = 1
- ERRPAR(1) = 1E-2
- ERRPAR(2) = 1E-4
-C UNIFORM GRID.
- IX = IDUMB(LX, RX, NDX, KX, NX)
-C UNIFORM GRID.
- IY = IDUMB(LY, RY, NDY, KY, NY)
-C SPACE FOR THE SOLUTION.
- IU = ISTKGT(NU*(NX-KX)*(NY-KY), 4)
- CALL SETD(NU*(NX-KX)*(NY-KY), 0D0, WS(IU))
- CALL DTTGR(WS(IU), NU, KX, WS(IX), NX, KY, WS(IY), NY, TSTART,
- 1 TSTOP, DT, AF, BC, ERRPAR, HANDLE)
- CALL LEAVE
- CALL WRAPUP
- STOP
- END
- SUBROUTINE AF(T, XI, NX, YI, NY, NU, U, UT, UX, UY, UXT,
- 1 UYT, A, AU, AUT, AUX, AUY, AUXT, AUYT, F, FU, FUT, FUX, FUY,
- 2 FUXT, FUYT)
- INTEGER NU, NX, NY
- DOUBLE PRECISION T, XI(NX), YI(NY), U(NX, NY, NU), UT(NX, NY, NU),
- 1 UX(NX, NY, NU)
- DOUBLE PRECISION UY(NX, NY, NU), UXT(NX, NY, NU), UYT(NX, NY, NU),
- 1 A(NX, NY, NU, 2), AU(NX, NY, NU, NU, 2), AUT(NX, NY, NU, NU, 2)
- DOUBLE PRECISION AUX(NX, NY, NU, NU, 2), AUY(NX, NY, NU, NU, 2),
- 1 AUXT(NX, NY, NU, NU, 2), AUYT(NX, NY, NU, NU, 2), F(NX, NY, NU)
- 2 , FU(NX, NY, NU, NU)
- DOUBLE PRECISION FUT(NX, NY, NU, NU), FUX(NX, NY, NU, NU), FUY(NX,
- 1 NY, NU, NU), FUXT(NX, NY, NU, NU), FUYT(NX, NY, NU, NU)
- EXTERNAL BT, LR
- INTEGER I, P, Q
- DOUBLE PRECISION D(600), X, Y, XX(100), YY(100)
- INTEGER TEMP
- IF (NX*NY .GT. 100) CALL SETERR(19HAF - NX*NY .GT. 100, 19, 1, 2)
- CALL DBTMAP(T, XI, YI, NX, NY, LR, BT, XX, YY, D)
-C MAP INTO (X,Y).
- CALL DTTGRU(NX, NY, D, UX, UY, UT, NU)
- DO 3 I = 1, NU
- DO 2 Q = 1, NY
- DO 1 P = 1, NX
- TEMP = P+(Q-1)*NX
- X = XX(TEMP)
- TEMP = P+(Q-1)*NX
- Y = YY(TEMP)
- A(P, Q, I, 1) = UX(P, Q, I)-.1*UY(P, Q, I)
- A(P, Q, I, 2) = UY(P, Q, I)+.1*UX(P, Q, I)
- AUX(P, Q, I, I, 1) = 1
- AUY(P, Q, I, I, 2) = 1
- AUY(P, Q, I, I, 1) = -.1
- AUX(P, Q, I, I, 2) = .1
- F(P, Q, 1) = UT(P, Q, 1)-X*Y
- FUT(P, Q, 1, 1) = 1
- 1 CONTINUE
- 2 CONTINUE
- 3 CONTINUE
-C MAP INTO (XI,ETA).
- CALL DTTGRG(NX, NY, D, NU, A, AU, AUX, AUY, F, FU, FUX, FUY)
- RETURN
- END
- SUBROUTINE BC(T, XI, NX, YI, NY, LX, RX, LY, RY, U, UT, UX
- 1 , UY, UXT, UYT, NU, B, BU, BUT, BUX, BUY, BUXT, BUYT)
- INTEGER NU, NX, NY
- DOUBLE PRECISION T, XI(NX), YI(NY), LX, RX, LY
- DOUBLE PRECISION RY, U(NX, NY, NU), UT(NX, NY, NU), UX(NX, NY, NU)
- 1 , UY(NX, NY, NU), UXT(NX, NY, NU)
- DOUBLE PRECISION UYT(NX, NY, NU), B(NX, NY, NU), BU(NX, NY, NU,
- 1 NU), BUT(NX, NY, NU, NU), BUX(NX, NY, NU, NU), BUY(NX, NY, NU
- 2 , NU)
- DOUBLE PRECISION BUXT(NX, NY, NU, NU), BUYT(NX, NY, NU, NU)
- EXTERNAL BT, LR
- INTEGER I, J
- DOUBLE PRECISION D(600), X, Y, XX(100), YY(100)
- INTEGER TEMP1
- LOGICAL TEMP
- IF (NX*NY .GT. 100) CALL SETERR(19HBC - NX*NY .GT. 100, 19, 1, 2)
- CALL DBTMAP(T, XI, YI, NX, NY, LR, BT, XX, YY, D)
-C MAP INTO (X,Y).
- CALL DTTGRU(NX, NY, D, UX, UY, UT, NU)
- DO 6 J = 1, NY
- DO 5 I = 1, NX
- TEMP1 = I+(J-1)*NX
- X = XX(TEMP1)
- TEMP1 = I+(J-1)*NX
- Y = YY(TEMP1)
- TEMP = XI(I) .EQ. LX
- IF (.NOT. TEMP) TEMP = XI(I) .EQ. RX
- IF (.NOT. TEMP) GOTO 1
- BU(I, J, 1, 1) = 1
-C LEFT OR RIGHT.
- B(I, J, 1) = U(I, J, 1)-T*X*Y
- GOTO 4
- 1 IF (YI(J) .NE. LY) GOTO 2
- B(I, J, 1) = (UX(I, J, 1)-T*Y)-(UY(I, J, 1)-T*X)
-C BOTTOM.
- BUX(I, J, 1, 1) = 1
-C NORMAL IS (1,-1).
- BUY(I, J, 1, 1) = -1
- GOTO 3
- 2 B(I, J, 1) = (UY(I, J, 1)-T*X)-(UX(I, J, 1)-T*Y)
-C TOP.
- BUX(I, J, 1, 1) = -1
-C NORMAL IS (-1,1).
- BUY(I, J, 1, 1) = 1
- 3 CONTINUE
- 4 CONTINUE
- 5 CONTINUE
- 6 CONTINUE
-C MAP INTO (XI,ETA).
- CALL DTTGRB(NX, NY, D, NU, BUX, BUY, BUT)
- RETURN
- END
- SUBROUTINE HANDLE(T0, U0, T, U, NV, DT, TSTOP)
- INTEGER NV
- DOUBLE PRECISION T0, U0(NV), T, U(NV), DT, TSTOP
- COMMON /D7TGRP/ ERRPAR, NU, MXQ, MYQ
- INTEGER NU, MXQ, MYQ
- REAL ERRPAR(2)
- COMMON /D7TGRM/ KX, IX, NX, KY, IY, NY
- INTEGER KX, IX, NX, KY, IY, NY
- IF (T0 .NE. T) GOTO 2
- WRITE (6, 1) T
- 1 FORMAT (16H RESTART FOR T =, 1PE10.2)
- RETURN
- 2 CALL GERR(KX, IX, NX, KY, IY, NY, U, NU, T)
- RETURN
- END
- SUBROUTINE GERR(KX, IX, NX, KY, IY, NY, U, NU, T)
- INTEGER KX, IX, NX, KY, IY, NY
- INTEGER NU
- DOUBLE PRECISION U(1), T
- COMMON /CSTAK/ DS
- DOUBLE PRECISION DS(500)
- INTEGER IFA, ITA(2), IXA(2), NTA(2), NXA(2), IDLUMD
- INTEGER IXS, IYS, NXS, NYS, ISTKGT, I
- INTEGER IEWE, KA(2), MA(2), IS(1000), I1MACH
- REAL RS(1000)
- LOGICAL LS(1000)
- COMPLEX CS(500)
- DOUBLE PRECISION DABS, ERRU, DMAX1, WS(500)
- INTEGER TEMP, TEMP1, TEMP2
- EQUIVALENCE (DS(1), CS(1), WS(1), RS(1), IS(1), LS(1))
-C TO GET AND PRINT THE ERROR AT EACH TIME-STEP.
-C U(NX-KX,NY-KY,NU).
-C THE PORT LIBRARY STACK AND ITS ALIASES.
- CALL ENTER(1)
-C FIND THE ERROR IN THE SOLUTION AT 2*KX * 2*KY POINTS / MESH RECTANGLE.
-C X SEARCH GRID.
- IXS = IDLUMD(WS(IX), NX, 2*KX, NXS)
-C Y SEARCH GRID.
- IYS = IDLUMD(WS(IY), NY, 2*KY, NYS)
-C U SEARCH GRID VALUES.
- IEWE = ISTKGT(NXS*NYS, 4)
-C THE EXACT SOLUTION.
- CALL EWE(T, WS(IXS), NXS, WS(IYS), NYS, WS(IEWE), NU)
- KA(1) = KX
- KA(2) = KY
- ITA(1) = IX
- ITA(2) = IY
- NTA(1) = NX
- NTA(2) = NY
- IXA(1) = IXS
- IXA(2) = IYS
- NXA(1) = NXS
- NXA(2) = NYS
- MA(1) = 0
-C GET SOLUTION.
- MA(2) = 0
-C APPROXIMATE SOLUTION VALUES.
- IFA = ISTKGT(NXS*NYS, 4)
-C EVALUATE THEM.
- CALL DTSD1(2, KA, WS, ITA, NTA, U, WS, IXA, NXA, MA, WS(IFA))
-C ERROR IN SOLUTION VALUES.
- ERRU = 0
- TEMP = NXS*NYS
- DO 1 I = 1, TEMP
- TEMP2 = IEWE+I
- TEMP1 = IFA+I
- ERRU = DMAX1(ERRU, DABS(WS(TEMP2-1)-WS(TEMP1-1)))
- 1 CONTINUE
- TEMP = I1MACH(2)
- WRITE (TEMP, 2) T, ERRU
- 2 FORMAT (14H ERROR IN U(.,, 1PE10.2, 3H) =, 1PE10.2)
- CALL LEAVE
- RETURN
- END
- SUBROUTINE EWE(T, XI, NX, YI, NY, U, NU)
- INTEGER NU, NX, NY
- DOUBLE PRECISION T, XI(NX), YI(NY), U(NX, NY, NU)
- EXTERNAL BT, LR
- INTEGER I, J, P
- DOUBLE PRECISION D(6000), X, Y, XX(1000), YY(1000)
-C THE EXACT SOLUTION.
- IF (NY .GT. 1000) CALL SETERR(18HEWE - NY .GT. 1000, 18, 1, 2)
- DO 3 P = 1, NU
- DO 2 I = 1, NX
- CALL DBTMAP(T, XI(I), YI, 1, NY, LR, BT, XX, YY, D)
- DO 1 J = 1, NY
- X = XX(J)
- Y = YY(J)
- U(I, J, P) = T*X*Y
- 1 CONTINUE
- 2 CONTINUE
- 3 CONTINUE
- RETURN
- END
- SUBROUTINE LR(T, LX, RX, LXT, RXT)
- DOUBLE PRECISION T, LX, RX, LXT, RXT
-C TO GET THE L AND R END-POINTS OF THE MAPPING IN X.
- LX = 0
- RX = 1
- LXT = 0
- RXT = 0
- RETURN
- END
- SUBROUTINE BT(T, X, F, G, FX, GX, FT, GT)
- DOUBLE PRECISION T, X, F, G, FX, GX
- DOUBLE PRECISION FT, GT
-C TO GET THE BOTTOM AND TOP OF MAPPING IN Y.
- F = X-1D0
- G = X
- FT = 0
- GT = 0
- FX = 1
- GX = 1
- RETURN
- END
diff --git a/CEP/PyBDSM/src/port3/ex/dtg5.f b/CEP/PyBDSM/src/port3/ex/dtg5.f
deleted file mode 100644
index 107f9ab99daebb224cfbb660a15850b293cd8bd7..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ex/dtg5.f
+++ /dev/null
@@ -1,238 +0,0 @@
-C$TEST DTG5
-C TO RUN AS A MAIN PROGRAM REMOVE NEXT LINE
- SUBROUTINE DTG5
-C***********************************************************************
-C
-C EXAMPLE OF USE OF PORT PROGRAM DTTGR
-C
-C***********************************************************************
- COMMON /CSTAK/ DS
- DOUBLE PRECISION DS(350000)
- EXTERNAL HANDLE, BC, AF
- INTEGER NDX, NDY, ISTKGT, I, IS(1000), IU
- INTEGER IX, IY, NU, KX, NX, KY
- INTEGER NY
- REAL ERRPAR(2), RS(1000), FLOAT
- LOGICAL LS(1000)
- COMPLEX CS(500)
- DOUBLE PRECISION TSTART, DBLE, DT, LX, LY, RX
- DOUBLE PRECISION RY, WS(500), TSTOP
- INTEGER TEMP, TEMP1
- EQUIVALENCE (DS(1), CS(1), WS(1), RS(1), IS(1), LS(1))
-C TO SOLVE LAPLACES EQUATION WITH REAL ( Z*LOG(Z) ) AS SOLUTION.
-C THE PORT LIBRARY STACK AND ITS ALIASES.
-C INITIALIZE THE PORT LIBRARY STACK LENGTH.
- CALL ISTKIN(350000, 4)
- CALL ENTER(1)
- NU = 1
- LX = 0
- RX = 1
- LY = 0
- RY = 1
- KX = 4
- KY = 4
- NDX = 2
- NDY = 2
- TSTART = 0
- TSTOP = 1
- DT = 1
- ERRPAR(1) = 1E-2
- ERRPAR(2) = 1E-4
- NX = NDX+2*(KX-1)
-C SPACE FOR X MESH.
- IX = ISTKGT(NX, 4)
- DO 1 I = 1, KX
- TEMP = IX+I
- WS(TEMP-1) = 0
- TEMP = IX+NX-I
- WS(TEMP) = RX
- 1 CONTINUE
-C 0 AND RX MULT = KX.
- TEMP = NDX-1
- DO 2 I = 1, TEMP
- TEMP1 = IX+KX-2+I
- WS(TEMP1) = RX*(DBLE(FLOAT(I-1))/(DBLE(FLOAT(NDX))-1D0))**KX
- 2 CONTINUE
- NY = NDY+2*(KY-1)
-C SPACE FOR Y MESH.
- IY = ISTKGT(NY, 4)
- DO 3 I = 1, KY
- TEMP = IY+I
- WS(TEMP-1) = 0
- TEMP = IY+NY-I
- WS(TEMP) = RY
- 3 CONTINUE
-C 0 AND RY MULT = KY.
- TEMP = NDY-1
- DO 4 I = 1, TEMP
- TEMP1 = IY+KY-2+I
- WS(TEMP1) = RY*(DBLE(FLOAT(I-1))/(DBLE(FLOAT(NDY))-1D0))**KY
- 4 CONTINUE
-C SPACE FOR THE SOLUTION.
- IU = ISTKGT(NU*(NX-KX)*(NY-KY), 4)
- CALL SETD(NU*(NX-KX)*(NY-KY), 0D0, WS(IU))
- CALL DTTGR(WS(IU), NU, KX, WS(IX), NX, KY, WS(IY), NY, TSTART,
- 1 TSTOP, DT, AF, BC, ERRPAR, HANDLE)
- CALL LEAVE
- CALL WRAPUP
- STOP
- END
- SUBROUTINE AF(T, XI, NX, YI, NY, NU, U, UT, UX, UY, UXT,
- 1 UYT, A, AU, AUT, AUX, AUY, AUXT, AUYT, F, FU, FUT, FUX, FUY,
- 2 FUXT, FUYT)
- INTEGER NU, NX, NY
- DOUBLE PRECISION T, XI(NX), YI(NY), U(NX, NY, NU), UT(NX, NY, NU),
- 1 UX(NX, NY, NU)
- DOUBLE PRECISION UY(NX, NY, NU), UXT(NX, NY, NU), UYT(NX, NY, NU),
- 1 A(NX, NY, NU, 2), AU(NX, NY, NU, NU, 2), AUT(NX, NY, NU, NU, 2)
- DOUBLE PRECISION AUX(NX, NY, NU, NU, 2), AUY(NX, NY, NU, NU, 2),
- 1 AUXT(NX, NY, NU, NU, 2), AUYT(NX, NY, NU, NU, 2), F(NX, NY, NU)
- 2 , FU(NX, NY, NU, NU)
- DOUBLE PRECISION FUT(NX, NY, NU, NU), FUX(NX, NY, NU, NU), FUY(NX,
- 1 NY, NU, NU), FUXT(NX, NY, NU, NU), FUYT(NX, NY, NU, NU)
- INTEGER I, P, Q
- DO 3 I = 1, NU
- DO 2 Q = 1, NY
- DO 1 P = 1, NX
- A(P, Q, I, 1) = UX(P, Q, I)
- A(P, Q, I, 2) = UY(P, Q, I)
- AUX(P, Q, I, I, 1) = 1
- AUY(P, Q, I, I, 2) = 1
- 1 CONTINUE
- 2 CONTINUE
- 3 CONTINUE
- RETURN
- END
- SUBROUTINE BC(T, X, NX, Y, NY, LX, RX, LY, RY, U, UT, UX,
- 1 UY, UXT, UYT, NU, B, BU, BUT, BUX, BUY, BUXT, BUYT)
- INTEGER NU, NX, NY
- DOUBLE PRECISION T, X(NX), Y(NY), LX, RX, LY
- DOUBLE PRECISION RY, U(NX, NY, NU), UT(NX, NY, NU), UX(NX, NY, NU)
- 1 , UY(NX, NY, NU), UXT(NX, NY, NU)
- DOUBLE PRECISION UYT(NX, NY, NU), B(NX, NY, NU), BU(NX, NY, NU,
- 1 NU), BUT(NX, NY, NU, NU), BUX(NX, NY, NU, NU), BUY(NX, NY, NU
- 2 , NU)
- DOUBLE PRECISION BUXT(NX, NY, NU, NU), BUYT(NX, NY, NU, NU)
- INTEGER I, J
- DOUBLE PRECISION R, DCOS, DLOG, DSIN, DATAN, THETA
- DOUBLE PRECISION DSQRT
- DO 6 J = 1, NY
- DO 5 I = 1, NX
- IF (Y(J) .NE. LY) GOTO 1
- B(I, J, 1) = UY(I, J, 1)
-C NEUMANN DATA ON BOTTOM.
- BUY(I, J, 1, 1) = 1
- GOTO 4
- 1 R = DSQRT(X(I)**2+Y(J)**2)
-C DIRICHLET DATA.
- IF (X(I) .LE. 0D0) GOTO 2
- THETA = DATAN(Y(J)/X(I))
- GOTO 3
- 2 THETA = 2D0*DATAN(1D0)
- 3 B(I, J, 1) = U(I, J, 1)-R*(DCOS(THETA)*DLOG(R)-THETA*
- 1 DSIN(THETA))
- BU(I, J, 1, 1) = 1
- 4 CONTINUE
- 5 CONTINUE
- 6 CONTINUE
- RETURN
- END
- SUBROUTINE HANDLE(T0, U0, T, U, NV, DT, TSTOP)
- INTEGER NV
- DOUBLE PRECISION T0, U0(NV), T, U(NV), DT, TSTOP
- COMMON /D7TGRP/ ERRPAR, NU, MXQ, MYQ
- INTEGER NU, MXQ, MYQ
- REAL ERRPAR(2)
- COMMON /D7TGRM/ KX, IX, NX, KY, IY, NY
- INTEGER KX, IX, NX, KY, IY, NY
- IF (T0 .NE. T) GOTO 2
- WRITE (6, 1) T
- 1 FORMAT (16H RESTART FOR T =, 1PE10.2)
- RETURN
- 2 CALL GERR(KX, IX, NX, KY, IY, NY, U, NU, T)
- RETURN
- END
- SUBROUTINE GERR(KX, IX, NX, KY, IY, NY, U, NU, T)
- INTEGER KX, IX, NX, KY, IY, NY
- INTEGER NU
- DOUBLE PRECISION U(1), T
- COMMON /CSTAK/ DS
- DOUBLE PRECISION DS(500)
- INTEGER IFA, ITA(2), IXA(2), NTA(2), NXA(2), IDLUMD
- INTEGER IXS, IYS, NXS, NYS, ISTKGT, I
- INTEGER IEWE, KA(2), MA(2), IS(1000), I1MACH
- REAL RS(1000)
- LOGICAL LS(1000)
- COMPLEX CS(500)
- DOUBLE PRECISION DABS, ERRU, DMAX1, WS(500)
- INTEGER TEMP, TEMP1, TEMP2
- EQUIVALENCE (DS(1), CS(1), WS(1), RS(1), IS(1), LS(1))
-C TO GET AND PRINT THE ERROR AT EACH TIME-STEP.
-C U(NX-KX,NY-KY,NU).
-C THE PORT LIBRARY STACK AND ITS ALIASES.
- CALL ENTER(1)
-C FIND THE ERROR IN THE SOLUTION AT 2*KX * 2*KY POINTS / MESH RECTANGLE.
-C X SEARCH GRID.
- IXS = IDLUMD(WS(IX), NX, 2*KX, NXS)
-C Y SEARCH GRID.
- IYS = IDLUMD(WS(IY), NY, 2*KY, NYS)
-C U SEARCH GRID VALUES.
- IEWE = ISTKGT(NXS*NYS, 4)
-C THE EXACT SOLUTION.
- CALL EWE(T, WS(IXS), NXS, WS(IYS), NYS, WS(IEWE), NU)
- KA(1) = KX
- KA(2) = KY
- ITA(1) = IX
- ITA(2) = IY
- NTA(1) = NX
- NTA(2) = NY
- IXA(1) = IXS
- IXA(2) = IYS
- NXA(1) = NXS
- NXA(2) = NYS
- MA(1) = 0
-C GET SOLUTION.
- MA(2) = 0
-C APPROXIMATE SOLUTION VALUES.
- IFA = ISTKGT(NXS*NYS, 4)
-C EVALUATE THEM.
- CALL DTSD1(2, KA, WS, ITA, NTA, U, WS, IXA, NXA, MA, WS(IFA))
-C ERROR IN SOLUTION VALUES.
- ERRU = 0
- TEMP = NXS*NYS
- DO 1 I = 1, TEMP
- TEMP2 = IEWE+I
- TEMP1 = IFA+I
- ERRU = DMAX1(ERRU, DABS(WS(TEMP2-1)-WS(TEMP1-1)))
- 1 CONTINUE
- TEMP = I1MACH(2)
- WRITE (TEMP, 2) T, ERRU
- 2 FORMAT (14H ERROR IN U(.,, 1PE10.2, 3H) =, 1PE10.2)
- CALL LEAVE
- RETURN
- END
- SUBROUTINE EWE(T, X, NX, Y, NY, U, NU)
- INTEGER NU, NX, NY
- DOUBLE PRECISION T, X(NX), Y(NY), U(NX, NY, NU)
- INTEGER I, J, P
- DOUBLE PRECISION R, DCOS, DLOG, DSIN, DATAN, THETA
- DOUBLE PRECISION DSQRT
-C THE EXACT SOLUTION.
- DO 7 P = 1, NU
- DO 6 I = 1, NX
- DO 5 J = 1, NY
- R = DSQRT(X(I)**2+Y(J)**2)
- IF (X(I) .LE. 0D0) GOTO 1
- THETA = DATAN(Y(J)/X(I))
- GOTO 2
- 1 THETA = 2D0*DATAN(1D0)
- 2 IF (R .LE. 0D0) GOTO 3
- U(I, J, P) = R*(DCOS(THETA)*DLOG(R)-THETA*DSIN(THETA))
- GOTO 4
- 3 U(I, J, P) = 0
- 4 CONTINUE
- 5 CONTINUE
- 6 CONTINUE
- 7 CONTINUE
- RETURN
- END
diff --git a/CEP/PyBDSM/src/port3/ex/dtg6.f b/CEP/PyBDSM/src/port3/ex/dtg6.f
deleted file mode 100644
index 8ebdb1abf73e8baebed6e25570e8de5ba5b2588f..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ex/dtg6.f
+++ /dev/null
@@ -1,384 +0,0 @@
-C$TEST DTG6
-C TO RUN AS A MAIN PROGRAM REMOVE NEXT LINE
- SUBROUTINE DTG6
-C***********************************************************************
-C
-C EXAMPLE OF USE OF PORT PROGRAM DTTGR
-C
-C***********************************************************************
- COMMON /CSTAK/ DS
- DOUBLE PRECISION DS(350000)
- EXTERNAL HANDLE, BC, AF
- INTEGER IUE, NDX, NDY, IUR, IXR, IYR
- INTEGER NXR, NYR, ISTKGT, I, IS(1000), IU
- INTEGER IX, IY, NU, KX, NX, KY
- INTEGER NY, I1MACH
- REAL ERRPAR(2), RS(1000), FLOAT
- LOGICAL LS(1000)
- COMPLEX CS(500)
- DOUBLE PRECISION TSTART, DBLE, DABS, EERR, ERRE, ERRR
- DOUBLE PRECISION DMAX1, DT, LX, LY, RX, RY
- DOUBLE PRECISION WS(500), TSTOP
- INTEGER TEMP, TEMP1, TEMP2
- EQUIVALENCE (DS(1), CS(1), WS(1), RS(1), IS(1), LS(1))
-C TO GET ERROR ESTIMATES FOR LAPLACES EQUATION WITH REAL ( Z*LOG(Z) ) AS
-C SOLUTION.
-C THE PORT LIBRARY STACK AND ITS ALIASES.
-C INITIALIZE THE PORT LIBRARY STACK LENGTH.
- CALL ISTKIN(350000, 4)
- CALL ENTER(1)
- NU = 1
- LX = 0
- RX = 1
- LY = 0
- RY = 1
- KX = 4
- KY = 4
- NDX = 2
- NDY = 2
- TSTART = 0
- TSTOP = 1
- DT = 1
- ERRPAR(1) = 1E-2
- ERRPAR(2) = 1E-4
- NX = NDX+2*(KX-1)
-C SPACE FOR X MESH.
- IX = ISTKGT(NX, 4)
- DO 1 I = 1, KX
- TEMP = IX+I
- WS(TEMP-1) = 0
- TEMP = IX+NX-I
- WS(TEMP) = RX
- 1 CONTINUE
-C 0 AND RX MULT = KX.
- TEMP = NDX-1
- DO 2 I = 1, TEMP
- TEMP2 = IX+KX-2+I
- WS(TEMP2) = RX*(DBLE(FLOAT(I-1))/(DBLE(FLOAT(NDX))-1D0))**KX
- 2 CONTINUE
- NY = NDY+2*(KY-1)
-C SPACE FOR Y MESH.
- IY = ISTKGT(NY, 4)
- DO 3 I = 1, KY
- TEMP = IY+I
- WS(TEMP-1) = 0
- TEMP = IY+NY-I
- WS(TEMP) = RY
- 3 CONTINUE
-C 0 AND RY MULT = KY.
- TEMP = NDY-1
- DO 4 I = 1, TEMP
- TEMP2 = IY+KY-2+I
- WS(TEMP2) = RY*(DBLE(FLOAT(I-1))/(DBLE(FLOAT(NDY))-1D0))**KY
- 4 CONTINUE
-C SPACE FOR THE SOLUTION.
- IU = ISTKGT(NU*(NX-KX)*(NY-KY), 4)
- CALL SETD(NU*(NX-KX)*(NY-KY), 0D0, WS(IU))
- TEMP = I1MACH(2)
- WRITE (TEMP, 5)
- 5 FORMAT (23H SOLVING ON CRUDE MESH.)
- CALL DTTGR(WS(IU), NU, KX, WS(IX), NX, KY, WS(IY), NY, TSTART,
- 1 TSTOP, DT, AF, BC, ERRPAR, HANDLE)
- DT = 1
- NDX = 2*NDX-1
-C REFINE MESH.
- NDY = 2*NDY-1
- NXR = NDX+2*(KX-1)
-C SPACE FOR X MESH.
- IXR = ISTKGT(NXR, 4)
- DO 6 I = 1, KX
- TEMP = IXR+I
- WS(TEMP-1) = 0
- TEMP = IXR+NXR-I
- WS(TEMP) = RX
- 6 CONTINUE
-C 0 AND RX MULT = KX.
- TEMP = NDX-1
- DO 7 I = 1, TEMP
- TEMP2 = IXR+KX-2+I
- WS(TEMP2) = RX*(DBLE(FLOAT(I-1))/(DBLE(FLOAT(NDX))-1D0))**KX
- 7 CONTINUE
- NYR = NDY+2*(KY-1)
-C SPACE FOR Y MESH.
- IYR = ISTKGT(NYR, 4)
- DO 8 I = 1, KY
- TEMP = IYR+I
- WS(TEMP-1) = 0
- TEMP = IYR+NYR-I
- WS(TEMP) = RY
- 8 CONTINUE
-C 0 AND RY MULT = KY.
- TEMP = NDY-1
- DO 9 I = 1, TEMP
- TEMP2 = IYR+KY-2+I
- WS(TEMP2) = RY*(DBLE(FLOAT(I-1))/(DBLE(FLOAT(NDY))-1D0))**KY
- 9 CONTINUE
-C SPACE FOR THE SOLUTION.
- IUR = ISTKGT(NU*(NXR-KX)*(NYR-KY), 4)
- CALL SETD(NU*(NXR-KX)*(NYR-KY), 0D0, WS(IUR))
- TEMP = I1MACH(2)
- WRITE (TEMP, 10)
- 10 FORMAT (25H SOLVING ON REFINED MESH.)
- CALL DTTGR(WS(IUR), NU, KX, WS(IXR), NXR, KY, WS(IYR), NYR,
- 1 TSTART, TSTOP, DT, AF, BC, ERRPAR, HANDLE)
- DT = 1
- ERRPAR(1) = ERRPAR(1)/10.
- ERRPAR(2) = ERRPAR(2)/10.
-C SPACE FOR THE SOLUTION.
- IUE = ISTKGT(NU*(NX-KX)*(NY-KY), 4)
- CALL SETD(NU*(NX-KX)*(NY-KY), 0D0, WS(IUE))
- TEMP = I1MACH(2)
- WRITE (TEMP, 11)
- 11 FORMAT (24H SOLVING WITH ERRPAR/10.)
- CALL DTTGR(WS(IUE), NU, KX, WS(IX), NX, KY, WS(IY), NY, TSTART,
- 1 TSTOP, DT, AF, BC, ERRPAR, HANDLE)
- ERRR = EERR(KX, IX, NX, KY, IY, NY, WS(IU), NU, IXR, NXR, IYR,
- 1 NYR, WS(IUR), TSTOP)
- ERRE = 0
- TEMP = NU*(NX-KX)*(NY-KY)
- DO 12 I = 1, TEMP
- TEMP2 = IU+I
- TEMP1 = IUE+I
- ERRE = DMAX1(ERRE, DABS(WS(TEMP2-1)-WS(TEMP1-1)))
- 12 CONTINUE
- TEMP = I1MACH(2)
- WRITE (TEMP, 13) ERRE
- 13 FORMAT (24H U ERROR FROM U AND UE =, 1PE10.2)
- TEMP = I1MACH(2)
- WRITE (TEMP, 14) ERRR
- 14 FORMAT (24H U ERROR FROM U AND UR =, 1PE10.2)
- CALL LEAVE
- CALL WRAPUP
- STOP
- END
- SUBROUTINE AF(T, XI, NX, YI, NY, NU, U, UT, UX, UY, UXT,
- 1 UYT, A, AU, AUT, AUX, AUY, AUXT, AUYT, F, FU, FUT, FUX, FUY,
- 2 FUXT, FUYT)
- INTEGER NU, NX, NY
- DOUBLE PRECISION T, XI(NX), YI(NY), U(NX, NY, NU), UT(NX, NY, NU),
- 1 UX(NX, NY, NU)
- DOUBLE PRECISION UY(NX, NY, NU), UXT(NX, NY, NU), UYT(NX, NY, NU),
- 1 A(NX, NY, NU, 2), AU(NX, NY, NU, NU, 2), AUT(NX, NY, NU, NU, 2)
- DOUBLE PRECISION AUX(NX, NY, NU, NU, 2), AUY(NX, NY, NU, NU, 2),
- 1 AUXT(NX, NY, NU, NU, 2), AUYT(NX, NY, NU, NU, 2), F(NX, NY, NU)
- 2 , FU(NX, NY, NU, NU)
- DOUBLE PRECISION FUT(NX, NY, NU, NU), FUX(NX, NY, NU, NU), FUY(NX,
- 1 NY, NU, NU), FUXT(NX, NY, NU, NU), FUYT(NX, NY, NU, NU)
- INTEGER I, P, Q
- DO 3 I = 1, NU
- DO 2 Q = 1, NY
- DO 1 P = 1, NX
- A(P, Q, I, 1) = UX(P, Q, I)
- A(P, Q, I, 2) = UY(P, Q, I)
- AUX(P, Q, I, I, 1) = 1
- AUY(P, Q, I, I, 2) = 1
- 1 CONTINUE
- 2 CONTINUE
- 3 CONTINUE
- RETURN
- END
- SUBROUTINE BC(T, X, NX, Y, NY, LX, RX, LY, RY, U, UT, UX,
- 1 UY, UXT, UYT, NU, B, BU, BUT, BUX, BUY, BUXT, BUYT)
- INTEGER NU, NX, NY
- DOUBLE PRECISION T, X(NX), Y(NY), LX, RX, LY
- DOUBLE PRECISION RY, U(NX, NY, NU), UT(NX, NY, NU), UX(NX, NY, NU)
- 1 , UY(NX, NY, NU), UXT(NX, NY, NU)
- DOUBLE PRECISION UYT(NX, NY, NU), B(NX, NY, NU), BU(NX, NY, NU,
- 1 NU), BUT(NX, NY, NU, NU), BUX(NX, NY, NU, NU), BUY(NX, NY, NU
- 2 , NU)
- DOUBLE PRECISION BUXT(NX, NY, NU, NU), BUYT(NX, NY, NU, NU)
- INTEGER I, J
- DOUBLE PRECISION R, DCOS, DLOG, DSIN, DATAN, THETA
- DOUBLE PRECISION DSQRT
- DO 6 J = 1, NY
- DO 5 I = 1, NX
- IF (Y(J) .NE. LY) GOTO 1
- B(I, J, 1) = UY(I, J, 1)
-C NEUMANN DATA ON BOTTOM.
- BUY(I, J, 1, 1) = 1
- GOTO 4
- 1 R = DSQRT(X(I)**2+Y(J)**2)
-C DIRICHLET DATA.
- IF (X(I) .LE. 0D0) GOTO 2
- THETA = DATAN(Y(J)/X(I))
- GOTO 3
- 2 THETA = 2D0*DATAN(1D0)
- 3 B(I, J, 1) = U(I, J, 1)-R*(DCOS(THETA)*DLOG(R)-THETA*
- 1 DSIN(THETA))
- BU(I, J, 1, 1) = 1
- 4 CONTINUE
- 5 CONTINUE
- 6 CONTINUE
- RETURN
- END
- SUBROUTINE HANDLE(T0, U0, T, U, NV, DT, TSTOP)
- INTEGER NV
- DOUBLE PRECISION T0, U0(NV), T, U(NV), DT, TSTOP
- COMMON /D7TGRP/ ERRPAR, NU, MXQ, MYQ
- INTEGER NU, MXQ, MYQ
- REAL ERRPAR(2)
- COMMON /D7TGRM/ KX, IX, NX, KY, IY, NY
- INTEGER KX, IX, NX, KY, IY, NY
- IF (T0 .NE. T) GOTO 2
- WRITE (6, 1) T
- 1 FORMAT (16H RESTART FOR T =, 1PE10.2)
- RETURN
- 2 CALL GERR(KX, IX, NX, KY, IY, NY, U, NU, T)
- RETURN
- END
- SUBROUTINE GERR(KX, IX, NX, KY, IY, NY, U, NU, T)
- INTEGER KX, IX, NX, KY, IY, NY
- INTEGER NU
- DOUBLE PRECISION U(1), T
- COMMON /CSTAK/ DS
- DOUBLE PRECISION DS(500)
- INTEGER IFA, ITA(2), IXA(2), NTA(2), NXA(2), IDLUMD
- INTEGER IXS, IYS, NXS, NYS, ISTKGT, I
- INTEGER IEWE, KA(2), MA(2), IS(1000), I1MACH
- REAL RS(1000)
- LOGICAL LS(1000)
- COMPLEX CS(500)
- DOUBLE PRECISION DABS, ERRU, DMAX1, WS(500)
- INTEGER TEMP, TEMP1, TEMP2
- EQUIVALENCE (DS(1), CS(1), WS(1), RS(1), IS(1), LS(1))
-C TO GET AND PRINT THE ERROR AT EACH TIME-STEP.
-C U(NX-KX,NY-KY,NU).
-C THE PORT LIBRARY STACK AND ITS ALIASES.
- CALL ENTER(1)
-C FIND THE ERROR IN THE SOLUTION AT 2*KX * 2*KY POINTS / MESH RECTANGLE.
-C X SEARCH GRID.
- IXS = IDLUMD(WS(IX), NX, 2*KX, NXS)
-C Y SEARCH GRID.
- IYS = IDLUMD(WS(IY), NY, 2*KY, NYS)
-C U SEARCH GRID VALUES.
- IEWE = ISTKGT(NXS*NYS, 4)
-C THE EXACT SOLUTION.
- CALL EWE(T, WS(IXS), NXS, WS(IYS), NYS, WS(IEWE), NU)
- KA(1) = KX
- KA(2) = KY
- ITA(1) = IX
- ITA(2) = IY
- NTA(1) = NX
- NTA(2) = NY
- IXA(1) = IXS
- IXA(2) = IYS
- NXA(1) = NXS
- NXA(2) = NYS
- MA(1) = 0
-C GET SOLUTION.
- MA(2) = 0
-C APPROXIMATE SOLUTION VALUES.
- IFA = ISTKGT(NXS*NYS, 4)
-C EVALUATE THEM.
- CALL DTSD1(2, KA, WS, ITA, NTA, U, WS, IXA, NXA, MA, WS(IFA))
-C ERROR IN SOLUTION VALUES.
- ERRU = 0
- TEMP = NXS*NYS
- DO 1 I = 1, TEMP
- TEMP2 = IEWE+I
- TEMP1 = IFA+I
- ERRU = DMAX1(ERRU, DABS(WS(TEMP2-1)-WS(TEMP1-1)))
- 1 CONTINUE
- TEMP = I1MACH(2)
- WRITE (TEMP, 2) T, ERRU
- 2 FORMAT (14H ERROR IN U(.,, 1PE10.2, 3H) =, 1PE10.2)
- CALL LEAVE
- RETURN
- END
- DOUBLE PRECISION FUNCTION EERR(KX, IX, NX, KY, IY, NY, U,
- 1 NU, IXR, NXR, IYR, NYR, UR, T)
- INTEGER KX, IX, NX, KY, IY, NY
- INTEGER NU, IXR, NXR, IYR, NYR
- DOUBLE PRECISION U(1), UR(1), T
- COMMON /CSTAK/ DS
- DOUBLE PRECISION DS(500)
- INTEGER IFA, ITA(2), IXA(2), NTA(2), NXA(2), IDLUMD
- INTEGER IXS, IYS, NXS, NYS, ISTKGT, I
- INTEGER IFAR, KA(2), MA(2), IS(1000), I1MACH
- REAL RS(1000)
- LOGICAL LS(1000)
- COMPLEX CS(500)
- DOUBLE PRECISION DABS, ERRU, DMAX1, WS(500)
- INTEGER TEMP, TEMP1, TEMP2
- EQUIVALENCE (DS(1), CS(1), WS(1), RS(1), IS(1), LS(1))
-C TO GET AND PRINT THE ERROR ESTIMATE AT EACH TIME-STEP.
-C U(NX-KX,NY-KY,NU), UR(NXR-KX,NYR-KY,NU).
-C THE PORT LIBRARY STACK AND ITS ALIASES.
- CALL ENTER(1)
-C FIND THE ERROR IN THE SOLUTION AT 2*KX * 2*KY POINTS / FINE MESH RECTA
-CNGLE.
-C X SEARCH GRID.
- IXS = IDLUMD(WS(IXR), NXR, 2*KX, NXS)
-C Y SEARCH GRID.
- IYS = IDLUMD(WS(IYR), NYR, 2*KY, NYS)
- KA(1) = KX
- KA(2) = KY
- ITA(1) = IX
- ITA(2) = IY
- NTA(1) = NX
- NTA(2) = NY
- IXA(1) = IXS
- IXA(2) = IYS
- NXA(1) = NXS
- NXA(2) = NYS
- MA(1) = 0
-C GET SOLUTION.
- MA(2) = 0
-C APPROXIMATE SOLUTION VALUES.
- IFA = ISTKGT(NXS*NYS, 4)
-C EVALUATE THEM.
- CALL DTSD1(2, KA, WS, ITA, NTA, U, WS, IXA, NXA, MA, WS(IFA))
- KA(1) = KX
- KA(2) = KY
- ITA(1) = IXR
- ITA(2) = IYR
- NTA(1) = NXR
- NTA(2) = NYR
- IXA(1) = IXS
- IXA(2) = IYS
- NXA(1) = NXS
- NXA(2) = NYS
- MA(1) = 0
-C GET SOLUTION.
- MA(2) = 0
-C APPROXIMATE SOLUTION VALUES.
- IFAR = ISTKGT(NXS*NYS, 4)
-C EVALUATE THEM.
- CALL DTSD1(2, KA, WS, ITA, NTA, UR, WS, IXA, NXA, MA, WS(IFAR))
-C ERROR IN SOLUTION VALUES.
- ERRU = 0
- TEMP = NXS*NYS
- DO 1 I = 1, TEMP
- TEMP2 = IFAR+I
- TEMP1 = IFA+I
- ERRU = DMAX1(ERRU, DABS(WS(TEMP2-1)-WS(TEMP1-1)))
- 1 CONTINUE
- CALL LEAVE
- EERR = ERRU
- RETURN
- END
- SUBROUTINE EWE(T, X, NX, Y, NY, U, NU)
- INTEGER NU, NX, NY
- DOUBLE PRECISION T, X(NX), Y(NY), U(NX, NY, NU)
- INTEGER I, J, P
- DOUBLE PRECISION R, DCOS, DLOG, DSIN, DATAN, THETA
- DOUBLE PRECISION DSQRT
-C THE EXACT SOLUTION.
- DO 7 P = 1, NU
- DO 6 I = 1, NX
- DO 5 J = 1, NY
- R = DSQRT(X(I)**2+Y(J)**2)
- IF (X(I) .LE. 0D0) GOTO 1
- THETA = DATAN(Y(J)/X(I))
- GOTO 2
- 1 THETA = 2D0*DATAN(1D0)
- 2 IF (R .LE. 0D0) GOTO 3
- U(I, J, P) = R*(DCOS(THETA)*DLOG(R)-THETA*DSIN(THETA))
- GOTO 4
- 3 U(I, J, P) = 0
- 4 CONTINUE
- 5 CONTINUE
- 6 CONTINUE
- 7 CONTINUE
- RETURN
- END
diff --git a/CEP/PyBDSM/src/port3/ex/dtgp.f b/CEP/PyBDSM/src/port3/ex/dtgp.f
deleted file mode 100644
index 2926e54d64f31c366c814bbc1aeaca54976155b5..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ex/dtgp.f
+++ /dev/null
@@ -1,186 +0,0 @@
-C$TEST DTGP
-C TO RUN AS A MAIN PROGRAM REMOVE NEXT LINE
- SUBROUTINE DTGP
-C***********************************************************************
-C
-C EXAMPLE OF USE OF PORT PROGRAM DTTGR
-C
-C***********************************************************************
- COMMON /CSTAK/ DS
- DOUBLE PRECISION DS(350000)
- EXTERNAL HANDLE, BC, AF
- INTEGER NDX, NDY, ISTKGT, IS(1000), IU, IX
- INTEGER IY, NU, KX, NX, KY, NY
- INTEGER IDUMB
- REAL ERRPAR(2), RS(1000)
- LOGICAL LS(1000)
- COMPLEX CS(500)
- DOUBLE PRECISION TSTART, DT, LX, LY, RX, RY
- DOUBLE PRECISION WS(500), TSTOP
- EQUIVALENCE (DS(1), CS(1), WS(1), RS(1), IS(1), LS(1))
-C TO SOLVE THE HEAT EQUATION WITH SOLUTION U == T*X*Y,
-C GRAD . ( U + UX + .1 * UY, U + UY + .1 * UX ) = UT + UX + UY +G(X,T)
-C THE PORT LIBRARY STACK AND ITS ALIASES.
-C INITIALIZE THE PORT LIBRARY STACK LENGTH.
- CALL ISTKIN(350000, 4)
- CALL ENTER(1)
- NU = 1
- LX = 0
- RX = 1
- LY = 0
- RY = 1
- KX = 2
- KY = 2
- NDX = 3
- NDY = 3
- TSTART = 0
- TSTOP = 1
- DT = 1
- ERRPAR(1) = 1E-2
- ERRPAR(2) = 1E-4
-C UNIFORM GRID.
- IX = IDUMB(LX, RX, NDX, KX, NX)
-C UNIFORM GRID.
- IY = IDUMB(LY, RY, NDY, KY, NY)
-C SPACE FOR THE SOLUTION.
- IU = ISTKGT(NU*(NX-KX)*(NY-KY), 4)
-C INITIAL CONDITIONS FOR U.
- CALL SETD(NU*(NX-KX)*(NY-KY), 0D0, WS(IU))
- CALL DTTGR(WS(IU), NU, KX, WS(IX), NX, KY, WS(IY), NY, TSTART,
- 1 TSTOP, DT, AF, BC, ERRPAR, HANDLE)
- CALL LEAVE
- CALL WRAPUP
- STOP
- END
- SUBROUTINE AF(T, X, NX, Y, NY, NU, U, UT, UX, UY, UXT, UYT
- 1 , A, AU, AUT, AUX, AUY, AUXT, AUYT, F, FU, FUT, FUX, FUY, FUXT,
- 2 FUYT)
- INTEGER NU, NX, NY
- DOUBLE PRECISION T, X(NX), Y(NY), U(NX, NY, NU), UT(NX, NY, NU),
- 1 UX(NX, NY, NU)
- DOUBLE PRECISION UY(NX, NY, NU), UXT(NX, NY, NU), UYT(NX, NY, NU),
- 1 A(NX, NY, NU, 2), AU(NX, NY, NU, NU, 2), AUT(NX, NY, NU, NU, 2)
- DOUBLE PRECISION AUX(NX, NY, NU, NU, 2), AUY(NX, NY, NU, NU, 2),
- 1 AUXT(NX, NY, NU, NU, 2), AUYT(NX, NY, NU, NU, 2), F(NX, NY, NU)
- 2 , FU(NX, NY, NU, NU)
- DOUBLE PRECISION FUT(NX, NY, NU, NU), FUX(NX, NY, NU, NU), FUY(NX,
- 1 NY, NU, NU), FUXT(NX, NY, NU, NU), FUYT(NX, NY, NU, NU)
- INTEGER I, P, Q
- DO 3 I = 1, NU
- DO 2 Q = 1, NY
- DO 1 P = 1, NX
- A(P, Q, I, 1) = UX(P, Q, I)+.1*UY(P, Q, I)+U(P, Q, I)
- A(P, Q, I, 2) = UY(P, Q, I)+.1*UX(P, Q, I)+U(P, Q, I)
- AUX(P, Q, I, I, 1) = 1
- AUY(P, Q, I, I, 2) = 1
- AUY(P, Q, I, I, 1) = .1
- AUX(P, Q, I, I, 2) = .1
- AU(P, Q, I, I, 1) = 1
- AU(P, Q, I, I, 2) = 1
- F(P, Q, I) = UT(P, Q, I)+UX(P, Q, I)+UY(P, Q, I)
- FUT(P, Q, I, I) = 1
- FUX(P, Q, I, I) = 1
- FUY(P, Q, I, I) = 1
- F(P, Q, I) = F(P, Q, I)+.2*T-X(P)*Y(Q)
- 1 CONTINUE
- 2 CONTINUE
- 3 CONTINUE
- RETURN
- END
- SUBROUTINE BC(T, X, NX, Y, NY, LX, RX, LY, RY, U, UT, UX,
- 1 UY, UXT, UYT, NU, B, BU, BUT, BUX, BUY, BUXT, BUYT)
- INTEGER NU, NX, NY
- DOUBLE PRECISION T, X(NX), Y(NY), LX, RX, LY
- DOUBLE PRECISION RY, U(NX, NY, NU), UT(NX, NY, NU), UX(NX, NY, NU)
- 1 , UY(NX, NY, NU), UXT(NX, NY, NU)
- DOUBLE PRECISION UYT(NX, NY, NU), B(NX, NY, NU), BU(NX, NY, NU,
- 1 NU), BUT(NX, NY, NU, NU), BUX(NX, NY, NU, NU), BUY(NX, NY, NU
- 2 , NU)
- DOUBLE PRECISION BUXT(NX, NY, NU, NU), BUYT(NX, NY, NU, NU)
- INTEGER I, J
- DO 2 J = 1, NY
- DO 1 I = 1, NX
- BU(I, J, 1, 1) = 1
- B(I, J, 1) = U(I, J, 1)-T*X(I)*Y(J)
- 1 CONTINUE
- 2 CONTINUE
- RETURN
- END
- SUBROUTINE HANDLE(T0, U0, T, U, NV, DT, TSTOP)
- INTEGER NV
- DOUBLE PRECISION T0, U0(NV), T, U(NV), DT, TSTOP
- COMMON /D7TGRP/ ERRPAR, NU, MXQ, MYQ
- INTEGER NU, MXQ, MYQ
- REAL ERRPAR(2)
- COMMON /D7TGRM/ KX, IX, NX, KY, IY, NY
- INTEGER KX, IX, NX, KY, IY, NY
- IF (T0 .NE. T) GOTO 2
- WRITE (6, 1) T
- 1 FORMAT (16H RESTART FOR T =, 1PE10.2)
- RETURN
-C PRINT RESULTS.
- 2 CALL GERR(KX, IX, NX, KY, IY, NY, U, NU, T)
- RETURN
- END
- SUBROUTINE GERR(KX, IX, NX, KY, IY, NY, U, NU, T)
- INTEGER KX, IX, NX, KY, IY, NY
- INTEGER NU
- DOUBLE PRECISION U(1), T
- COMMON /CSTAK/ DS
- DOUBLE PRECISION DS(500)
- INTEGER IFA, ITA(2), IXA(2), NTA(2), NXA(2), IDLUMD
- INTEGER IXS, IYS, NXS, NYS, ISTKGT, I
- INTEGER KA(2), MA(2), IS(1000), I1MACH
- REAL RS(1000)
- LOGICAL LS(1000)
- COMPLEX CS(500)
- DOUBLE PRECISION WS(500)
- INTEGER TEMP, TEMP1
- EQUIVALENCE (DS(1), CS(1), WS(1), RS(1), IS(1), LS(1))
-C TO PRINT THE SOLUTION AT EACH TIME-STEP.
-C U(NX-KX,NY,KY,NU).
-C THE PORT LIBRARY STACK AND ITS ALIASES.
- CALL ENTER(1)
-C FIND THE SOLUTION AT 2 * 2 POINTS / MESH RECTANGLE.
-C X SEARCH GRID.
- IXS = IDLUMD(WS(IX), NX, 2, NXS)
-C Y SEARCH GRID.
- IYS = IDLUMD(WS(IY), NY, 2, NYS)
- KA(1) = KX
- KA(2) = KY
- ITA(1) = IX
- ITA(2) = IY
- NTA(1) = NX
- NTA(2) = NY
- IXA(1) = IXS
- IXA(2) = IYS
- NXA(1) = NXS
- NXA(2) = NYS
- MA(1) = 0
-C GET SOLUTION.
- MA(2) = 0
-C APPROXIMATE SOLUTION VALUES.
- IFA = ISTKGT(NXS*NYS, 4)
-C EVALUATE THEM.
- CALL DTSD1(2, KA, WS, ITA, NTA, U, WS, IXA, NXA, MA, WS(IFA))
- TEMP1 = IFA+NXS*NYS-1
- TEMP = I1MACH(2)
- WRITE (TEMP, 1) T, (WS(I), I = IFA, TEMP1)
- 1 FORMAT (3H U(, 1PE10.2, 7H,.,.) =, (1P5E10.2/20X,1P4E10.2))
- CALL LEAVE
- RETURN
- END
- SUBROUTINE EWE(T, X, NX, Y, NY, U, NU)
- INTEGER NU, NX, NY
- DOUBLE PRECISION T, X(NX), Y(NY), U(NX, NY, NU)
- INTEGER I, J, P
-C THE EXACT SOLUTION.
- DO 3 P = 1, NU
- DO 2 I = 1, NX
- DO 1 J = 1, NY
- U(I, J, P) = T*X(I)*Y(J)
- 1 CONTINUE
- 2 CONTINUE
- 3 CONTINUE
- RETURN
- END
diff --git a/CEP/PyBDSM/src/port3/ex/dttgrx1.f b/CEP/PyBDSM/src/port3/ex/dttgrx1.f
deleted file mode 100644
index a1ebffdc62234ff54441f9b27598b070bfae211b..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ex/dttgrx1.f
+++ /dev/null
@@ -1,197 +0,0 @@
-C$TEST DTG1
-C TO RUN AS A MAIN PROGRAM REMOVE NEXT LINE
- SUBROUTINE DTG1
-C***********************************************************************
-C
-C EXAMPLE OF USE OF PORT PROGRAM DTTGR
-C
-C***********************************************************************
- COMMON /CSTAK/ DS
- DOUBLE PRECISION DS(350000)
- EXTERNAL HANDLE, BC, AF
- INTEGER NDX, NDY, ISTKGT, IS(1000), IU, IX
- INTEGER IY, NU, KX, NX, KY, NY
- INTEGER IDUMB
- REAL ERRPAR(2), RS(1000)
- LOGICAL LS(1000)
- COMPLEX CS(500)
- DOUBLE PRECISION TSTART, DT, LX, LY, RX, RY
- DOUBLE PRECISION WS(500), TSTOP
- EQUIVALENCE (DS(1), CS(1), WS(1), RS(1), IS(1), LS(1))
-C TO SOLVE THE HEAT EQUATION WITH SOLUTION U == T*X*Y,
-C GRAD . ( U + UX + .1 * UY, U + UY + .1 * UX ) = UT + UX + UY +G(X,T)
-C THE PORT LIBRARY STACK AND ITS ALIASES.
-C INITIALIZE THE PORT LIBRARY STACK LENGTH.
- CALL ISTKIN(350000, 4)
- CALL ENTER(1)
- NU = 1
- LX = 0
- RX = 1
- LY = 0
- RY = 1
- KX = 2
- KY = 2
- NDX = 3
- NDY = 3
- TSTART = 0
- TSTOP = 1
- DT = 1
- ERRPAR(1) = 1E-2
- ERRPAR(2) = 1E-4
-C UNIFORM GRID.
- IX = IDUMB(LX, RX, NDX, KX, NX)
-C UNIFORM GRID.
- IY = IDUMB(LY, RY, NDY, KY, NY)
-C SPACE FOR THE SOLUTION.
- IU = ISTKGT(NU*(NX-KX)*(NY-KY), 4)
-C INITIAL CONDITIONS FOR U.
- CALL SETD(NU*(NX-KX)*(NY-KY), 0D0, WS(IU))
- CALL DTTGR(WS(IU), NU, KX, WS(IX), NX, KY, WS(IY), NY, TSTART,
- 1 TSTOP, DT, AF, BC, ERRPAR, HANDLE)
- CALL LEAVE
- CALL WRAPUP
- STOP
- END
- SUBROUTINE AF(T, X, NX, Y, NY, NU, U, UT, UX, UY, UXT, UYT
- 1 , A, AU, AUT, AUX, AUY, AUXT, AUYT, F, FU, FUT, FUX, FUY, FUXT,
- 2 FUYT)
- INTEGER NU, NX, NY
- DOUBLE PRECISION T, X(NX), Y(NY), U(NX, NY, NU), UT(NX, NY, NU),
- 1 UX(NX, NY, NU)
- DOUBLE PRECISION UY(NX, NY, NU), UXT(NX, NY, NU), UYT(NX, NY, NU),
- 1 A(NX, NY, NU, 2), AU(NX, NY, NU, NU, 2), AUT(NX, NY, NU, NU, 2)
- DOUBLE PRECISION AUX(NX, NY, NU, NU, 2), AUY(NX, NY, NU, NU, 2),
- 1 AUXT(NX, NY, NU, NU, 2), AUYT(NX, NY, NU, NU, 2), F(NX, NY, NU)
- 2 , FU(NX, NY, NU, NU)
- DOUBLE PRECISION FUT(NX, NY, NU, NU), FUX(NX, NY, NU, NU), FUY(NX,
- 1 NY, NU, NU), FUXT(NX, NY, NU, NU), FUYT(NX, NY, NU, NU)
- INTEGER I, P, Q
- DO 3 I = 1, NU
- DO 2 Q = 1, NY
- DO 1 P = 1, NX
- A(P, Q, I, 1) = UX(P, Q, I)+.1*UY(P, Q, I)+U(P, Q, I)
- A(P, Q, I, 2) = UY(P, Q, I)+.1*UX(P, Q, I)+U(P, Q, I)
- AUX(P, Q, I, I, 1) = 1
- AUY(P, Q, I, I, 2) = 1
- AUY(P, Q, I, I, 1) = .1
- AUX(P, Q, I, I, 2) = .1
- AU(P, Q, I, I, 1) = 1
- AU(P, Q, I, I, 2) = 1
- F(P, Q, I) = UT(P, Q, I)+UX(P, Q, I)+UY(P, Q, I)
- FUT(P, Q, I, I) = 1
- FUX(P, Q, I, I) = 1
- FUY(P, Q, I, I) = 1
- F(P, Q, I) = F(P, Q, I)+.2*T-X(P)*Y(Q)
- 1 CONTINUE
- 2 CONTINUE
- 3 CONTINUE
- RETURN
- END
- SUBROUTINE BC(T, X, NX, Y, NY, LX, RX, LY, RY, U, UT, UX,
- 1 UY, UXT, UYT, NU, B, BU, BUT, BUX, BUY, BUXT, BUYT)
- INTEGER NU, NX, NY
- DOUBLE PRECISION T, X(NX), Y(NY), LX, RX, LY
- DOUBLE PRECISION RY, U(NX, NY, NU), UT(NX, NY, NU), UX(NX, NY, NU)
- 1 , UY(NX, NY, NU), UXT(NX, NY, NU)
- DOUBLE PRECISION UYT(NX, NY, NU), B(NX, NY, NU), BU(NX, NY, NU,
- 1 NU), BUT(NX, NY, NU, NU), BUX(NX, NY, NU, NU), BUY(NX, NY, NU
- 2 , NU)
- DOUBLE PRECISION BUXT(NX, NY, NU, NU), BUYT(NX, NY, NU, NU)
- INTEGER I, J
- DO 2 J = 1, NY
- DO 1 I = 1, NX
- BU(I, J, 1, 1) = 1
- B(I, J, 1) = U(I, J, 1)-T*X(I)*Y(J)
- 1 CONTINUE
- 2 CONTINUE
- RETURN
- END
- SUBROUTINE HANDLE(T0, U0, T, U, NV, DT, TSTOP)
- INTEGER NV
- DOUBLE PRECISION T0, U0(NV), T, U(NV), DT, TSTOP
- COMMON /D7TGRP/ ERRPAR, NU, MXQ, MYQ
- INTEGER NU, MXQ, MYQ
- REAL ERRPAR(2)
- COMMON /D7TGRM/ KX, IX, NX, KY, IY, NY
- INTEGER KX, IX, NX, KY, IY, NY
- IF (T0 .NE. T) GOTO 2
- WRITE (6, 1) T
- 1 FORMAT (16H RESTART FOR T =, 1PE10.2)
- RETURN
-C GET AND PRINT THE ERROR.
- 2 CALL GERR(KX, IX, NX, KY, IY, NY, U, NU, T)
- RETURN
- END
- SUBROUTINE GERR(KX, IX, NX, KY, IY, NY, U, NU, T)
- INTEGER KX, IX, NX, KY, IY, NY
- INTEGER NU
- DOUBLE PRECISION U(1), T
- COMMON /CSTAK/ DS
- DOUBLE PRECISION DS(500)
- INTEGER IFA, ITA(2), IXA(2), NTA(2), NXA(2), IDLUMD
- INTEGER IXS, IYS, NXS, NYS, ISTKGT, I
- INTEGER IEWE, KA(2), MA(2), IS(1000), I1MACH
- REAL RS(1000)
- LOGICAL LS(1000)
- COMPLEX CS(500)
- DOUBLE PRECISION DABS, ERRU, DMAX1, WS(500)
- INTEGER TEMP, TEMP1, TEMP2
- EQUIVALENCE (DS(1), CS(1), WS(1), RS(1), IS(1), LS(1))
-C TO GET AND PRINT THE ERROR AT EACH TIME-STEP.
-C U(NX-KX,NY0KY,NU).
-C THE PORT LIBRARY STACK AND ITS ALIASES.
- CALL ENTER(1)
-C FIND THE ERROR IN THE SOLUTION AT 2*KX * 2*KY POINTS / MESH RECTANGLE.
-C X SEARCH GRID.
- IXS = IDLUMD(WS(IX), NX, 2*KX, NXS)
-C Y SEARCH GRID.
- IYS = IDLUMD(WS(IY), NY, 2*KY, NYS)
-C U SEARCH GRID VALUES.
- IEWE = ISTKGT(NXS*NYS, 4)
-C THE EXACT SOLUTION.
- CALL EWE(T, WS(IXS), NXS, WS(IYS), NYS, WS(IEWE), NU)
- KA(1) = KX
- KA(2) = KY
- ITA(1) = IX
- ITA(2) = IY
- NTA(1) = NX
- NTA(2) = NY
- IXA(1) = IXS
- IXA(2) = IYS
- NXA(1) = NXS
- NXA(2) = NYS
- MA(1) = 0
-C GET SOLUTION.
- MA(2) = 0
-C APPROXIMATE SOLUTION VALUES.
- IFA = ISTKGT(NXS*NYS, 4)
-C EVALUATE THEM.
- CALL DTSD1(2, KA, WS, ITA, NTA, U, WS, IXA, NXA, MA, WS(IFA))
-C ERROR IN SOLUTION VALUES.
- ERRU = 0
- TEMP = NXS*NYS
- DO 1 I = 1, TEMP
- TEMP2 = IEWE+I
- TEMP1 = IFA+I
- ERRU = DMAX1(ERRU, DABS(WS(TEMP2-1)-WS(TEMP1-1)))
- 1 CONTINUE
- TEMP = I1MACH(2)
- WRITE (TEMP, 2) T, ERRU
- 2 FORMAT (14H ERROR IN U(.,, 1PE10.2, 3H) =, 1PE10.2)
- CALL LEAVE
- RETURN
- END
- SUBROUTINE EWE(T, X, NX, Y, NY, U, NU)
- INTEGER NU, NX, NY
- DOUBLE PRECISION T, X(NX), Y(NY), U(NX, NY, NU)
- INTEGER I, J, P
-C THE EXACT SOLUTION.
- DO 3 P = 1, NU
- DO 2 I = 1, NX
- DO 1 J = 1, NY
- U(I, J, P) = T*X(I)*Y(J)
- 1 CONTINUE
- 2 CONTINUE
- 3 CONTINUE
- RETURN
- END
diff --git a/CEP/PyBDSM/src/port3/ex/dttgrx1p.f b/CEP/PyBDSM/src/port3/ex/dttgrx1p.f
deleted file mode 100644
index 2926e54d64f31c366c814bbc1aeaca54976155b5..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ex/dttgrx1p.f
+++ /dev/null
@@ -1,186 +0,0 @@
-C$TEST DTGP
-C TO RUN AS A MAIN PROGRAM REMOVE NEXT LINE
- SUBROUTINE DTGP
-C***********************************************************************
-C
-C EXAMPLE OF USE OF PORT PROGRAM DTTGR
-C
-C***********************************************************************
- COMMON /CSTAK/ DS
- DOUBLE PRECISION DS(350000)
- EXTERNAL HANDLE, BC, AF
- INTEGER NDX, NDY, ISTKGT, IS(1000), IU, IX
- INTEGER IY, NU, KX, NX, KY, NY
- INTEGER IDUMB
- REAL ERRPAR(2), RS(1000)
- LOGICAL LS(1000)
- COMPLEX CS(500)
- DOUBLE PRECISION TSTART, DT, LX, LY, RX, RY
- DOUBLE PRECISION WS(500), TSTOP
- EQUIVALENCE (DS(1), CS(1), WS(1), RS(1), IS(1), LS(1))
-C TO SOLVE THE HEAT EQUATION WITH SOLUTION U == T*X*Y,
-C GRAD . ( U + UX + .1 * UY, U + UY + .1 * UX ) = UT + UX + UY +G(X,T)
-C THE PORT LIBRARY STACK AND ITS ALIASES.
-C INITIALIZE THE PORT LIBRARY STACK LENGTH.
- CALL ISTKIN(350000, 4)
- CALL ENTER(1)
- NU = 1
- LX = 0
- RX = 1
- LY = 0
- RY = 1
- KX = 2
- KY = 2
- NDX = 3
- NDY = 3
- TSTART = 0
- TSTOP = 1
- DT = 1
- ERRPAR(1) = 1E-2
- ERRPAR(2) = 1E-4
-C UNIFORM GRID.
- IX = IDUMB(LX, RX, NDX, KX, NX)
-C UNIFORM GRID.
- IY = IDUMB(LY, RY, NDY, KY, NY)
-C SPACE FOR THE SOLUTION.
- IU = ISTKGT(NU*(NX-KX)*(NY-KY), 4)
-C INITIAL CONDITIONS FOR U.
- CALL SETD(NU*(NX-KX)*(NY-KY), 0D0, WS(IU))
- CALL DTTGR(WS(IU), NU, KX, WS(IX), NX, KY, WS(IY), NY, TSTART,
- 1 TSTOP, DT, AF, BC, ERRPAR, HANDLE)
- CALL LEAVE
- CALL WRAPUP
- STOP
- END
- SUBROUTINE AF(T, X, NX, Y, NY, NU, U, UT, UX, UY, UXT, UYT
- 1 , A, AU, AUT, AUX, AUY, AUXT, AUYT, F, FU, FUT, FUX, FUY, FUXT,
- 2 FUYT)
- INTEGER NU, NX, NY
- DOUBLE PRECISION T, X(NX), Y(NY), U(NX, NY, NU), UT(NX, NY, NU),
- 1 UX(NX, NY, NU)
- DOUBLE PRECISION UY(NX, NY, NU), UXT(NX, NY, NU), UYT(NX, NY, NU),
- 1 A(NX, NY, NU, 2), AU(NX, NY, NU, NU, 2), AUT(NX, NY, NU, NU, 2)
- DOUBLE PRECISION AUX(NX, NY, NU, NU, 2), AUY(NX, NY, NU, NU, 2),
- 1 AUXT(NX, NY, NU, NU, 2), AUYT(NX, NY, NU, NU, 2), F(NX, NY, NU)
- 2 , FU(NX, NY, NU, NU)
- DOUBLE PRECISION FUT(NX, NY, NU, NU), FUX(NX, NY, NU, NU), FUY(NX,
- 1 NY, NU, NU), FUXT(NX, NY, NU, NU), FUYT(NX, NY, NU, NU)
- INTEGER I, P, Q
- DO 3 I = 1, NU
- DO 2 Q = 1, NY
- DO 1 P = 1, NX
- A(P, Q, I, 1) = UX(P, Q, I)+.1*UY(P, Q, I)+U(P, Q, I)
- A(P, Q, I, 2) = UY(P, Q, I)+.1*UX(P, Q, I)+U(P, Q, I)
- AUX(P, Q, I, I, 1) = 1
- AUY(P, Q, I, I, 2) = 1
- AUY(P, Q, I, I, 1) = .1
- AUX(P, Q, I, I, 2) = .1
- AU(P, Q, I, I, 1) = 1
- AU(P, Q, I, I, 2) = 1
- F(P, Q, I) = UT(P, Q, I)+UX(P, Q, I)+UY(P, Q, I)
- FUT(P, Q, I, I) = 1
- FUX(P, Q, I, I) = 1
- FUY(P, Q, I, I) = 1
- F(P, Q, I) = F(P, Q, I)+.2*T-X(P)*Y(Q)
- 1 CONTINUE
- 2 CONTINUE
- 3 CONTINUE
- RETURN
- END
- SUBROUTINE BC(T, X, NX, Y, NY, LX, RX, LY, RY, U, UT, UX,
- 1 UY, UXT, UYT, NU, B, BU, BUT, BUX, BUY, BUXT, BUYT)
- INTEGER NU, NX, NY
- DOUBLE PRECISION T, X(NX), Y(NY), LX, RX, LY
- DOUBLE PRECISION RY, U(NX, NY, NU), UT(NX, NY, NU), UX(NX, NY, NU)
- 1 , UY(NX, NY, NU), UXT(NX, NY, NU)
- DOUBLE PRECISION UYT(NX, NY, NU), B(NX, NY, NU), BU(NX, NY, NU,
- 1 NU), BUT(NX, NY, NU, NU), BUX(NX, NY, NU, NU), BUY(NX, NY, NU
- 2 , NU)
- DOUBLE PRECISION BUXT(NX, NY, NU, NU), BUYT(NX, NY, NU, NU)
- INTEGER I, J
- DO 2 J = 1, NY
- DO 1 I = 1, NX
- BU(I, J, 1, 1) = 1
- B(I, J, 1) = U(I, J, 1)-T*X(I)*Y(J)
- 1 CONTINUE
- 2 CONTINUE
- RETURN
- END
- SUBROUTINE HANDLE(T0, U0, T, U, NV, DT, TSTOP)
- INTEGER NV
- DOUBLE PRECISION T0, U0(NV), T, U(NV), DT, TSTOP
- COMMON /D7TGRP/ ERRPAR, NU, MXQ, MYQ
- INTEGER NU, MXQ, MYQ
- REAL ERRPAR(2)
- COMMON /D7TGRM/ KX, IX, NX, KY, IY, NY
- INTEGER KX, IX, NX, KY, IY, NY
- IF (T0 .NE. T) GOTO 2
- WRITE (6, 1) T
- 1 FORMAT (16H RESTART FOR T =, 1PE10.2)
- RETURN
-C PRINT RESULTS.
- 2 CALL GERR(KX, IX, NX, KY, IY, NY, U, NU, T)
- RETURN
- END
- SUBROUTINE GERR(KX, IX, NX, KY, IY, NY, U, NU, T)
- INTEGER KX, IX, NX, KY, IY, NY
- INTEGER NU
- DOUBLE PRECISION U(1), T
- COMMON /CSTAK/ DS
- DOUBLE PRECISION DS(500)
- INTEGER IFA, ITA(2), IXA(2), NTA(2), NXA(2), IDLUMD
- INTEGER IXS, IYS, NXS, NYS, ISTKGT, I
- INTEGER KA(2), MA(2), IS(1000), I1MACH
- REAL RS(1000)
- LOGICAL LS(1000)
- COMPLEX CS(500)
- DOUBLE PRECISION WS(500)
- INTEGER TEMP, TEMP1
- EQUIVALENCE (DS(1), CS(1), WS(1), RS(1), IS(1), LS(1))
-C TO PRINT THE SOLUTION AT EACH TIME-STEP.
-C U(NX-KX,NY,KY,NU).
-C THE PORT LIBRARY STACK AND ITS ALIASES.
- CALL ENTER(1)
-C FIND THE SOLUTION AT 2 * 2 POINTS / MESH RECTANGLE.
-C X SEARCH GRID.
- IXS = IDLUMD(WS(IX), NX, 2, NXS)
-C Y SEARCH GRID.
- IYS = IDLUMD(WS(IY), NY, 2, NYS)
- KA(1) = KX
- KA(2) = KY
- ITA(1) = IX
- ITA(2) = IY
- NTA(1) = NX
- NTA(2) = NY
- IXA(1) = IXS
- IXA(2) = IYS
- NXA(1) = NXS
- NXA(2) = NYS
- MA(1) = 0
-C GET SOLUTION.
- MA(2) = 0
-C APPROXIMATE SOLUTION VALUES.
- IFA = ISTKGT(NXS*NYS, 4)
-C EVALUATE THEM.
- CALL DTSD1(2, KA, WS, ITA, NTA, U, WS, IXA, NXA, MA, WS(IFA))
- TEMP1 = IFA+NXS*NYS-1
- TEMP = I1MACH(2)
- WRITE (TEMP, 1) T, (WS(I), I = IFA, TEMP1)
- 1 FORMAT (3H U(, 1PE10.2, 7H,.,.) =, (1P5E10.2/20X,1P4E10.2))
- CALL LEAVE
- RETURN
- END
- SUBROUTINE EWE(T, X, NX, Y, NY, U, NU)
- INTEGER NU, NX, NY
- DOUBLE PRECISION T, X(NX), Y(NY), U(NX, NY, NU)
- INTEGER I, J, P
-C THE EXACT SOLUTION.
- DO 3 P = 1, NU
- DO 2 I = 1, NX
- DO 1 J = 1, NY
- U(I, J, P) = T*X(I)*Y(J)
- 1 CONTINUE
- 2 CONTINUE
- 3 CONTINUE
- RETURN
- END
diff --git a/CEP/PyBDSM/src/port3/ex/dttgrx2.f b/CEP/PyBDSM/src/port3/ex/dttgrx2.f
deleted file mode 100644
index 69fce80ff121b236196a7b2c36062f59ca145b8b..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ex/dttgrx2.f
+++ /dev/null
@@ -1,202 +0,0 @@
-C$TEST DTG2
-C TO RUN AS A MAIN PROGRAM REMOVE NEXT LINE
- SUBROUTINE DTG2
-C***********************************************************************
-C
-C EXAMPLE OF USE OF PORT PROGRAM DTTGR
-C
-C***********************************************************************
- COMMON /CSTAK/ DS
- DOUBLE PRECISION DS(350000)
- EXTERNAL HANDLE, BC, AF
- INTEGER NDX, NDY, ISTKGT, IS(1000), IU, IX
- INTEGER IY, NU, KX, NX, KY, NY
- INTEGER IDUMB
- REAL ERRPAR(2), RS(1000)
- LOGICAL LS(1000)
- COMPLEX CS(500)
- DOUBLE PRECISION TSTART, DT, LX, LY, RX, RY
- DOUBLE PRECISION WS(500), TSTOP
- EQUIVALENCE (DS(1), CS(1), WS(1), RS(1), IS(1), LS(1))
-C TO SOLVE TWO COUPLED, NONLINEAR HEAT EQUATIONS.
-C U1 SUB T = DIV . ( U1X, U1Y ) - U1*U2 + G1
-C U2 SUB T = DIV . ( U2X, U2Y ) - U1*U2 + G2
-C THE PORT LIBRARY STACK AND ITS ALIASES.
-C INITIALIZE THE PORT LIBRARY STACK LENGTH.
- CALL ISTKIN(350000, 4)
- CALL ENTER(1)
- NU = 2
- LX = 0
- RX = 1
- LY = 0
- RY = 1
- KX = 4
- KY = 4
- NDX = 3
- NDY = 3
- TSTART = 0
- TSTOP = 1
- DT = 1E-2
- ERRPAR(1) = 1E-2
- ERRPAR(2) = 1E-4
-C UNIFORM GRID.
- IX = IDUMB(LX, RX, NDX, KX, NX)
-C UNIFORM GRID.
- IY = IDUMB(LY, RY, NDY, KY, NY)
-C SPACE FOR THE SOLUTION.
- IU = ISTKGT(NU*(NX-KX)*(NY-KY), 4)
- CALL SETD(NU*(NX-KX)*(NY-KY), 1D0, WS(IU))
- CALL DTTGR(WS(IU), NU, KX, WS(IX), NX, KY, WS(IY), NY, TSTART,
- 1 TSTOP, DT, AF, BC, ERRPAR, HANDLE)
- CALL LEAVE
- CALL WRAPUP
- STOP
- END
- SUBROUTINE AF(T, X, NX, Y, NY, NU, U, UT, UX, UY, UXT, UYT
- 1 , A, AU, AUT, AUX, AUY, AUXT, AUYT, F, FU, FUT, FUX, FUY, FUXT,
- 2 FUYT)
- INTEGER NU, NX, NY
- DOUBLE PRECISION T, X(NX), Y(NY), U(NX, NY, NU), UT(NX, NY, NU),
- 1 UX(NX, NY, NU)
- DOUBLE PRECISION UY(NX, NY, NU), UXT(NX, NY, NU), UYT(NX, NY, NU),
- 1 A(NX, NY, NU, 2), AU(NX, NY, NU, NU, 2), AUT(NX, NY, NU, NU, 2)
- DOUBLE PRECISION AUX(NX, NY, NU, NU, 2), AUY(NX, NY, NU, NU, 2),
- 1 AUXT(NX, NY, NU, NU, 2), AUYT(NX, NY, NU, NU, 2), F(NX, NY, NU)
- 2 , FU(NX, NY, NU, NU)
- DOUBLE PRECISION FUT(NX, NY, NU, NU), FUX(NX, NY, NU, NU), FUY(NX,
- 1 NY, NU, NU), FUXT(NX, NY, NU, NU), FUYT(NX, NY, NU, NU)
- INTEGER P, Q
- DOUBLE PRECISION DEXP
- DO 2 Q = 1, NY
- DO 1 P = 1, NX
- A(P, Q, 1, 1) = UX(P, Q, 1)
- AUX(P, Q, 1, 1, 1) = 1
- A(P, Q, 1, 2) = UY(P, Q, 1)
- AUY(P, Q, 1, 1, 2) = 1
- F(P, Q, 1) = UT(P, Q, 1)+U(P, Q, 1)*U(P, Q, 2)
- FU(P, Q, 1, 1) = U(P, Q, 2)
- FU(P, Q, 1, 2) = U(P, Q, 1)
- FUT(P, Q, 1, 1) = 1
- A(P, Q, 2, 1) = UX(P, Q, 2)
- AUX(P, Q, 2, 2, 1) = 1
- A(P, Q, 2, 2) = UY(P, Q, 2)
- AUY(P, Q, 2, 2, 2) = 1
- F(P, Q, 2) = UT(P, Q, 2)+U(P, Q, 1)*U(P, Q, 2)
- FU(P, Q, 2, 1) = U(P, Q, 2)
- FU(P, Q, 2, 2) = U(P, Q, 1)
- FUT(P, Q, 2, 2) = 1
- F(P, Q, 1) = F(P, Q, 1)-(DEXP(T*(X(P)-Y(Q)))*(X(P)-Y(Q)-2D0*
- 1 T*T)+1D0)
- F(P, Q, 2) = F(P, Q, 2)-(DEXP(T*(Y(Q)-X(P)))*(Y(Q)-X(P)-2D0*
- 1 T*T)+1D0)
- 1 CONTINUE
- 2 CONTINUE
- RETURN
- END
- SUBROUTINE BC(T, X, NX, Y, NY, LX, RX, LY, RY, U, UT, UX,
- 1 UY, UXT, UYT, NU, B, BU, BUT, BUX, BUY, BUXT, BUYT)
- INTEGER NU, NX, NY
- DOUBLE PRECISION T, X(NX), Y(NY), LX, RX, LY
- DOUBLE PRECISION RY, U(NX, NY, NU), UT(NX, NY, NU), UX(NX, NY, NU)
- 1 , UY(NX, NY, NU), UXT(NX, NY, NU)
- DOUBLE PRECISION UYT(NX, NY, NU), B(NX, NY, NU), BU(NX, NY, NU,
- 1 NU), BUT(NX, NY, NU, NU), BUX(NX, NY, NU, NU), BUY(NX, NY, NU
- 2 , NU)
- DOUBLE PRECISION BUXT(NX, NY, NU, NU), BUYT(NX, NY, NU, NU)
- INTEGER I, J
- DOUBLE PRECISION DEXP
- DO 2 J = 1, NY
- DO 1 I = 1, NX
- BU(I, J, 1, 1) = 1
- B(I, J, 1) = U(I, J, 1)-DEXP(T*(X(I)-Y(J)))
- BU(I, J, 2, 2) = 1
- B(I, J, 2) = U(I, J, 2)-DEXP(T*(Y(J)-X(I)))
- 1 CONTINUE
- 2 CONTINUE
- RETURN
- END
- SUBROUTINE HANDLE(T0, U0, T, U, NV, DT, TSTOP)
- INTEGER NV
- DOUBLE PRECISION T0, U0(NV), T, U(NV), DT, TSTOP
- COMMON /CSTAK/ DS
- DOUBLE PRECISION DS(500)
- COMMON /D7TGRP/ ERRPAR, NU, MXQ, MYQ
- INTEGER NU, MXQ, MYQ
- REAL ERRPAR(2)
- COMMON /D7TGRM/ KX, IX, NX, KY, IY, NY
- INTEGER KX, IX, NX, KY, IY, NY
- INTEGER IFA, ITA(2), IXA(2), NTA(2), NXA(2), IDLUMD
- INTEGER IXS, IYS, NXS, NYS, ISTKGT, I
- INTEGER J, IEWE, KA(2), MA(2), IS(1000), I1MACH
- REAL RS(1000)
- LOGICAL LS(1000)
- COMPLEX CS(500)
- DOUBLE PRECISION DABS, ERRU, DMAX1, WS(500)
- INTEGER TEMP, TEMP1, TEMP2
- EQUIVALENCE (DS(1), CS(1), WS(1), RS(1), IS(1), LS(1))
-C THE PORT LIBRARY STACK AND ITS ALIASES.
- IF (T0 .NE. T) GOTO 2
- WRITE (6, 1) T
- 1 FORMAT (16H RESTART FOR T =, 1PE10.2)
- RETURN
- 2 CALL ENTER(1)
-C FIND THE ERROR IN THE SOLUTION AT 2*KX * 2*KY POINTS / MESH RECTANGLE.
-C X SEARCH GRID.
- IXS = IDLUMD(WS(IX), NX, 2*KX, NXS)
-C Y SEARCH GRID.
- IYS = IDLUMD(WS(IY), NY, 2*KY, NYS)
-C U SEARCH GRID VALUES.
- IEWE = ISTKGT(NU*NXS*NYS, 4)
-C THE EXACT SOLUTION.
- CALL EWE(T, WS(IXS), NXS, WS(IYS), NYS, WS(IEWE), NU)
- KA(1) = KX
- KA(2) = KY
- ITA(1) = IX
- ITA(2) = IY
- NTA(1) = NX
- NTA(2) = NY
- IXA(1) = IXS
- IXA(2) = IYS
- NXA(1) = NXS
- NXA(2) = NYS
- MA(1) = 0
-C GET SOLUTION.
- MA(2) = 0
-C APPROXIMATE SOLUTION VALUES.
- IFA = ISTKGT(NXS*NYS, 4)
- DO 5 J = 1, NU
-C EVALUATE THEM.
- TEMP = (J-1)*(NX-KX)*(NY-KY)
- CALL DTSD1(2, KA, WS, ITA, NTA, U(TEMP+1), WS, IXA, NXA, MA,
- 1 WS(IFA))
-C ERROR IN SOLUTION VALUES.
- ERRU = 0
- TEMP = NXS*NYS
- DO 3 I = 1, TEMP
- TEMP2 = IEWE+I-1+(J-1)*NXS*NYS
- TEMP1 = IFA+I
- ERRU = DMAX1(ERRU, DABS(WS(TEMP2)-WS(TEMP1-1)))
- 3 CONTINUE
- TEMP = I1MACH(2)
- WRITE (TEMP, 4) T, J, ERRU
- 4 FORMAT (14H ERROR IN U(.,, 1PE10.2, 1H,, I2, 3H) =, 1PE10.2)
- 5 CONTINUE
- CALL LEAVE
- RETURN
- END
- SUBROUTINE EWE(T, X, NX, Y, NY, U, NU)
- INTEGER NU, NX, NY
- DOUBLE PRECISION T, X(NX), Y(NY), U(NX, NY, NU)
- INTEGER I, J, P
- REAL FLOAT
- DOUBLE PRECISION DBLE, DEXP
-C THE EXACT SOLUTION.
- DO 3 P = 1, NU
- DO 2 I = 1, NX
- DO 1 J = 1, NY
- U(I, J, P) = DEXP(DBLE(FLOAT((-1)**(P+1)))*T*(X(I)-Y(J)))
- 1 CONTINUE
- 2 CONTINUE
- 3 CONTINUE
- RETURN
- END
diff --git a/CEP/PyBDSM/src/port3/ex/dttgrx3.f b/CEP/PyBDSM/src/port3/ex/dttgrx3.f
deleted file mode 100644
index 708e737198774ed0c30596d9279d8f65ac01d294..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ex/dttgrx3.f
+++ /dev/null
@@ -1,235 +0,0 @@
-C$TEST DTG3
-C TO RUN AS A MAIN PROGRAM REMOVE NEXT LINE
- SUBROUTINE DTG3
-C***********************************************************************
-C
-C EXAMPLE OF USE OF PORT PROGRAM DTTGR
-C
-C***********************************************************************
- COMMON /CSTAK/ DS
- DOUBLE PRECISION DS(350000)
- EXTERNAL HANDLE, BC, AF
- INTEGER NDX, NDY, IDLUMB, ISTKGT, I, IS(1000)
- INTEGER IU, IX, IY, NU, KX, NX
- INTEGER KY, NY, IDUMB, IMMMD
- REAL ERRPAR(2), RS(1000)
- LOGICAL LS(1000)
- COMPLEX CS(500)
- DOUBLE PRECISION TSTART, DT, YB(4), LX, RX, WS(500)
- DOUBLE PRECISION TSTOP
- EQUIVALENCE (DS(1), CS(1), WS(1), RS(1), IS(1), LS(1))
-C TO SOLVE THE LAYERED HEAT EQUATION, WITH KAPPA = 1, 1/2, 1/3,
-C DIV . ( KAPPA(X,Y) * GRAD U ) = UT + G
-C THE PORT LIBRARY STACK AND ITS ALIASES.
-C INITIALIZE THE PORT LIBRARY STACK LENGTH.
- CALL ISTKIN(350000, 4)
- CALL ENTER(1)
- NU = 1
- LX = 0
- RX = 1
- DO 1 I = 1, 4
- YB(I) = I-1
- 1 CONTINUE
- KX = 2
- KY = 2
- NDX = 3
- NDY = 3
- TSTART = 0
- TSTOP = 1
- DT = 1
- ERRPAR(1) = 1E-2
- ERRPAR(2) = 1E-4
-C UNIFORM GRID.
- IX = IDUMB(LX, RX, NDX, KX, NX)
-C UNIFORM GRID.
- IY = IDLUMB(YB, 4, NDY, KY, NY)
-C MAKE MULT = KY-1.
- IY = IMMMD(IY, NY, YB(2), KY-1)
-C MAKE MULT = KY-1.
- IY = IMMMD(IY, NY, YB(3), KY-1)
-C SPACE FOR THE SOLUTION.
- IU = ISTKGT(NU*(NX-KX)*(NY-KY), 4)
- CALL SETD(NU*(NX-KX)*(NY-KY), 0D0, WS(IU))
- CALL DTTGR(WS(IU), NU, KX, WS(IX), NX, KY, WS(IY), NY, TSTART,
- 1 TSTOP, DT, AF, BC, ERRPAR, HANDLE)
- CALL LEAVE
- CALL WRAPUP
- STOP
- END
- SUBROUTINE AF(T, X, NX, Y, NY, NU, U, UT, UX, UY, UXT, UYT
- 1 , A, AU, AUT, AUX, AUY, AUXT, AUYT, F, FU, FUT, FUX, FUY, FUXT,
- 2 FUYT)
- INTEGER NU, NX, NY
- DOUBLE PRECISION T, X(NX), Y(NY), U(NX, NY, NU), UT(NX, NY, NU),
- 1 UX(NX, NY, NU)
- DOUBLE PRECISION UY(NX, NY, NU), UXT(NX, NY, NU), UYT(NX, NY, NU),
- 1 A(NX, NY, NU, 2), AU(NX, NY, NU, NU, 2), AUT(NX, NY, NU, NU, 2)
- DOUBLE PRECISION AUX(NX, NY, NU, NU, 2), AUY(NX, NY, NU, NU, 2),
- 1 AUXT(NX, NY, NU, NU, 2), AUYT(NX, NY, NU, NU, 2), F(NX, NY, NU)
- 2 , FU(NX, NY, NU, NU)
- DOUBLE PRECISION FUT(NX, NY, NU, NU), FUX(NX, NY, NU, NU), FUY(NX,
- 1 NY, NU, NU), FUXT(NX, NY, NU, NU), FUYT(NX, NY, NU, NU)
- INTEGER I, P, Q
- DOUBLE PRECISION KAPPA
- LOGICAL TEMP
- DO 7 I = 1, NU
- DO 6 Q = 1, NY
- DO 5 P = 1, NX
- IF (Y(Q) .GE. 1D0) GOTO 1
- KAPPA = 1
- GOTO 4
- 1 IF (Y(Q) .GE. 2D0) GOTO 2
- KAPPA = 0.5
- GOTO 3
- 2 KAPPA = 1D0/3D0
- 3 CONTINUE
- 4 A(P, Q, I, 1) = KAPPA*UX(P, Q, I)
- AUX(P, Q, I, I, 1) = KAPPA
- A(P, Q, I, 2) = KAPPA*UY(P, Q, I)
- AUY(P, Q, I, I, 2) = KAPPA
- F(P, Q, I) = UT(P, Q, I)
- FUT(P, Q, I, I) = 1
- F(P, Q, I) = F(P, Q, I)-Y(Q)/KAPPA
- TEMP = 1D0 .LT. Y(Q)
- IF (TEMP) TEMP = Y(Q) .LT. 2D0
- IF (TEMP) F(P, Q, I) = F(P, Q, I)+1D0
- TEMP = 2D0 .LT. Y(Q)
- IF (TEMP) TEMP = Y(Q) .LT. 3D0
- IF (TEMP) F(P, Q, I) = F(P, Q, I)+3D0
- 5 CONTINUE
- 6 CONTINUE
- 7 CONTINUE
- RETURN
- END
- SUBROUTINE BC(T, X, NX, Y, NY, LX, RX, LY, RY, U, UT, UX,
- 1 UY, UXT, UYT, NU, B, BU, BUT, BUX, BUY, BUXT, BUYT)
- INTEGER NU, NX, NY
- DOUBLE PRECISION T, X(NX), Y(NY), LX, RX, LY
- DOUBLE PRECISION RY, U(NX, NY, NU), UT(NX, NY, NU), UX(NX, NY, NU)
- 1 , UY(NX, NY, NU), UXT(NX, NY, NU)
- DOUBLE PRECISION UYT(NX, NY, NU), B(NX, NY, NU), BU(NX, NY, NU,
- 1 NU), BUT(NX, NY, NU, NU), BUX(NX, NY, NU, NU), BUY(NX, NY, NU
- 2 , NU)
- DOUBLE PRECISION BUXT(NX, NY, NU, NU), BUYT(NX, NY, NU, NU)
- INTEGER I, J
- LOGICAL TEMP
- DO 6 J = 1, NY
- DO 5 I = 1, NX
- TEMP = X(I) .EQ. LX
- IF (.NOT. TEMP) TEMP = X(I) .EQ. RX
- IF (.NOT. TEMP) GOTO 1
- BUX(I, J, 1, 1) = 1
-C LEFT OR RIGHT.
-C NEUMANN BCS.
- B(I, J, 1) = UX(I, J, 1)
- GOTO 4
- 1 IF (Y(J) .NE. LY) GOTO 2
- B(I, J, 1) = U(I, J, 1)
-C BOTTOM.
- BU(I, J, 1, 1) = 1
- GOTO 3
- 2 B(I, J, 1) = U(I, J, 1)-6D0*T
-C TOP.
- BU(I, J, 1, 1) = 1
- 3 CONTINUE
- 4 CONTINUE
- 5 CONTINUE
- 6 CONTINUE
- RETURN
- END
- SUBROUTINE HANDLE(T0, U0, T, U, NV, DT, TSTOP)
- INTEGER NV
- DOUBLE PRECISION T0, U0(NV), T, U(NV), DT, TSTOP
- COMMON /D7TGRP/ ERRPAR, NU, MXQ, MYQ
- INTEGER NU, MXQ, MYQ
- REAL ERRPAR(2)
- COMMON /D7TGRM/ KX, IX, NX, KY, IY, NY
- INTEGER KX, IX, NX, KY, IY, NY
- IF (T0 .NE. T) GOTO 2
- WRITE (6, 1) T
- 1 FORMAT (16H RESTART FOR T =, 1PE10.2)
- RETURN
- 2 CALL GERR(KX, IX, NX, KY, IY, NY, U, NU, T)
- RETURN
- END
- SUBROUTINE GERR(KX, IX, NX, KY, IY, NY, U, NU, T)
- INTEGER KX, IX, NX, KY, IY, NY
- INTEGER NU
- DOUBLE PRECISION U(1), T
- COMMON /CSTAK/ DS
- DOUBLE PRECISION DS(500)
- INTEGER IFA, ITA(2), IXA(2), NTA(2), NXA(2), IDLUMD
- INTEGER IXS, IYS, NXS, NYS, ISTKGT, I
- INTEGER IEWE, KA(2), MA(2), IS(1000), I1MACH
- REAL RS(1000)
- LOGICAL LS(1000)
- COMPLEX CS(500)
- DOUBLE PRECISION DABS, ERRU, DMAX1, WS(500)
- INTEGER TEMP, TEMP1, TEMP2
- EQUIVALENCE (DS(1), CS(1), WS(1), RS(1), IS(1), LS(1))
-C TO GET AND PRINT THE ERROR AT EACH TIME-STEP.
-C U(NX-KX,NY,KY,NU).
-C THE PORT LIBRARY STACK AND ITS ALIASES.
- CALL ENTER(1)
-C FIND THE ERROR IN THE SOLUTION AT 2*KX * 2*KY POINTS / MESH RECTANGLE.
-C X SEARCH GRID.
- IXS = IDLUMD(WS(IX), NX, 2*KX, NXS)
-C Y SEARCH GRID.
- IYS = IDLUMD(WS(IY), NY, 2*KY, NYS)
-C U SEARCH GRID VALUES.
- IEWE = ISTKGT(NXS*NYS, 4)
-C THE EXACT SOLUTION.
- CALL EWE(T, WS(IXS), NXS, WS(IYS), NYS, WS(IEWE), NU)
- KA(1) = KX
- KA(2) = KY
- ITA(1) = IX
- ITA(2) = IY
- NTA(1) = NX
- NTA(2) = NY
- IXA(1) = IXS
- IXA(2) = IYS
- NXA(1) = NXS
- NXA(2) = NYS
- MA(1) = 0
-C GET SOLUTION.
- MA(2) = 0
-C APPROXIMATE SOLUTION VALUES.
- IFA = ISTKGT(NXS*NYS, 4)
-C EVALUATE THEM.
- CALL DTSD1(2, KA, WS, ITA, NTA, U, WS, IXA, NXA, MA, WS(IFA))
-C ERROR IN SOLUTION VALUES.
- ERRU = 0
- TEMP = NXS*NYS
- DO 1 I = 1, TEMP
- TEMP2 = IEWE+I
- TEMP1 = IFA+I
- ERRU = DMAX1(ERRU, DABS(WS(TEMP2-1)-WS(TEMP1-1)))
- 1 CONTINUE
- TEMP = I1MACH(2)
- WRITE (TEMP, 2) T, ERRU
- 2 FORMAT (14H ERROR IN U(.,, 1PE10.2, 3H) =, 1PE10.2)
- CALL LEAVE
- RETURN
- END
- SUBROUTINE EWE(T, X, NX, Y, NY, U, NU)
- INTEGER NU, NX, NY
- DOUBLE PRECISION T, X(NX), Y(NY), U(NX, NY, NU)
- INTEGER I, J, P
-C THE EXACT SOLUTION.
- DO 7 P = 1, NU
- DO 6 I = 1, NX
- DO 5 J = 1, NY
- IF (Y(J) .GE. 1D0) GOTO 1
- U(I, J, P) = T*Y(J)
- GOTO 4
- 1 IF (Y(J) .GE. 2D0) GOTO 2
- U(I, J, P) = 2D0*T*Y(J)-T
- GOTO 3
- 2 U(I, J, P) = 3D0*T*Y(J)-3D0*T
- 3 CONTINUE
- 4 CONTINUE
- 5 CONTINUE
- 6 CONTINUE
- 7 CONTINUE
- RETURN
- END
diff --git a/CEP/PyBDSM/src/port3/ex/dttgrx4.f b/CEP/PyBDSM/src/port3/ex/dttgrx4.f
deleted file mode 100644
index e584be21768828186b37afaaea21565a0f083762..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ex/dttgrx4.f
+++ /dev/null
@@ -1,265 +0,0 @@
-C$TEST DTG4
-C TO RUN AS A MAIN PROGRAM REMOVE NEXT LINE
- SUBROUTINE DTG4
-C***********************************************************************
-C
-C EXAMPLE OF USE OF PORT PROGRAM DTTGR
-C
-C***********************************************************************
- COMMON /CSTAK/ DS
- DOUBLE PRECISION DS(350000)
- EXTERNAL HANDLE, BC, AF
- INTEGER NDX, NDY, ISTKGT, IS(1000), IU, IX
- INTEGER IY, NU, KX, NX, KY, NY
- INTEGER IDUMB
- REAL ERRPAR(2), RS(1000)
- LOGICAL LS(1000)
- COMPLEX CS(500)
- DOUBLE PRECISION TSTART, DT, LX, LY, RX, RY
- DOUBLE PRECISION WS(500), TSTOP
- EQUIVALENCE (DS(1), CS(1), WS(1), RS(1), IS(1), LS(1))
-C TO SOLVE THE LINEAR HEAT EQUATION
-C GRAD . ( UX - 0.1 * UY , 0.1*UX + UY ) = UT - X*Y
-C WITH SOLUTION U == T*X*Y ON [0,+1]**2, EXACT FOR K = 4,
-C WITH TILTED TOP AND BOTTOM, NORMAL BCS THERE.
-C THE PORT LIBRARY STACK AND ITS ALIASES.
-C INITIALIZE THE PORT LIBRARY STACK LENGTH.
- CALL ISTKIN(350000, 4)
- CALL ENTER(1)
- NU = 1
- LX = 0
- RX = 1
- LY = 0
- RY = 1
- KX = 4
- KY = 4
- NDX = 3
- NDY = 3
- TSTART = 0
- TSTOP = 1
- DT = 1
- ERRPAR(1) = 1E-2
- ERRPAR(2) = 1E-4
-C UNIFORM GRID.
- IX = IDUMB(LX, RX, NDX, KX, NX)
-C UNIFORM GRID.
- IY = IDUMB(LY, RY, NDY, KY, NY)
-C SPACE FOR THE SOLUTION.
- IU = ISTKGT(NU*(NX-KX)*(NY-KY), 4)
- CALL SETD(NU*(NX-KX)*(NY-KY), 0D0, WS(IU))
- CALL DTTGR(WS(IU), NU, KX, WS(IX), NX, KY, WS(IY), NY, TSTART,
- 1 TSTOP, DT, AF, BC, ERRPAR, HANDLE)
- CALL LEAVE
- CALL WRAPUP
- STOP
- END
- SUBROUTINE AF(T, XI, NX, YI, NY, NU, U, UT, UX, UY, UXT,
- 1 UYT, A, AU, AUT, AUX, AUY, AUXT, AUYT, F, FU, FUT, FUX, FUY,
- 2 FUXT, FUYT)
- INTEGER NU, NX, NY
- DOUBLE PRECISION T, XI(NX), YI(NY), U(NX, NY, NU), UT(NX, NY, NU),
- 1 UX(NX, NY, NU)
- DOUBLE PRECISION UY(NX, NY, NU), UXT(NX, NY, NU), UYT(NX, NY, NU),
- 1 A(NX, NY, NU, 2), AU(NX, NY, NU, NU, 2), AUT(NX, NY, NU, NU, 2)
- DOUBLE PRECISION AUX(NX, NY, NU, NU, 2), AUY(NX, NY, NU, NU, 2),
- 1 AUXT(NX, NY, NU, NU, 2), AUYT(NX, NY, NU, NU, 2), F(NX, NY, NU)
- 2 , FU(NX, NY, NU, NU)
- DOUBLE PRECISION FUT(NX, NY, NU, NU), FUX(NX, NY, NU, NU), FUY(NX,
- 1 NY, NU, NU), FUXT(NX, NY, NU, NU), FUYT(NX, NY, NU, NU)
- EXTERNAL BT, LR
- INTEGER I, P, Q
- DOUBLE PRECISION D(600), X, Y, XX(100), YY(100)
- INTEGER TEMP
- IF (NX*NY .GT. 100) CALL SETERR(19HAF - NX*NY .GT. 100, 19, 1, 2)
- CALL DBTMAP(T, XI, YI, NX, NY, LR, BT, XX, YY, D)
-C MAP INTO (X,Y).
- CALL DTTGRU(NX, NY, D, UX, UY, UT, NU)
- DO 3 I = 1, NU
- DO 2 Q = 1, NY
- DO 1 P = 1, NX
- TEMP = P+(Q-1)*NX
- X = XX(TEMP)
- TEMP = P+(Q-1)*NX
- Y = YY(TEMP)
- A(P, Q, I, 1) = UX(P, Q, I)-.1*UY(P, Q, I)
- A(P, Q, I, 2) = UY(P, Q, I)+.1*UX(P, Q, I)
- AUX(P, Q, I, I, 1) = 1
- AUY(P, Q, I, I, 2) = 1
- AUY(P, Q, I, I, 1) = -.1
- AUX(P, Q, I, I, 2) = .1
- F(P, Q, 1) = UT(P, Q, 1)-X*Y
- FUT(P, Q, 1, 1) = 1
- 1 CONTINUE
- 2 CONTINUE
- 3 CONTINUE
-C MAP INTO (XI,ETA).
- CALL DTTGRG(NX, NY, D, NU, A, AU, AUX, AUY, F, FU, FUX, FUY)
- RETURN
- END
- SUBROUTINE BC(T, XI, NX, YI, NY, LX, RX, LY, RY, U, UT, UX
- 1 , UY, UXT, UYT, NU, B, BU, BUT, BUX, BUY, BUXT, BUYT)
- INTEGER NU, NX, NY
- DOUBLE PRECISION T, XI(NX), YI(NY), LX, RX, LY
- DOUBLE PRECISION RY, U(NX, NY, NU), UT(NX, NY, NU), UX(NX, NY, NU)
- 1 , UY(NX, NY, NU), UXT(NX, NY, NU)
- DOUBLE PRECISION UYT(NX, NY, NU), B(NX, NY, NU), BU(NX, NY, NU,
- 1 NU), BUT(NX, NY, NU, NU), BUX(NX, NY, NU, NU), BUY(NX, NY, NU
- 2 , NU)
- DOUBLE PRECISION BUXT(NX, NY, NU, NU), BUYT(NX, NY, NU, NU)
- EXTERNAL BT, LR
- INTEGER I, J
- DOUBLE PRECISION D(600), X, Y, XX(100), YY(100)
- INTEGER TEMP1
- LOGICAL TEMP
- IF (NX*NY .GT. 100) CALL SETERR(19HBC - NX*NY .GT. 100, 19, 1, 2)
- CALL DBTMAP(T, XI, YI, NX, NY, LR, BT, XX, YY, D)
-C MAP INTO (X,Y).
- CALL DTTGRU(NX, NY, D, UX, UY, UT, NU)
- DO 6 J = 1, NY
- DO 5 I = 1, NX
- TEMP1 = I+(J-1)*NX
- X = XX(TEMP1)
- TEMP1 = I+(J-1)*NX
- Y = YY(TEMP1)
- TEMP = XI(I) .EQ. LX
- IF (.NOT. TEMP) TEMP = XI(I) .EQ. RX
- IF (.NOT. TEMP) GOTO 1
- BU(I, J, 1, 1) = 1
-C LEFT OR RIGHT.
- B(I, J, 1) = U(I, J, 1)-T*X*Y
- GOTO 4
- 1 IF (YI(J) .NE. LY) GOTO 2
- B(I, J, 1) = (UX(I, J, 1)-T*Y)-(UY(I, J, 1)-T*X)
-C BOTTOM.
- BUX(I, J, 1, 1) = 1
-C NORMAL IS (1,-1).
- BUY(I, J, 1, 1) = -1
- GOTO 3
- 2 B(I, J, 1) = (UY(I, J, 1)-T*X)-(UX(I, J, 1)-T*Y)
-C TOP.
- BUX(I, J, 1, 1) = -1
-C NORMAL IS (-1,1).
- BUY(I, J, 1, 1) = 1
- 3 CONTINUE
- 4 CONTINUE
- 5 CONTINUE
- 6 CONTINUE
-C MAP INTO (XI,ETA).
- CALL DTTGRB(NX, NY, D, NU, BUX, BUY, BUT)
- RETURN
- END
- SUBROUTINE HANDLE(T0, U0, T, U, NV, DT, TSTOP)
- INTEGER NV
- DOUBLE PRECISION T0, U0(NV), T, U(NV), DT, TSTOP
- COMMON /D7TGRP/ ERRPAR, NU, MXQ, MYQ
- INTEGER NU, MXQ, MYQ
- REAL ERRPAR(2)
- COMMON /D7TGRM/ KX, IX, NX, KY, IY, NY
- INTEGER KX, IX, NX, KY, IY, NY
- IF (T0 .NE. T) GOTO 2
- WRITE (6, 1) T
- 1 FORMAT (16H RESTART FOR T =, 1PE10.2)
- RETURN
- 2 CALL GERR(KX, IX, NX, KY, IY, NY, U, NU, T)
- RETURN
- END
- SUBROUTINE GERR(KX, IX, NX, KY, IY, NY, U, NU, T)
- INTEGER KX, IX, NX, KY, IY, NY
- INTEGER NU
- DOUBLE PRECISION U(1), T
- COMMON /CSTAK/ DS
- DOUBLE PRECISION DS(500)
- INTEGER IFA, ITA(2), IXA(2), NTA(2), NXA(2), IDLUMD
- INTEGER IXS, IYS, NXS, NYS, ISTKGT, I
- INTEGER IEWE, KA(2), MA(2), IS(1000), I1MACH
- REAL RS(1000)
- LOGICAL LS(1000)
- COMPLEX CS(500)
- DOUBLE PRECISION DABS, ERRU, DMAX1, WS(500)
- INTEGER TEMP, TEMP1, TEMP2
- EQUIVALENCE (DS(1), CS(1), WS(1), RS(1), IS(1), LS(1))
-C TO GET AND PRINT THE ERROR AT EACH TIME-STEP.
-C U(NX-KX,NY-KY,NU).
-C THE PORT LIBRARY STACK AND ITS ALIASES.
- CALL ENTER(1)
-C FIND THE ERROR IN THE SOLUTION AT 2*KX * 2*KY POINTS / MESH RECTANGLE.
-C X SEARCH GRID.
- IXS = IDLUMD(WS(IX), NX, 2*KX, NXS)
-C Y SEARCH GRID.
- IYS = IDLUMD(WS(IY), NY, 2*KY, NYS)
-C U SEARCH GRID VALUES.
- IEWE = ISTKGT(NXS*NYS, 4)
-C THE EXACT SOLUTION.
- CALL EWE(T, WS(IXS), NXS, WS(IYS), NYS, WS(IEWE), NU)
- KA(1) = KX
- KA(2) = KY
- ITA(1) = IX
- ITA(2) = IY
- NTA(1) = NX
- NTA(2) = NY
- IXA(1) = IXS
- IXA(2) = IYS
- NXA(1) = NXS
- NXA(2) = NYS
- MA(1) = 0
-C GET SOLUTION.
- MA(2) = 0
-C APPROXIMATE SOLUTION VALUES.
- IFA = ISTKGT(NXS*NYS, 4)
-C EVALUATE THEM.
- CALL DTSD1(2, KA, WS, ITA, NTA, U, WS, IXA, NXA, MA, WS(IFA))
-C ERROR IN SOLUTION VALUES.
- ERRU = 0
- TEMP = NXS*NYS
- DO 1 I = 1, TEMP
- TEMP2 = IEWE+I
- TEMP1 = IFA+I
- ERRU = DMAX1(ERRU, DABS(WS(TEMP2-1)-WS(TEMP1-1)))
- 1 CONTINUE
- TEMP = I1MACH(2)
- WRITE (TEMP, 2) T, ERRU
- 2 FORMAT (14H ERROR IN U(.,, 1PE10.2, 3H) =, 1PE10.2)
- CALL LEAVE
- RETURN
- END
- SUBROUTINE EWE(T, XI, NX, YI, NY, U, NU)
- INTEGER NU, NX, NY
- DOUBLE PRECISION T, XI(NX), YI(NY), U(NX, NY, NU)
- EXTERNAL BT, LR
- INTEGER I, J, P
- DOUBLE PRECISION D(6000), X, Y, XX(1000), YY(1000)
-C THE EXACT SOLUTION.
- IF (NY .GT. 1000) CALL SETERR(18HEWE - NY .GT. 1000, 18, 1, 2)
- DO 3 P = 1, NU
- DO 2 I = 1, NX
- CALL DBTMAP(T, XI(I), YI, 1, NY, LR, BT, XX, YY, D)
- DO 1 J = 1, NY
- X = XX(J)
- Y = YY(J)
- U(I, J, P) = T*X*Y
- 1 CONTINUE
- 2 CONTINUE
- 3 CONTINUE
- RETURN
- END
- SUBROUTINE LR(T, LX, RX, LXT, RXT)
- DOUBLE PRECISION T, LX, RX, LXT, RXT
-C TO GET THE L AND R END-POINTS OF THE MAPPING IN X.
- LX = 0
- RX = 1
- LXT = 0
- RXT = 0
- RETURN
- END
- SUBROUTINE BT(T, X, F, G, FX, GX, FT, GT)
- DOUBLE PRECISION T, X, F, G, FX, GX
- DOUBLE PRECISION FT, GT
-C TO GET THE BOTTOM AND TOP OF MAPPING IN Y.
- F = X-1D0
- G = X
- FT = 0
- GT = 0
- FX = 1
- GX = 1
- RETURN
- END
diff --git a/CEP/PyBDSM/src/port3/ex/dttgrx5.f b/CEP/PyBDSM/src/port3/ex/dttgrx5.f
deleted file mode 100644
index 107f9ab99daebb224cfbb660a15850b293cd8bd7..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ex/dttgrx5.f
+++ /dev/null
@@ -1,238 +0,0 @@
-C$TEST DTG5
-C TO RUN AS A MAIN PROGRAM REMOVE NEXT LINE
- SUBROUTINE DTG5
-C***********************************************************************
-C
-C EXAMPLE OF USE OF PORT PROGRAM DTTGR
-C
-C***********************************************************************
- COMMON /CSTAK/ DS
- DOUBLE PRECISION DS(350000)
- EXTERNAL HANDLE, BC, AF
- INTEGER NDX, NDY, ISTKGT, I, IS(1000), IU
- INTEGER IX, IY, NU, KX, NX, KY
- INTEGER NY
- REAL ERRPAR(2), RS(1000), FLOAT
- LOGICAL LS(1000)
- COMPLEX CS(500)
- DOUBLE PRECISION TSTART, DBLE, DT, LX, LY, RX
- DOUBLE PRECISION RY, WS(500), TSTOP
- INTEGER TEMP, TEMP1
- EQUIVALENCE (DS(1), CS(1), WS(1), RS(1), IS(1), LS(1))
-C TO SOLVE LAPLACES EQUATION WITH REAL ( Z*LOG(Z) ) AS SOLUTION.
-C THE PORT LIBRARY STACK AND ITS ALIASES.
-C INITIALIZE THE PORT LIBRARY STACK LENGTH.
- CALL ISTKIN(350000, 4)
- CALL ENTER(1)
- NU = 1
- LX = 0
- RX = 1
- LY = 0
- RY = 1
- KX = 4
- KY = 4
- NDX = 2
- NDY = 2
- TSTART = 0
- TSTOP = 1
- DT = 1
- ERRPAR(1) = 1E-2
- ERRPAR(2) = 1E-4
- NX = NDX+2*(KX-1)
-C SPACE FOR X MESH.
- IX = ISTKGT(NX, 4)
- DO 1 I = 1, KX
- TEMP = IX+I
- WS(TEMP-1) = 0
- TEMP = IX+NX-I
- WS(TEMP) = RX
- 1 CONTINUE
-C 0 AND RX MULT = KX.
- TEMP = NDX-1
- DO 2 I = 1, TEMP
- TEMP1 = IX+KX-2+I
- WS(TEMP1) = RX*(DBLE(FLOAT(I-1))/(DBLE(FLOAT(NDX))-1D0))**KX
- 2 CONTINUE
- NY = NDY+2*(KY-1)
-C SPACE FOR Y MESH.
- IY = ISTKGT(NY, 4)
- DO 3 I = 1, KY
- TEMP = IY+I
- WS(TEMP-1) = 0
- TEMP = IY+NY-I
- WS(TEMP) = RY
- 3 CONTINUE
-C 0 AND RY MULT = KY.
- TEMP = NDY-1
- DO 4 I = 1, TEMP
- TEMP1 = IY+KY-2+I
- WS(TEMP1) = RY*(DBLE(FLOAT(I-1))/(DBLE(FLOAT(NDY))-1D0))**KY
- 4 CONTINUE
-C SPACE FOR THE SOLUTION.
- IU = ISTKGT(NU*(NX-KX)*(NY-KY), 4)
- CALL SETD(NU*(NX-KX)*(NY-KY), 0D0, WS(IU))
- CALL DTTGR(WS(IU), NU, KX, WS(IX), NX, KY, WS(IY), NY, TSTART,
- 1 TSTOP, DT, AF, BC, ERRPAR, HANDLE)
- CALL LEAVE
- CALL WRAPUP
- STOP
- END
- SUBROUTINE AF(T, XI, NX, YI, NY, NU, U, UT, UX, UY, UXT,
- 1 UYT, A, AU, AUT, AUX, AUY, AUXT, AUYT, F, FU, FUT, FUX, FUY,
- 2 FUXT, FUYT)
- INTEGER NU, NX, NY
- DOUBLE PRECISION T, XI(NX), YI(NY), U(NX, NY, NU), UT(NX, NY, NU),
- 1 UX(NX, NY, NU)
- DOUBLE PRECISION UY(NX, NY, NU), UXT(NX, NY, NU), UYT(NX, NY, NU),
- 1 A(NX, NY, NU, 2), AU(NX, NY, NU, NU, 2), AUT(NX, NY, NU, NU, 2)
- DOUBLE PRECISION AUX(NX, NY, NU, NU, 2), AUY(NX, NY, NU, NU, 2),
- 1 AUXT(NX, NY, NU, NU, 2), AUYT(NX, NY, NU, NU, 2), F(NX, NY, NU)
- 2 , FU(NX, NY, NU, NU)
- DOUBLE PRECISION FUT(NX, NY, NU, NU), FUX(NX, NY, NU, NU), FUY(NX,
- 1 NY, NU, NU), FUXT(NX, NY, NU, NU), FUYT(NX, NY, NU, NU)
- INTEGER I, P, Q
- DO 3 I = 1, NU
- DO 2 Q = 1, NY
- DO 1 P = 1, NX
- A(P, Q, I, 1) = UX(P, Q, I)
- A(P, Q, I, 2) = UY(P, Q, I)
- AUX(P, Q, I, I, 1) = 1
- AUY(P, Q, I, I, 2) = 1
- 1 CONTINUE
- 2 CONTINUE
- 3 CONTINUE
- RETURN
- END
- SUBROUTINE BC(T, X, NX, Y, NY, LX, RX, LY, RY, U, UT, UX,
- 1 UY, UXT, UYT, NU, B, BU, BUT, BUX, BUY, BUXT, BUYT)
- INTEGER NU, NX, NY
- DOUBLE PRECISION T, X(NX), Y(NY), LX, RX, LY
- DOUBLE PRECISION RY, U(NX, NY, NU), UT(NX, NY, NU), UX(NX, NY, NU)
- 1 , UY(NX, NY, NU), UXT(NX, NY, NU)
- DOUBLE PRECISION UYT(NX, NY, NU), B(NX, NY, NU), BU(NX, NY, NU,
- 1 NU), BUT(NX, NY, NU, NU), BUX(NX, NY, NU, NU), BUY(NX, NY, NU
- 2 , NU)
- DOUBLE PRECISION BUXT(NX, NY, NU, NU), BUYT(NX, NY, NU, NU)
- INTEGER I, J
- DOUBLE PRECISION R, DCOS, DLOG, DSIN, DATAN, THETA
- DOUBLE PRECISION DSQRT
- DO 6 J = 1, NY
- DO 5 I = 1, NX
- IF (Y(J) .NE. LY) GOTO 1
- B(I, J, 1) = UY(I, J, 1)
-C NEUMANN DATA ON BOTTOM.
- BUY(I, J, 1, 1) = 1
- GOTO 4
- 1 R = DSQRT(X(I)**2+Y(J)**2)
-C DIRICHLET DATA.
- IF (X(I) .LE. 0D0) GOTO 2
- THETA = DATAN(Y(J)/X(I))
- GOTO 3
- 2 THETA = 2D0*DATAN(1D0)
- 3 B(I, J, 1) = U(I, J, 1)-R*(DCOS(THETA)*DLOG(R)-THETA*
- 1 DSIN(THETA))
- BU(I, J, 1, 1) = 1
- 4 CONTINUE
- 5 CONTINUE
- 6 CONTINUE
- RETURN
- END
- SUBROUTINE HANDLE(T0, U0, T, U, NV, DT, TSTOP)
- INTEGER NV
- DOUBLE PRECISION T0, U0(NV), T, U(NV), DT, TSTOP
- COMMON /D7TGRP/ ERRPAR, NU, MXQ, MYQ
- INTEGER NU, MXQ, MYQ
- REAL ERRPAR(2)
- COMMON /D7TGRM/ KX, IX, NX, KY, IY, NY
- INTEGER KX, IX, NX, KY, IY, NY
- IF (T0 .NE. T) GOTO 2
- WRITE (6, 1) T
- 1 FORMAT (16H RESTART FOR T =, 1PE10.2)
- RETURN
- 2 CALL GERR(KX, IX, NX, KY, IY, NY, U, NU, T)
- RETURN
- END
- SUBROUTINE GERR(KX, IX, NX, KY, IY, NY, U, NU, T)
- INTEGER KX, IX, NX, KY, IY, NY
- INTEGER NU
- DOUBLE PRECISION U(1), T
- COMMON /CSTAK/ DS
- DOUBLE PRECISION DS(500)
- INTEGER IFA, ITA(2), IXA(2), NTA(2), NXA(2), IDLUMD
- INTEGER IXS, IYS, NXS, NYS, ISTKGT, I
- INTEGER IEWE, KA(2), MA(2), IS(1000), I1MACH
- REAL RS(1000)
- LOGICAL LS(1000)
- COMPLEX CS(500)
- DOUBLE PRECISION DABS, ERRU, DMAX1, WS(500)
- INTEGER TEMP, TEMP1, TEMP2
- EQUIVALENCE (DS(1), CS(1), WS(1), RS(1), IS(1), LS(1))
-C TO GET AND PRINT THE ERROR AT EACH TIME-STEP.
-C U(NX-KX,NY-KY,NU).
-C THE PORT LIBRARY STACK AND ITS ALIASES.
- CALL ENTER(1)
-C FIND THE ERROR IN THE SOLUTION AT 2*KX * 2*KY POINTS / MESH RECTANGLE.
-C X SEARCH GRID.
- IXS = IDLUMD(WS(IX), NX, 2*KX, NXS)
-C Y SEARCH GRID.
- IYS = IDLUMD(WS(IY), NY, 2*KY, NYS)
-C U SEARCH GRID VALUES.
- IEWE = ISTKGT(NXS*NYS, 4)
-C THE EXACT SOLUTION.
- CALL EWE(T, WS(IXS), NXS, WS(IYS), NYS, WS(IEWE), NU)
- KA(1) = KX
- KA(2) = KY
- ITA(1) = IX
- ITA(2) = IY
- NTA(1) = NX
- NTA(2) = NY
- IXA(1) = IXS
- IXA(2) = IYS
- NXA(1) = NXS
- NXA(2) = NYS
- MA(1) = 0
-C GET SOLUTION.
- MA(2) = 0
-C APPROXIMATE SOLUTION VALUES.
- IFA = ISTKGT(NXS*NYS, 4)
-C EVALUATE THEM.
- CALL DTSD1(2, KA, WS, ITA, NTA, U, WS, IXA, NXA, MA, WS(IFA))
-C ERROR IN SOLUTION VALUES.
- ERRU = 0
- TEMP = NXS*NYS
- DO 1 I = 1, TEMP
- TEMP2 = IEWE+I
- TEMP1 = IFA+I
- ERRU = DMAX1(ERRU, DABS(WS(TEMP2-1)-WS(TEMP1-1)))
- 1 CONTINUE
- TEMP = I1MACH(2)
- WRITE (TEMP, 2) T, ERRU
- 2 FORMAT (14H ERROR IN U(.,, 1PE10.2, 3H) =, 1PE10.2)
- CALL LEAVE
- RETURN
- END
- SUBROUTINE EWE(T, X, NX, Y, NY, U, NU)
- INTEGER NU, NX, NY
- DOUBLE PRECISION T, X(NX), Y(NY), U(NX, NY, NU)
- INTEGER I, J, P
- DOUBLE PRECISION R, DCOS, DLOG, DSIN, DATAN, THETA
- DOUBLE PRECISION DSQRT
-C THE EXACT SOLUTION.
- DO 7 P = 1, NU
- DO 6 I = 1, NX
- DO 5 J = 1, NY
- R = DSQRT(X(I)**2+Y(J)**2)
- IF (X(I) .LE. 0D0) GOTO 1
- THETA = DATAN(Y(J)/X(I))
- GOTO 2
- 1 THETA = 2D0*DATAN(1D0)
- 2 IF (R .LE. 0D0) GOTO 3
- U(I, J, P) = R*(DCOS(THETA)*DLOG(R)-THETA*DSIN(THETA))
- GOTO 4
- 3 U(I, J, P) = 0
- 4 CONTINUE
- 5 CONTINUE
- 6 CONTINUE
- 7 CONTINUE
- RETURN
- END
diff --git a/CEP/PyBDSM/src/port3/ex/dttgrx6.f b/CEP/PyBDSM/src/port3/ex/dttgrx6.f
deleted file mode 100644
index 8ebdb1abf73e8baebed6e25570e8de5ba5b2588f..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ex/dttgrx6.f
+++ /dev/null
@@ -1,384 +0,0 @@
-C$TEST DTG6
-C TO RUN AS A MAIN PROGRAM REMOVE NEXT LINE
- SUBROUTINE DTG6
-C***********************************************************************
-C
-C EXAMPLE OF USE OF PORT PROGRAM DTTGR
-C
-C***********************************************************************
- COMMON /CSTAK/ DS
- DOUBLE PRECISION DS(350000)
- EXTERNAL HANDLE, BC, AF
- INTEGER IUE, NDX, NDY, IUR, IXR, IYR
- INTEGER NXR, NYR, ISTKGT, I, IS(1000), IU
- INTEGER IX, IY, NU, KX, NX, KY
- INTEGER NY, I1MACH
- REAL ERRPAR(2), RS(1000), FLOAT
- LOGICAL LS(1000)
- COMPLEX CS(500)
- DOUBLE PRECISION TSTART, DBLE, DABS, EERR, ERRE, ERRR
- DOUBLE PRECISION DMAX1, DT, LX, LY, RX, RY
- DOUBLE PRECISION WS(500), TSTOP
- INTEGER TEMP, TEMP1, TEMP2
- EQUIVALENCE (DS(1), CS(1), WS(1), RS(1), IS(1), LS(1))
-C TO GET ERROR ESTIMATES FOR LAPLACES EQUATION WITH REAL ( Z*LOG(Z) ) AS
-C SOLUTION.
-C THE PORT LIBRARY STACK AND ITS ALIASES.
-C INITIALIZE THE PORT LIBRARY STACK LENGTH.
- CALL ISTKIN(350000, 4)
- CALL ENTER(1)
- NU = 1
- LX = 0
- RX = 1
- LY = 0
- RY = 1
- KX = 4
- KY = 4
- NDX = 2
- NDY = 2
- TSTART = 0
- TSTOP = 1
- DT = 1
- ERRPAR(1) = 1E-2
- ERRPAR(2) = 1E-4
- NX = NDX+2*(KX-1)
-C SPACE FOR X MESH.
- IX = ISTKGT(NX, 4)
- DO 1 I = 1, KX
- TEMP = IX+I
- WS(TEMP-1) = 0
- TEMP = IX+NX-I
- WS(TEMP) = RX
- 1 CONTINUE
-C 0 AND RX MULT = KX.
- TEMP = NDX-1
- DO 2 I = 1, TEMP
- TEMP2 = IX+KX-2+I
- WS(TEMP2) = RX*(DBLE(FLOAT(I-1))/(DBLE(FLOAT(NDX))-1D0))**KX
- 2 CONTINUE
- NY = NDY+2*(KY-1)
-C SPACE FOR Y MESH.
- IY = ISTKGT(NY, 4)
- DO 3 I = 1, KY
- TEMP = IY+I
- WS(TEMP-1) = 0
- TEMP = IY+NY-I
- WS(TEMP) = RY
- 3 CONTINUE
-C 0 AND RY MULT = KY.
- TEMP = NDY-1
- DO 4 I = 1, TEMP
- TEMP2 = IY+KY-2+I
- WS(TEMP2) = RY*(DBLE(FLOAT(I-1))/(DBLE(FLOAT(NDY))-1D0))**KY
- 4 CONTINUE
-C SPACE FOR THE SOLUTION.
- IU = ISTKGT(NU*(NX-KX)*(NY-KY), 4)
- CALL SETD(NU*(NX-KX)*(NY-KY), 0D0, WS(IU))
- TEMP = I1MACH(2)
- WRITE (TEMP, 5)
- 5 FORMAT (23H SOLVING ON CRUDE MESH.)
- CALL DTTGR(WS(IU), NU, KX, WS(IX), NX, KY, WS(IY), NY, TSTART,
- 1 TSTOP, DT, AF, BC, ERRPAR, HANDLE)
- DT = 1
- NDX = 2*NDX-1
-C REFINE MESH.
- NDY = 2*NDY-1
- NXR = NDX+2*(KX-1)
-C SPACE FOR X MESH.
- IXR = ISTKGT(NXR, 4)
- DO 6 I = 1, KX
- TEMP = IXR+I
- WS(TEMP-1) = 0
- TEMP = IXR+NXR-I
- WS(TEMP) = RX
- 6 CONTINUE
-C 0 AND RX MULT = KX.
- TEMP = NDX-1
- DO 7 I = 1, TEMP
- TEMP2 = IXR+KX-2+I
- WS(TEMP2) = RX*(DBLE(FLOAT(I-1))/(DBLE(FLOAT(NDX))-1D0))**KX
- 7 CONTINUE
- NYR = NDY+2*(KY-1)
-C SPACE FOR Y MESH.
- IYR = ISTKGT(NYR, 4)
- DO 8 I = 1, KY
- TEMP = IYR+I
- WS(TEMP-1) = 0
- TEMP = IYR+NYR-I
- WS(TEMP) = RY
- 8 CONTINUE
-C 0 AND RY MULT = KY.
- TEMP = NDY-1
- DO 9 I = 1, TEMP
- TEMP2 = IYR+KY-2+I
- WS(TEMP2) = RY*(DBLE(FLOAT(I-1))/(DBLE(FLOAT(NDY))-1D0))**KY
- 9 CONTINUE
-C SPACE FOR THE SOLUTION.
- IUR = ISTKGT(NU*(NXR-KX)*(NYR-KY), 4)
- CALL SETD(NU*(NXR-KX)*(NYR-KY), 0D0, WS(IUR))
- TEMP = I1MACH(2)
- WRITE (TEMP, 10)
- 10 FORMAT (25H SOLVING ON REFINED MESH.)
- CALL DTTGR(WS(IUR), NU, KX, WS(IXR), NXR, KY, WS(IYR), NYR,
- 1 TSTART, TSTOP, DT, AF, BC, ERRPAR, HANDLE)
- DT = 1
- ERRPAR(1) = ERRPAR(1)/10.
- ERRPAR(2) = ERRPAR(2)/10.
-C SPACE FOR THE SOLUTION.
- IUE = ISTKGT(NU*(NX-KX)*(NY-KY), 4)
- CALL SETD(NU*(NX-KX)*(NY-KY), 0D0, WS(IUE))
- TEMP = I1MACH(2)
- WRITE (TEMP, 11)
- 11 FORMAT (24H SOLVING WITH ERRPAR/10.)
- CALL DTTGR(WS(IUE), NU, KX, WS(IX), NX, KY, WS(IY), NY, TSTART,
- 1 TSTOP, DT, AF, BC, ERRPAR, HANDLE)
- ERRR = EERR(KX, IX, NX, KY, IY, NY, WS(IU), NU, IXR, NXR, IYR,
- 1 NYR, WS(IUR), TSTOP)
- ERRE = 0
- TEMP = NU*(NX-KX)*(NY-KY)
- DO 12 I = 1, TEMP
- TEMP2 = IU+I
- TEMP1 = IUE+I
- ERRE = DMAX1(ERRE, DABS(WS(TEMP2-1)-WS(TEMP1-1)))
- 12 CONTINUE
- TEMP = I1MACH(2)
- WRITE (TEMP, 13) ERRE
- 13 FORMAT (24H U ERROR FROM U AND UE =, 1PE10.2)
- TEMP = I1MACH(2)
- WRITE (TEMP, 14) ERRR
- 14 FORMAT (24H U ERROR FROM U AND UR =, 1PE10.2)
- CALL LEAVE
- CALL WRAPUP
- STOP
- END
- SUBROUTINE AF(T, XI, NX, YI, NY, NU, U, UT, UX, UY, UXT,
- 1 UYT, A, AU, AUT, AUX, AUY, AUXT, AUYT, F, FU, FUT, FUX, FUY,
- 2 FUXT, FUYT)
- INTEGER NU, NX, NY
- DOUBLE PRECISION T, XI(NX), YI(NY), U(NX, NY, NU), UT(NX, NY, NU),
- 1 UX(NX, NY, NU)
- DOUBLE PRECISION UY(NX, NY, NU), UXT(NX, NY, NU), UYT(NX, NY, NU),
- 1 A(NX, NY, NU, 2), AU(NX, NY, NU, NU, 2), AUT(NX, NY, NU, NU, 2)
- DOUBLE PRECISION AUX(NX, NY, NU, NU, 2), AUY(NX, NY, NU, NU, 2),
- 1 AUXT(NX, NY, NU, NU, 2), AUYT(NX, NY, NU, NU, 2), F(NX, NY, NU)
- 2 , FU(NX, NY, NU, NU)
- DOUBLE PRECISION FUT(NX, NY, NU, NU), FUX(NX, NY, NU, NU), FUY(NX,
- 1 NY, NU, NU), FUXT(NX, NY, NU, NU), FUYT(NX, NY, NU, NU)
- INTEGER I, P, Q
- DO 3 I = 1, NU
- DO 2 Q = 1, NY
- DO 1 P = 1, NX
- A(P, Q, I, 1) = UX(P, Q, I)
- A(P, Q, I, 2) = UY(P, Q, I)
- AUX(P, Q, I, I, 1) = 1
- AUY(P, Q, I, I, 2) = 1
- 1 CONTINUE
- 2 CONTINUE
- 3 CONTINUE
- RETURN
- END
- SUBROUTINE BC(T, X, NX, Y, NY, LX, RX, LY, RY, U, UT, UX,
- 1 UY, UXT, UYT, NU, B, BU, BUT, BUX, BUY, BUXT, BUYT)
- INTEGER NU, NX, NY
- DOUBLE PRECISION T, X(NX), Y(NY), LX, RX, LY
- DOUBLE PRECISION RY, U(NX, NY, NU), UT(NX, NY, NU), UX(NX, NY, NU)
- 1 , UY(NX, NY, NU), UXT(NX, NY, NU)
- DOUBLE PRECISION UYT(NX, NY, NU), B(NX, NY, NU), BU(NX, NY, NU,
- 1 NU), BUT(NX, NY, NU, NU), BUX(NX, NY, NU, NU), BUY(NX, NY, NU
- 2 , NU)
- DOUBLE PRECISION BUXT(NX, NY, NU, NU), BUYT(NX, NY, NU, NU)
- INTEGER I, J
- DOUBLE PRECISION R, DCOS, DLOG, DSIN, DATAN, THETA
- DOUBLE PRECISION DSQRT
- DO 6 J = 1, NY
- DO 5 I = 1, NX
- IF (Y(J) .NE. LY) GOTO 1
- B(I, J, 1) = UY(I, J, 1)
-C NEUMANN DATA ON BOTTOM.
- BUY(I, J, 1, 1) = 1
- GOTO 4
- 1 R = DSQRT(X(I)**2+Y(J)**2)
-C DIRICHLET DATA.
- IF (X(I) .LE. 0D0) GOTO 2
- THETA = DATAN(Y(J)/X(I))
- GOTO 3
- 2 THETA = 2D0*DATAN(1D0)
- 3 B(I, J, 1) = U(I, J, 1)-R*(DCOS(THETA)*DLOG(R)-THETA*
- 1 DSIN(THETA))
- BU(I, J, 1, 1) = 1
- 4 CONTINUE
- 5 CONTINUE
- 6 CONTINUE
- RETURN
- END
- SUBROUTINE HANDLE(T0, U0, T, U, NV, DT, TSTOP)
- INTEGER NV
- DOUBLE PRECISION T0, U0(NV), T, U(NV), DT, TSTOP
- COMMON /D7TGRP/ ERRPAR, NU, MXQ, MYQ
- INTEGER NU, MXQ, MYQ
- REAL ERRPAR(2)
- COMMON /D7TGRM/ KX, IX, NX, KY, IY, NY
- INTEGER KX, IX, NX, KY, IY, NY
- IF (T0 .NE. T) GOTO 2
- WRITE (6, 1) T
- 1 FORMAT (16H RESTART FOR T =, 1PE10.2)
- RETURN
- 2 CALL GERR(KX, IX, NX, KY, IY, NY, U, NU, T)
- RETURN
- END
- SUBROUTINE GERR(KX, IX, NX, KY, IY, NY, U, NU, T)
- INTEGER KX, IX, NX, KY, IY, NY
- INTEGER NU
- DOUBLE PRECISION U(1), T
- COMMON /CSTAK/ DS
- DOUBLE PRECISION DS(500)
- INTEGER IFA, ITA(2), IXA(2), NTA(2), NXA(2), IDLUMD
- INTEGER IXS, IYS, NXS, NYS, ISTKGT, I
- INTEGER IEWE, KA(2), MA(2), IS(1000), I1MACH
- REAL RS(1000)
- LOGICAL LS(1000)
- COMPLEX CS(500)
- DOUBLE PRECISION DABS, ERRU, DMAX1, WS(500)
- INTEGER TEMP, TEMP1, TEMP2
- EQUIVALENCE (DS(1), CS(1), WS(1), RS(1), IS(1), LS(1))
-C TO GET AND PRINT THE ERROR AT EACH TIME-STEP.
-C U(NX-KX,NY-KY,NU).
-C THE PORT LIBRARY STACK AND ITS ALIASES.
- CALL ENTER(1)
-C FIND THE ERROR IN THE SOLUTION AT 2*KX * 2*KY POINTS / MESH RECTANGLE.
-C X SEARCH GRID.
- IXS = IDLUMD(WS(IX), NX, 2*KX, NXS)
-C Y SEARCH GRID.
- IYS = IDLUMD(WS(IY), NY, 2*KY, NYS)
-C U SEARCH GRID VALUES.
- IEWE = ISTKGT(NXS*NYS, 4)
-C THE EXACT SOLUTION.
- CALL EWE(T, WS(IXS), NXS, WS(IYS), NYS, WS(IEWE), NU)
- KA(1) = KX
- KA(2) = KY
- ITA(1) = IX
- ITA(2) = IY
- NTA(1) = NX
- NTA(2) = NY
- IXA(1) = IXS
- IXA(2) = IYS
- NXA(1) = NXS
- NXA(2) = NYS
- MA(1) = 0
-C GET SOLUTION.
- MA(2) = 0
-C APPROXIMATE SOLUTION VALUES.
- IFA = ISTKGT(NXS*NYS, 4)
-C EVALUATE THEM.
- CALL DTSD1(2, KA, WS, ITA, NTA, U, WS, IXA, NXA, MA, WS(IFA))
-C ERROR IN SOLUTION VALUES.
- ERRU = 0
- TEMP = NXS*NYS
- DO 1 I = 1, TEMP
- TEMP2 = IEWE+I
- TEMP1 = IFA+I
- ERRU = DMAX1(ERRU, DABS(WS(TEMP2-1)-WS(TEMP1-1)))
- 1 CONTINUE
- TEMP = I1MACH(2)
- WRITE (TEMP, 2) T, ERRU
- 2 FORMAT (14H ERROR IN U(.,, 1PE10.2, 3H) =, 1PE10.2)
- CALL LEAVE
- RETURN
- END
- DOUBLE PRECISION FUNCTION EERR(KX, IX, NX, KY, IY, NY, U,
- 1 NU, IXR, NXR, IYR, NYR, UR, T)
- INTEGER KX, IX, NX, KY, IY, NY
- INTEGER NU, IXR, NXR, IYR, NYR
- DOUBLE PRECISION U(1), UR(1), T
- COMMON /CSTAK/ DS
- DOUBLE PRECISION DS(500)
- INTEGER IFA, ITA(2), IXA(2), NTA(2), NXA(2), IDLUMD
- INTEGER IXS, IYS, NXS, NYS, ISTKGT, I
- INTEGER IFAR, KA(2), MA(2), IS(1000), I1MACH
- REAL RS(1000)
- LOGICAL LS(1000)
- COMPLEX CS(500)
- DOUBLE PRECISION DABS, ERRU, DMAX1, WS(500)
- INTEGER TEMP, TEMP1, TEMP2
- EQUIVALENCE (DS(1), CS(1), WS(1), RS(1), IS(1), LS(1))
-C TO GET AND PRINT THE ERROR ESTIMATE AT EACH TIME-STEP.
-C U(NX-KX,NY-KY,NU), UR(NXR-KX,NYR-KY,NU).
-C THE PORT LIBRARY STACK AND ITS ALIASES.
- CALL ENTER(1)
-C FIND THE ERROR IN THE SOLUTION AT 2*KX * 2*KY POINTS / FINE MESH RECTA
-CNGLE.
-C X SEARCH GRID.
- IXS = IDLUMD(WS(IXR), NXR, 2*KX, NXS)
-C Y SEARCH GRID.
- IYS = IDLUMD(WS(IYR), NYR, 2*KY, NYS)
- KA(1) = KX
- KA(2) = KY
- ITA(1) = IX
- ITA(2) = IY
- NTA(1) = NX
- NTA(2) = NY
- IXA(1) = IXS
- IXA(2) = IYS
- NXA(1) = NXS
- NXA(2) = NYS
- MA(1) = 0
-C GET SOLUTION.
- MA(2) = 0
-C APPROXIMATE SOLUTION VALUES.
- IFA = ISTKGT(NXS*NYS, 4)
-C EVALUATE THEM.
- CALL DTSD1(2, KA, WS, ITA, NTA, U, WS, IXA, NXA, MA, WS(IFA))
- KA(1) = KX
- KA(2) = KY
- ITA(1) = IXR
- ITA(2) = IYR
- NTA(1) = NXR
- NTA(2) = NYR
- IXA(1) = IXS
- IXA(2) = IYS
- NXA(1) = NXS
- NXA(2) = NYS
- MA(1) = 0
-C GET SOLUTION.
- MA(2) = 0
-C APPROXIMATE SOLUTION VALUES.
- IFAR = ISTKGT(NXS*NYS, 4)
-C EVALUATE THEM.
- CALL DTSD1(2, KA, WS, ITA, NTA, UR, WS, IXA, NXA, MA, WS(IFAR))
-C ERROR IN SOLUTION VALUES.
- ERRU = 0
- TEMP = NXS*NYS
- DO 1 I = 1, TEMP
- TEMP2 = IFAR+I
- TEMP1 = IFA+I
- ERRU = DMAX1(ERRU, DABS(WS(TEMP2-1)-WS(TEMP1-1)))
- 1 CONTINUE
- CALL LEAVE
- EERR = ERRU
- RETURN
- END
- SUBROUTINE EWE(T, X, NX, Y, NY, U, NU)
- INTEGER NU, NX, NY
- DOUBLE PRECISION T, X(NX), Y(NY), U(NX, NY, NU)
- INTEGER I, J, P
- DOUBLE PRECISION R, DCOS, DLOG, DSIN, DATAN, THETA
- DOUBLE PRECISION DSQRT
-C THE EXACT SOLUTION.
- DO 7 P = 1, NU
- DO 6 I = 1, NX
- DO 5 J = 1, NY
- R = DSQRT(X(I)**2+Y(J)**2)
- IF (X(I) .LE. 0D0) GOTO 1
- THETA = DATAN(Y(J)/X(I))
- GOTO 2
- 1 THETA = 2D0*DATAN(1D0)
- 2 IF (R .LE. 0D0) GOTO 3
- U(I, J, P) = R*(DCOS(THETA)*DLOG(R)-THETA*DSIN(THETA))
- GOTO 4
- 3 U(I, J, P) = 0
- 4 CONTINUE
- 5 CONTINUE
- 6 CONTINUE
- 7 CONTINUE
- RETURN
- END
diff --git a/CEP/PyBDSM/src/port3/ex/ebea.f b/CEP/PyBDSM/src/port3/ex/ebea.f
deleted file mode 100644
index 82d4f45bf64650e4b30dfadd4446abb851a3bd1c..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ex/ebea.f
+++ /dev/null
@@ -1,50 +0,0 @@
-C$TEST EBEA
-C TO RUN AS A MAIN PROGRAM REMOVE NEXT LINE
- SUBROUTINE EBEA
-C***********************************************************************
-C
-C EXAMPLE OF USE OF THE PORT PROGRAM EEBSF
-C
-C***********************************************************************
- INTEGER I1MACH,IWRITE,K,NT1,NT2
- EXTERNAL F
- REAL EESFF,EEBSF,T1(100),A1(100),T2(100),A2(100),
- 1 ERROR(2),ERREST(2)
-C
-C MAKE THE MESH
-C
- K = 4
- CALL UMB(0.0E0,3.14E0,16,K,T1,NT1)
- CALL UMB(0.0E0,3.14E0,21,K,T2,NT2)
-C
-C DO THE FITTING
-C
- CALL L2SFF(F,K,T1,NT1,A1)
- CALL L2SFF(F,K,T2,NT2,A2)
-C
-C GET THE ERROR
-C
- ERROR(1) = EESFF(K,T1,NT1,A1,F)
- ERROR(2) = EESFF(K,T2,NT2,A2,F)
-C
- ERREST(1) = EEBSF(K,T1,NT1,A1,T2,NT2,A2)
- ERREST(2) = ERREST(1)*(FLOAT(NT1-2*K+1)/FLOAT(
- 1 NT2-2*K-1))**K
- IWRITE = I1MACH(2)
- WRITE(IWRITE,99)ERROR(1),ERROR(2),ERREST(1),ERREST(2)
- 99 FORMAT(8H ERROR = ,2E10.2,8H ESTER = ,2E10.2)
-C
- STOP
-C
- END
- SUBROUTINE F(X,NX,FX,WX)
-C
- REAL X(NX),FX(NX),WX(NX)
-C
- DO 10 I = 1,NX
- FX(I) = SIN(X(I))
- 10 CONTINUE
-C
- RETURN
-C
- END
diff --git a/CEP/PyBDSM/src/port3/ex/errk.f b/CEP/PyBDSM/src/port3/ex/errk.f
deleted file mode 100644
index a0d8b17ab53dee5f196a2242344be5baa1251c38..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ex/errk.f
+++ /dev/null
@@ -1,39 +0,0 @@
-C$TEST ERRK
-C TO RUN AS A MAIN PROGRAM REMOVE NEXT LINE
- SUBROUTINE ERRK
-C***********************************************************************
-C
-C EXAMPLE OF USE OF THE PORT PROGRAM STKDMP
-C
-C***********************************************************************
-C SAMPLE USE OF THE STACK DUMP
- INTEGER IPTR, ISTKGT
-C
- COMMON /CSTAK/ DSTAK
- DOUBLE PRECISION DSTAK(500)
- INTEGER ISTAK(1000)
- LOGICAL LSTAK(1000)
- REAL RSTAK(1000)
- COMPLEX CMSTAK(500)
- EQUIVALENCE (DSTAK(1), ISTAK(1))
- EQUIVALENCE (DSTAK(1), LSTAK(1))
- EQUIVALENCE (DSTAK(1), RSTAK(1))
- EQUIVALENCE (DSTAK(1), CMSTAK(1))
-C
- IPTR = ISTKGT(25, 1)
- CALL SETL(25, .FALSE., LSTAK(IPTR))
- IPTR = ISTKGT(25, 2)
- CALL SETI(25, -1, ISTAK(IPTR))
- IPTR = ISTKGT(25, 3)
- CALL SETR(25, 1.0, RSTAK(IPTR))
- IPTR = ISTKGT(25, 4)
- CALL SETD(25, 1.0D0, DSTAK(IPTR))
- IPTR = ISTKGT(25, 5)
- CALL SETC(25, CMPLX(1.0, -1.0), CMSTAK(IPTR))
- IPTR = ISTKGT(25, 5)
- CALL SETC(25, CMPLX(1.0, -1.0), CMSTAK(IPTR))
- CALL ISTKRL(1)
-C
- CALL STKDMP
- STOP
- END
diff --git a/CEP/PyBDSM/src/port3/ex/evaa.f b/CEP/PyBDSM/src/port3/ex/evaa.f
deleted file mode 100644
index 056a36a13e3d524421e21b5afda86a87256b58bf..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ex/evaa.f
+++ /dev/null
@@ -1,44 +0,0 @@
-C$TEST EVAA
-C TO RUN AS A MAIN PROGRAM REMOVE NEXT LINE
- SUBROUTINE EVAA
-C***********************************************************************
-C
-C EXAMPLE OF USE OF THE PORT PROGRAM EIGEN
-C
-C***********************************************************************
- REAL A(4,4),ORT(4),Z(4,4)
- REAL H(4,4),WR(4),WI(4)
-C
- DATA A(1,1),A(1,2),A(1,3),A(1,4) / 3., 1., 2., 5. /
- DATA A(2,1),A(2,2),A(2,3),A(2,4) / 2., 1., 3., 7. /
- DATA A(3,1),A(3,2),A(3,3),A(3,4) / 3., 1., 2., 4. /
- DATA A(4,1),A(4,2),A(4,3),A(4,4) / 4., 1., 3., 2. /
-C
- NM=4
- N=4
-C
-C SET OUTPUT WRITE UNIT
-C
- IWUNIT=I1MACH(2)
-C
- CALL EIGEN(NM,N,A,WR,WI,Z)
-C
- WRITE (IWUNIT,96)
- 96 FORMAT (22H0THE EIGENVALUES ARE -/)
-C
- WRITE (IWUNIT,97) (WR(J),WI(J),J=1,N)
- 97 FORMAT (/1X,2E20.8)
-C
- DO 20 K=1,N
- SCALE=AMAX1(ABS(Z(1,K)),ABS(Z(2,K)),ABS(Z(3,K)),ABS(Z(4,K)))
- DO 20 J=1,N
- 20 Z(J,K)=Z(J,K)/SCALE
-C
- WRITE (IWUNIT,98)
- 98 FORMAT (30H0THE SCALED EIGENVECTORS ARE -//)
-C
- WRITE (IWUNIT,99) ((Z(J,K),K=1,N),J=1,N)
- 99 FORMAT (1X,1P4E18.8/)
-C
- STOP
- END
diff --git a/CEP/PyBDSM/src/port3/ex/extr.f b/CEP/PyBDSM/src/port3/ex/extr.f
deleted file mode 100644
index 094058ae511a65c3efaaba57fa974bfa90ba719d..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ex/extr.f
+++ /dev/null
@@ -1,30 +0,0 @@
-C$TEST EXTR
-C TO RUN AS A MAIN PROGRAM REMOVE NEXT LINE
- SUBROUTINE EXTR
-C***********************************************************************
-C
-C EXAMPLE OF USE OF THE PORT PROGRAM EXTRMX
-C
-C***********************************************************************
- INTEGER IWRITE,IEXT(100),NEX,IMAX,IMIN,IMAG
- INTEGER I1MACH,I,J
- REAL PI,STEP,X,F(100)
-C
- IWRITE = I1MACH(2)
- PI = 3.1415926532
- STEP = 2.0*PI/99.0
- DO 10 I=1,100
- X = STEP*FLOAT(I-1)
- 10 F(I) = EXP(-X)*COS(X)
-C
- CALL EXTRMR(100,F,NEX,IEXT,IMAX,IMIN,IMAG)
-C
- WRITE(IWRITE,20)
- 20 FORMAT(6X,9HEXTREMALS/5X,1HX,10X,4HF(X))
- DO 30 J=1,NEX
- I =IEXT(J)
- X = STEP*FLOAT(I-1)
- 30 WRITE(IWRITE,40) X,F(I)
- 40 FORMAT(2F10.5)
- STOP
- END
diff --git a/CEP/PyBDSM/src/port3/ex/ffta b/CEP/PyBDSM/src/port3/ex/ffta
deleted file mode 100644
index 22efaa2495b63aa4687999249ac7ba16a241a472..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ex/ffta
+++ /dev/null
@@ -1,55 +0,0 @@
-C$TEST FFTA
-C TO RUN AS A MAIN PROGRAM REMOVE NEXT LINE
- SUBROUTINE FTRA
-C***********************************************************************
-C
-C EXAMPLE OF USE OF THE PORT PROGRAM FFTR
-C
-C***********************************************************************
- REAL A(34),B(17),C(32)
-C
-C SET UP THE INPUT DATA FOR E**(-T)
-C AND SAVE IT IN THE VECTOR C FOR LATER COMPARISON.
-C
- A(1) = .5
- C(1) = A(1)
- DO 10 K=2,32
- A(K) = EXP(-.25*FLOAT(K-1))
- 10 C(K) = A(K)
-C
-C CALL FOR THE TRANSFORM AND PRINT THE FOURIER COEFFICIENTS
-C
- CALL FFTR(34,A,B)
-C
- IWRITE = I1MACH(2)
- WRITE (IWRITE, 997)
- 997 FORMAT (1X,9HFREQUENCY,5X,20HFOURIER COEFFICIENTS//)
- WRITE (IWRITE, 998)
- 998 FORMAT (1X,7H(=N/NT),5X,9HREAL PART,6X,9HIMAGINARY///)
-C
- ENT = 1.0/(32. * 0.25)
- DO 20 K=1,17
- FREQ = FLOAT(K-1) * ENT
- 20 WRITE (IWRITE,98) FREQ, A(K), B(K)
- 98 FORMAT (2X,F6.3,2F15.8)
-C
-C DO THE INVERSE TRANSFORM
-C
- CALL FFTRI(32,A,B)
-C
-C SCALE THE RESULTS, FIND THE ERROR, AND PRINT
-C
- WRITE (IWRITE, 999)
- 999 FORMAT (///4X,1HT,9X,5HINPUT,10X,5HERROR//)
-C
- EN = 4*16
- ENI = 1./EN
- DO 30 K=1,32
- A(K) = ENI*A(K)
- ERR = A(K) - C(K)
- T = .25*FLOAT(K-1)
- 30 WRITE (IWRITE,99) T,C(K),ERR
- 99 FORMAT (2X,F4.2,1X,F15.8,4X,1PE10.2)
-C
- STOP
- END
diff --git a/CEP/PyBDSM/src/port3/ex/fftc b/CEP/PyBDSM/src/port3/ex/fftc
deleted file mode 100644
index c0cab1ce0a66378ab982bc322e58aefcaf53fc65..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ex/fftc
+++ /dev/null
@@ -1,63 +0,0 @@
-C$TEST FFTC
-C TO RUN AS A MAIN PROGRAM REMOVE NEXT LINE
- SUBROUTINE FTRC
-C***********************************************************************
-C
-C EXAMPLE OF USE OF THE PORT PROGRAM FFTC
-C
-C***********************************************************************
- REAL A(32),B(32),C(32),D(32)
-C
-C THE REAL DATA IS ALL ZERO AND THE
-C IMAGINARY PART IS E**(-T).
-C
-C SAVE THE IMAGINARY DATA IN THE VECTOR C FOR LATER COMPARISON
-C
- DO 5 K=1,32
- 5 A(K) = 0.
-C
- B(1) = .5
- C(1) = B(1)
- DO 10 K=2,32
- B(K) = EXP(-.25*FLOAT(K-1))
- 10 C(K) = B(K)
-C
-C CALL FOR THE TRANSFORM AND PRINT THE FOURIER COEFFICIENTS
-C
- CALL FFTC(32,A,B)
-C
- IWRITE = I1MACH(2)
- WRITE (IWRITE, 997)
- 997 FORMAT (1X,9HFREQUENCY,5X,20HFOURIER COEFFICIENTS//)
- WRITE (IWRITE, 998)
- 998 FORMAT (1X,7H(=N/NT),5X,9HREAL PART,6X,9HIMAGINARY///)
-C
- ENT = 1.0/(32. * 0.25)
- DO 20 K=1,32
- FREQ = FLOAT(K-1) * ENT
- IF (FREQ .GT. 2.) FREQ = -4.0 + FREQ
- 20 WRITE (IWRITE,98) FREQ, A(K), B(K)
- 98 FORMAT (2X,F6.3,2F15.8)
-C
-C DO THE INVERSE TRANSFORM
-C
- CALL FFTCI(32,A,B)
-C
-C SCALE THE RESULTS, FIND THE ERROR, AND PRINT
-C
- WRITE (IWRITE, 999)
- 999 FORMAT (///4X,1HT,7X,18HERROR IN REAL PART,
- 1 4X,23HERROR IN IMAGINARY PART//)
-C
- ENI = 1./FLOAT(32)
- DO 30 K=1,32
- A(K) = ENI*A(K)
- B(K) = ENI*B(K)
- ERR1 = A(K) - 0.0
- ERR2 = B(K) - C(K)
- T = .25*FLOAT(K-1)
- 30 WRITE (IWRITE,99) T,ERR1,ERR2
- 99 FORMAT (2X,F4.2,8X,1PE10.2,14X,1PE10.2)
-C
- STOP
- END
diff --git a/CEP/PyBDSM/src/port3/ex/fmtr.f b/CEP/PyBDSM/src/port3/ex/fmtr.f
deleted file mode 100644
index 8b1bd448a8f229658ea26ad214e2f5c7b7f474b2..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ex/fmtr.f
+++ /dev/null
@@ -1,39 +0,0 @@
-C$TEST FMTR
-C TO RUN AS A MAIN PROGRAM REMOVE NEXT LINE
- SUBROUTINE FMTR
-C***********************************************************************
-C
-C EXAMPLE OF USE OF THE PORT PROGRAM FRMATT
-C
-C***********************************************************************
-C EXAMPLE PROGRAM TO FIND THE CORRECT FORMAT SPECIFICATIONS
-C AND THEN PRINT OUT AN INTEGER, REAL AND DOUBLE-PRECISION ARRAY.
-C
- INTEGER K, XINT(9), IWIDTH, IWRITE
- INTEGER WSP, MANTSP, WDP, MANTDP
- REAL XREAL(9)
- DOUBLE PRECISION DFLOAT, XDP(9)
-C
- IWRITE = I1MACH(2)
-C
- DO 10 K=1,9
- XINT(K) = K
- XREAL(K) = FLOAT(K)
- XDP(K) = DFLOAT(K)
- 10 CONTINUE
-C
- CALL FRMATI(IWIDTH)
- CALL FRMATR(WSP, MANTSP)
- CALL FRMATD(WDP, MANTDP)
-C
-C TAKE ONE OFF THE MANTISSA WIDTH TO ALLOW FOR 1PEW.D FORMAT.
-C
- MANTSP = MANTSP - 1
- MANTDP = MANTDP - 1
-C
- CALL APRNTI(XINT, 9, IWRITE, 80, IWIDTH)
- CALL APRNTR(XREAL, 9, IWRITE, 80, WSP, MANTSP)
- CALL APRNTD(XDP, 9, IWRITE, 80, WDP, MANTDP)
-C
- STOP
- END
diff --git a/CEP/PyBDSM/src/port3/ex/ftra.f b/CEP/PyBDSM/src/port3/ex/ftra.f
deleted file mode 100644
index 22efaa2495b63aa4687999249ac7ba16a241a472..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ex/ftra.f
+++ /dev/null
@@ -1,55 +0,0 @@
-C$TEST FFTA
-C TO RUN AS A MAIN PROGRAM REMOVE NEXT LINE
- SUBROUTINE FTRA
-C***********************************************************************
-C
-C EXAMPLE OF USE OF THE PORT PROGRAM FFTR
-C
-C***********************************************************************
- REAL A(34),B(17),C(32)
-C
-C SET UP THE INPUT DATA FOR E**(-T)
-C AND SAVE IT IN THE VECTOR C FOR LATER COMPARISON.
-C
- A(1) = .5
- C(1) = A(1)
- DO 10 K=2,32
- A(K) = EXP(-.25*FLOAT(K-1))
- 10 C(K) = A(K)
-C
-C CALL FOR THE TRANSFORM AND PRINT THE FOURIER COEFFICIENTS
-C
- CALL FFTR(34,A,B)
-C
- IWRITE = I1MACH(2)
- WRITE (IWRITE, 997)
- 997 FORMAT (1X,9HFREQUENCY,5X,20HFOURIER COEFFICIENTS//)
- WRITE (IWRITE, 998)
- 998 FORMAT (1X,7H(=N/NT),5X,9HREAL PART,6X,9HIMAGINARY///)
-C
- ENT = 1.0/(32. * 0.25)
- DO 20 K=1,17
- FREQ = FLOAT(K-1) * ENT
- 20 WRITE (IWRITE,98) FREQ, A(K), B(K)
- 98 FORMAT (2X,F6.3,2F15.8)
-C
-C DO THE INVERSE TRANSFORM
-C
- CALL FFTRI(32,A,B)
-C
-C SCALE THE RESULTS, FIND THE ERROR, AND PRINT
-C
- WRITE (IWRITE, 999)
- 999 FORMAT (///4X,1HT,9X,5HINPUT,10X,5HERROR//)
-C
- EN = 4*16
- ENI = 1./EN
- DO 30 K=1,32
- A(K) = ENI*A(K)
- ERR = A(K) - C(K)
- T = .25*FLOAT(K-1)
- 30 WRITE (IWRITE,99) T,C(K),ERR
- 99 FORMAT (2X,F4.2,1X,F15.8,4X,1PE10.2)
-C
- STOP
- END
diff --git a/CEP/PyBDSM/src/port3/ex/ftrc.f b/CEP/PyBDSM/src/port3/ex/ftrc.f
deleted file mode 100644
index c0cab1ce0a66378ab982bc322e58aefcaf53fc65..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ex/ftrc.f
+++ /dev/null
@@ -1,63 +0,0 @@
-C$TEST FFTC
-C TO RUN AS A MAIN PROGRAM REMOVE NEXT LINE
- SUBROUTINE FTRC
-C***********************************************************************
-C
-C EXAMPLE OF USE OF THE PORT PROGRAM FFTC
-C
-C***********************************************************************
- REAL A(32),B(32),C(32),D(32)
-C
-C THE REAL DATA IS ALL ZERO AND THE
-C IMAGINARY PART IS E**(-T).
-C
-C SAVE THE IMAGINARY DATA IN THE VECTOR C FOR LATER COMPARISON
-C
- DO 5 K=1,32
- 5 A(K) = 0.
-C
- B(1) = .5
- C(1) = B(1)
- DO 10 K=2,32
- B(K) = EXP(-.25*FLOAT(K-1))
- 10 C(K) = B(K)
-C
-C CALL FOR THE TRANSFORM AND PRINT THE FOURIER COEFFICIENTS
-C
- CALL FFTC(32,A,B)
-C
- IWRITE = I1MACH(2)
- WRITE (IWRITE, 997)
- 997 FORMAT (1X,9HFREQUENCY,5X,20HFOURIER COEFFICIENTS//)
- WRITE (IWRITE, 998)
- 998 FORMAT (1X,7H(=N/NT),5X,9HREAL PART,6X,9HIMAGINARY///)
-C
- ENT = 1.0/(32. * 0.25)
- DO 20 K=1,32
- FREQ = FLOAT(K-1) * ENT
- IF (FREQ .GT. 2.) FREQ = -4.0 + FREQ
- 20 WRITE (IWRITE,98) FREQ, A(K), B(K)
- 98 FORMAT (2X,F6.3,2F15.8)
-C
-C DO THE INVERSE TRANSFORM
-C
- CALL FFTCI(32,A,B)
-C
-C SCALE THE RESULTS, FIND THE ERROR, AND PRINT
-C
- WRITE (IWRITE, 999)
- 999 FORMAT (///4X,1HT,7X,18HERROR IN REAL PART,
- 1 4X,23HERROR IN IMAGINARY PART//)
-C
- ENI = 1./FLOAT(32)
- DO 30 K=1,32
- A(K) = ENI*A(K)
- B(K) = ENI*B(K)
- ERR1 = A(K) - 0.0
- ERR2 = B(K) - C(K)
- T = .25*FLOAT(K-1)
- 30 WRITE (IWRITE,99) T,ERR1,ERR2
- 99 FORMAT (2X,F4.2,8X,1PE10.2,14X,1PE10.2)
-C
- STOP
- END
diff --git a/CEP/PyBDSM/src/port3/ex/index.html b/CEP/PyBDSM/src/port3/ex/index.html
deleted file mode 100644
index 5d565df5b282f9d96cf75eac1fe468471bc249ec..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ex/index.html
+++ /dev/null
@@ -1,527 +0,0 @@
-<head>
-<title>port/ex</title>
-<meta name="waisindex" value="nse">
-</head>
-<h1>port/ex</h1>
-<p>
-Click <A HREF="http://www.netlib.org/master_counts2.html#port/ex">here</A> to see the number of accesses to this library.
-<p><hr>
-<pre>
-# Index for port/ex
-file <a href="apnr.f">apnr.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/ex/apnr.f">apnr.f plus dependencies</a>
-for testing APRNTX
-
-file <a href="lban.f">lban.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/ex/lban.f">lban.f plus dependencies</a>
-for testing BABS
-
-file <a href="lbab.f">lbab.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/ex/lbab.f">lbab.f plus dependencies</a>
-for testing BACE
-
-file <a href="lbaj.f">lbaj.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/ex/lbaj.f">lbaj.f plus dependencies</a>
-for testing BADC
-
-file <a href="lbaf.f">lbaf.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/ex/lbaf.f">lbaf.f plus dependencies</a>
-for testing BALE
-
-file <a href="lbal.f">lbal.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/ex/lbal.f">lbal.f plus dependencies</a>
-for testing BALU
-
-file <a href="lbap.f">lbap.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/ex/lbap.f">lbap.f plus dependencies</a>
-for testing BAML
-
-file <a href="lbak.f">lbak.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/ex/lbak.f">lbak.f plus dependencies</a>
-for testing BANM
-
-file <a href="lbaa.f">lbaa.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/ex/lbaa.f">lbaa.f plus dependencies</a>
-for testing BASS
-
-file <a href="lpsb.f">lpsb.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/ex/lpsb.f">lpsb.f plus dependencies</a>
-for testing BPCE
-
-file <a href="lpsg.f">lpsg.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/ex/lpsg.f">lpsg.f plus dependencies</a>
-for testing BPDC
-
-file <a href="lpsk.f">lpsk.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/ex/lpsk.f">lpsk.f plus dependencies</a>
-for testing BPFS
-
-file <a href="lpsj.f">lpsj.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/ex/lpsj.f">lpsj.f plus dependencies</a>
-for testing BPLD
-
-file <a href="lpsf.f">lpsf.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/ex/lpsf.f">lpsf.f plus dependencies</a>
-for testing BPLE
-
-file <a href="lpsm.f">lpsm.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/ex/lpsm.f">lpsm.f plus dependencies</a>
-for testing BPML
-
-file <a href="lpsa.f">lpsa.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/ex/lpsa.f">lpsa.f plus dependencies</a>
-for testing BPSS
-
-file <a href="qblc.f">qblc.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/ex/qblc.f">qblc.f plus dependencies</a>
-for testing BQUAD
-
-file <a href="bura.f">bura.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/ex/bura.f">bura.f plus dependencies</a>
-for testing BURAM
-
-file <a href="burb.f">burb.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/ex/burb.f">burb.f plus dependencies</a>
-for testing BURM1
-
-file <a href="cdex.f">cdex.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/ex/cdex.f">cdex.f plus dependencies</a>
-for testing CDEXP
-
-file <a href="cdlg.f">cdlg.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/ex/cdlg.f">cdlg.f plus dependencies</a>
-for testing CDLOG
-
-file <a href="cpla.f">cpla.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/ex/cpla.f">cpla.f plus dependencies</a>
-for testing CPOLY
-
-file <a href="cspe.f">cspe.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/ex/cspe.f">cspe.f plus dependencies</a>
-for testing CSPDI
-
-file <a href="cspq.f">cspq.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/ex/cspq.f">cspq.f plus dependencies</a>
-for testing CSPFE
-
-file <a href="cspg.f">cspg.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/ex/cspg.f">cspg.f plus dependencies</a>
-for testing CSPIN
-
-file <a href="cspa.f">cspa.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/ex/cspa.f">cspa.f plus dependencies</a>
-for testing CSPQU
-
-file <a href="sdba.f">sdba.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/ex/sdba.f">sdba.f plus dependencies</a>
-for testing DL2SF
-
-file <a href="qodd.f">qodd.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/ex/qodd.f">qodd.f plus dependencies</a>
-for testing DODEQ
-
-file <a href="rpad.f">rpad.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/ex/rpad.f">rpad.f plus dependencies</a>
-for testing DRPOLY
-
-file <a href="xkhd.f">xkhd.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/ex/xkhd.f">xkhd.f plus dependencies</a>
-for testing DXKTH
-
-file <a href="ebea.f">ebea.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/ex/ebea.f">ebea.f plus dependencies</a>
-for testing EEBSF
-
-file <a href="evaa.f">evaa.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/ex/evaa.f">evaa.f plus dependencies</a>
-for testing EIGEN
-
-file <a href="extr.f">extr.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/ex/extr.f">extr.f plus dependencies</a>
-for testing EXTRMX
-
-file <a href="lrpe.f">lrpe.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/ex/lrpe.f">lrpe.f plus dependencies</a>
-for testing FEAS
-
-file <a href="lrpf.f">lrpf.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/ex/lrpf.f">lrpf.f plus dependencies</a>
-for testing FEASA
-
-file <a href="ftrc.f">ftrc.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/ex/ftrc.f">ftrc.f plus dependencies</a>
-for testing FFTC
-
-file <a href="ftra.f">ftra.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/ex/ftra.f">ftra.f plus dependencies</a>
-for testing FFTR
-
-file <a href="mnna.f">mnna.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/ex/mnna.f">mnna.f plus dependencies</a>
-for testing FMIN
-
-file <a href="fmtr.f">fmtr.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/ex/fmtr.f">fmtr.f plus dependencies</a>
-for testing FRMATT
-
-file <a href="lgel.f">lgel.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/ex/lgel.f">lgel.f plus dependencies</a>
-for testing GEBS
-
-file <a href="lgeb.f">lgeb.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/ex/lgeb.f">lgeb.f plus dependencies</a>
-for testing GECE
-
-file <a href="lgef.f">lgef.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/ex/lgef.f">lgef.f plus dependencies</a>
-for testing GELE
-
-file <a href="lgej.f">lgej.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/ex/lgej.f">lgej.f plus dependencies</a>
-for testing GELU
-
-file <a href="lgem.f">lgem.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/ex/lgem.f">lgem.f plus dependencies</a>
-for testing GEML
-
-file <a href="lgeh.f">lgeh.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/ex/lgeh.f">lgeh.f plus dependencies</a>
-for testing GENM
-
-file <a href="lgea.f">lgea.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/ex/lgea.f">lgea.f plus dependencies</a>
-for testing GESS
-
-file <a href="qgsg.f">qgsg.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/ex/qgsg.f">qgsg.f plus dependencies</a>
-for testing GQ1
-
-file <a href="qgsh.f">qgsh.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/ex/qgsh.f">qgsh.f plus dependencies</a>
-for testing GQEX
-
-file <a href="qgsj.f">qgsj.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/ex/qgsj.f">qgsj.f plus dependencies</a>
-for testing GQEX2
-
-file <a href="qgsm.f">qgsm.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/ex/qgsm.f">qgsm.f plus dependencies</a>
-for testing GQEXA
-
-file <a href="qgsp.f">qgsp.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/ex/qgsp.f">qgsp.f plus dependencies</a>
-for testing GQLOG
-
-file <a href="qgsr.f">qgsr.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/ex/qgsr.f">qgsr.f plus dependencies</a>
-for testing GQXA
-
-file <a href="qgst.f">qgst.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/ex/qgst.f">qgst.f plus dependencies</a>
-for testing GQXAB
-
-file <a href="ddea.f">ddea.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/ex/ddea.f">ddea.f plus dependencies</a>
-for testing IODE
-
-file <a href="qpra.f">qpra.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/ex/qpra.f">qpra.f plus dependencies</a>
-for testing IQP
-
-file <a href="xkhi.f">xkhi.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/ex/xkhi.f">xkhi.f plus dependencies</a>
-for testing IXKTH
-
-file <a href="lsfa.f">lsfa.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/ex/lsfa.f">lsfa.f plus dependencies</a>
-for testing L2SFF
-
-file <a href="lrpb.f">lrpb.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/ex/lrpb.f">lrpb.f plus dependencies</a>
-for testing LINPA
-
-file <a href="lrpg.f">lrpg.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/ex/lrpg.f">lrpg.f plus dependencies</a>
-for testing LINPA
-
-file <a href="lrpa.f">lrpa.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/ex/lrpa.f">lrpa.f plus dependencies</a>
-for testing LINPR
-
-file <a href="lnab.f">lnab.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/ex/lnab.f">lnab.f plus dependencies</a>
-for testing LSTSQ
-
-file <a href="llza.f">llza.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/ex/llza.f">llza.f plus dependencies</a>
-for testing LZ
-
-file <a href="mfte.f">mfte.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/ex/mfte.f">mfte.f plus dependencies</a>
-for testing MFTCC
-
-file <a href="mftg.f">mftg.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/ex/mftg.f">mftg.f plus dependencies</a>
-for testing MFTCR
-
-file <a href="mftf.f">mftf.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/ex/mftf.f">mftf.f plus dependencies</a>
-for testing MFTRC
-
-file <a href="nlsa.f">nlsa.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/ex/nlsa.f">nlsa.f plus dependencies</a>
-for testing MNF
-
-file <a href="nlsb.f">nlsb.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/ex/nlsb.f">nlsb.f plus dependencies</a>
-for testing MNFB
-
-file <a href="mllr.f">mllr.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/ex/mllr.f">mllr.f plus dependencies</a>
-for testing MULLR
-
-file <a href="nlsj.f">nlsj.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/ex/nlsj.f">nlsj.f plus dependencies</a>
-for testing N2F
-
-file <a href="nlsk.f">nlsk.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/ex/nlsk.f">nlsk.f plus dependencies</a>
-for testing N2FB
-
-file <a href="nlsp.f">nlsp.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/ex/nlsp.f">nlsp.f plus dependencies</a>
-for testing N2PB
-
-file <a href="nsfa.f">nsfa.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/ex/nsfa.f">nsfa.f plus dependencies</a>
-for testing NSF1
-
-file <a href="nlsr.f">nlsr.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/ex/nlsr.f">nlsr.f plus dependencies</a>
-for testing NSG
-
-file <a href="nmsk.f">nmsk.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/ex/nmsk.f">nmsk.f plus dependencies</a>
-for testing NSGB
-
-file <a href="desa.f">desa.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/ex/desa.f">desa.f plus dependencies</a>
-for testing ODES
-
-file <a href="pdea.f">pdea.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/ex/pdea.f">pdea.f plus dependencies</a>
-for testing POST
-
-file <a href="pdew.f">pdew.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/ex/pdew.f">pdew.f plus dependencies</a>
-for testing POSTU
-
-file <a href="qblg.f">qblg.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/ex/qblg.f">qblg.f plus dependencies</a>
-for testing QUAD
-
-file <a href="ranc.f">ranc.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/ex/ranc.f">ranc.f plus dependencies</a>
-for testing RANBYT
-
-file <a href="rnrm.f">rnrm.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/ex/rnrm.f">rnrm.f plus dependencies</a>
-for testing RNORM
-
-file <a href="qbla.f">qbla.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/ex/qbla.f">qbla.f plus dependencies</a>
-for testing RQUAD
-
-file <a href="ntle.f">ntle.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/ex/ntle.f">ntle.f plus dependencies</a>
-for testing SMNFB
-
-file <a href="ntlf.f">ntlf.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/ex/ntlf.f">ntlf.f plus dependencies</a>
-for testing SMNG
-
-file <a href="ntlh.f">ntlh.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/ex/ntlh.f">ntlh.f plus dependencies</a>
-for testing SMNGB
-
-file <a href="ntlk.f">ntlk.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/ex/ntlk.f">ntlk.f plus dependencies</a>
-for testing SMNH
-
-file <a href="ntlm.f">ntlm.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/ex/ntlm.f">ntlm.f plus dependencies</a>
-for testing SMNHB
-
-file <a href="nsnm.f">nsnm.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/ex/nsnm.f">nsnm.f plus dependencies</a>
-for testing SMNSX
-
-file <a href="np2a.f">np2a.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/ex/np2a.f">np2a.f plus dependencies</a>
-for testing SN2F
-
-file <a href="np2b.f">np2b.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/ex/np2b.f">np2b.f plus dependencies</a>
-for testing SN2FB
-
-file <a href="np2e.f">np2e.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/ex/np2e.f">np2e.f plus dependencies</a>
-for testing SN2G
-
-file <a href="np2f.f">np2f.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/ex/np2f.f">np2f.f plus dependencies</a>
-for testing SN2GB
-
-file <a href="ntlp.f">ntlp.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/ex/ntlp.f">ntlp.f plus dependencies</a>
-for testing SNSF
-
-file <a href="ntlt.f">ntlt.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/ex/ntlt.f">ntlt.f plus dependencies</a>
-for testing SNSFB
-
-file <a href="ntlr.f">ntlr.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/ex/ntlr.f">ntlr.f plus dependencies</a>
-for testing SNSG
-
-file <a href="ntlu.f">ntlu.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/ex/ntlu.f">ntlu.f plus dependencies</a>
-for testing SNSGB
-
-file <a href="prsm.f">prsm.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/ex/prsm.f">prsm.f plus dependencies</a>
-for testing SPFCE
-
-file <a href="prsf.f">prsf.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/ex/prsf.f">prsf.f plus dependencies</a>
-for testing SPFLE
-
-file <a href="prst.f">prst.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/ex/prst.f">prst.f plus dependencies</a>
-for testing SPFLU
-
-file <a href="prsz.f">prsz.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/ex/prsz.f">prsz.f plus dependencies</a>
-for testing SPFML
-
-file <a href="prsy.f">prsy.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/ex/prsy.f">prsy.f plus dependencies</a>
-for testing SPFNF
-
-file <a href="prea.f">prea.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/ex/prea.f">prea.f plus dependencies</a>
-for testing SPFOR
-
-file <a href="splf.f">splf.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/ex/splf.f">splf.f plus dependencies</a>
-for testing SPLNI
-
-file <a href="prsj.f">prsj.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/ex/prsj.f">prsj.f plus dependencies</a>
-for testing SPMCE
-
-file <a href="prsa.f">prsa.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/ex/prsa.f">prsa.f plus dependencies</a>
-for testing SPMLE
-
-file <a href="prsp.f">prsp.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/ex/prsp.f">prsp.f plus dependencies</a>
-for testing SPMLU
-
-file <a href="prs1.f">prs1.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/ex/prs1.f">prs1.f plus dependencies</a>
-for testing SPMML
-
-file <a href="prs3.f">prs3.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/ex/prs3.f">prs3.f plus dependencies</a>
-for testing SPMNF
-
-file <a href="prma.f">prma.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/ex/prma.f">prma.f plus dependencies</a>
-for testing SPMSF
-
-file <a href="errk.f">errk.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/ex/errk.f">errk.f plus dependencies</a>
-for testing STKDMP
-
-file <a href="lymb.f">lymb.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/ex/lymb.f">lymb.f plus dependencies</a>
-for testing SYCE
-
-file <a href="lymp.f">lymp.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/ex/lymp.f">lymp.f plus dependencies</a>
-for testing SYML
-
-file <a href="lymk.f">lymk.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/ex/lymk.f">lymk.f plus dependencies</a>
-for testing SYNM
-
-file <a href="lyma.f">lyma.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/ex/lyma.f">lyma.f plus dependencies</a>
-for testing SYSS
-
-file <a href="vdsa.f">vdsa.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/ex/vdsa.f">vdsa.f plus dependencies</a>
-for testing VDSS1
-
-file <a href="vdsb.f">vdsb.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/ex/vdsb.f">vdsb.f plus dependencies</a>
-for testing VDSS2
-
-file <a href="vdse.f">vdse.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/ex/vdse.f">vdse.f plus dependencies</a>
-for testing VDSS3
-
-file <a href="xkt.f">xkt.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/ex/xkt.f">xkt.f plus dependencies</a>
-for testing XKTH
-
-file <a href="zera.f">zera.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/ex/zera.f">zera.f plus dependencies</a>
-for testing ZERO
-
-file <a href="zona.f">zona.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/ex/zona.f">zona.f plus dependencies</a>
-for testing ZONE
-
-file <a href="zonb.f">zonb.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/ex/zonb.f">zonb.f plus dependencies</a>
-for testing ZONEJ
-
-file <a href="README">README</a>
-
-file <a href="dpostx1.f">dpostx1.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/ex/dpostx1.f">dpostx1.f plus dependencies</a>
-
-file <a href="dpostx10.f">dpostx10.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/ex/dpostx10.f">dpostx10.f plus dependencies</a>
-
-file <a href="dpostx2.f">dpostx2.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/ex/dpostx2.f">dpostx2.f plus dependencies</a>
-
-file <a href="dpostx3.f">dpostx3.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/ex/dpostx3.f">dpostx3.f plus dependencies</a>
-
-file <a href="dpostx4.f">dpostx4.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/ex/dpostx4.f">dpostx4.f plus dependencies</a>
-
-file <a href="dpostx5.f">dpostx5.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/ex/dpostx5.f">dpostx5.f plus dependencies</a>
-
-file <a href="dpostx6.f">dpostx6.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/ex/dpostx6.f">dpostx6.f plus dependencies</a>
-
-file <a href="dpostx7.f">dpostx7.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/ex/dpostx7.f">dpostx7.f plus dependencies</a>
-
-file <a href="dpostx8.f">dpostx8.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/ex/dpostx8.f">dpostx8.f plus dependencies</a>
-
-file <a href="dpostx9.f">dpostx9.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/ex/dpostx9.f">dpostx9.f plus dependencies</a>
-
-file <a href="dpt1.f">dpt1.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/ex/dpt1.f">dpt1.f plus dependencies</a>
-
-file <a href="dpt2.f">dpt2.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/ex/dpt2.f">dpt2.f plus dependencies</a>
-
-file <a href="dpt3.f">dpt3.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/ex/dpt3.f">dpt3.f plus dependencies</a>
-
-file <a href="dpt4.f">dpt4.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/ex/dpt4.f">dpt4.f plus dependencies</a>
-
-file <a href="dpt5.f">dpt5.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/ex/dpt5.f">dpt5.f plus dependencies</a>
-
-file <a href="dpt6.f">dpt6.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/ex/dpt6.f">dpt6.f plus dependencies</a>
-
-file <a href="dpt7.f">dpt7.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/ex/dpt7.f">dpt7.f plus dependencies</a>
-
-file <a href="dpt8.f">dpt8.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/ex/dpt8.f">dpt8.f plus dependencies</a>
-
-file <a href="dpt9.f">dpt9.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/ex/dpt9.f">dpt9.f plus dependencies</a>
-
-file <a href="dptt.f">dptt.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/ex/dptt.f">dptt.f plus dependencies</a>
-
-file <a href="dtg1.f">dtg1.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/ex/dtg1.f">dtg1.f plus dependencies</a>
-
-file <a href="dtg2.f">dtg2.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/ex/dtg2.f">dtg2.f plus dependencies</a>
-
-file <a href="dtg3.f">dtg3.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/ex/dtg3.f">dtg3.f plus dependencies</a>
-
-file <a href="dtg4.f">dtg4.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/ex/dtg4.f">dtg4.f plus dependencies</a>
-
-file <a href="dtg5.f">dtg5.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/ex/dtg5.f">dtg5.f plus dependencies</a>
-
-file <a href="dtg6.f">dtg6.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/ex/dtg6.f">dtg6.f plus dependencies</a>
-
-file <a href="dtgp.f">dtgp.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/ex/dtgp.f">dtgp.f plus dependencies</a>
-
-file <a href="dttgrx1.f">dttgrx1.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/ex/dttgrx1.f">dttgrx1.f plus dependencies</a>
-
-file <a href="dttgrx1p.f">dttgrx1p.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/ex/dttgrx1p.f">dttgrx1p.f plus dependencies</a>
-
-file <a href="dttgrx2.f">dttgrx2.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/ex/dttgrx2.f">dttgrx2.f plus dependencies</a>
-
-file <a href="dttgrx3.f">dttgrx3.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/ex/dttgrx3.f">dttgrx3.f plus dependencies</a>
-
-file <a href="dttgrx4.f">dttgrx4.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/ex/dttgrx4.f">dttgrx4.f plus dependencies</a>
-
-file <a href="dttgrx5.f">dttgrx5.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/ex/dttgrx5.f">dttgrx5.f plus dependencies</a>
-
-file <a href="dttgrx6.f">dttgrx6.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/ex/dttgrx6.f">dttgrx6.f plus dependencies</a>
-
-file <a href="ffta">ffta</a>
-
-file <a href="fftc">fftc</a>
-
-file <a href="postx1.f">postx1.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/ex/postx1.f">postx1.f plus dependencies</a>
-
-file <a href="postx10.f">postx10.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/ex/postx10.f">postx10.f plus dependencies</a>
-
-file <a href="postx2.f">postx2.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/ex/postx2.f">postx2.f plus dependencies</a>
-
-file <a href="postx3.f">postx3.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/ex/postx3.f">postx3.f plus dependencies</a>
-
-file <a href="postx4.f">postx4.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/ex/postx4.f">postx4.f plus dependencies</a>
-
-file <a href="postx5.f">postx5.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/ex/postx5.f">postx5.f plus dependencies</a>
-
-file <a href="postx6.f">postx6.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/ex/postx6.f">postx6.f plus dependencies</a>
-
-file <a href="postx7.f">postx7.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/ex/postx7.f">postx7.f plus dependencies</a>
-
-file <a href="postx8.f">postx8.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/ex/postx8.f">postx8.f plus dependencies</a>
-
-file <a href="postx9.f">postx9.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/ex/postx9.f">postx9.f plus dependencies</a>
-
-file <a href="pst1.f">pst1.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/ex/pst1.f">pst1.f plus dependencies</a>
-
-file <a href="pst2.f">pst2.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/ex/pst2.f">pst2.f plus dependencies</a>
-
-file <a href="pst3.f">pst3.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/ex/pst3.f">pst3.f plus dependencies</a>
-
-file <a href="pst4.f">pst4.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/ex/pst4.f">pst4.f plus dependencies</a>
-
-file <a href="pst5.f">pst5.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/ex/pst5.f">pst5.f plus dependencies</a>
-
-file <a href="pst6.f">pst6.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/ex/pst6.f">pst6.f plus dependencies</a>
-
-file <a href="pst7.f">pst7.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/ex/pst7.f">pst7.f plus dependencies</a>
-
-file <a href="pst8.f">pst8.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/ex/pst8.f">pst8.f plus dependencies</a>
-
-file <a href="pst9.f">pst9.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/ex/pst9.f">pst9.f plus dependencies</a>
-
-file <a href="pstt.f">pstt.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/ex/pstt.f">pstt.f plus dependencies</a>
-
-file <a href="ttg1.f">ttg1.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/ex/ttg1.f">ttg1.f plus dependencies</a>
-
-file <a href="ttg2.f">ttg2.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/ex/ttg2.f">ttg2.f plus dependencies</a>
-
-file <a href="ttg3.f">ttg3.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/ex/ttg3.f">ttg3.f plus dependencies</a>
-
-file <a href="ttg4.f">ttg4.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/ex/ttg4.f">ttg4.f plus dependencies</a>
-
-file <a href="ttg5.f">ttg5.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/ex/ttg5.f">ttg5.f plus dependencies</a>
-
-file <a href="ttg6.f">ttg6.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/ex/ttg6.f">ttg6.f plus dependencies</a>
-
-file <a href="ttgp.f">ttgp.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/ex/ttgp.f">ttgp.f plus dependencies</a>
-
-file <a href="ttgrx1.f">ttgrx1.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/ex/ttgrx1.f">ttgrx1.f plus dependencies</a>
-
-file <a href="ttgrx1p.f">ttgrx1p.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/ex/ttgrx1p.f">ttgrx1p.f plus dependencies</a>
-
-file <a href="ttgrx2.f">ttgrx2.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/ex/ttgrx2.f">ttgrx2.f plus dependencies</a>
-
-file <a href="ttgrx3.f">ttgrx3.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/ex/ttgrx3.f">ttgrx3.f plus dependencies</a>
-
-file <a href="ttgrx4.f">ttgrx4.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/ex/ttgrx4.f">ttgrx4.f plus dependencies</a>
-
-file <a href="ttgrx5.f">ttgrx5.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/ex/ttgrx5.f">ttgrx5.f plus dependencies</a>
-
-file <a href="ttgrx6.f">ttgrx6.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/ex/ttgrx6.f">ttgrx6.f plus dependencies</a>
-
-file <a href="xkth">xkth</a>
-
-file <a href="zap.ed">zap.ed</a>
-
-file <a href="zap.ex">zap.ex</a>
-
-file <a href="zap.head">zap.head</a>
-
-file <a href="zap.t">zap.t</a>
-
-file <a href="zip.ed">zip.ed</a>
-
-</pre>
-</body>
-</html>
diff --git a/CEP/PyBDSM/src/port3/ex/lbaa.f b/CEP/PyBDSM/src/port3/ex/lbaa.f
deleted file mode 100644
index b3fa886ad60741700943d1ba0403b02be5d688dc..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ex/lbaa.f
+++ /dev/null
@@ -1,56 +0,0 @@
-C$TEST LBAA
-C TO RUN AS A MAIN PROGRAM REMOVE NEXT LINE
- SUBROUTINE LBAA
-C***********************************************************************
-C
-C EXAMPLE OF USE OF THE PORT PROGRAM BASS
-C
-C***********************************************************************
- INTEGER N, IG, ML, M, I, J, IWRITE, I1MACH
- REAL G(13,80), B(80,2), X(80)
- REAL START, FLOAT, ERR, ERR2, ABS, COND
- IG=13
- N=80
- DO 60 ML=2,6
-C
-C CONSTRUCT THE MATRIX A(I,J)=I+J AND PACK IT INTO G
-C
- M=2*ML-1
- START=-FLOAT(M-ML)
- DO 20 I=1,N
- G(1,I)=START+FLOAT(2*I)
- IF(M.EQ.1) GO TO 20
- DO 10 J=2,M
- G(J,I)=G(J-1,I)+1.
- 10 CONTINUE
- 20 CONTINUE
-C CONSTRUCT FIRST RIGHT-HAND SIDE SO SOLUTION IS ALL 1S
- DO 30 I=1,N
- 30 X(I)=1
- CALL BAML(N,ML,M,G,IG,X,B)
-C CONSTRUCT THE SECOND COLUMN SO X(I)=I
- DO 40 I=1,N
- 40 X(I)=I
- CALL BAML(N,ML,M,G,IG,X,B(1,2))
-C SOLVE THE SYSTEM
- CALL BASS(N,ML,M,G,IG,B,80,2,COND)
-C COMPUTE THE ERRORS IN THE SOLUTION
- ERR=0.0
- ERR2=0.0
- DO 50 I=1,N
- ERR=ERR+ABS(B(I,1)-1.0)
- ERR2=ERR2+ABS(B(I,2)-FLOAT(I))
- 50 CONTINUE
- ERR=ERR/FLOAT(N)
- ERR2=ERR2/FLOAT(N*(N+1))*2.0
- IWRITE=I1MACH(2)
- WRITE(IWRITE,51)ML,COND
- 51 FORMAT(/9H WHEN ML=,I4,21H THE CONDITION NO. IS,1PE15.7)
- WRITE(IWRITE,52)ERR
- 52 FORMAT(38H REL. ERROR IN THE FIRST SOLUTION IS ,1PE15.7)
- WRITE(IWRITE,53)ERR2
- 53 FORMAT(38H REL. ERROR IN THE SECOND SOLUTION IS ,1PE15.7)
- 60 CONTINUE
- 70 CONTINUE
- STOP
- END
diff --git a/CEP/PyBDSM/src/port3/ex/lbab.f b/CEP/PyBDSM/src/port3/ex/lbab.f
deleted file mode 100644
index 2a3d1c08628cbabdb582d68b058b30662f75353e..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ex/lbab.f
+++ /dev/null
@@ -1,67 +0,0 @@
-C$TEST LBAB
-C TO RUN AS A MAIN PROGRAM REMOVE NEXT LINE
- SUBROUTINE LBAB
-C***********************************************************************
-C
-C EXAMPLE OF USE OF THE PORT PROGRAM BACE
-C
-C***********************************************************************
- INTEGER IG, IGL, N, ML, M, I, J, MU, IWRITE, I1MACH
- INTEGER INTER(80)
- REAL G(13, 80), B(80), X(80), GL(6, 80)
- REAL START, FLOAT, AINNO, COND, CONDNO, ABS, AINNOI
- IG=13
- IGL=6
- N=80
- IWRITE=I1MACH(2)
- DO 60 ML=2,6
-C
-C CONSTRUCT THE MATRIX A(I,J)=I+J AND PACK IT INTO G
- M=2*ML - 1
- START=-FLOAT(M-ML)
- DO 20 I=1,N
- G(1,I)=START+FLOAT(2*I)
- DO 10 J=2,M
- G(J,I)=G(J-1,I)+1.
- 10 CONTINUE
- 20 CONTINUE
-C
-C DETERMINE AN ESTIMATE OF THE CONDITION NUMBER
-C AND COMPUTE THE LU DECOMPOSITION
-C
- CALL BACE(N,ML,M,G,IG,GL,IGL,INTER,MU,COND)
-C
-C DETERMINE THE NORM OF THE INVERSE MATRIX BY
-C SOLVING FOR ONE COLUMN OF THE INVERSE MATRIX
-C AT A TIME
-C
- AINNO=0.0
- DO 50 I=1,N
-C
-C FIND THE ITH COLUMN OF THE INVERSE MATRIX BY
-C SETTING THE RIGHT HAND SIDE TO THE ITH COLUMN
-C OF THE IDENTITY MATRIX
-C
- DO 30 J=1,N
- B(J)=0.0
- 30 CONTINUE
- B(I)=1.0
- CALL BAFS(N,ML,GL,IGL,INTER,B,80,1)
- CALL BABS(N,G,IG,B,80,1,MU)
-C FIND THE NORM OF THE ITH COLUMN
- AINNOI=0.0
- DO 40 J=1,N
- AINNOI=AINNOI+ABS(B(J))
- 40 CONTINUE
- IF(AINNOI.GT.AINNO)AINNO=AINNOI
- 50 CONTINUE
- WRITE(IWRITE,51)ML
- 51 FORMAT(/6H ML IS ,I4)
- WRITE(IWRITE,52)COND
- 52 FORMAT(22H CONDITION ESTIMATE IS,1PE15.7)
- CONDNO=AINNO*FLOAT(M*(N-ML+1)*2)
- WRITE(IWRITE,53)CONDNO
- 53 FORMAT(22H TRUE CONDITION NO. IS,1PE15.7)
- 60 CONTINUE
- STOP
- END
diff --git a/CEP/PyBDSM/src/port3/ex/lbaf.f b/CEP/PyBDSM/src/port3/ex/lbaf.f
deleted file mode 100644
index adf2a5a848a74350d009322370030bc4ae233586..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ex/lbaf.f
+++ /dev/null
@@ -1,81 +0,0 @@
-C$TEST LBAF
-C TO RUN AS A MAIN PROGRAM REMOVE NEXT LINE
- SUBROUTINE LBAF
-C***********************************************************************
-C
-C EXAMPLE OF USE OF THE PORT PROGRAM BALE
-C
-C***********************************************************************
- INTEGER IG, IWRITE, I1MACH, N, ML, II, MP1, I, K
- INTEGER IB, NB, IT, ILAPSZ
- REAL G(19, 100), B(100, 10), BB(100, 10), GG(19, 100)
- REAL COND, TIME1, TIME2, UNI
-C
-C THIS PROGRAM SOLVES BANDED SYSTEMS USING BALE AND
-C BASS AND COMPARES THE TIME FOR EACH OF THEM. THE
-C SYSTEMS HAVE VARIOUS BANDWIDTHS,DIMENSIONS, AND
-C NUMBERS OF RIGHT-HAND SIDES
- DOUBLE PRECISION D(600)
- COMMON /CSTAK/ D
-C MAKE SURE THE STACK MECHANISM HAS SUFFICIENT SPACE
-C FOR BASS
- CALL ISTKIN(1200,3)
- IG=19
- IWRITE=I1MACH(2)
- IB=100
- DO 70 N=50,100,50
- DO 60 ML=2,10,8
- M=2*ML - 1
- MP1=M+1
- DO 50 NB=1,10,9
- WRITE(IWRITE,1)N,M,NB
- 1 FORMAT(/5H N IS,I4,6H M IS ,I3,7H NB IS ,I3)
-C
-C CONSTRUCT THE MATRIX A(I,J)=ABS(I-J) AND PACK IT INTO G
-C AND MAKE A COPY OF THE MATRIX SO THE SYSTEM CAN BE
-C SOLVED WITH BOTH BALE AND BASS
-C
- K=ML - 1
- DO 20 I=1,ML
- II=MP1 - I
- DO 10 J=1,N
- G(I,J)=K
- GG(I,J)=K
- G(II,J)=K
- GG(II,J)=K
- 10 CONTINUE
- K=K - 1
- 20 CONTINUE
-C
-C CONSTRUCT RANDOM RIGHT-HAND SIDES
-C AND MAKE A COPY
-C
- DO 40 I=1,NB
- DO 30 II=1,N
- B(II,I)=UNI(0)
- BB(II,I)=B(II,I)
- 30 CONTINUE
- 40 CONTINUE
-C
-C SOLVE THE SYSTEM USING BOTH BASS AND BALE
-C
- IT=ILAPSZ(0)
- CALL BASS(N,ML,M,G,IG,B,IB,NB,COND)
- TIME1=(ILAPSZ(0)-IT)/64.0
- WRITE(IWRITE,41)TIME1
- 41 FORMAT(34H TIME FOR BASS IN MILLISECONDS IS ,F10.1)
- IT=ILAPSZ(0)
- CALL BALE(N,ML,M,GG,IG,BB,IB,NB)
- TIME2=(ILAPSZ(0)-IT)/64.0
- WRITE(IWRITE,42)TIME2
- 42 FORMAT(34H TIME FOR BALE IN MIILISECONDS IS ,F10.1)
- 50 CONTINUE
- 60 CONTINUE
- 70 CONTINUE
- STOP
- END
- INTEGER FUNCTION ILAPSZ(N)
- INTEGER N
- ILAPSZ = 0
- RETURN
- END
diff --git a/CEP/PyBDSM/src/port3/ex/lbaj.f b/CEP/PyBDSM/src/port3/ex/lbaj.f
deleted file mode 100644
index 86448716b3838f3ca2de497403678cf90b4186c2..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ex/lbaj.f
+++ /dev/null
@@ -1,50 +0,0 @@
-C$TEST LBAJ
-C***********************************************************************
-C
-C EXAMPLE OF USE OF THE PORT PROGRAM BADC
-C
-C***********************************************************************
- SUBROUTINE NEWTON(N,M,ML,X,EPS,FUN,JAC,LIMIT,F)
-C
-C THIS SUBROUTINE IMPLEMENTS A LINEARIZED FORM OF NEWTONS
-C METHOD TO FIND THE ZERO OF A FUNCTION F DEFINED BY
-C FUN, WHOSE BAND JACOBIAN (WITH BANDWIDTH M AND ML
-C LOWER DIAGONALS) IS EVALUATED IN JAC. LIMIT GIVES
-C A BOUND ON THE NUMBER OF ITERATIONS AND IN F THE
-C FINAL FUNCTION VALUE IS RETURNED.
-C
- INTEGER N, ML, M, LIMIT
- INTEGER JG, JAL, JINTER, ISTKGT, MU, LIM, I
- INTEGER IST(1000)
- REAL EPS, X(N), F(N)
- REAL FU, SNRM2, R(1000)
- DOUBLE PRECISION D(500)
- EXTERNAL FUN,JAC
- COMMON /CSTAK/ D
- EQUIVALENCE (D(1),R(1)),(D(1),IST(1))
-C
-C GET SPACE FOR G,INTER, AND AL FROM
-C THE STORAGE STACK
-C
- JG= ISTKGT(M*N,3)
- JAL = ISTKGT ((ML-1)*N,3)
- JINTER = ISTKGT(N,2)
- CALL JAC(N,M,ML,X,R(JG),M)
- CALL BADC(N,ML,M,R(JH),M,R(JAL),ML-1,IST(JINTER),MU)
- LIM=0
- 10 CALL FUN(N,X,F)
- FU=SNRM2(N,F,1)
-C
-C CHECK FOR CONVERGENCE OR IF ITERATION LIMIT IS REACHED
-C
- IF (FU.LE.EPS.OR.LIM.GT.LIMIT) RETURN
- LIM=LIM+1
-C SOLVE THE LINEAR SYSTEM
- CALL BAFS(N,ML,R(JAL),ML-1,IST(JINTER),F,N,1)
- CALL BABS(N,R(JG),M,F,N,1,MU)
-C CORRECT THE CURRENT ESTIMATE OF THE SOLUTION
- DO 20 I=1,N
- X(I)=X(I)-F(I)
- 20 CONTINUE
- GO TO 10
- END
diff --git a/CEP/PyBDSM/src/port3/ex/lbak.f b/CEP/PyBDSM/src/port3/ex/lbak.f
deleted file mode 100644
index e2234aba1ed744ed12d23a801562908ed9528cc8..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ex/lbak.f
+++ /dev/null
@@ -1,36 +0,0 @@
-C$TEST LBAK
-C TO RUN AS A MAIN PROGRAM REMOVE NEXT LINE
- SUBROUTINE LBAK
-C***********************************************************************
-C
-C EXAMPLE OF USE OF THE PORT PROGRAM BANM
-C
-C***********************************************************************
- INTEGER IG, ML, M, N, I, J, IWRITE, I1MACH
- REAL G(13, 80), START, BANM, TRNORM
- IG=13
- N=80
- DO 30 ML=2,6
-C
-C CONSTRUCT THE MATRIX A(I,J)=I+J AND PACK IT INTO G
-C
- M=2*ML-1
- START=-FLOAT(M-ML)
- DO 20 I=1,N
- G(1,I)=START+FLOAT(2*I)
- DO 10 J=2,M
- G(J,I)=G(J-1,I)+1.0
- 10 CONTINUE
- 20 CONTINUE
-C
-C PRINT OUT THE NORM CALCULATED FROM BANM AND THE TRUE NORM
-C
- TRNORM=M*(N-ML+1)*2
- IWRITE=I1MACH(2)
- WRITE(IWRITE,21)ML
- 21 FORMAT(/6H ML IS ,I4)
- WRITE(IWRITE,22)TRNORM,BANM(N,ML,M,G,IG)
- 22 FORMAT(15H THE TRUE NORM=,E15.5,15H COMPUTED NORM=,E15.5)
- 30 CONTINUE
- STOP
- END
diff --git a/CEP/PyBDSM/src/port3/ex/lbal.f b/CEP/PyBDSM/src/port3/ex/lbal.f
deleted file mode 100644
index a3ff0228de3b5ae950834d365fdaf74dc5448f1f..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ex/lbal.f
+++ /dev/null
@@ -1,52 +0,0 @@
-C$TEST LBAL
-C***********************************************************************
-C
-C EXAMPLE OF USE OF THE PORT PROGRAM BALU
-C
-C***********************************************************************
- SUBROUTINE BADET(N,ML,M,A,IA,DETMAN,IDETEX)
-C
-C THIS SUBROUTINE COMPUTES THE DETERMINANT OF A
-C BANDED MATRIX STORED IN PACKED FORM IN A
-C THE DETERMINANT IS COMPUTED AS DETMAN*BETA**IDETEX,
-C WHERE BETA IS THE BASE OF THE MACHINE AND
-C DETMAN IS BETWEEN 1/BETA AND 1 IN ABSOLUTE VALUE
-C
- INTEGER ML, M, N, IA, IDETEX
- INTEGER E, ISPAC, IALOW, ISTKGT, ISIGN, INTER, I, MU
- INTEGER IN(1000)
- REAL A(IA,1), DETMAN, BETA, ONOVBE, S
- REAL R(1000)
- DOUBLE PRECISION D(500)
- COMMON /CSTAK/D
- EQUIVALENCE(D(1),R(1)),(D(1),IN(1))
-C
-C ALLOCATE SPACE FROM THE STACK FOR THE PIVOT ARRAY
-C AND THE EXTRA SPACE TO HOLD THE LOWER TRIANGLE
-C
- ISPAC=(ML-1)*N
- IALOW=ISTKGT(ISPAC,3)
- INTER=ISTKGT(N,2)
- CALL BALU(N,ML,M,A,IA,R(IALOW),ML-1,IN(INTER),MU,0.0)
-C
-C THE DETERMINANT IS THE PRODUCT OF THE ELEMENTS OF
-C ROW 1 OF A TIMES THE LAST ELEMENT IN THE ARRAY INTER.
-C WE TRY TO COMPUTE THIS PRODUCT IN A WAY THAT WILL
-C AVOID UNDERFLOW AND OVERFLOW.
-C
- BETA=FLOAT(I1MACH(10))
- ONOVBE=1.0/BETA
- ISIGN=INTER+N-1
- DETMAN=IN(ISIGN)*ONOVBE
- IDETEX=1
- DO 10 I=1,N
- CALL UMKFL(A(1,I),E,S)
- DETMAN=DETMAN*S
- IDETEX=IDETEX+E
- IF (ABS(DETMAN).GE.ONOVBE) GO TO 10
- IDETEX=IDETEX-1
- DETMAN=DETMAN*BETA
- 10 CONTINUE
- CALL ISTKRL(2)
- RETURN
- END
diff --git a/CEP/PyBDSM/src/port3/ex/lban.f b/CEP/PyBDSM/src/port3/ex/lban.f
deleted file mode 100644
index dba83fcc233eb25cccb54c751bb73b79c6a42799..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ex/lban.f
+++ /dev/null
@@ -1,97 +0,0 @@
-C$TEST LBAN
-C TO RUN AS A MAIN PROGRAM REMOVE NEXT LINE
- SUBROUTINE LBAN
-C***********************************************************************
-C
-C EXAMPLE OF USE OF THE PORT PROGRAM BABS
-C
-C***********************************************************************
- INTEGER N, I, IWRITE, I1MACH
- REAL G(3, 200), EVEC(100)
- N=10
- DO 10 I=1,N
- G(1,I)=-1.0
- G(2,I)=1.0
- G(3,I)=-1.0
- 10 CONTINUE
- G(2,1)=-.75
- G(2,N)=-.75
- G(3,1)=-.5
- G(1,2)=-.5
- G(1,N)=-.5
- G(3,N-1)=-.5
- IWRITE=I1MACH(2)
- CALL EIGVEC(N,3,2,G,3,-1.0,EVEC,2)
- DO 20 I=1,N
- WRITE(IWRITE,21)EVEC(I)
- 20 CONTINUE
- 21 FORMAT(12H EIGENVECTOR,F16.8)
- STOP
- END
- SUBROUTINE EIGVEC(N,M,ML,G,IG,EVAL,EVEC,LIMIT)
-C
-C GIVEN A BANDED MATRIX PACKED INTO G WITH
-C N ROWS, M NONZERO DIAGONALS AND ML NONZERO DIAGONALS
-C ON AND BELOW THE DIAGONAL AND GIVEN AN EIGENVALUE OF THE
-C MATRIX IN EVAL, THIS SUBROUTINE USES INVERSE ITERATION TO
-C DETERMINE THE CORRESPONDING EIGENVECTOR AND RETURNS IT
-C IN EVEC.
-C LIMIT IS A BOUND ON THE NUMBER OF ITERATIONS
-C
- INTEGER N, M, ML, IG, LIMIT
- INTEGER I, JAL, ISTKGT, JINTER, JX, MU, IERR, NERROR
- INTEGER LIM, JJ, ISAMAX, JXI, IST(1000)
- REAL G(IG, N), EVEC(N), EVAL
- REAL SIZE, R1MACH, EPS, SC, BET, D1, SC2, ABS
- REAL R(1000)
- DOUBLE PRECISION D(500)
- COMMON /CSTAK/ D
- EQUIVALENCE (D(1),IST(1)),(R(1),D(1))
- CALL ENTER(1)
-C DETERMINE ITERATION TOLERANCE
- SIZE = BANM(N,ML,M,G,IG)
- EPS=SIZE*R1MACH(4)
-C SUBTRACT EIGENVALUE FROM DIAGONAL OF G
- DO 10 I=1,N
- G(ML,I)=G(ML,I) - EVAL
- 10 CONTINUE
-C GET SPACE FROM STACK FOR AL,INTER, AND SCRATCH VECTOR
- JAL =ISTKGT(N*(ML-1),3)
- JINTER=ISTKGT(N,2)
- JX=ISTKGT(N,3)
-C GET LU DECOMPOSITION OF MATRIX
- CALL BALU(N,ML,M,G,IG,R(JAL),ML-1,IST(JINTER),MU,EPS)
-C OBTAIN INITIAL RIGHT HAND SIDE
- IF (NERROR(IERR).NE.0) CALL ERROFF
- DO 20 I=1,N
- EVEC(I)=1.0
- 20 CONTINUE
- CALL BABS(N,G,IG,EVEC,N,1,MU)
- LIM=0
- JJ=ISAMAX(N,EVEC,1)
- SC=1.0/EVEC(JJ)
-C SCALE FIRST RHS TO HAVE INFINITY NORM OF 1
- CALL SSCAL(N,SC,EVEC,1)
-C ITERATIVE PHASE BEGINS HERE
- 30 LIM=LIM+1
-C MAKE A COPY OF OLD APPROXIMATION
- CALL MOVEFR(N,EVEC,R(JX))
-C GET NEW APPROXIMATION OF EIGNVECTOR
- CALL BAFS(N,ML,R(JAL),ML-1,IST(JINTER),EVEC,N,1)
- CALL BABS(N,G,IG,EVEC,N,1,MU)
- BET=1.0/EVEC(JJ)
- JJ=ISAMAX(N,EVEC,1)
- SC2=1.0/EVEC(JJ)
-C COMPUTE CONVERGENCE CRITERIA
- D1=0.0
- DO 40 I=1,N
- JXI=JX-1+I
- D1=AMAX1(D1,ABS((R(JXI)-BET*EVEC(I))*SC2))
- 40 CONTINUE
- SC=SC2
- CALL SSCAL(N,SC,EVEC,1)
-C TEST FOR CONVERGENCE AND IF ITERATION LIMIT EXCEEDED
- IF (D1.GT.EPS.AND.LIM.LT.LIMIT) GO TO 30
- CALL LEAVE
- RETURN
- END
diff --git a/CEP/PyBDSM/src/port3/ex/lbap.f b/CEP/PyBDSM/src/port3/ex/lbap.f
deleted file mode 100644
index f7327446648c01c4e13eb6a44da388939ef75ba1..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ex/lbap.f
+++ /dev/null
@@ -1,60 +0,0 @@
-C$TEST LBAP
-C TO RUN AS A MAIN PROGRAM REMOVE NEXT LINE
- SUBROUTINE LBAP
-C***********************************************************************
-C
-C EXAMPLE OF USE OF THE PORT PROGRAM BAML
-C
-C***********************************************************************
- INTEGER IG, M, ML, N, I, IWRITE, I1MACH
- REAL G(5,20), X(20), B(20), UNI, ERR, SASUM, ABS, COND
- IG=5
- M=5
- N=10
- ML=3
-C
-C CONSTRUCT THE A MATRIX AND PACK IT INTO G
-C
- DO 10 I=1,N
- G(1,I)=2.0
- G(2,I)=1.0
- G(3,I)=0.0
- G(4,I)=1.0
- G(5,I)=2.0
- 10 CONTINUE
-C
-C CONSTRUCT A RANDOM VECTOR
-C
- DO 20 I=1,N
- X(I)=UNI(0)
- 20 CONTINUE
-C
-C CONSTRUCT B=AX
-C
- CALL BAML(N,ML,M,G,IG,X,B)
-C
-C SOLVE THE SYSTEM AX=B
-C
- CALL BASS(N,ML,M,G,IG,B,N,1,COND)
-C
-C PRINT OUT THE TRUE SOLUTION AND THE COMPUTED SOLUTION
-C
- IWRITE=I1MACH(2)
- WRITE(IWRITE,21)
- 21 FORMAT(34H TRUE SOLUTION COMPUTED SOLUTION)
- WRITE(IWRITE,22)(X(I),B(I),I=1,N)
- 22 FORMAT(1H ,2E17.8)
-C
-C COMPUTE THE RELATIVE ERROR
-C
- ERR=0.0
- DO 30 I=1,N
- ERR=ERR+ABS(B(I)-X(I))
- 30 CONTINUE
- ERR=ERR/SASUM(N,X,1)
- WRITE(IWRITE,31)ERR
- 31 FORMAT(19H RELATIVE ERROR IS ,1PE15.7)
- WRITE(IWRITE,32)COND
- 32 FORMAT(20H CONDITION NUMBER IS,1PE15.7)
- STOP
- END
diff --git a/CEP/PyBDSM/src/port3/ex/lgea.f b/CEP/PyBDSM/src/port3/ex/lgea.f
deleted file mode 100644
index 4552bfbabe3b6e669431d5f8182ea0d3c6207d8a..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ex/lgea.f
+++ /dev/null
@@ -1,55 +0,0 @@
-C$TEST LGEA
-C TO RUN AS A MAIN PROGRAM REMOVE NEXT LINE
- SUBROUTINE LGEA
-C***********************************************************************
-C
-C EXAMPLE OF USE OF THE PORT PROGRAM GESS
-C
-C***********************************************************************
- INTEGER N, IREAD, I1MACH, I, NB, IWRITE, J
- REAL A(5,5), B(5,2), COND
- N=5
- IREAD=I1MACH(1)
-C
- DO 10 I=1,N
- READ(IREAD,1) (A(I,J),J=1,N)
- 1 FORMAT(1X,5F10.0)
- 10 CONTINUE
-C
- NB=2
- DO 20 I=1,N
- READ(IREAD,11) (B(I,J),J=1,NB)
- 11 FORMAT(1X,2F10.3)
- 20 CONTINUE
-C
-C SOLVE AX = B BY CALLING GESS
-C
- CALL GESS(N,A,N,B,N,NB,COND)
- IWRITE=I1MACH(2)
- WRITE(IWRITE,21) COND
- 21 FORMAT(52H AN ESTIMATE OF THE CONDITION NUMBER OF THE MATRIX =,
- 1 E14.7)
-C
- WRITE(IWRITE,22)
- 22 FORMAT(27H THE COMPUTED SOLUTION X IS,//)
- DO 30 I=1,N
- WRITE(IWRITE,23) (B(I,J),J=1,NB)
- 23 FORMAT(1H ,5F20.7)
- 30 CONTINUE
-C
- STOP
- END
-C
-C DATA FOR THE EXAMPLE IN THE PORT SHEET... (REMOVE THE C
-C IN COLUMN 1 BEFORE FEEDING THIS DATA TO THE PROGRAM ABOVE.)
-C$DATA
-C 1. -2. 3. 7. -9.
-C -2. 8. -6. 9. 50.
-C 11. -6. 18. -15. -18.
-C 7. 2. -15. 273. 173.
-C -9. 50. -18. 6. 1667.
-C 30. 29.419
-C -191. -190.994
-C 133. 133.072
-C -986. -985.775
-C -6496. -6495.553
diff --git a/CEP/PyBDSM/src/port3/ex/lgeb.f b/CEP/PyBDSM/src/port3/ex/lgeb.f
deleted file mode 100644
index af577ccf4dfb5a3ad83a83404c66e86e72ebfa9e..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ex/lgeb.f
+++ /dev/null
@@ -1,118 +0,0 @@
-C$TEST LGEB
-C TO RUN AS A MAIN PROGRAM REMOVE NEXT LINE
- SUBROUTINE LGEB
-C***********************************************************************
-C
-C EXAMPLE OF USE OF THE PORT PROGRAM GECE
-C
-C***********************************************************************
- INTEGER N, IA, IB, NB, INTER(5), IREAD, I1MACH
- INTEGER I, J, IWRITE, ITER, IEND
- REAL A(5, 5), SAVEA(5, 5), B(5), SAVEB(5), R(5)
- REAL COND, BNORM, R1MACH, ABS, RNORM
- DOUBLE PRECISION DSDOT
-C
- N=5
- IA=5
- IB=5
- NB=1
- IREAD=I1MACH(1)
-C
- DO 10 I=1,N
- 10 READ(IREAD,11) (A(I,J),J=1,N)
- 11 FORMAT(1X,5F8.0)
- DO 20 I=1,IB
- 20 READ(IREAD,21) B(I)
- 21 FORMAT(F8.0)
-C
-C SAVE THE MATRIX AND RIGHT-HAND SIDE (WHICH WILL BE OVERWRITTEN)
-C
- DO 40 I=1,N
- SAVEB(I)=B(I)
- DO 30 J=1,N
- 30 SAVEA(I,J)=A(I,J)
- 40 CONTINUE
-C
-C SOLVE AX = B USING SEPARATE CALLS TO GECE, GEFS, GEBS
-C
- CALL GECE(N,A,IA,INTER,COND)
- IWRITE=I1MACH(2)
- IF (COND.GE.1.0/R1MACH(4)) WRITE(IWRITE,41)
- 41 FORMAT(49H CONDITION NUMBER HIGH,ACCURATE SOLUTION UNLIKELY)
-C
- CALL GEFS(N,A,IA,B,IB,NB,INTER)
-C
- CALL GEBS(N,A,IA,B,IB,NB)
- WRITE(IWRITE,42)
- 42 FORMAT(44H ESTIMATED CONDITION NUMBER OF THE MATRIX A,)
- WRITE(IWRITE,43) COND
- 43 FORMAT(27H USING ONE CALL TO GECE = ,E15.7)
- BNORM=0.0
- WRITE(IWRITE,44)
- 44 FORMAT(/22H THE FIRST SOLUTION X,)
- WRITE(IWRITE,45)
- 45 FORMAT(41H (USING CALLS TO GECE, GEFS, AND GEBS) = )
-C
-C COMPUTE NORM OF SOLUTION
-C
- DO 50 I=1,N
- BNORM=BNORM + ABS(B(I))
- 50 WRITE(IWRITE,51) B(I)
- 51 FORMAT(1X, 5F20.7)
-C
-C REFINE THE SOLUTION DEPENDING ON THE LENGTH OF THE MANTISSA
-C
- IEND=I1MACH(11)*IFIX(R1MACH(5)/ALOG10(2.0) + 1.0)
- DO 90 ITER=1,IEND
-C COMPUTE RESIDUAL R = B - AX, IN DOUBLE PRECISION
-C
- WRITE(IWRITE,52)
- 52 FORMAT(/27H THE RESIDUAL R = B - AX = )
- DO 70 I=1,IA
- DSDOT=0.0
- DO 60 J=1,N
- 60 DSDOT = DSDOT + DBLE(SAVEA(I,J))*B(J)
- R(I) = SAVEB(I) - DSDOT
- 70 WRITE(IWRITE,51) R(I)
-C
-C SOLVE LU*(DELTA X) = R USING SEPARATE CALLS TO GEFS AND GEBS
-C
- CALL GEFS(N,A,IA,R,IB,NB,INTER)
- CALL GEBS(N,A,IA,R,IB,NB)
-C
-C THE NEW SOLUTION X = X + DELTA X
-C
- WRITE(IWRITE,71)
- 71 FORMAT(/38H THE NEW SOLUTION X = X + DELTA X = )
-C
-C DETERMINE NORM OF CORRECTION AND ADD IN CORRECTION
-C
- RNORM=0.0
- DO 80 I=1,N
- B(I) = B(I) + R(I)
- RNORM=RNORM + ABS(R(I))
- 80 WRITE(IWRITE,51) B(I)
-C
-C TEST FOR CONVERGENCE
-C
- IF(RNORM.LT.R1MACH(4)*BNORM) GO TO 100
- 90 CONTINUE
- WRITE(IWRITE,91)
- 91 FORMAT(/29H ITERATIVE IMPROVEMENT FAILED)
- 100 CONTINUE
- STOP
- END
-C
-C DATA FOR THE EXAMPLE IN THE PORT SHEET... (REMOVE THE C
-C IN COLUMN 1 BEFORE FEEDING THIS DATA TO THE PROGRAM ABOVE.)
-C$DATA
-C 1. -2. 3. 7. -9.
-C -2. 8. -6. 2. 50.
-C 3. -6. 18. -15. -18.
-C 7. 2. -15. 273. 174.
-C -9. 50. -18. 173. 1667.
-C 78.
-C -320.
-C -81.
-C 215.
-C-10856.
diff --git a/CEP/PyBDSM/src/port3/ex/lgef.f b/CEP/PyBDSM/src/port3/ex/lgef.f
deleted file mode 100644
index bd894ac88c126f423d5155f751c44c105ca5e5d5..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ex/lgef.f
+++ /dev/null
@@ -1,63 +0,0 @@
-C$TEST LGEF
-C TO RUN AS A MAIN PROGRAM REMOVE NEXT LINE
- SUBROUTINE LGEF
-C***********************************************************************
-C
-C EXAMPLE OF USE OF THE PORT PROGRAM GELE
-C
-C***********************************************************************
- INTEGER IA, IB, I1MACH, N, I, J, IT, ILAPSZ, IWRITE
- REAL A(100, 100), AA(100, 100), B(100), BB(100)
- REAL SUM, ERR, COND, ABS, TIME, TIMES, AMAX1
- IA=100
- IB =100
-C
-C GENERATE THE MATRIX AND RIGHT-HAND SIDE
-C
- DO 40 N=10,90,40
- DO 20 I=1,N
- SUM=0.0
- DO 10 J=1,N
- A(I,J)=IABS(I-J)
- IF (I.GE.J) A(I,J)=A(I,J) + 1.0
- AA(I,J)=A(I,J)
- SUM=SUM + AA(I,J)
- 10 CONTINUE
- B(I)=SUM
- BB(I)=SUM
- 20 CONTINUE
-C
-C CALL GELE AND TIME IT
- IT =ILAPSZ(0)
- CALL GELE(N,A,IA,B,IB,1)
- TIME=FLOAT(ILAPSZ(0)-IT)/64.0
-C
-C COMPUTE THE MAXIMUM ERROR
-C
- ERR=0.0
- DO 30 I=1,N
- ERR=AMAX1(ERR, ABS(B(I)-1.0))
- 30 CONTINUE
-C
-C CALL GESS
-C
- IT =ILAPSZ(0)
- CALL GESS(N,AA,IA,BB,IB,1,COND)
- TIMES=FLOAT(ILAPSZ(0)-IT)/64.0
- IWRITE=I1MACH(2)
- WRITE(IWRITE,31)N,COND
- 31 FORMAT(8H FOR N= ,I4,20H CONDITION NUMBER = ,E15.7)
- WRITE(IWRITE,32)ERR
- 32 FORMAT(30H MAXIMUM ERROR IN SOLUTION IS ,F15.7)
- WRITE(IWRITE,33)TIME
- 33 FORMAT(34H TIME IN MILLISECONDS FOR GELE IS ,F10.2)
- WRITE(IWRITE,34)TIMES
- 34 FORMAT(34H TIME IN MILLISECONDS FOR GESS IS ,F10.2)
- 40 CONTINUE
- STOP
- END
- INTEGER FUNCTION ILAPSZ(N)
- INTEGER N
- ILAPSZ = 0
- RETURN
- END
diff --git a/CEP/PyBDSM/src/port3/ex/lgeh.f b/CEP/PyBDSM/src/port3/ex/lgeh.f
deleted file mode 100644
index 538b22bec45a99f46c3fb57f19353289f3800bad..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ex/lgeh.f
+++ /dev/null
@@ -1,57 +0,0 @@
-C$TEST LGEH
-C TO RUN AS A MAIN PROGRAM REMOVE NEXT LINE
- SUBROUTINE LGEH
-C***********************************************************************
-C
-C EXAMPLE OF USE OF THE PORT PROGRAM GENM
-C
-C***********************************************************************
- INTEGER I, J, L, N, IA, IWRITE, I1MACH
- REAL A(50, 50), AA(50, 50), B(50), X(50)
- REAL RELERR, RELRES, XNORM, RNORM, ERR, R(50)
- REAL GENM, SAMAX
- IA = 50
-C
-C GENERATE MATRIX
-C
- N=50
- DO 20 I=1,N
- DO 10 J=I,N
- A(I,J)=J-I
- A(J,I)=J-I + 1
- AA(I,J)=A(I,J)
- AA(J,I)=A(J,I)
- 10 CONTINUE
- B(I)=I
- 20 CONTINUE
-C
-C GENERATE RIGHT HAND SIDE
-C
- CALL GEML(N,A,IA,B,X)
-C
-C MAKE COPY OF RIGHT HAND SIDE
-C
- CALL MOVEFR(N,X,B)
-C
-C SOLVE THE SYSTEM
-C
- CALL GELE(N,A,IA,B,N,1)
-C
-C COMPUTE THE RELATIVE ERROR AND THE RELATIVE RESIDUAL
-C
- CALL GEML(N,AA,IA,B,R)
- ERR=0.0
- DO 30 I=1,N
- ERR=AMAX1(ERR,ABS(B(I)-FLOAT(I)))
- R(I)=R(I)-X(I)
- 30 CONTINUE
- XNORM=SAMAX(N,X,1)
- RNORM=SAMAX(N,R,1)
- RELERR=ERR/XNORM
- RELRES=RNORM/(XNORM*GENM(N,AA,IA))
- IWRITE=I1MACH(2)
- WRITE(IWRITE,31)RELERR,RELRES
- 31 FORMAT(16H RELATIVE ERROR=,E15.5,19H RELATIVE RESIDUAL=,
- 1 E15.5)
- STOP
- END
diff --git a/CEP/PyBDSM/src/port3/ex/lgej.f b/CEP/PyBDSM/src/port3/ex/lgej.f
deleted file mode 100644
index 9369a366d590d22768f602dc408d0a7c072abc94..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ex/lgej.f
+++ /dev/null
@@ -1,46 +0,0 @@
-C$TEST LGEJ
-C***********************************************************************
-C
-C EXAMPLE OF USE OF THE PORT PROGRAM GELU
-C
-C***********************************************************************
- SUBROUTINE DET(N,A,IA,DETMAN,IDETEX)
-C
-C THIS SUBROUTINE COMPUTES THE DETERMINANT OF A
-C THE RESULT IS GIVEN BY DETMAN*BETA**IDETEX
-C WHERE BETA IS THE BASE OF THE MACHINE
-C AND DETMAN IS BETWEEN 1/BETA AND 1
-C
- INTEGER N, IA, IDETEX
- INTEGER E, IPOINT, ISTKGT, I1MACH, ISIGN, I
- INTEGER IN(1000)
- REAL A(IA, N), DETMAN, BETA, FLOAT, ONOVBE, M, ABS
- DOUBLE PRECISION D(500)
- COMMON /CSTAK/ D
- EQUIVALENCE(D(1),IN(1))
-C
-C ALLOCATE SPACE FROM THE STACK FOR THE PIVOT ARRAY
-C
- IPOINT=ISTKGT(N,2)
- CALL GELU(N,A,IA,IN(IPOINT),0.0)
-C
-C THE DETERMINANT IS THE PRODUCT OF THE DIAGONAL ELEMENTS
-C AND THE LAST ELEMENT OF THE INTERCHANGE ARRAY
-C WE TRY TO COMPUTE THIS PRODUCT IN A WAY THAT WILL
-C AVOID UNDERFLOW AND OVERFLOW
-C
- BETA=FLOAT(I1MACH(10))
- ONOVBE=1.0/BETA
- ISIGN=IPOINT + N-1
- DETMAN=IN(ISIGN)*ONOVBE
- IDETEX=1
- DO 10 I=1,N
- CALL UMKFL(A(I,I),E,M)
- DETMAN=DETMAN*M
- IDETEX=IDETEX+E
- IF(ABS(DETMAN).GE.ONOVBE) GO TO 10
- IDETEX=IDETEX-1
- DETMAN=DETMAN*BETA
- 10 CONTINUE
- RETURN
- END
diff --git a/CEP/PyBDSM/src/port3/ex/lgel.f b/CEP/PyBDSM/src/port3/ex/lgel.f
deleted file mode 100644
index eaccbe80c33c80225241de916aa32e51a53f8219..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ex/lgel.f
+++ /dev/null
@@ -1,29 +0,0 @@
-C$TEST LGEL
-C TO RUN AS A MAIN PROGRAM REMOVE NEXT LINE
- SUBROUTINE LGEL
-C***********************************************************************
-C
-C EXAMPLE OF USE OF THE PORT PROGRAM GEBS
-C
-C***********************************************************************
- INTEGER N, I, J, IWRITE, I1MACH
- REAL A(15,15), B(15)
- N=15
-C
-C FORM THE MATRIX AND SET THE RIGHT-HAND SIDE
-C TO THE LAST COLUMN OF THE IDENTITY MATRIX
- DO 20 I=1,N
- DO 10 J=I,N
- A(I,J) = -1.0
- 10 CONTINUE
- A(I,I) = 1.0
- B(I) = 0.0
- 20 CONTINUE
- B(N)=1.0
-C FIND THE LAST COLUMN OF THE INVERSE MATRIX
- CALL GEBS(N,A,15,B,N,1)
- IWRITE=I1MACH(2)
- WRITE(IWRITE,21)(I,B(I),I=1,N)
- 21 FORMAT(3H B(,I3,3H )=,F15.4)
- STOP
- END
diff --git a/CEP/PyBDSM/src/port3/ex/lgem.f b/CEP/PyBDSM/src/port3/ex/lgem.f
deleted file mode 100644
index 5898add01234d6d09f904a881b78689cc72a25c4..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ex/lgem.f
+++ /dev/null
@@ -1,57 +0,0 @@
-C$TEST LGEM
-C TO RUN AS A MAIN PROGRAM REMOVE NEXT LINE
- SUBROUTINE LGEM
-C***********************************************************************
-C
-C EXAMPLE OF USE OF THE PORT PROGRAM GEML
-C
-C***********************************************************************
- INTEGER I, J, IWRITE, I1MACH, N
- REAL A(10, 10), X(10), B(10)
- REAL ERR, SASUM, UNI, COND
- N=10
-C
-C CONSTRUCT A MATRIX
-C
- DO 20 I=1,N
- DO 10 J=I,N
- A(I,J)=J-I
- A(J,I)=J-I + 1
- 10 CONTINUE
- 20 CONTINUE
-C
-C CONSTRUCT A RANDOM VECTOR X
-C
- DO 30 I=1,N
- X(I)=UNI(0)
- 30 CONTINUE
-C
-C FIND THE VECTOR B=AX
-C
- CALL GEML(N,A,10,X,B)
-C
-C SOLVE THE SYSTEM AX=B
-C
- CALL GESS(N,A,10,B,N,1,COND)
-C
-C PRINT THE COMPUTED AND TRUE SOLUTION
-C
- IWRITE=I1MACH(2)
- WRITE(IWRITE,31)
- 31 FORMAT(34H TRUE SOLUTION COMPUTED SOLUTION)
- WRITE(IWRITE,32)(X(I),B(I),I=1,N)
- 32 FORMAT(1H ,2E17.8)
-C
-C COMPUTE THE RELATIVE ERROR
-C
- ERR=0.0
- DO 40 I=1,N
- ERR=ERR + ABS(B(I)-X(I))
- 40 CONTINUE
- ERR=ERR/SASUM(N,X,1)
- WRITE(IWRITE,41)ERR
- 41 FORMAT(19H RELATIVE ERROR IS ,1PE15.7)
- WRITE(6,42)COND
- 42 FORMAT(21H CONDITION NUMBER IS ,1PE15.7)
- STOP
- END
diff --git a/CEP/PyBDSM/src/port3/ex/llza.f b/CEP/PyBDSM/src/port3/ex/llza.f
deleted file mode 100644
index 505ec571abc1241b9562e58dc0d51737f96a82aa..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ex/llza.f
+++ /dev/null
@@ -1,56 +0,0 @@
-C$TEST LLZA
-C TO RUN AS A MAIN PROGRAM REMOVE NEXT LINE
- SUBROUTINE LLZA
-C***********************************************************************
-C
-C EXAMPLE OF USE OF THE PORT PROGRAM LZ
-C
-C***********************************************************************
- COMPLEX B(5,5),A(5,5),EIGA(5),EIGB(5),X,EIG
- IIN=I1MACH(1)
- IOUT=I1MACH(2)
-C
-C READ IN MATRICES
-C
- READ(IIN,10)((A(I,J),J=1,5),I=1,5)
- READ(IIN,10)((B(I,J),J=1,5),I=1,5)
- 10 FORMAT(10F6.0)
-C
-C PRINT MATRICES
-C
- WRITE(IOUT,20)
- 20 FORMAT(13H THE A MATRIX)
- WRITE(IOUT,30)((A(I,J),J=1,5),I=1,5)
- 30 FORMAT(5(F6.0,2H+ ,F6.0,1HI))
- WRITE(IOUT,40)
- 40 FORMAT(13H THE B MATRIX)
- WRITE(IOUT,30)((B(I,J),J=1,5), I=1,5)
-C
-C SOLVE THE EIGENVALUE PROBLEM
-C
- CALL LZ(5,A,5,B,5,X,1,.FALSE.,EIGA,EIGB)
- WRITE(IOUT,50)
- 50 FORMAT(10X,4HEIGA,16X,4HEIGB,22X,10HEIGENVALUE)
- DO 60 I=1,5
- EIG=CMPLX(R1MACH(2),R1MACH(2))
- IF(REAL(EIGB(I)).NE.0.0.OR.AIMAG(EIGB(I)).NE.0.0)
- 1 EIG=EIGA(I)/EIGB(I)
- WRITE(IOUT,70)EIGA(I),EIGB(I),EIG
- 60 CONTINUE
- 70 FORMAT(1H ,2E10.3,2X,2E10.3,2X,2E16.8)
- STOP
- END
-C
-C DATA FOR THE EXAMPLE IN THE PORT SHEET... (REMOVE THE C
-C IN COLUMN 1 BEFORE FEEDING THIS DATA TO THE PROGRAM ABOVE.)
-C$DATA
-C 41. -369. -143. -747. -20.-1368. 20. 486. 104. -432.
-C 148. 261. 144. 666. -6.-1152. -78. 45. 8. -540.
-C -19. 819. 87. 243. 4. 1548. -56. -954. -164. 180.
-C -60. -945. -81. -279. 99. 171. 34. 441. 84. -144.
-C 1. -468. 133. 747. 132. 774. -46. -45. -12. -216.
-C 90. 161. 180. 335. 36. 182. -90. -162. -72. -36.
-C -105. -169. -210. -322. -42. 24. 105. 167. 84. 204.
-C -90. -211. -180. -307. -36. -160. 90. 186. 72. 36.
-C 75. 205. 150. 215. 30. 45. -75. -165. -60. -80.
-C -75. -48. -150. -299. -30. -102. 75. 89. 60. 88.
diff --git a/CEP/PyBDSM/src/port3/ex/lnab.f b/CEP/PyBDSM/src/port3/ex/lnab.f
deleted file mode 100644
index eb407ae7a0c77f2e5d4b62ae962d73f9db552c5f..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ex/lnab.f
+++ /dev/null
@@ -1,63 +0,0 @@
-C$TEST LNAB
-C TO RUN AS A MAIN PROGRAM REMOVE NEXT LINE
- SUBROUTINE LNAB
-C***********************************************************************
-C
-C EXAMPLE OF USE OF THE PORT PROGRAM LSTSQ
-C
-C***********************************************************************
- REAL X(10,2), Y(10), C(2), XX(10,2), YY(10)
-C
-C SET THE FIRST COLUMN OF THE X ARRAY TO THE ACTUAL X,
-C AND THE SECOND COLUMN TO 1.0
-C
- DO 10 K=1,6
- X(K,1) = FLOAT(K)
- 10 X(K,2) = 1.
-C
-C SET THE VALUES OF THE RIGHT-HAND SIDE, Y
-C
- Y(1) = .3
- Y(2) = .95
- Y(3) = 2.6
- Y(4) = 2.5
- Y(5) = 2.3
- Y(6) = 3.95
-C
-C SINCE LSTSQ WRITES OVER THE ARRAYS X AND Y,
-C SAVE THEM FOR LATER DEMONSTRATION COMPUTATION.
-C
- DO 15 K=1,6
- YY(K) = Y(K)
- DO 15 J=1,2
- 15 XX(K,J)=X(K,J)
-C
- CALL LSTSQ (10,2,6,2,X,Y,1,C)
-C
- IWRITE = I1MACH(2)
- WRITE(IWRITE,97) C(1), C(2)
- 97 FORMAT (8H0C(1) = ,E16.8, 11H C(2) = ,E16.8)
-C
-C COMPUTE THE SUM OF THE SQUARES OF THE ERROR
-C USING BRUTE FORCE.
-C
- ERR = 0.
- DO 20 J=1,6
- ADD = (C(1)*XX(J,1)+C(2)-YY(J))**2
- 20 ERR = ERR + ADD
-C
- WRITE(IWRITE,98) ERR
- 98 FORMAT(35H0LEAST-SQUARES ERROR (VERSION 1) = ,E16.8)
-C
-C COMPUTE THE LEAST-SQUARES ERROR USING THE PROGRAM SOLUTION.
-C
- ERR = 0.
- DO 30 L=3,6
- ERR = ERR + Y(L)*Y(L)
- 30 CONTINUE
-C
- WRITE(IWRITE,99) ERR
- 99 FORMAT(35H0LEAST-SQUARES ERROR (VERSION 2) = ,E16.8)
-C
- STOP
- END
diff --git a/CEP/PyBDSM/src/port3/ex/lpsa.f b/CEP/PyBDSM/src/port3/ex/lpsa.f
deleted file mode 100644
index bae76069d2d7f6d09a8e759ef47bbbd342c6f5a5..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ex/lpsa.f
+++ /dev/null
@@ -1,44 +0,0 @@
-C$TEST LPSA
-C TO RUN AS A MAIN PROGRAM REMOVE NEXT LINE
- SUBROUTINE LPSA
-C***********************************************************************
-C
-C EXAMPLE OF USE OF THE PORT PROGRAM BPSS
-C
-C***********************************************************************
- INTEGER N, K, I, IWRITE, I1MACH, MU
- REAL G(2,100), B(200)
- REAL X, COND, ERR, AMAX1
-C CONSTRUCT MATRIX AND RIGHT-HAND SIDE SO TRUE SOLUTION IS
-C COMPOSED ENTIRELY OF ONES
- N=100
- X=1
- DO 30 K=1,3
- DO 10 I=1,N
- G(1,I)=2.0
- G(2,I)=-1.0
- B(I)=0.0
- 10 CONTINUE
- G(1,1)=1.0+X
- G(1,N)=1.0+X
- B(1)=X
- B(N)=X
-C SOLVE THE SYSTEM
- MU=2
- CALL BPSS(N,MU,G,2,B,N,1,COND)
- IWRITE=I1MACH(2)
- WRITE(IWRITE,11)X
- 11 FORMAT(/5H X IS,F15.7)
- WRITE(IWRITE,12)COND
- 12 FORMAT(20H CONDITION NUMBER IS,1PE15.7)
-C COMPUTE THE ERROR
- ERR=0.0
- DO 20 I=1,N
- ERR=AMAX1(ERR,ABS(B(I)-1.0))
- 20 CONTINUE
- WRITE(IWRITE,21)ERR
- 21 FORMAT(22H FOR BPSS THE ERROR IS,F16.8)
- X=X/100.
- 30 CONTINUE
- STOP
- END
diff --git a/CEP/PyBDSM/src/port3/ex/lpsb.f b/CEP/PyBDSM/src/port3/ex/lpsb.f
deleted file mode 100644
index 8a1b829379b3b376063ae375e26ee1af8ab8c80d..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ex/lpsb.f
+++ /dev/null
@@ -1,57 +0,0 @@
-C$TEST LPSB
-C TO RUN AS A MAIN PROGRAM REMOVE NEXT LINE
- SUBROUTINE LPSB
-C***********************************************************************
-C
-C EXAMPLE OF USE OF THE PORT PROGRAM BPCE
-C
-C***********************************************************************
- INTEGER N, MU, IG, K, I, IWRITE, I1MACH, J
- REAL G(2,100), B(200)
- REAL X, COND, AINVNO, AINORM, ABS
- N=100
- X=1.0
- MU=2
- IG=2
- DO 50 K=1,3
-C CONSTRUCT MATRIX
- DO 10 I=1,N
- G(1,I)=2.0
- G(2,I)=-1.0
- 10 CONTINUE
- G(1,1)=1.0+X
- G(1,N)=1.0+X
-C GET ESTIMATE OF CONDITION NUMBER FROM BPCE
- CALL BPCE(N,MU,G,IG,COND)
- IWRITE=I1MACH(2)
- WRITE(IWRITE,11)X
- 11 FORMAT(/10H WHEN X IS,E14.6)
- WRITE(IWRITE,12)COND
- 12 FORMAT(25H CONDITION ESTIMATE IS ,E15.8)
-C SINCE CONDITION NUMBER IS NORM(A)*NORM(INVERSE(A)),
-C FIND THE NORM OF EACH COLUMN OF INVERSE(A). GENERATE
-C THE COLUMNS ONE AT A TIME AND REUSE SPACE
- AINVNO=0.0
- DO 40 I=1,N
-C GENERATE ITH COLUMN OF IDENTITY MATRIX AS RIGHT HAND SIDE
- DO 20 J=1,N
- B(J)=0.0
- 20 CONTINUE
- B(I)=1.0
-C SOLVE AX=B TO GET ITH COLUMN OF A(INVERSE)
- CALL BPFS(N,MU,G,IG,B,N,1)
- CALL BPBS(N,MU,G,IG,B,N,1)
-C FIND NORM OF COLUMN
- AINORM=0.0
- DO 30 J=1,N
- AINORM=AINORM+ABS(B(J))
- 30 CONTINUE
- IF(AINVNO.LT.AINORM)AINVNO=AINORM
- 40 CONTINUE
- COND=4.0*AINVNO
- WRITE(IWRITE,41)COND
- 41 FORMAT(25H TRUE CONDITION NUMBER IS,E15.8)
- X=X/100.0
- 50 CONTINUE
- STOP
- END
diff --git a/CEP/PyBDSM/src/port3/ex/lpsf.f b/CEP/PyBDSM/src/port3/ex/lpsf.f
deleted file mode 100644
index 99d3c4be7664e940296079f10af159e66f816e15..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ex/lpsf.f
+++ /dev/null
@@ -1,55 +0,0 @@
-C$TEST LPSF
-C TO RUN AS A MAIN PROGRAM REMOVE NEXT LINE
- SUBROUTINE LPSF
-C***********************************************************************
-C
-C EXAMPLE OF USE OF THE PORT PROGRAM BPLE
-C
-C***********************************************************************
- INTEGER IG, N, MU, MLM1, I, KBLOK, KK, J
- INTEGER IWRITE, I1MACH
- REAL G(11,100), B(100), X(100)
- REAL ERR, AMAX1
- IG=11
- N=100
- MU=11
-C
-C SET UP MATRIX FOR ELLIPTIC PDE IN 2 DIMENSIONS
-C
- MLM1=MU-1
- I=0
- DO 30 KBLOK=1,MLM1
- DO 20 KK=1,MLM1
- I=I+1
- G(1,I)=4.0
- G(2,I)=-1.0
- DO 10 J=3,MLM1
- G(J,I)=0.0
- 10 CONTINUE
- G(MU,I)=-1.0
- 20 CONTINUE
- G(2,I)=0.0
- 30 CONTINUE
-C
-C SET UP RIGHT HAND SIDE SO SOLUTION IS ALL 1'S
-C
- DO 40 I=1,N
- X(I)=1.0
- 40 CONTINUE
- CALL BPML(N,MU,G,IG,X,B)
-C
-C SOLVE THE SYSTEM
-C
- CALL BPLE(N,MU,G,IG,B,100,1)
-C
-C COMPUTE THE ERROR
-C
- ERR=0.0
- DO 50 I=1,N
- ERR=AMAX1(ERR,ABS(B(I)-1.0))
- 50 CONTINUE
- IWRITE=I1MACH(2)
- WRITE(IWRITE,51)ERR
- 51 FORMAT(31H ERROR IN SOLUTION FROM BPLE IS,F15.8)
- STOP
- END
diff --git a/CEP/PyBDSM/src/port3/ex/lpsg.f b/CEP/PyBDSM/src/port3/ex/lpsg.f
deleted file mode 100644
index 64a6b80da296fa751c0a8f1361631a0d7fe5003f..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ex/lpsg.f
+++ /dev/null
@@ -1,71 +0,0 @@
-C$TEST LPSG
-C TO RUN AS A MAIN PROGRAM REMOVE NEXT LINE
- SUBROUTINE LPSG
-C***********************************************************************
-C
-C EXAMPLE OF USE OF THE PORT PROGRAM BPDC
-C
-C***********************************************************************
- INTEGER IG, MLM1, IWRITE, I1MACH, K, N, MU
- INTEGER NBLOK, KBLOK, KK, I, J, IT, ILAPSZ, IT2
- REAL G(17, 100), G2(17, 100), G3(17, 100)
- REAL COND
- IG=17
- MLM1=4
- IWRITE=I1MACH(2)
- DO 70 K=1,3
- DO 60 N=48,96,48
- MU=MLM1+1
- I=0
- NBLOK=N/MLM1
-C
-C SET UP THREE MATRICES FOR ELLIPTIC PDE IN 2 DIMENSION
-C
- DO 30 KBLOK=1,NBLOK
- DO 20 KK=1,MLM1
- I=I+1
- G(1,I)=4.0
- G(2,I)=-1.0
- G(MU,I)=-1.0
- DO 10 J=3,MLM1
- G(J,I)=0.0
- 10 CONTINUE
- 20 CONTINUE
- G(2,I)=0.0
- 30 CONTINUE
- DO 50 I=1,N
- DO 40 J=1,MU
- G2(J,I)=G(J,I)
- G3(J,I)=G(J,I)
- 40 CONTINUE
- 50 CONTINUE
- WRITE(IWRITE,51)N,MU
- 51 FORMAT(/6H N IS ,I4,30H ,NUMBER OF UPPER DIAGONALS IS,I3)
-C TIME DECOMPOSITION BY BPLD
- IT=ILAPSZ(0)
- CALL BPLD(N,MU,G,IG,0.0)
- IT=ILAPSZ(0)-IT
- WRITE(IWRITE,52)IT
- 52 FORMAT(14H TIME FOR BPLD,I7)
-C TIME DECOMPOSITION BY BPDC
- IT2=ILAPSZ(0)
- CALL BPDC(N,MU,G2,IG)
- IT2=ILAPSZ(0)-IT2
- WRITE(IWRITE,53)IT2
- 53 FORMAT(14H TIME FOR BPDC,I7)
-C TIME DECOMPOSITION BY BPCE
- IT3=ILAPSZ(0)
- CALL BPCE(N,MU,G3,IG,COND)
- IT3=ILAPSZ(0)-IT3
- WRITE(IWRITE,54)IT3
- 54 FORMAT(14H TIME FOR BPCE,I7)
- 60 CONTINUE
- MLM1=MLM1*2
- 70 CONTINUE
- STOP
- END
- INTEGER FUNCTION ILAPSZ(N)
- INTEGER N
- ILAPSZ = 0
- RETURN
- END
diff --git a/CEP/PyBDSM/src/port3/ex/lpsj.f b/CEP/PyBDSM/src/port3/ex/lpsj.f
deleted file mode 100644
index 8154158bc20cb388d6a58df867a9b4c6d66f7c50..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ex/lpsj.f
+++ /dev/null
@@ -1,38 +0,0 @@
-C$TEST LPSJ
-C***********************************************************************
-C
-C EXAMPLE OF USE OF THE PORT PROGRAM BPLD
-C
-C***********************************************************************
- SUBROUTINE BPDET(N,MU,G,IG,DETMAN,IDETEX)
-C
-C THIS SUBROUTINE COMPUTES THE DETERMINANT OF A
-C BAND SYMMETRIC POSITIVE DEFINITE MATRIX STORED IN G.
-C IT IS GIVEN BY DETMAN*BETA**IDETEX
-C WHERE BETA IS THE BASE OF THE MACHINE
-C AND DETMAN IS BETWEEN 1/BETA AND 1
-C
- REAL G(IG,N),DETMAN
- REAL ONOVBE,M
- INTEGER E
- INTEGER IDETEX
- CALL BPLD(N,MU,G,IG,0.0)
-C
-C THE DETERMINANT IS THE PRODUCT OF THE ELEMENTS OF ROW 1 OF G
-C WE TRY TO COMPUTE THIS PRODUCT IN A WAY THAT WILL
-C AVOID UNDERFLOW AND OVERFLOW
-C
- ONOVBE=1.0/FLOAT(I1MACH(10))
- DETMAN=ONOVBE
- BETA=FLOAT(I1MACH(10))
- IDETEX=1
- DO 10 I=1,N
- CALL UMKFL(G(1,I),E,M)
- DETMAN=DETMAN*M
- IDETEX=IDETEX+E
- IF(DETMAN.GE.ONOVBE) GO TO 10
- IDETEX=IDETEX-1
- DETMAN=DETMAN*BETA
- 10 CONTINUE
- RETURN
- END
diff --git a/CEP/PyBDSM/src/port3/ex/lpsk.f b/CEP/PyBDSM/src/port3/ex/lpsk.f
deleted file mode 100644
index 88efd068be84f43e7292930bdf5b5cb4f0e62138..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ex/lpsk.f
+++ /dev/null
@@ -1,80 +0,0 @@
-C$TEST LPSK
-C TO RUN AS A MAIN PROGRAM REMOVE NEXT LINE
- SUBROUTINE LPSK
-C***********************************************************************
-C
-C EXAMPLE OF USE OF THE PORT PROGRAM BPFS
-C
-C***********************************************************************
- INTEGER N, ML, IG, NM1, K, I, IWRITE, I1MACH, IT, IEND, ITER
- REAL G(2,100), B(200), R(200)
- REAL X, ERR, AMAX1, RNORM, BNORM, R1MACH, ABS
- DOUBLE PRECISION DBLE
-C CONSTRUCT MATRIX AND RIGHT HAND SIDE SO TRUE SOLUTION IS
-C COMPOSED ENTIRELY OF 1S
- N=100
- X=1
- ML=2
- IG=2
- NM1=N-1
- DO 90 K=1,3
- DO 10 I=1,N
- G(1,I)=2.0
- G(2,I)=-1.0
- B(I)=0.0
- 10 CONTINUE
- G(1,1)=1.0+X
- G(1,N)=1.0+X
- B(1)=X
- B(N)=X
-C SOLVE THE SYSTEM
- CALL BPLE(N,ML,G,IG,B,N,1)
- IWRITE=I1MACH(2)
- WRITE(IWRITE,11)X
- 11 FORMAT(/5H X IS,F16.8)
-C COMPUTE THE ERROR
- ERR=0.0
- DO 20 I=1,N
- ERR=AMAX1(ERR,ABS(B(I)-1.0))
- 20 CONTINUE
- WRITE(IWRITE,21)ERR
- 21 FORMAT(22H FOR BPLE THE ERROR IS,F16.8)
- IEND=I1MACH(11)*IFIX(R1MACH(5)/ALOG10(2.0)+1.0)
-C FIND THE NORM OF THE SOLUTION
- BNORM=0.0
- DO 30 I=1,N
- BNORM=AMAX1(BNORM,ABS(B(I)))
- 30 CONTINUE
-C REFINE THE SOLUTION
- DO 60 ITER=1,IEND
- IT=ITER
-C COMPUTE THE RESIDUAL R=B-AX, IN DOUBLE PRECISION
- DO 40 I=2,NM1
- R(I)=DBLE(B(I-1))+DBLE(B(I+1))-2.D0*DBLE(B(I))
- 40 CONTINUE
- R(1)=X+B(2)-DBLE(1.0+X)*DBLE(B(1))
- R(N)=X+B(N-1)-DBLE(1.+X)*DBLE(B(N))
-C SOLVE A(DELTAX)=R
- CALL BPFS(N,ML,G,IG,R,N,1)
- CALL BPBS(N,ML,G,IG,R,N,1)
-C DETERMINE NORM OF CORRECTION AND ADD IN CORRECTION
- RNORM=0.0
- DO 50 I=1,N
- B(I)=B(I)+R(I)
- RNORM=RNORM+ABS(R(I))
- 50 CONTINUE
- IF(RNORM.LT.R1MACH(4)*BNORM) GO TO 70
- 60 CONTINUE
- WRITE(IWRITE,61)
- 61 FORMAT(18H REFINEMENT FAILED)
-C COMPUTE NEW ERROR
- 70 ERR=0.0
- DO 80 I=1,N
- ERR=AMAX1(ERR,ABS(B(I)-1.0))
- 80 CONTINUE
- WRITE(IWRITE,81)IT,ERR
- 81 FORMAT(24H ERROR AFTER REFINEMENT ,I4,3H IS,E14.7)
- X=X/100.0
- 90 CONTINUE
- STOP
- END
diff --git a/CEP/PyBDSM/src/port3/ex/lpsm.f b/CEP/PyBDSM/src/port3/ex/lpsm.f
deleted file mode 100644
index 92c9ff224e6120028901d6c13bf6b21f2d9086d3..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ex/lpsm.f
+++ /dev/null
@@ -1,55 +0,0 @@
-C$TEST LPSM
-C TO RUN AS A MAIN PROGRAM REMOVE NEXT LINE
- SUBROUTINE LPSM
-C***********************************************************************
-C
-C EXAMPLE OF USE OF THE PORT PROGRAM BPML
-C
-C***********************************************************************
- INTEGER IG, N, MU, I, IWRITE, I1MACH
- REAL G(3,20), X(20), B(20)
- REAL UNI, ERR, COND, SASUM, ABS
- IG=3
- N=10
- MU=3
-C
-C CONSTRUCT MATRIX A AND PACK IT INTO G
-C
- DO 10 I=1,N
- G(1,I)=4.0
- G(2,I)=-1.0
- G(3,I)=-1.0
- 10 CONTINUE
-C
-C CONSTRUCT A RANDOM VECTOR
-C
- DO 20 I=1,N
- X(I)=UNI(0)
- 20 CONTINUE
-C
-C CONSTRUCT B=AX
-C
- CALL BPML(N,MU,G,IG,X,B)
-C
-C SOLVE THE SYSTEM AX=B
-C
- CALL BPSS(N,MU,G,IG,B,N,1,COND)
-C
-C PRINT OUT THE TRUE SOLUTION AND THE COMPUTED SOLUTION
-C
- IWRITE=I1MACH(2)
- WRITE(IWRITE,21)
- 21 FORMAT(34H TRUE SOLUTION COMPUTED SOLUTION)
- WRITE(IWRITE,22)(X(I),B(I),I=1,N)
- 22 FORMAT(1H ,2E16.8)
- ERR=0.0
- DO 30 I=1,N
- ERR=ERR+ABS(B(I)-X(I))
- 30 CONTINUE
- ERR=ERR/SASUM(N,X,1)
- WRITE(IWRITE,31)ERR
- 31 FORMAT(19H RELATIVE ERROR IS ,1PE15.7)
- WRITE(IWRITE,32)COND
- 32 FORMAT(20H CONDITION NUMBER IS,1PE15.7)
- STOP
- END
diff --git a/CEP/PyBDSM/src/port3/ex/lrpa.f b/CEP/PyBDSM/src/port3/ex/lrpa.f
deleted file mode 100644
index 9c444d78c5c460894f46ff31a4eeadcf2c8e7deb..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ex/lrpa.f
+++ /dev/null
@@ -1,56 +0,0 @@
-C$TEST LRPA
-C TO RUN AS A MAIN PROGRAM REMOVE NEXT LINE
- SUBROUTINE LRPA
-C***********************************************************************
-C
-C EXAMPLE OF USE OF THE PORT PROGRAM LINPR
-C
-C***********************************************************************
- REAL X(4),B(3),C(4),A(3,4),SIMP(8)
- INTEGER ISIMP(8)
- N=4
- IA=3
- M=3
- IE=1
-C
-C SET UP GENERAL CONSTRAINTS
-C
- DO 10 J=1,N
- A(1,J)=FLOAT(J)
- A(2,J)=0.0
- A(3,J)=0.0
- 10 CONTINUE
- A(2,1)=1.0
- A(2,2)=1.0
- A(3,2)=-1.0
- A(3,4)=-1.0
- B(1)=5
- B(2)=1.0
- B(3)=-5.0
-C
-C SET UP SIMPLE CONSTRAINTS
-C
- IS=8
- DO 20 I=1,N
- SIMP(I)=FLOAT(-I)
- ISIMP(I)=I
- SIMP(I+N)=10.0
- ISIMP(I+N)=-I
- 20 CONTINUE
-C
-C SET UP COST VECTOR AND INITIAL GUESS
-C
- DO 30 I=1,N
- C(I)=FLOAT(I+1)
- X(I)=1.0
- 30 CONTINUE
-C
-C CALL LINEAR PROGRAMMING PACKAGE
-C
- CALL LINPR(A,M,N,IA,B,C,X,15,CTX,IS,SIMP,ISIMP,IE)
- WRITE(6,21)(X(I),I=1,N)
- 21 FORMAT(11H SOLUTION: ,4E15.6)
- WRITE(6,22)CTX
- 22 FORMAT(17H FUNCTION VALUE: ,E15.5)
- STOP
- END
diff --git a/CEP/PyBDSM/src/port3/ex/lrpb.f b/CEP/PyBDSM/src/port3/ex/lrpb.f
deleted file mode 100644
index 70deca40a7f5209d95d8b32eebf1d2acec0f6aba..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ex/lrpb.f
+++ /dev/null
@@ -1,99 +0,0 @@
-C$TEST LRPB
-C TO RUN AS A MAIN PROGRAM REMOVE NEXT LINE
- SUBROUTINE LRPB
-C***********************************************************************
-C
-C FIRST EXAMPLE OF USE OF THE PORT PROGRAM LINPA
-C
-C***********************************************************************
- REAL X(4),B(3),C(4),A(3,4),SIMP(8)
- EXTERNAL LPMAN, PRINT
- INTEGER ISIMP(8),IPTG(3)
- REAL U(4)
- N=4
- IA=3
- M=3
- IE=1
-C
-C SET UP GENERAL CONSTRAINTS
-C
- DO 10 J=1,N
- A(1,J)=FLOAT(J)
- A(2,J)=0.0
- A(3,J)=0.0
- 10 CONTINUE
- A(2,1)=1.0
- A(2,2)=1.0
- A(3,2)=-1.0
- A(3,4)=-1.0
- B(1)=5
- B(2)=1.0
- B(3)=-5.0
-C
-C SET UP SIMPLE CONSTRAINTS
-C
- IS=8
- DO 20 I=1,N
- SIMP(I)=FLOAT(-I)
- ISIMP(I)=I
- SIMP(I+N)=10.0
- ISIMP(I+N)=-I
- 20 CONTINUE
-C
-C SET UP COST VECTOR AND INITIAL GUESS
-C
- DO 30 I=1,N
- C(I)=FLOAT(I+1)
- X(I)=1.0
- 30 CONTINUE
-C
-C CALL LINEAR PROGRAMMING PACKAGE
-C
- CALL LINPA(A,M,N,LPMAN,IA,B,C,X,15,CTX,IS,SIMP,ISIMP,IE,
- 1PRINT,IAG,IAS,IPTG,U)
- IWRITE=I1MACH(2)
- WRITE(IWRITE,21)(X(I),I=1,N)
- 21 FORMAT(11H SOLUTION: ,4E15.6)
- WRITE(IWRITE,22)CTX
- 22 FORMAT(17H FUNCTION VALUE: ,E15.5)
- STOP
- END
- SUBROUTINE PRINT(A,M,N,AMAN,IA,B,C,X,CTX,IS,SIMP,ISIMP,IE,
- 1 ITER,IPTG,IAG,IAS,U,IEND)
-C
-C THIS IS A PRINT ROUTINE
-C
- REAL CTX,A(1),X(N),B(1)
- LOGICAL IEND
- EXTERNAL AMAN
- INTEGER IA(1),IPTG(N),ISIMP(1),S
- REAL SIMP(1),C(1),U(1)
- IEND = .FALSE.
- IWRITE=I1MACH(2)
- TOL = -R1MACH(4)*(5.0+4.0*SASUM(N,X,1))*10.0
- IAGPE=IAG+IE
- WRITE(IWRITE,1)ITER,CTX,IAGPE,IAS
- 1 FORMAT(/14H AT ITERATION ,I5,6H CTX= ,E15.5,
- 1 /18H NO.OF ACT. GEN.= ,I5,15H NO.OF ACT.SIM=,I5)
- WRITE(IWRITE,2)(X(I),I=1,N)
- 2 FORMAT(3H X ,5E15.5)
- DO 10 I=1,M
- CALL AMAN(.TRUE.,A,IA,N,I,X,TOUT)
- TOUT=TOUT-B(I)
- IF (TOUT .LT. TOL)IEND=.TRUE.
- WRITE(IWRITE,9)I,TOUT
- 9 FORMAT(15H AT CONSTRAINT ,I5,11H RESIDUAL= ,E15.5)
- 10 CONTINUE
- IF (IAGPE .EQ. 0)GO TO 12
- WRITE(IWRITE,11)(IPTG(I),I=1,IAGPE)
- 11 FORMAT(29H ACTIVE GENERAL CONSTRAINTS ,10I4)
- 12 IF (IAS .LT. 1)RETURN
- DO 15 I=1,IAS
- IP=IABS(ISIMP(I))
- IF (ISIMP(I) .GT. 0)WRITE(IWRITE,13)IP
- 13 FORMAT(18H LOWER BOUND ON X(,I2,11H) IS ACTIVE)
- IF (ISIMP(I) .LT. 0)WRITE(IWRITE,14)IP
- 14 FORMAT(18H UPPER BOUND ON X(,I2,11H) IS ACTIVE)
- 15 CONTINUE
- RETURN
- END
diff --git a/CEP/PyBDSM/src/port3/ex/lrpe.f b/CEP/PyBDSM/src/port3/ex/lrpe.f
deleted file mode 100644
index d596591cfe393b22aed08bb474ab4d141970beff..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ex/lrpe.f
+++ /dev/null
@@ -1,62 +0,0 @@
-C$TEST LRPE
-C TO RUN AS A MAIN PROGRAM REMOVE NEXT LINE
- SUBROUTINE LRPE
-C***********************************************************************
-C
-C EXAMPLE OF USE OF THE PORT PROGRAM FEAS
-C
-C***********************************************************************
- REAL X(4),B(5),A(5,4),SIMP(8)
- INTEGER ISIMP(8)
- DATA B(1)/5.0/,B(2)/9.0/,B(3)/9.0/,B(4)/1.0/,B(5)/-5.0/
- N=4
- IA=5
- M=5
- IE=2
- IWRITE=I1MACH(2)
-C
-C SET UP GENERAL CONSTRAINTS
-C
- DO 10 J=1,N
- A(1,J)=FLOAT(J)
- A(2,J)=FLOAT(J+1)
- A(3,J)=FLOAT(J*J)
- A(4,J)=0.0
- A(5,J)=0.0
- 10 CONTINUE
- A(4,1)=1.0
- A(4,2)=1.0
- A(5,2)=-1.0
- A(5,4)=-1.0
-C
-C SET UP SIMPLE CONSTRAINTS
-C
- IS=8
- DO 20 I=1,N
- SIMP(I)=FLOAT(-I)
- ISIMP(I)=I
- SIMP(I+N)=FLOAT(I+2)
- ISIMP(I+N)=-I
- 20 CONTINUE
-C
-C SET UP INITIAL GUESS
-C
- DO 30 I=1,N
- X(I)=1.0
- 30 CONTINUE
-C
-C CALL FEASIBLE POINT ALGORITHM
-C
- CALL FEAS(A,M,N,IA,B,X,15,IS,SIMP,ISIMP,IE)
- WRITE(IWRITE,31)(X(I),I=1,N)
- 31 FORMAT(11H SOLUTION: ,4E15.6)
-C
-C CHECK ANSWER
-C
- DO 40 I=1,M
- S = SDOT(N, A(I,1), IA, X, 1) -B(I)
- WRITE(IWRITE,41)I, S
- 40 CONTINUE
- 41 FORMAT(28H THE RESIDUAL AT CONSTRAINT ,I4,4H IS ,E15.5)
- STOP
- END
diff --git a/CEP/PyBDSM/src/port3/ex/lrpf.f b/CEP/PyBDSM/src/port3/ex/lrpf.f
deleted file mode 100644
index 264872aa58414a66777af2d4566b9af041dc30a1..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ex/lrpf.f
+++ /dev/null
@@ -1,101 +0,0 @@
-C$TEST LRPF
-C TO RUN AS A MAIN PROGRAM REMOVE NEXT LINE
- SUBROUTINE LRPF
-C***********************************************************************
-C
-C EXAMPLE OF USE OF THE PORT PROGRAM FEASA
-C
-C***********************************************************************
- REAL X(4),B(5),A(5,4),SIMP(8)
- EXTERNAL LPMAN, FPRNT
- INTEGER ISIMP(8), IPTG(10)
- DATA B(1)/5.0/,B(2)/9.0/,B(3)/9.0/,B(4)/1.0/,B(5)/-5.0/
- N=4
- IA=5
- M=5
- IE=2
- IWRITE=I1MACH(2)
-C
-C SET UP GENERAL CONSTRAINTS
-C
- DO 10 J=1,N
- A(1,J)=FLOAT(J)
- A(2,J)=FLOAT(J+1)
- A(3,J)=FLOAT(J*J)
- A(4,J)=0.0
- A(5,J)=0.0
- 10 CONTINUE
- A(4,1)=1.0
- A(4,2)=1.0
- A(5,2)=-1.0
- A(5,4)=-1.0
-C
-C SET UP SIMPLE CONSTRAINTS
-C
- IS=8
- DO 20 I=1,N
- SIMP(I)=FLOAT(-I)
- ISIMP(I)=I
- SIMP(I+N)=FLOAT(I+2)
- ISIMP(I+N)=-I
- 20 CONTINUE
-C
-C SET UP INITIAL GUESS
-C
- DO 30 I=1,N
- X(I)=1.0
- 30 CONTINUE
-C
-C CALL FEASIBLE POINT ALGORITHM
-C
- CALL FEASA(A,M,N,LPMAN,IA,B,X,15,IS,SIMP,ISIMP,IE,
- 1 FPRNT,IAG,IAS,IPTG)
- WRITE(IWRITE,31)(X(I),I=1,N)
- 31 FORMAT(11H SOLUTION: ,4E15.6)
-C
-C CHECK ANSWER
-C
- DO 40 I=1,M
- S = SDOT(N, A(I,1), IA, X, 1) -B(I)
- WRITE(IWRITE,41)I, S
- 40 CONTINUE
- 41 FORMAT(28H THE RESIDUAL AT CONSTRAINT ,I4,4H IS ,E15.5)
- STOP
- END
- SUBROUTINE FPRNT(A,M,N,AMAN,IA,B,C,X,CTX,IS,SIMP,ISIMP,IE,
- 1 ITER,IPTG,IAG,IAS,U,IEND,IPHAS)
-C
-C THIS IS A PRINT ROUTINE
-C
- REAL CTX,A(1),X(N),B(1)
- LOGICAL IEND
- EXTERNAL AMAN
- INTEGER IA(1),IPTG(N),ISIMP(1),S
- REAL SIMP(1),C(1),U(1)
- IEND = .FALSE.
- IWRITE=I1MACH(2)
- IAGPE=IAG+IE
- WRITE(IWRITE,1)ITER,IAGPE,IAS
- 1 FORMAT(/14H AT ITERATION ,I5,
- 1 /18H NO.OF ACT. GEN.= ,I5,15H NO.OF ACT.SIM= I5)
- WRITE(IWRITE,2)(X(I),I=1,N)
- 2 FORMAT(3H X ,5E15.5)
- DO 10 I=1,M
- CALL AMAN(.TRUE.,A,IA,N,I,X,TOUT)
- TOUT=TOUT-B(I)
- WRITE(IWRITE,9)I,TOUT
- 9 FORMAT(15H AT CONSTRAINT ,I5,11H RESIDUAL= ,E15.5)
- 10 CONTINUE
- IF (IAGPE.EQ.0)GO TO 12
- WRITE(IWRITE,11)(IPTG(I),I=1,IAGPE)
- 11 FORMAT(29H ACTIVE GENERAL CONSTRAINTS ,10I4)
- 12 IF (IAS.LT.1)RETURN
- DO 15 I=1,IAS
- IP=IABS(ISIMP(I))
- IF (ISIMP(I).GT.0)WRITE(IWRITE,13)IP
- 13 FORMAT(18H LOWER BOUND ON X(,I2,11H) IS ACTIVE)
- IF (ISIMP(I).LT.0)WRITE(IWRITE,14)IP
- 14 FORMAT(18H UPPER BOUND ON X(,I2,11H) IS ACTIVE)
- 15 CONTINUE
- RETURN
- END
diff --git a/CEP/PyBDSM/src/port3/ex/lrpg.f b/CEP/PyBDSM/src/port3/ex/lrpg.f
deleted file mode 100644
index 94da05e14f9385521a018de63b28c4cb27d62519..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ex/lrpg.f
+++ /dev/null
@@ -1,79 +0,0 @@
-C$TEST LRPG
-C TO RUN AS A MAIN PROGRAM REMOVE NEXT LINE
- SUBROUTINE LRPG
-C***********************************************************************
-C
-C SECOND EXAMPLE OF USE OF THE PORT PROGRAM LINPA
-C
-C***********************************************************************
- REAL X(30), C(30), B(29), SIMP(31), U(30)
- INTEGER ISIMP(31), IPTG(30)
- EXTERNAL LPRNT,AMAN
- COMMON /CSTAK/DSTAK
- DOUBLE PRECISION DSTAK(2000)
-C
-C GET WORK SPACE FROM THE STACK
-C
- CALL ISTKIN(2000,4)
- N=30
- M=29
- IE=0
- IS=31
-C
-C SET UP RIGHT HAND SIDE
-C
- DO 10 I =1,M
- B(I) = FLOAT(I)/10.0
- 10 CONTINUE
-C
-C SET UP INITIAL GUESS, OBJECTIVE FUNCTION AND SIMPLE CONSTRAINTS
-C
- SIGN=-1.0
- DO 20 I=1,N
- X(I)=3.0*FLOAT(I)
- C(I)=SIGN*FLOAT(I)
- SIGN=-SIGN
- ISIMP(I)=I
- SIMP(I)=FLOAT(I)
- 20 CONTINUE
- ISIMP(N+1)=-N
- SIMP(N+1)=3.0*FLOAT(N)
-C
-C SOLVE THE PROBLEM AND PRINT OUT THE RESULTS
-C
- CALL LINPA(A,M,N,AMAN,IA,B,C,X,100,CTX,IS,SIMP,ISIMP,IE,
- 1 LPRNT,IAG,IAS,IPTG,U)
- IWRITE=I1MACH(2)
- WRITE(IWRITE,21)(X(I),I=1,N)
- 21 FORMAT(10H SOLUTION ,5E15.5)
-C
- IF(IAG .GT. 1)WRITE(IWRITE,22)(IPTG(I),I=1,IAG)
- 22 FORMAT( 28H ACTIVE GENERAL CONSTRAINTS ,15I3)
-C
- IF (IAS .EQ. 0)STOP
- DO 30 I=1,IAS
- IP=IABS(ISIMP(I))
- WRITE(IWRITE,23)IP
- 23 FORMAT(12H BOUND ON X(,I2,11H) IS ACTIVE)
- 30 CONTINUE
- STOP
- END
- SUBROUTINE AMAN(L,A,IA,N,I,TVEC,T)
- LOGICAL L
- REAL TVEC(N)
- IF (L) GOTO 20
-C
-C THE ITH ROW IS REQUESTED
-C
- DO 10 J=1,N
- TVEC(J)=0.0
- 10 CONTINUE
- TVEC(I+1)=1.0
- TVEC(I)=-1.0
- RETURN
-C
-C THIS IS INNERPRODUCT REQUEST
-C
- 20 T=TVEC(I+1)-TVEC(I)
- RETURN
- END
diff --git a/CEP/PyBDSM/src/port3/ex/lsfa.f b/CEP/PyBDSM/src/port3/ex/lsfa.f
deleted file mode 100644
index b01b2b19e2ef3a478eabdfbe92e8b3393c102e02..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ex/lsfa.f
+++ /dev/null
@@ -1,44 +0,0 @@
-C$TEST LSFA
-C TO RUN AS A MAIN PROGRAM REMOVE NEXT LINE
- SUBROUTINE LSFA
-C***********************************************************************
-C
-C EXAMPLE OF USE OF THE PORT PROGRAM L2SFF
-C
-C***********************************************************************
- EXTERNAL F
- INTEGER K,IWRITE,I1MACH,NT
- REAL EESFF, T(100), A(100), ERROR
-C
-C MAKE THE MESH
-C
- K = 4
- CALL UMB (0.0E0,3.14E0,21,K,T,NT)
-C
-C DO THE FITTING
-C
- CALL L2SFF (F, K, T, NT, A)
-C
-C GET THE ERROR
-C
- ERROR = EESFF (K, T, NT, A, F)
-C
- IWRITE = I1MACH(2)
- WRITE (IWRITE, 1000) ERROR
- 1000 FORMAT (9H ERROR = ,E10.2)
-C
- STOP
-C
- END
- SUBROUTINE F(X, NX, FX, WX)
-C
- INTEGER I,NX
- REAL X(NX), FX(NX), WX(NX)
-C
- DO 1000 I = 1,NX
- FX(I) = SIN(X(I))
- 1000 CONTINUE
-C
- RETURN
-C
- END
diff --git a/CEP/PyBDSM/src/port3/ex/lyma.f b/CEP/PyBDSM/src/port3/ex/lyma.f
deleted file mode 100644
index 5b4a30cd3b920658958df7c3598ffd70ecf8b6a0..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ex/lyma.f
+++ /dev/null
@@ -1,46 +0,0 @@
-C$TEST LYMA
-C TO RUN AS A MAIN PROGRAM REMOVE NEXT LINE
- SUBROUTINE LYMA
-C***********************************************************************
-C
-C EXAMPLE OF USE OF THE PORT PROGRAM SYSS
-C
-C***********************************************************************
- INTEGER N, L, I, IWRITE, I1MACH
- REAL C(5000), B(100)
- REAL SUM, FLOAT, ABS, ERR, COND
- DO 40 N=10,90,40
-C
-C CREATE THE MATRIX A(I,J)=ABS(I-J), PACK IT INTO
-C THE VECTOR C AND FORM THE RIGHT-HAND SIDE SO THE
-C SOLUTION HAS ALL ONES.
-C
- L=1
- SUM=(N*(N-1))/2
- DO 20 I=1,N
- DO 10 J=I,N
- C(L)=J-I
- L=L+1
- 10 CONTINUE
- B(I)=SUM
- SUM=SUM+FLOAT(I-(N-I))
- 20 CONTINUE
-C
-C SOLVE THE SYSTEM AND GET THE CONDITION NUMBER OF THE MATRIX
- CALL SYSS(N,C,B,100,1,COND)
-C
-C COMPUTE THE ERROR IN THE SOLUTION
- ERR=0.0
- DO 30 I=1,N
- 30 ERR=ERR+ABS(B(I)-1.0)
- ERR=ERR/FLOAT(N)
- IWRITE=I1MACH(2)
- WRITE(IWRITE,31)N
- 31 FORMAT(/8H FOR N= ,I5)
- WRITE(IWRITE,32)COND
- 32 FORMAT(23H CONDITION ESTIMATE IS 1PE15.7)
- WRITE(IWRITE,33)ERR
- 33 FORMAT(30H RELATIVE ERROR IN SOLUTION IS,1PE15.7)
- 40 CONTINUE
- STOP
- END
diff --git a/CEP/PyBDSM/src/port3/ex/lymb.f b/CEP/PyBDSM/src/port3/ex/lymb.f
deleted file mode 100644
index 4b84223d03b47c06a3b66d44013051239c03a1ee..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ex/lymb.f
+++ /dev/null
@@ -1,109 +0,0 @@
-C$TEST LYMB
-C TO RUN AS A MAIN PROGRAM REMOVE NEXT LINE
- SUBROUTINE LYMB
-C***********************************************************************
-C
-C EXAMPLE OF USE OF THE PORT PROGRAM SYCE
-C
-C***********************************************************************
- INTEGER N, JEND, IREAD, I1MACH, I, JBEGIN, J, IWRITE
- INTEGER INTER(6), IEND, ITER, L, IFIX
- REAL C(20), SAVEC(36), B(6), SAVEB(6), R(6)
- REAL COND, R1MACH, BNORM, RNORM, ABS, ALOG10
- DOUBLE PRECISION D(6)
- N=5
-C
-C READ IN A SYMMETRIC MATRIX WHOSE UPPER TRIANGULAR
-C PORTION IS STORED ONE ROW PER CARD. MAKE A
-C COPY OF THE MATRIX SO THAT IT CAN BE USED LATER
-C
- JEND=0
- IREAD=I1MACH(1)
- DO 20 I=1,N
- JBEGIN=JEND+1
- JEND=JBEGIN+N - I
- READ(IREAD,1)(C(J),J=JBEGIN,JEND)
- 1 FORMAT(5F8.0)
- DO 10 J=JBEGIN,JEND
- SAVEC(J)=C(J)
- 10 CONTINUE
- 20 CONTINUE
-C READ IN RIGHT HAND SIDE AND SAVE IT
- DO 30 I=1,N
- READ(IREAD,1)B(I)
- SAVEB(I)=B(I)
- 30 CONTINUE
-C
-C SOLVE AX = B USING SEPARATE CALLS TO SYCE AND SYFBS
-C
- CALL SYCE(N,C,INTER,COND)
- CALL SYFBS(N,C,B,6,1,INTER)
- IWRITE=I1MACH(2)
- IF(COND.GE.1.0/R1MACH(4))WRITE(IWRITE,31)
- 31 FORMAT(49H CONDITION NUMBER HIGH,ACCURATE SOLUTION UNLIKELY)
- WRITE(IWRITE,32) COND
- 32 FORMAT(21H CONDITION NUMBER IS ,1PE16.8)
-C COMPUTE NORM OF SOLUTION
- BNORM=0.0
- WRITE(IWRITE,33)
- 33 FORMAT(43H THE FIRST SOLUTION X, FROM SYCE AND SYFBS=)
- DO 40 I=1,N
- BNORM=BNORM+ABS(B(I))
- 40 WRITE(IWRITE,41)B(I)
- 41 FORMAT(1H ,F20.7)
-C
-C IEND IS THE UPPER BOUND ON THE NUMBER OF BITS PER WORD
-C
- IEND=I1MACH(11)*IFIX(R1MACH(5)/ALOG10(2.0)+1.0)
-C
-C REFINE SOLUTION
-C
- DO 90 ITER=1,IEND
-C
-C COMPUTE RESIDUAL R = B - AX, IN DOUBLE PRECISION
-C
- DO 50 I=1,N
- 50 D(I)=DBLE(SAVEB(I))
- L=1
- DO 70 I=1,N
- DO 60 J=I,N
- IF (I.NE.J) D(J)=D(J) - DBLE(SAVEC(L))*B(I)
- D(I) = D(I) - DBLE(SAVEC(L))*B(J)
- 60 L=L+1
- R(I) = D(I)
- 70 CONTINUE
-C
-C SOLVE A(DELTAX) =R
-C
- CALL SYFBS(N,C,R,8,1,INTER)
-C
-C DETERMINE NORM OF CORRECTION AND ADD IN CORRECTION
-C
- WRITE(IWRITE,71)ITER
- 71 FORMAT(30H THE SOLUTION AFTER ITERATION ,I5)
- RNORM=0.0
- DO 80 I=1,N
- B(I) = B(I) + R(I)
- RNORM=RNORM+ABS(R(I))
- WRITE(IWRITE,41)B(I)
- 80 CONTINUE
- IF(RNORM.LT.R1MACH(4)*BNORM) STOP
- 90 CONTINUE
- WRITE(IWRITE,91)
- 91 FORMAT(29H ITERATIVE IMPROVEMENT FAILED)
- STOP
- END
-C
-C DATA FOR THE EXAMPLE IN THE PORT SHEET... (REMOVE THE C
-C IN COLUMN 1 BEFORE FEEDING THIS DATA TO THE PROGRAM ABOVE.)
-C$DATA
-C -4. 0. -16. -32. 28.
-C 1. 5. 10. -6.
-C -37. -66. 64.
-C -85. 53.
-C -15.
-C 448.
-C -111.
-C 1029.
-C 1207.
-C -719.
diff --git a/CEP/PyBDSM/src/port3/ex/lymk.f b/CEP/PyBDSM/src/port3/ex/lymk.f
deleted file mode 100644
index 918786d62cc236059f64517323265c4d0c168fc9..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ex/lymk.f
+++ /dev/null
@@ -1,56 +0,0 @@
-C$TEST LYMK
-C TO RUN AS A MAIN PROGRAM REMOVE NEXT LINE
- SUBROUTINE LYMK
-C***********************************************************************
-C
-C EXAMPLE OF USE OF THE PORT PROGRAM SYNM
-C
-C***********************************************************************
- INTEGER I, J, L, N, I1MACH, IWRITE
- REAL C(1300), CC(1300), B(50), X(50)
- REAL RELERR, RELRES, XNORM, RNORM, ERR, R(50)
- REAL SYNM, SAMAX
- L=0
-C
-C GENERATE MATRIX
-C
- N=50
- DO 20 I=1,N
- DO 10 J=I,N
- L=L+1
- C(L)=J-I
- CC(L)=C(L)
- 10 CONTINUE
- B(I)=I
- 20 CONTINUE
-C
-C GENERATE RIGHT HAND SIDE
-C
- CALL SYML(N,C,B,X)
-C
-C MAKE COPY OF RIGHT HAND SIDE
-C
- CALL MOVEFR(N,X,B)
-C
-C SOLVE THE SYSTEM
-C
- CALL SYLE(N,C,B,N,1)
-C
-C COMPUTE THE RELATIVE ERROR AND THE RELATIVE RESIDUAL
-C
- CALL SYML(N,CC,B,R)
- ERR=0.0
- DO 30 I=1,N
- ERR=AMAX1(ERR,ABS(B(I)-FLOAT(I)))
- R(I)=R(I)-X(I)
- 30 CONTINUE
- XNORM=SAMAX(N,X,1)
- RNORM=SAMAX(N,R,1)
- RELERR=ERR/XNORM
- RELRES=RNORM/(XNORM*SYNM(N,CC))
- IWRITE=I1MACH(2)
- WRITE(IWRITE,31)RELERR,RELRES
- 31 FORMAT(16H RELATIVE ERROR=,E15.5,19H RELATIVE RESIDUAL=,
- 1 E15.5)
- STOP
- END
diff --git a/CEP/PyBDSM/src/port3/ex/lymp.f b/CEP/PyBDSM/src/port3/ex/lymp.f
deleted file mode 100644
index 076457dce3123882b7f27c38c5e3f98ad58c04c6..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ex/lymp.f
+++ /dev/null
@@ -1,56 +0,0 @@
-C$TEST LYMP
-C TO RUN AS A MAIN PROGRAM REMOVE NEXT LINE
- SUBROUTINE LYMP
-C***********************************************************************
-C
-C EXAMPLE OF USE OF THE PORT PROGRAM SYML
-C
-C***********************************************************************
- INTEGER N, L, I, J, IWRITE, I1MACH
- REAL C(55), X(10), B(10)
- REAL UNI, ERR, SASUM, ABS
- N=10
-C
-C CONSTRUCT THE MATRIX A(I,J)=ABS(J-I) AND PACK INTO C
-C
- L=0
- DO 20 I=1,N
- DO 10 J=I,N
- L=L+1
- C(L)=J-I
- 10 CONTINUE
- 20 CONTINUE
-C
-C CONSTRUCT A RANDOM VECTOR X
-C
- DO 30 I=1,N
- X(I)=UNI(0)
- 30 CONTINUE
-C
-C FIND THE VECTOR B=AX
-C
- CALL SYML(N,C,X,B)
-C
-C SOLVE THE SYSTEM AX=B
-C
- CALL SYLE(N,C,B,N,1)
-C
-C PRINT THE COMPUTED AND TRUE SOLUTION
-C
- IWRITE=I1MACH(2)
- WRITE(IWRITE,31)
- 31 FORMAT(34H TRUE SOLUTION COMPUTED SOLUTION)
- WRITE(IWRITE,32)(X(I),B(I),I=1,N)
- 32 FORMAT(1H ,2E17.8)
-C
-C COMPUTE THE RELATIVE ERROR
-C
- ERR=0.0
- DO 40 I=1,N
- ERR=ERR+ABS(B(I)-X(I))
- 40 CONTINUE
- ERR=ERR/SASUM(N,X,1)
- WRITE(IWRITE,41)ERR
- 41 FORMAT(19H RELATIVE ERROR IS ,1PE15.7)
- STOP
- END
diff --git a/CEP/PyBDSM/src/port3/ex/mfte.f b/CEP/PyBDSM/src/port3/ex/mfte.f
deleted file mode 100644
index e1ea126257d1a0d3fb8d7a64d5413a22a65893dc..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ex/mfte.f
+++ /dev/null
@@ -1,96 +0,0 @@
-C$TEST MFTE
-C TO RUN AS A MAIN PROGRAM REMOVE NEXT LINE
- SUBROUTINE MFTE
-C***********************************************************************
-C
-C EXAMPLE OF USE OF THE PORT PROGRAM MFTCC
-C
-C***********************************************************************
- REAL A(25,25,25),B(25,25,25),T(50)
- REAL AA(25,25,25),BB(25,25,25)
- REAL RSTAK(1262)
- REAL SUM,FN1
- INTEGER IFX(25)
- INTEGER I,J,K,L,IFB
- DOUBLE PRECISION DSTAK(631)
- COMMON /CSTAK/DSTAK
- EQUIVALENCE (RSTAK(1),DSTAK(1))
-C
-C N IS THE DIMENSION OF THE COMPLEX CUBE
-C
- N = 25
-C
-C GET ONE PLANE OF WORKSPACE
-C
- NWK = 2*N*N + 12
- CALL ISTKIN(NWK,3)
-C
-C SET REAL AND IMAGINARY PARTS TO YOUR FAVORITE VALUES HERE
-C AA AND BB ARE COPIES TO COMPARE WITH UNNORMALIZED OUTPUT
-C THIS EXAMPLE USES RANDOM DATA, SEE THE UTILITY CHAPTER OF PORT 3.
-C
- DO 1 K = 1,N
- DO 1 J = 1,N
- DO 1 I = 1,N
- A(I,J,K) = UNI(0)
- AA(I,J,K) = A(I,J,K)
- B(I,J,K) = UNI(0)
- BB(I,J,K) = B(I,J,K)
- 1 CONTINUE
-C
-C INITIALIZE TRIGONOMETRIC TABLES AND FACTOR N
-C
- CALL MFTCI(N,IFX,T)
-C
-C OUTER LOOP COMPUTES A FORWARD (SIGN=1.0), THEN BACKWARD (SIGN=-1.0)
-C TRANSFORM. FIRST X, THEN Y, THEN Z.
-C
- SIGN = 1.0E0
- N2 = N*N
- NT = N
-C
-C
- DO 2 IFB = 1,2
-C X-DIRECTION TRANSFORMS FOR EACH X-Y PLANE
- DO 3 L = 1,N
- CALL MFTCC(NT,NT,A(1,1,L),B(1,1,L),1,NT,
- * A(1,1,L),B(1,1,L),1,NT,IFX,T,SIGN)
- 3 CONTINUE
-C Y-DIRECTION TRANSFORMS FOR EACH X-Y PLANE
- DO 4 L = 1,N
- CALL MFTCC(NT,NT,A(1,1,L),B(1,1,L),NT,1,
- * A(1,1,L),B(1,1,L),NT,1,IFX,T,SIGN)
- 4 CONTINUE
-C Z-DIRECTION TRANSFORMS FOR EACH Y-Z PLANE
- DO 5 L = 1,N
- CALL MFTCC(NT,NT,A(L,1,1),B(L,1,1),NT,N2,
- * A(L,1,1),B(L,1,1),NT,N2,IFX,T,SIGN)
- 5 CONTINUE
-C
- SIGN = -1.0E0
- 2 CONTINUE
-C
-C
-C COMPARE INPUT TO UNNORMALIZED OUTPUT FROM FORWARD/BACKWARD FFT
-C
- FN1 = 1.0E0/FLOAT(N*N*N)
- DO 6 K = 1,N
- DO 6 J = 1,N
- DO 6 I = 1,N
- AA(I,J,K) = AA(I,J,K) - FN1*A(I,J,K)
- BB(I,J,K) = BB(I,J,K) - FN1*B(I,J,K)
- 6 CONTINUE
-C
-C ERR IS THE RMS ERROR, SDOT COMPUTES THE SUM OF SQUARES, SEE THE
-C LINEAR ALGEBRA CHAPTER OF PORT 3
-C
- ERR = SDOT(N2,AA,1,AA,1) + SDOT(N2,BB,1,BB,1)
- ERR = SQRT(FN1*ERR)
-C
-C PRINT RESULTS
-C
- IWRITE = I1MACH(2)
- WRITE(IWRITE,1000)N,N,N,ERR
- 1000 FORMAT(1X,18H FOR LATTICE SIZE ,I3,2(2H X,I3),9H ERROR = ,E11.5)
- STOP
- END
diff --git a/CEP/PyBDSM/src/port3/ex/mftf.f b/CEP/PyBDSM/src/port3/ex/mftf.f
deleted file mode 100644
index 17ed8f418a4b4d3583791d5a3afbbec716bfbba3..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ex/mftf.f
+++ /dev/null
@@ -1,87 +0,0 @@
-C$TEST MFTF
-C TO RUN AS A MAIN PROGRAM REMOVE NEXT LINE
- SUBROUTINE MFTF
-C***********************************************************************
-C
-C EXAMPLE OF USE OF THE PORT PROGRAM MFTRC
-C
-C***********************************************************************
- REAL A(200,100)
- REAL AA(200,100)
- REAL TX(200),TY(200)
- REAL RSTAK(20014)
- REAL FN2,RMSERR,SIGN,SUM
- INTEGER IFX(25),IFY(25)
- INTEGER I,J,N,N2,NP2,NP3,N2MK
- DOUBLE PRECISION DSTAK(10007)
- COMMON /CSTAK/DSTAK
- EQUIVALENCE (RSTAK(1),DSTAK(1))
-C
-C
- CALL ISTKIN(20014,3)
-C
- N = 100
- NP2 = 102
- N2 = 200
-C
-C SET INPUT VECTORS TO YOUR FAVORITE VALUES HERE, THIS EXAMPLE
-C USES RANDOM INITIAL VALUES.
-C
- DO 1 J = 1,N
- DO 2 I = 1,N
- A(I,J) = UNI(0)
- AA(I,J) = A(I,J)
- 2 CONTINUE
- 1 CONTINUE
-C
- SIGN = 1.0E0
- CALL MFTRI(N,IFX,TX)
- CALL MFTCI(N,IFY,TY)
-C
-C X-DIMENSION
-C
- CALL MFTRC(N,N,A,1,N2,A(1,1),A(2,1),2,N2,IFX,TX,SIGN)
-C
-C FILL-IN FROM CONJUGATION OF TERMS
-C
- NP3 = N+3
- N2MK = N-1
- DO 3 I = NP3,N2,2
- DO 4 J = 1,N
- A(I,J) = A(N2MK,J)
- A(I+1,J) = - A(N2MK+1,J)
- 4 CONTINUE
- N2MK = N2MK - 2
- 3 CONTINUE
-C
-C DO COMPLEX PART IN Y-DIRECTION
-C
- CALL MFTCC(N,N,A(1,1),A(2,1),N2,2,A(1,1),A(2,1),N2,2,IFY,TY,SIGN)
-C
-C NOW GO BACKWARDS, COMPLEX TO COMPLEX FIRST
-C
- SIGN = -1.0E0
- CALL MFTCC(N,N,A(1,1),A(2,1),N2,2,A(1,1),A(2,1),N2,2,IFY,TY,SIGN)
-C
-C AND BACK TO REAL
-C
- CALL MFTCR(N,N,A(1,1),A(2,1),2,N2,A,1,N2,IFX,TX,SIGN)
-C
-C COMPARE TO INPUT
-C
- FN2 = 1./FLOAT(N*N)
- SUM = 0.0E0
- DO 5 J = 1,N
- DO 6 I = 1,N
- SUM = SUM + (AA(I,J) - FN2*A(I,J))**2
- 6 CONTINUE
- 5 CONTINUE
-C
-C PRINT ROOT MEAN SQUARE ERROR
-C
- RMSERR = SQRT(SUM*FN2)
- IWRITE = I1MACH(2)
- WRITE(IWRITE,1000) N,N,RMSERR
- 1000 FORMAT(1X,5H FOR ,I3,1HX,I3,20H ARRAY, RMS ERROR = ,1PE12.3)
- STOP
- END
diff --git a/CEP/PyBDSM/src/port3/ex/mftg.f b/CEP/PyBDSM/src/port3/ex/mftg.f
deleted file mode 100644
index 6e87f2ff882b778a884f5bbfd4478aa2e681d1c6..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ex/mftg.f
+++ /dev/null
@@ -1,119 +0,0 @@
-C$TEST MFTG
-C TO RUN AS A MAIN PROGRAM REMOVE NEXT LINE
- SUBROUTINE MFTG
-C***********************************************************************
-C
-C EXAMPLE OF USE OF THE PORT PROGRAM MFTCR
-C
-C***********************************************************************
- REAL A(200,100)
- REAL AA(200,100)
- REAL TX(200),TY(200)
- REAL RSTAK(3212)
- REAL FN2,RMSERR,SIGN,SUM
- INTEGER IFX(25),IFY(25)
- INTEGER I,J,N,N2,NP2,NP3,N2MK,NNS0,NNS,NSEGS
- DOUBLE PRECISION DSTAK(1606)
- COMMON /CSTAK/DSTAK
- EQUIVALENCE (RSTAK(1),DSTAK(1))
-C
-C
- CALL ISTKIN(3212,3)
-C
- N = 100
- NP2 = 102
- N2 = 200
-C
-C THE SEGMENT SIZE IS ARBITRARILY CHOSEN TO BE 16 X N - I.E. USING
-C MFTCC, MFTRC, MFTCR TO COMPUTE UP TO 16 INDEPENDENT VECTORS AT A
-C TIME.
-C
- NSEGS = (N-1)/16 + 1
- NNS0 = MOD(N-1,16) + 1
-C
-C EXAMPLE USES RANDOM INPUT DATA
-C
- DO 1 J = 1,N
- DO 2 I = 1,N
- A(I,J) = UNI(0)
- AA(I,J) = A(I,J)
- 2 CONTINUE
- 1 CONTINUE
-C
- SIGN = 1.0E0
- CALL MFTRI(N,IFX,TX)
- CALL MFTCI(N,IFY,TY)
-C
-C X-DIMENSION
-C
- NNS = NNS0
- L = 1
- DO 3 LL = 1,NSEGS
- CALL MFTRC(N,NNS,A(1,L),1,N2,A(1,L),A(2,L),2,N2,IFX,TX,SIGN)
- L = L + NNS
- NNS = 16
- 3 CONTINUE
-C
-C FILL-IN FROM CONJUGATION OF TERMS
-C
- NP3 = N+3
- N2MK = N-1
- DO 4 I = NP3,N2,2
- DO 5 J = 1,N
- A(I,J) = A(N2MK,J)
- A(I+1,J) = - A(N2MK+1,J)
- 5 CONTINUE
- N2MK = N2MK - 2
- 4 CONTINUE
-C
-C DO COMPLEX PART IN Y-DIRECTION
-C
- NNS = NNS0
- L = 1
- DO 6 LL = 1,NSEGS
- CALL MFTCC(N,NNS,A(L,1),A(L+1,1),N2,2,
- * A(L,1),A(L+1,1),N2,2,IFY,TY,SIGN)
- L = L + 2*NNS
- NNS = 16
- 6 CONTINUE
-C
-C NOW GO BACKWARDS, COMPLEX TO COMPLEX FIRST
-C
- SIGN = -1.0E0
- NNS = NNS0
- L = 1
- DO 7 LL = 1,NSEGS
- CALL MFTCC(N,NNS,A(L,1),A(L+1,1),N2,2,
- * A(L,1),A(L+1,1),N2,2,IFY,TY,SIGN)
- L = L + 2*NNS
- NNS = 16
- 7 CONTINUE
-C
-C AND BACK TO REAL
-C
- NNS = NNS0
- L = 1
- DO 8 LL = 1,NSEGS
- CALL MFTCR(N,NNS,A(1,L),A(2,L),2,N2,A(1,L),1,N2,IFX,TX,SIGN)
- L = L + NNS
- NNS = 16
- 8 CONTINUE
-C
-C COMPARE TO INPUT
-C
- FN2 = 1./FLOAT(N*N)
- SUM = 0.0E0
- DO 9 J = 1,N
- DO 10 I = 1,N
- SUM = SUM + (AA(I,J) - FN2*A(I,J))**2
- 10 CONTINUE
- 9 CONTINUE
-C
-C PRINT ROOT MEAN SQUARE ERROR
-C
- RMSERR = SQRT(SUM*FN2)
- IWRITE = I1MACH(2)
- WRITE(IWRITE,1000) N,N,RMSERR
- 1000 FORMAT(1X,5H FOR ,I3,1HX,I3,20H ARRAY, RMS ERROR = ,1PE12.3)
- STOP
- END
diff --git a/CEP/PyBDSM/src/port3/ex/mllr.f b/CEP/PyBDSM/src/port3/ex/mllr.f
deleted file mode 100644
index 9b68feb4a5ff68d5ce8bf574a833912b0d6c7ec7..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ex/mllr.f
+++ /dev/null
@@ -1,44 +0,0 @@
-C$TEST MLLR
-C TO RUN AS A MAIN PROGRAM REMOVE NEXT LINE
- SUBROUTINE MLLR
-C***********************************************************************
-C
-C EXAMPLE OF USE OF THE PORT PROGRAM MULLR
-C
-C***********************************************************************
- INTEGER ITER, MAXITR, IWRITE
- REAL EPSF, EPSZ
- COMPLEX MULLR, TESTF, Z1, Z2, Z3, ZANS
- COMPLEX CEXP, CSIN
- EXTERNAL TESTF
-C
-C SET UP THE INITIAL GUESSES AND TOLERANCES
-C
- Z1 = CMPLX(2.0, 1.0)
- Z2 = CMPLX(5.0, 4.0)
- Z3 = CMPLX(3.0, 2.0)
-C
- EPSZ = .00001
- EPSF = .000001
- MAXITR = 50
-C
- ZANS = MULLR(TESTF, Z1, Z2, Z3, EPSZ, EPSF, MAXITR, ITER)
-C
-C WRITE IWRITE THE ANSWER AND THE NUMBER OF ITERATIONS
-C
- IWRITE = I1MACH(2)
- WRITE (IWRITE, 999) ZANS, ITER
- 999 FORMAT(1H ,12HTHE ZERO IS ,2F11.8, 3X,
- 1 I3,21H ITERATIONS WERE USED)
-C
-C
- STOP
- END
- COMPLEX FUNCTION TESTF(Z)
-C
- COMPLEX Z
-C
- TESTF = Z*CEXP(Z) - CSIN(Z)
-C
- RETURN
- END
diff --git a/CEP/PyBDSM/src/port3/ex/mnna.f b/CEP/PyBDSM/src/port3/ex/mnna.f
deleted file mode 100644
index d616605c96656d8a75e35277fdf71b878bdeb934..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ex/mnna.f
+++ /dev/null
@@ -1,28 +0,0 @@
-C$TEST MNNA
-C TO RUN AS A MAIN PROGRAM REMOVE NEXT LINE
- SUBROUTINE MNNA
-C***********************************************************************
-C
-C EXAMPLE OF USE OF THE PORT PROGRAM FMIN
-C
-C***********************************************************************
- EXTERNAL F
- INTEGER IWRITE,I1MACH
- REAL A,B,T,ANS,X
- IWRITE = I1MACH(2)
- A = .8
- B = 1.2
- T = .0000001
- ANS = FMIN(F,X,A,B,T)
- WRITE (IWRITE,9999) A,B,T
-9999 FORMAT (5H A = ,1PE14.8,5H B = ,1PE14.8,5H T = ,1PE9.3)
- WRITE (IWRITE,9998) ANS
-9998 FORMAT(16H THE MINIMUM IS ,1PE16.8)
- WRITE (IWRITE,9997) X
-9997 FORMAT(14H IT OCCURS AT ,1PE18.8)
- STOP
- END
- FUNCTION F(X)
- F = -X * EXP(-X)
- RETURN
- END
diff --git a/CEP/PyBDSM/src/port3/ex/nlsa.f b/CEP/PyBDSM/src/port3/ex/nlsa.f
deleted file mode 100644
index 84aef7d94b0aa02d0954c0edad3486a07e3612e1..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ex/nlsa.f
+++ /dev/null
@@ -1,122 +0,0 @@
-C$TEST NLSA
-C TO RUN AS A MAIN PROGRAM REMOVE NEXT LINE
- SUBROUTINE NLSA
-C***********************************************************************
-C
-C EXAMPLE OF USE OF THE PORT PROGRAMS MNF, MNG AND MNH
-C
-C***********************************************************************
-C *** MNF, MNG, MNH EXAMPLE PROGRAM
-C
-C *** MINIMIZE F(X) = 0.1*S(X)**4 + SUM(I = 1(1)3) (I * (X(I) - 10)**2),
-C *** WHERE S(X) = SUM(I = 1(1)3) X(I),
-C *** STARTING FROM X = (2, 30, 9),
-C *** WITH SCALE VECTOR D = (1, 2, 3).
-C
- INTEGER LIV, LV
- INTEGER IV(59), P, UI(1)
- REAL D(3), UR(1), V(123), X(3)
- EXTERNAL DUMMY, QF, QGH
-C
- DATA LIV/59/, LV/123/, P/3/
-C
- DATA X(1)/2.E+0/, X(2)/3.E+1/, X(3)/9.E+0/
- DATA D(1)/1.E+0/, D(2)/2.E+0/, D(3)/3.E+0/
-C
-C *** BODY ***
-C
-C *** SET IV(1) TO 0 TO USE ALL DEFAULT INPUTS...
-C
- IV(1) = 0
-C
-C ... HINDSIGHT (THE PRINTED OUTPUT FROM THIS EXAMPLE) SUGGESTS THAT
-C ... THE ALGORITHM MIGHT TAKE FEWER FUNCTION EVALUATIONS ON THIS
-C ... PROBLEM IF THE INITIAL STEP BOUND, V(LMAX0), WERE INCREASED
-C ... FROM ITS DEFAULT VALUE OF 1.0 TO 10.0 . WE WOULD DO THIS BY
-C ... REPLACING THE ABOVE ASSIGNMENT OF 0 TO IV(1) WITH THE TWO LINES...
-C
-C CALL IVSET(2, IV, LIV, LV, V)
-C V(35) = 10.0
-C
-C
-C *** SOLVE THE PROBLEM -- MNH WILL PRINT THE SOLUTION FOR US...
-C
- CALL MNH(P, D, X, QF, QGH, IV, LIV, LV, V, UI, UR, DUMMY)
-C
-C *** FOR MNF AND MNG, THE CORRESPONDING CALLS WOULD BE...
-C
-C CALL MNF(P, D, X, QF, IV, LIV, LV, V, UI, UR, DUMMY)
-C CALL MNG(P, D, X, QF, QG, IV, LIV, LV, V, UI, UR, DUMMY)
-C
-C *** QG WOULD BE A SUBROUTINE, DECLARED EXTERNAL IN PLACE OF QGH ABOVE,
-C *** THAT WOULD BE THE SAME AS QGH (SEE BELOW) EXCEPT FOR HAVING
-C *** THE PARAMETER H OMITTED.
-C
-C *** NOTE -- ON MOST SYSTEMS, WE COULD SIMPLY PASS QF OR QGH
-C *** AS THE LAST PARAMETER TO MNH, SINCE QF AND QGH IGNORE
-C *** THEIR UF PARAMETER. BUT THERE EXIST SYSTEMS (E.G. UNIVAC)
-C *** THAT WOULD GIVE A RUN-TIME ERROR IF WE DID THIS. HENCE WE
-C *** PASS THE IMMEDIATELY FOLLOWING DUMMY SUBROUTINE AS UF.
-C
- 999 STOP
- END
- SUBROUTINE DUMMY
- RETURN
- END
- SUBROUTINE QF(P, X, NF, F, UI, UR, UF)
-C
-C *** THIS ROUTINE COMPUTES THE OBJECTIVE FUNCTION, F(X)
-C
- INTEGER P, NF, UI(1)
- REAL X(P), F, UR(1)
- EXTERNAL UF
-C
- INTEGER I
- REAL PT1, TEN, ZERO
-C
- DATA PT1 /0.1E+0/, TEN/1.E+1/, ZERO/0.E+0/
-C
-C
- F = ZERO
- DO 10 I = 1, P
- 10 F = F + X(I)
- F = PT1 * F**4
- DO 20 I = 1, P
- 20 F = F + I*(X(I) - TEN)**2
- 999 RETURN
- END
- SUBROUTINE QGH(P, X, NF, G, H, UI, UR, UF)
-C
-C *** THIS ROUTINE COMPUTES THE GRADIENT, G(X), AND THE LOWER TRIANGLE
-C *** OF THE HESSIAN, H(X).
-C
- INTEGER P, NF, UI(1)
- REAL X(P), G(P), H(1), UR(1)
- EXTERNAL UF
-C
- INTEGER I, K
- REAL S, S34
- REAL ONEPT2, PT4, TEN, TWO, ZERO
-C
- DATA ONEPT2/1.2E+0/,PT4/0.4E+0/,TEN/1.E+1/,TWO/2.E+0/,ZERO/0.E+0/
-C
-C
- S = ZERO
- DO 10 I = 1, P
- 10 S = S + X(I)
-C
-C *** INITIALIZE H TO 1.2*S**2 ***
-C
- CALL SETR(P*(P+1)/2, ONEPT2*S**2, H)
-C
-C *** NOW COMPUTE G AND ADD (2, 4, ..., 2*P) TO THE DIAGONAL OF H
-C
- S34 = PT4 * S**3
- K = 0
- DO 20 I = 1, P
- G(I) = S34 + TWO * I * (X(I) - TEN)
- K = K + I
- H(K) = H(K) + TWO*I
- 20 CONTINUE
- 999 RETURN
- END
diff --git a/CEP/PyBDSM/src/port3/ex/nlsb.f b/CEP/PyBDSM/src/port3/ex/nlsb.f
deleted file mode 100644
index 8a2902fd26f7de3864ad35022505ed48900bc899..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ex/nlsb.f
+++ /dev/null
@@ -1,128 +0,0 @@
-C$TEST NLSB
-C TO RUN AS A MAIN PROGRAM REMOVE NEXT LINE
- SUBROUTINE NLSB
-C***********************************************************************
-C
-C EXAMPLE OF USE OF THE PORT PROGRAMS MNFB, MNGB, AND MNHB
-C
-C***********************************************************************
-C *** MNFB, MNGB, MNHB EXAMPLE PROGRAM
-C
-C *** MINIMIZE F(X) = 0.1*S(X)**4 + SUM(I = 1(1)3) (I * (X(I) - 10)**2),
-C *** WHERE S(X) = SUM(I = 1(1)3) X(I)
-C *** SUBJECT TO
-C *** 1 .LE. X(1) .LE. 3,
-C *** -2 .LE. X(2) .LE. 10,
-C *** 1 .LE. X(3) .LE. 21,
-C *** STARTING FROM X = (2, 30, 9),
-C *** WITH SCALE VECTOR D = (1, 2, 3)
-C
- INTEGER LIV, LV
- INTEGER IV(68), P, UI(1)
- REAL B(2,3), D(3), UR(1), V(132), X(3)
- EXTERNAL DUMMY, QF, QGH
-C
- DATA LIV/68/, LV/132/, P/3/
-C
- DATA B(1,1)/1.E+0/, B(2,1)/3.E+0/,
- 1 B(1,2)/-2.E+0/, B(2,2)/1.E+1/,
- 2 B(1,3)/1.E+0/, B(2,3)/2.1E+1/
-C
- DATA X(1)/2.E+0/, X(2)/3.E+1/, X(3)/9.E+0/
- DATA D(1)/1.E+0/, D(2)/2.E+0/, D(3)/3.E+0/
-C
-C *** BODY ***
-C
-C *** SET IV(1) TO 0 TO USE ALL DEFAULT INPUTS...
-C
- IV(1) = 0
-C
-C ... WE COULD HAVE MNHB INITIALIZE THE SCALE VECTOR D TO ALL ONES
-C ... BY SETTING V(DINIT) TO 1.0 . WE WOULD DO THIS BY REPLACING
-C ... THE ABOVE ASSIGNMENT OF 0 TO IV(1) WITH THE FOLLOWING TWO LINES...
-C
-C CALL IVSET(2, IV, LIV, LV, V)
-C V(38) = 1.0
-C
-C
-C *** SOLVE THE PROBLEM -- MNHB WILL PRINT THE SOLUTION FOR US...
-C
- CALL MNHB(P, D, X, B, QF, QGH, IV, LIV, LV, V, UI, UR, DUMMY)
-C
-C *** FOR MNFB AND MNGB, THE CORRESPONDING CALLS WOULD BE...
-C
-C CALL MNFB(P, D, X, B, QF, IV, LIV, LV, V, UI, UR, DUMMY)
-C CALL MNGB(P, D, X, B, QF, QG, IV, LIV, LV, V, UI, UR, DUMMY)
-C
-C *** QG WOULD BE A SUBROUTINE, DECLARED EXTERNAL IN PLACE OF QGH ABOVE,
-C *** THAT WOULD BE THE SAME AS QGH (SEE BELOW) EXCEPT FOR HAVING
-C *** THE PARAMETER H OMITTED.
-C
-C *** NOTE -- ON MOST SYSTEMS, WE COULD SIMPLY PASS QF OR QGH
-C *** AS THE LAST PARAMETER TO MNHB, SINCE QF AND QGH IGNORE
-C *** THEIR UF PARAMETER. BUT THERE EXIST SYSTEMS (E.G. UNIVAC)
-C *** THAT WOULD GIVE A RUN-TIME ERROR IF WE DID THIS. HENCE WE
-C *** PASS THE IMMEDIATELY FOLLOWING DUMMY SUBROUTINE AS UF.
-C
- 999 STOP
- END
- SUBROUTINE DUMMY
- RETURN
- END
- SUBROUTINE QF(P, X, NF, F, UI, UR, UF)
-C
-C *** THIS ROUTINE COMPUTES THE OBJECTIVE FUNCTION, F(X)
-C
- INTEGER P, NF, UI(1)
- REAL X(P), F, UR(1)
- EXTERNAL UF
-C
- INTEGER I
- REAL PT1, TEN, ZERO
-C
- DATA PT1 /0.1E+0/, TEN/1.E+1/, ZERO/0.E+0/
-C
-C
- F = ZERO
- DO 10 I = 1, P
- 10 F = F + X(I)
- F = PT1 * F**4
- DO 20 I = 1, P
- 20 F = F + I*(X(I) - TEN)**2
- 999 RETURN
- END
- SUBROUTINE QGH(P, X, NF, G, H, UI, UR, UF)
-C
-C *** THIS ROUTINE COMPUTES THE GRADIENT, G(X), AND THE LOWER TRIANGLE
-C *** OF THE HESSIAN, H(X).
-C
- INTEGER P, NF, UI(1)
- REAL X(P), G(P), H(1), UR(1)
- EXTERNAL UF
-C
- INTEGER I, K
- REAL S, S34
- REAL ONEPT2, PT4, TEN, TWO, ZERO
-C
- DATA ONEPT2/1.2E+0/,PT4/0.4E+0/,TEN/1.E+1/,TWO/2.E+0/,ZERO/0.E+0/
-C
-C
- S = ZERO
- DO 10 I = 1, P
- 10 S = S + X(I)
-C
-C *** INITIALIZE H TO 1.2*S**2 ***
-C
- CALL SETR(P*(P+1)/2, ONEPT2*S**2, H)
-C
-C *** NOW COMPUTE G AND ADD (2, 4, ..., 2*P) TO THE DIAGONAL OF H
-C
- S34 = PT4 * S**3
- K = 0
- DO 20 I = 1, P
- G(I) = S34 + TWO * I * (X(I) - TEN)
- K = K + I
- H(K) = H(K) + TWO*I
- 20 CONTINUE
- 999 RETURN
- END
diff --git a/CEP/PyBDSM/src/port3/ex/nlsj.f b/CEP/PyBDSM/src/port3/ex/nlsj.f
deleted file mode 100644
index fa818064f32556b61af90ff00c82bcebb699e2db..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ex/nlsj.f
+++ /dev/null
@@ -1,129 +0,0 @@
-C$TEST NLSJ
-C TO RUN AS A MAIN PROGRAM REMOVE NEXT LINE
- SUBROUTINE NLSJ
-C***********************************************************************
-C
-C EXAMPLE OF USE OF THE PORT PROGRAMS N2F AND N2G
-C
-C***********************************************************************
-C *** N2F AND N2G, EXAMPLE PROGRAM ***
-C
-C *** FIT N = 33 DATA POINTS (T,Y) TO THE CURVE
-C *** X(1) + X(2)*EXP(T*X(4)) + X(3)*EXP(T*X(5))
-C
-C *** THE FOLLOWING CODE IS FOR CALLING N2G. DIFFERENCES FOR
-C *** CALLING N2F ARE EXPLAINED IN COMMENTS.
-C
- INTEGER I, IV(87), LIV, LTY, LV, UI(1)
- REAL TY(50,2), V(471), X(5)
- EXTERNAL DUMMY, OSB1J, OSB1R
- DATA LIV/87/, LTY/50/, LV/471/
-C
-C *** FOR N2F, OMIT OSB1J FROM THE EXTERNAL STATEMENT.
-C
-C
-C *** TO MAKE THIS EXAMPLE SELF-CONTAINED, WE USE A DATA STATEMENT
-C *** AND DO LOOP TO SUPPLY (T,Y) PAIRS TO THE ARRAY TY.
-C
-C *** Y VALUES...
-C
- DATA TY(1,2) /8.44E-1/, TY(2,2) /9.08E-1/, TY(3,2)/9.32E-1/,
- 1 TY(4,2) /9.36E-1/, TY(5,2) /9.25E-1/, TY(6,2)/9.08E-1/,
- 2 TY(7,2) /8.81E-1/, TY(8,2) /8.50E-1/, TY(9,2)/8.18E-1/,
- 3 TY(10,2)/7.84E-1/, TY(11,2)/7.51E-1/, TY(12,2)/7.18E-1/,
- 4 TY(13,2)/6.85E-1/, TY(14,2)/6.58E-1/, TY(15,2)/6.28E-1/,
- 5 TY(16,2)/6.03E-1/, TY(17,2)/5.80E-1/, TY(18,2)/5.58E-1/,
- 6 TY(19,2)/5.38E-1/, TY(20,2)/5.22E-1/, TY(21,2)/5.06E-1/,
- 7 TY(22,2)/4.90E-1/, TY(23,2)/4.78E-1/, TY(24,2)/4.67E-1/,
- 8 TY(25,2)/4.57E-1/, TY(26,2)/4.48E-1/, TY(27,2)/4.38E-1/,
- 9 TY(28,2)/4.31E-1/, TY(29,2)/4.24E-1/, TY(30,2)/4.20E-1/,
- A TY(31,2)/4.14E-1/, TY(32,2)/4.11E-1/, TY(33,2)/4.06E-1/
-C
-C *** T VALUES...
-C
- DO 10 I = 1, 33
- TY(I,1) = -10.E+0 * FLOAT(I-1)
- 10 CONTINUE
-C
-C *** SUPPLY LEAD DIMENSION OF TY IN UI(1)...
-C *** (MOST COMPILERS WOULD LET US SIMPLY PASS LTY FOR UI,
-C *** BUT SOME, E.G. WATFIV, WILL NOT.)
-C
- UI(1) = LTY
-C
-C *** SPECIFY ALL DEFAULT IV AND V INPUT COMPONENTS (N2G AND N2F
-C *** ONLY)...
-C
- IV(1) = 0
-C
-C *** SUPPLY INITIAL GUESS...
-C
- X(1) = 0.5E+0
- X(2) = 1.5E+0
- X(3) = -1.E+0
- X(4) = 1.E-2
- X(5) = 2.E-2
-C
-C *** SOLVE THE PROBLEM -- N2G WILL PRINT THE SOLUTION FOR US...
-C
- CALL N2G(33, 5, X, OSB1R, OSB1J, IV, LIV, LV, V, UI, TY, DUMMY)
-C
-C *** FOR N2F, THE CORRESPONDING CALLS WOULD BE...
-C
-C CALL N2F(33, 5, X, OSB1R, IV, LIV, LV, V, UI, TY, DUMMY)
-C
-C
-C *** NOTE -- ON MOST SYSTEMS, WE COULD SIMPLY PASS OSB1R (OR OSB1J)
-C *** AS THE UF PARAMETER, SINCE OSB1R AND OSB1J IGNORE THIS
-C *** PARAMETER. BUT THERE EXIST SYSTEMS (E.G. UNIVAC) THAT WOULD
-C *** GIVE A RUN-TIME ERROR IF WE DID THIS. HENCE WE PASS THE
-C *** IMMEDIATELY FOLLOWING DUMMY SUBROUTINE AS UF.
-C
- STOP
- END
- SUBROUTINE DUMMY
- RETURN
- END
- SUBROUTINE OSB1R(N, P, X, NF, R, LTY, TY, UF)
-C
-C *** THIS ROUTINE COMPUTES THE RESIDUAL VECTOR, R = R(X),
-C *** FOR TEST PROBLEM OSBORNE1.
-C
- INTEGER N, P, NF, LTY
- REAL X(P), R(N), TY(LTY,2)
- EXTERNAL UF
-C
- INTEGER I
- REAL TI, YI
-C
- DO 10 I = 1, N
- TI = TY(I,1)
- YI = TY(I,2)
- R(I) = YI - (X(1) + X(2)* EXP(X(4)*TI) + X(3)* EXP(X(5)*TI))
- 10 CONTINUE
- RETURN
- END
- SUBROUTINE OSB1J(N, P, X, NF, J, LTY, TY, UF)
-C
-C *** THIS ROUTINE COMPUTES THE JACOBIAN MATRIX, J = J(X),
-C *** FOR TEST PROBLEM OSBORNE1. J(I,K) IS SET TO THE PARTIAL
-C *** DERIVATIVE OF COMPONENT I OF R WITH RESPECT TO X(K).
-C
- INTEGER N, P, NF, LTY
- REAL X(P), J(N,P), TY(LTY,2)
- EXTERNAL UF
-C
- INTEGER I
- REAL NEGONE, TI
- DATA NEGONE/-1.E+0/
-C
- DO 10 I = 1, N
- TI = TY(I,1)
- J(I,1) = NEGONE
- J(I,2) = - EXP(X(4)*TI)
- J(I,3) = - EXP(X(5)*TI)
- J(I,4) = TI*X(2)*J(I,2)
- J(I,5) = TI*X(3)*J(I,3)
- 10 CONTINUE
- RETURN
- END
diff --git a/CEP/PyBDSM/src/port3/ex/nlsk.f b/CEP/PyBDSM/src/port3/ex/nlsk.f
deleted file mode 100644
index 70bef4a07d54c4bb6bd28f11a78a5e44fe6f2751..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ex/nlsk.f
+++ /dev/null
@@ -1,146 +0,0 @@
-C$TEST NLSK
-C TO RUN AS A MAIN PROGRAM REMOVE NEXT LINE
- SUBROUTINE NLSK
-C***********************************************************************
-C
-C EXAMPLE OF USE OF THE PORT PROGRAMS N2FB AND N2GB
-C
-C***********************************************************************
-C *** N2FB AND N2GB EXAMPLE PROGRAM ***
-C
-C *** FIT N = 33 DATA POINTS (T,Y) TO THE CURVE
-C *** X(1) + X(2)*EXP(T*X(4)) + X(3)*EXP(T*X(5))
-C
-C *** THE FOLLOWING CODE IS FOR CALLING N2GB. DIFFERENCES FOR
-C *** CALLING N2FB ARE EXPLAINED IN COMMENTS.
-C
- INTEGER I, IV(102), LIV, LTY, LV, UI(1)
- REAL B(2,5), BIG, TY(50,2), V(491), X(5)
- EXTERNAL DUMMY, OSB1J, OSB1R, R1MACH
- REAL R1MACH
- DATA LIV/102/, LTY/50/, LV/491/
-C
-C *** FOR N2FB, OMIT OSB1J FROM THE EXTERNAL STATEMENT.
-C
-C
-C *** TO MAKE THIS EXAMPLE SELF-CONTAINED, WE USE A DATA STATEMENT
-C *** AND DO LOOP TO SUPPLY (T,Y) PAIRS TO THE ARRAY TY.
-C
-C *** Y VALUES...
-C
- DATA TY(1,2) /8.44E-1/, TY(2,2) /9.08E-1/, TY(3,2)/9.32E-1/,
- 1 TY(4,2) /9.36E-1/, TY(5,2) /9.25E-1/, TY(6,2)/9.08E-1/,
- 2 TY(7,2) /8.81E-1/, TY(8,2) /8.50E-1/, TY(9,2)/8.18E-1/,
- 3 TY(10,2)/7.84E-1/, TY(11,2)/7.51E-1/, TY(12,2)/7.18E-1/,
- 4 TY(13,2)/6.85E-1/, TY(14,2)/6.58E-1/, TY(15,2)/6.28E-1/,
- 5 TY(16,2)/6.03E-1/, TY(17,2)/5.80E-1/, TY(18,2)/5.58E-1/,
- 6 TY(19,2)/5.38E-1/, TY(20,2)/5.22E-1/, TY(21,2)/5.06E-1/,
- 7 TY(22,2)/4.90E-1/, TY(23,2)/4.78E-1/, TY(24,2)/4.67E-1/,
- 8 TY(25,2)/4.57E-1/, TY(26,2)/4.48E-1/, TY(27,2)/4.38E-1/,
- 9 TY(28,2)/4.31E-1/, TY(29,2)/4.24E-1/, TY(30,2)/4.20E-1/,
- A TY(31,2)/4.14E-1/, TY(32,2)/4.11E-1/, TY(33,2)/4.06E-1/
-C
-C *** T VALUES...
-C
- DO 10 I = 1, 33
- TY(I,1) = -10.E+0 * FLOAT(I-1)
- 10 CONTINUE
-C
-C *** SUPPLY LEAD DIMENSION OF TY IN UI(1)...
-C *** (MOST COMPILERS WOULD LET US SIMPLY PASS LTY FOR UI,
-C *** BUT SOME, E.G. WATFIV, WILL NOT.)
-C
- UI(1) = LTY
-C
-C *** SPECIFY ALL DEFAULT IV AND V INPUT COMPONENTS (N2GB AND N2FB
-C *** ONLY)...
-C
- IV(1) = 0
-C
-C *** SUPPLY INITIAL GUESS...
-C
- X(1) = 0.5E+0
- X(2) = 1.5E+0
- X(3) = -1.E+0
- X(4) = 1.E-2
- X(5) = 2.E-2
-C
-C *** SET BIG TO LARGEST POSITIVE (MODEL) NUMBER...
-C
- BIG = R1MACH(2)
-C
-C *** SUPPLY BOUNDS -- INCLUDING LOWER BOUNDS OF -BIG AND UPPER
-C *** BOUNDS OF BIG WHERE WE DO NOT WISH TO IMPOSE BOUNDS...
-C
- DO 20 I = 1, 5
- B(1,I) = -BIG
- B(2,I) = BIG
- 20 CONTINUE
-C
- B(2,4) = .0125
- B(1,5) = .03
-C
-C *** SOLVE THE PROBLEM -- N2GB WILL PRINT THE SOLUTION FOR US...
-C
- CALL N2GB(33, 5, X, B, OSB1R, OSB1J, IV, LIV, LV, V, UI, TY,
- 1 DUMMY)
-C
-C *** FOR N2FB, THE CORRESPONDING CALL WOULD BE...
-C
-C CALL N2FB(33, 5, X, B, OSB1R, IV, LIV, LV, V, UI, TY, DUMMY)
-C
-C
-C *** NOTE -- ON MOST SYSTEMS, WE COULD SIMPLY PASS OSB1R (OR OSB1J)
-C *** AS THE UF PARAMETER, SINCE OSB1R AND OSB1J IGNORE THIS
-C *** PARAMETER. BUT THERE EXIST SYSTEMS (E.G. UNIVAC) THAT WOULD
-C *** GIVE A RUN-TIME ERROR IF WE DID THIS. HENCE WE PASS THE
-C *** IMMEDIATELY FOLLOWING DUMMY SUBROUTINE AS UF.
-C
- STOP
- END
- SUBROUTINE DUMMY
- RETURN
- END
- SUBROUTINE OSB1R(N, P, X, NF, R, LTY, TY, UF)
-C
-C *** THIS ROUTINE COMPUTES THE RESIDUAL VECTOR, R = R(X),
-C *** FOR TEST PROBLEM OSBORNE1.
-C
- INTEGER N, P, NF, LTY
- REAL X(P), R(N), TY(LTY,2)
- EXTERNAL UF
-C
- INTEGER I
- REAL TI, YI
-C
- DO 10 I = 1, N
- TI = TY(I,1)
- YI = TY(I,2)
- R(I) = YI - (X(1) + X(2)* EXP(X(4)*TI) + X(3)* EXP(X(5)*TI))
- 10 CONTINUE
- RETURN
- END
- SUBROUTINE OSB1J(N, P, X, NF, J, LTY, TY, UF)
-C
-C *** THIS ROUTINE COMPUTES THE JACOBIAN MATRIX, J = J(X),
-C *** FOR TEST PROBLEM OSBORNE1. J(I,K) IS SET TO THE PARTIAL
-C *** DERIVATIVE OF COMPONENT I OF R WITH RESPECT TO X(K).
-C
- INTEGER N, P, NF, LTY
- REAL X(P), J(N,P), TY(LTY,2)
- EXTERNAL UF
-C
- INTEGER I
- REAL NEGONE, TI
- DATA NEGONE/-1.E+0/
-C
- DO 10 I = 1, N
- TI = TY(I,1)
- J(I,1) = NEGONE
- J(I,2) = - EXP(X(4)*TI)
- J(I,3) = - EXP(X(5)*TI)
- J(I,4) = TI*X(2)*J(I,2)
- J(I,5) = TI*X(3)*J(I,3)
- 10 CONTINUE
- RETURN
- END
diff --git a/CEP/PyBDSM/src/port3/ex/nlsp.f b/CEP/PyBDSM/src/port3/ex/nlsp.f
deleted file mode 100644
index 74f9b242d15404af455c1e4176c6b1fc81d56881..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ex/nlsp.f
+++ /dev/null
@@ -1,146 +0,0 @@
-C$TEST NLSP
-C TO RUN AS A MAIN PROGRAM REMOVE NEXT LINE
- SUBROUTINE NLSP
-C***********************************************************************
-C
-C EXAMPLE OF USE OF THE PORT PROGRAM N2PB
-C
-C***********************************************************************
-C *** N2PB EXAMPLE PROGRAM ***
-C
-C *** FIT N = 33 DATA POINTS (T,Y) TO THE CURVE
-C *** X(1) + X(2)*EXP(T*X(4)) + X(3)*EXP(T*X(5))
-C
- INTEGER I, IV(102), LIV, LTY, LV, UI(1)
- REAL B(2,5), BIG, TY(50,2), V(302), X(5)
- EXTERNAL DUMMY, OSB1J, OSB1R, R1MACH
- REAL R1MACH
- DATA LIV/102/, LTY/50/, LV/302/
-C
-C *** TO MAKE THIS EXAMPLE SELF-CONTAINED, WE USE A DATA STATEMENT
-C *** AND DO LOOP TO SUPPLY (T,Y) PAIRS TO THE ARRAY TY.
-C
-C *** Y VALUES...
-C
- DATA TY(1,2) /8.44E-1/, TY(2,2) /9.08E-1/, TY(3,2)/9.32E-1/,
- 1 TY(4,2) /9.36E-1/, TY(5,2) /9.25E-1/, TY(6,2)/9.08E-1/,
- 2 TY(7,2) /8.81E-1/, TY(8,2) /8.50E-1/, TY(9,2)/8.18E-1/,
- 3 TY(10,2)/7.84E-1/, TY(11,2)/7.51E-1/, TY(12,2)/7.18E-1/,
- 4 TY(13,2)/6.85E-1/, TY(14,2)/6.58E-1/, TY(15,2)/6.28E-1/,
- 5 TY(16,2)/6.03E-1/, TY(17,2)/5.80E-1/, TY(18,2)/5.58E-1/,
- 6 TY(19,2)/5.38E-1/, TY(20,2)/5.22E-1/, TY(21,2)/5.06E-1/,
- 7 TY(22,2)/4.90E-1/, TY(23,2)/4.78E-1/, TY(24,2)/4.67E-1/,
- 8 TY(25,2)/4.57E-1/, TY(26,2)/4.48E-1/, TY(27,2)/4.38E-1/,
- 9 TY(28,2)/4.31E-1/, TY(29,2)/4.24E-1/, TY(30,2)/4.20E-1/,
- A TY(31,2)/4.14E-1/, TY(32,2)/4.11E-1/, TY(33,2)/4.06E-1/
-C
-C *** T VALUES...
-C
- DO 10 I = 1, 33
- TY(I,1) = -10.E+0 * FLOAT(I-1)
- 10 CONTINUE
-C
-C *** SUPPLY LEAD DIMENSION OF TY IN UI(1)...
-C *** (MOST COMPILERS WOULD LET US SIMPLY PASS LTY FOR UI,
-C *** BUT SOME, E.G. WATFIV, WILL NOT.)
-C
- UI(1) = LTY
-C
-C *** SPECIFY ALL DEFAULT IV AND V INPUT COMPONENTS...
-C
- IV(1) = 0
-C
-C ... TO LIMIT THE NUMBER OF ITERATIONS TO 100, WE WOULD REPLACE THE
-C ... ABOVE ASSIGNMENT OF 0 TO IV(1) WITH THE FOLLOWING TWO LINES...
-C
-C CALL IVSET(1, IV, LIV, LV, V)
-C IV(18) = 100
-C
-C
-C *** SUPPLY INITIAL GUESS...
-C
- X(1) = 0.5E+0
- X(2) = 1.5E+0
- X(3) = -1.E+0
- X(4) = 1.E-2
- X(5) = 2.E-2
-C
-C *** SET BIG TO LARGEST POSITIVE (MODEL) NUMBER...
-C
- BIG = R1MACH(2)
-C
-C *** SUPPLY BOUNDS -- INCLUDING LOWER BOUNDS OF -BIG AND UPPER
-C *** BOUNDS OF BIG WHERE WE DO NOT WISH TO IMPOSE BOUNDS...
-C
- DO 20 I = 1, 5
- B(1,I) = -BIG
- B(2,I) = BIG
- 20 CONTINUE
-C
- B(2,4) = .0125
- B(1,5) = .03
-C
-C *** SOLVE THE PROBLEM -- N2PB WILL PRINT THE SOLUTION FOR US.
-C *** WE COMPUTE 7 RESIDUAL COMPONENTS OR JACOBIAN ROWS PER CALL...
-C
- CALL N2PB(33, 7, 5, X, B, OSB1R, OSB1J, IV, LIV, LV, V, UI, TY,
- 1 DUMMY)
-C
-C
-C *** NOTE -- ON MOST SYSTEMS, WE COULD SIMPLY PASS OSB1R OR OSB1J
-C *** AS THE LAST PARAMETER TO N2PB, SINCE OSB1R AND OSB1J IGNORE
-C *** THEIR UF PARAMETER. BUT THERE EXIST SYSTEMS (E.G. UNIVAC)
-C *** THAT WOULD GIVE A RUN-TIME ERROR IF WE DID THIS. HENCE WE
-C *** PASS THE IMMEDIATELY FOLLOWING DUMMY SUBROUTINE AS UF.
-C
- STOP
- END
- SUBROUTINE DUMMY
- RETURN
- END
- SUBROUTINE OSB1R(N, ND1, N1, N2, P, X, NF, R, LTY, TY, UF)
-C
-C *** THIS ROUTINE COMPUTES CHUNKS OF THE RESIDUAL VECTOR, R = R(X),
-C *** FOR TEST PROBLEM OSBORNE1.
-C
- INTEGER N, ND1, N1, N2, P, NF, LTY
- REAL X(P), R(ND1), TY(LTY,2)
- EXTERNAL UF
-C
- INTEGER I, I1
- REAL TI, YI
-C
- I1 = 1
- DO 10 I = N1, N2
- TI = TY(I,1)
- YI = TY(I,2)
- R(I1) = YI - (X(1) + X(2)* EXP(X(4)*TI) + X(3)* EXP(X(5)*TI))
- I1 = I1 + 1
- 10 CONTINUE
- RETURN
- END
- SUBROUTINE OSB1J(N, ND1, N1, N2, P, X, NF, J, LTY, TY, UF)
-C
-C *** THIS ROUTINE COMPUTES CHUNKS OF THE JACOBIAN MATRIX, J = J(X),
-C *** FOR TEST PROBLEM OSBORNE1.
-C
- INTEGER N, ND1, N1, N2, P, NF, LTY
- REAL X(P), J(ND1,P), TY(LTY,2)
- EXTERNAL UF
-C
- INTEGER I, I1
- REAL NEGONE, TI
- DATA NEGONE/-1.E+0/
-C
- I1 = 1
- DO 10 I = N1, N2
- TI = TY(I,1)
- J(I1,1) = NEGONE
- J(I1,2) = - EXP(X(4)*TI)
- J(I1,3) = - EXP(X(5)*TI)
- J(I1,4) = TI*X(2)*J(I1,2)
- J(I1,5) = TI*X(3)*J(I1,3)
- I1 = I1 + 1
- 10 CONTINUE
- RETURN
- END
diff --git a/CEP/PyBDSM/src/port3/ex/nlsr.f b/CEP/PyBDSM/src/port3/ex/nlsr.f
deleted file mode 100644
index 7878154696c3eecac4e1887f68fe5f5b5cfa43c0..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ex/nlsr.f
+++ /dev/null
@@ -1,139 +0,0 @@
-C$TEST NLSR
-C TO RUN AS A MAIN PROGRAM REMOVE NEXT LINE
- SUBROUTINE NLSR
-C***********************************************************************
-C
-C EXAMPLE OF USE OF THE PORT PROGRAMS NSG AND NSF
-C
-C***********************************************************************
-C *** NSG AND NSF EXAMPLE PROGRAM ***
-C
-C *** FIT N = 33 DATA POINTS (T,Y) TO THE CURVE
-C *** X(1) + X(2)*DEXP(T*X(4)) + X(3)*DEXP(T*X(5))
-C
-C *** THE FOLLOWING CODE IS FOR CALLING NSG. DIFFERENCES FOR
-C *** CALLING NSF ARE EXPLAINED IN COMMENTS.
-C
- INTEGER I, J, INC(4,2), IV(124), LIV, LTY, LV, UI(1)
- DOUBLE PRECISION C(3), T(33), Y(33), V(612), X(5)
- EXTERNAL DUMMY, OSB1A, OSB1B
- DATA LIV/124/, LTY/50/, LV/612/
-C
-C *** FOR NSF, OMIT OSB1B FROM THE EXTERNAL STATEMENT.
-C
-C
-C *** TO MAKE THIS EXAMPLE SELF-CONTAINED, WE USE A DATA STATEMENT
-C *** AND DO LOOP TO SUPPLY (T(I),Y(I)) PAIRS.
-C
-C *** Y VALUES...
-C
- DATA Y(1) /8.44D-1/, Y(2) /9.08D-1/, Y(3)/9.32D-1/,
- 1 Y(4) /9.36D-1/, Y(5) /9.25D-1/, Y(6)/9.08D-1/,
- 2 Y(7) /8.81D-1/, Y(8) /8.50D-1/, Y(9)/8.18D-1/,
- 3 Y(10)/7.84D-1/, Y(11)/7.51D-1/, Y(12)/7.18D-1/,
- 4 Y(13)/6.85D-1/, Y(14)/6.58D-1/, Y(15)/6.28D-1/,
- 5 Y(16)/6.03D-1/, Y(17)/5.80D-1/, Y(18)/5.58D-1/,
- 6 Y(19)/5.38D-1/, Y(20)/5.22D-1/, Y(21)/5.06D-1/,
- 7 Y(22)/4.90D-1/, Y(23)/4.78D-1/, Y(24)/4.67D-1/,
- 8 Y(25)/4.57D-1/, Y(26)/4.48D-1/, Y(27)/4.38D-1/,
- 9 Y(28)/4.31D-1/, Y(29)/4.24D-1/, Y(30)/4.20D-1/,
- A Y(31)/4.14D-1/, Y(32)/4.11D-1/, Y(33)/4.06D-1/
-C
-C *** T VALUES...
-C
- DO 10 I = 1, 33
- T(I) = -10.D+0 *FLOAT(I-1)
- 10 CONTINUE
-C
-C *** SET UP INC ***
-C
- DO 30 J = 1, 2
- DO 20 I = 1, 4
- 20 INC(I,J) = 0
- 30 CONTINUE
- INC(2,1) = 1
- INC(3,2) = 1
-C
-C *** SPECIFY ALL DEFAULT IV AND V INPUT COMPONENTS ***
-C
- IV(1) = 0
-C
-C ... TO TURN OFF THE DEFAULT COMPUTATION AND PRINTING OF THE
-C ... REGRESSION DIAGNOSTIC VECTOR, WE WOULD REPLACE THE ABOVE
-C ... ASSIGNMENT OF 0 TO IV(1) WITH THE FOLLOWING THREE LINES...
-C
-C CALL IVSET(1, IV, LIV, LV, V)
-C IV(57) = 1
-C IV(14) = 1
-C
-C ... THAT IS, WE SET IV(RDREQ) AND IV(COVPRT) TO 1, THUS REQUESTING
-C ... COMPUTATION AND PRINTING OF JUST A COVARIANCE MATRIX.
-C
-C
-C *** SUPPLY INITIAL GUESS...
-C
- X(1) = 1.D-2
- X(2) = 2.D-2
-C
-C *** SOLVE THE PROBLEM -- NSG WILL PRINT THE SOLUTION FOR US...
-C
- CALL DNSG(33, 2, 3, X, C, Y, OSB1A, OSB1B, INC, 4,
- 1 IV, LIV, LV, V, UI, T, DUMMY)
-C
-C *** FOR NSF, THE CORRESPONDING CALL WOULD BE...
-C
-C CALL NSF(33, 2, 3, X, C, Y, OSB1A, INC, 4,
-C 1 IV, LIV, LV, V, UI, T, DUMMY)
-C
-C
-C *** NOTE -- ON MOST SYSTEMS, WE COULD SIMPLY PASS OSB1A (OR OSB1B)
-C *** AS THE UF PARAMETER, SINCE OSB1A AND OSB1B IGNORE THIS
-C *** PARAMETER. BUT THERE EXIST SYSTEMS (E.G. UNIVAC) THAT WOULD
-C *** GIVE A RUN-TIME ERROR IF WE DID THIS. HENCE WE PASS THE
-C *** IMMEDIATELY FOLLOWING DUMMY SUBROUTINE AS UF.
-C
- STOP
- END
- SUBROUTINE DUMMY
- RETURN
- END
- SUBROUTINE OSB1A(N, P, L, X, NF, A, UI, T, UF)
-C
-C *** THIS ROUTINE COMPUTES THE A MATRIX, A = A(X),
-C *** FOR TEST PROBLEM OSBORNE1.
-C
- INTEGER L, N, NF, P, UI(1)
- DOUBLE PRECISION A(N,1), T(N), X(P)
- EXTERNAL UF
-C
- INTEGER I
- DOUBLE PRECISION ONE, TI
- DATA ONE/1.D+0/
-C
- DO 10 I = 1, N
- TI = T(I)
- A(I,1) = ONE
- A(I,2) = DEXP(TI*X(1))
- A(I,3) = DEXP(TI*X(2))
- 10 CONTINUE
- RETURN
- END
- SUBROUTINE OSB1B(N, P, L, X, NF, B, UI, T, UF)
-C
-C *** THIS ROUTINE COMPUTES THE JACOBIAN TENSOR, B = B(X),
-C *** FOR TEST PROBLEM OSBORNE1.
-C
- INTEGER L, N, NF, P, UI(1)
- DOUBLE PRECISION B(N,2), T(N), X(P)
- EXTERNAL UF
-C
- INTEGER I
- DOUBLE PRECISION TI
-C
- DO 10 I = 1, N
- TI = T(I)
- B(I,1) = TI * DEXP(TI*X(1))
- B(I,2) = TI * DEXP(TI*X(2))
- 10 CONTINUE
- RETURN
- END
diff --git a/CEP/PyBDSM/src/port3/ex/nmsk.f b/CEP/PyBDSM/src/port3/ex/nmsk.f
deleted file mode 100644
index b4816512213a07617db02a5fd2bbbf05b5cb0b12..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ex/nmsk.f
+++ /dev/null
@@ -1,149 +0,0 @@
-C$TEST NMSK
-C TO RUN AS A MAIN PROGRAM REMOVE NEXT LINE
- SUBROUTINE NMSK
-C***********************************************************************
-C
-C EXAMPLE OF USE OF THE PORT PROGRAMS NSGB AND NSFB
-C
-C***********************************************************************
-C *** NSGB AND NSFB EXAMPLE PROGRAM ***
-C
-C *** FIT N = 33 DATA POINTS (T,Y) TO THE CURVE
-C *** X(1) + X(2)*EXP(T*X(4)) + X(3)*EXP(T*X(5))
-C
-C *** THE FOLLOWING CODE IS FOR CALLING NSGB. DIFFERENCES FOR
-C *** CALLING NSFB ARE EXPLAINED IN COMMENTS.
-C
- INTEGER I, J, INC(4,2), IV(130), LIV, LTY, LV, UI(1)
- REAL BX(2,2), BIG, C(3), T(33), Y(33), V(461), X(5)
- EXTERNAL DUMMY, OSB1A, OSB1B, R1MACH
- REAL R1MACH
-C
-C *** FOR NSFB, OMIT OSB1B FROM THE EXTERNAL STATEMENT.
-C
- DATA LIV/130/, LTY/50/, LV/461/
-C
-C *** TO MAKE THIS EXAMPLE SELF-CONTAINED, WE USE A DATA STATEMENT
-C *** AND DO LOOP TO SUPPLY (T(I),Y(I)) PAIRS.
-C
-C *** Y VALUES...
-C
- DATA Y(1) /8.44E-1/, Y(2) /9.08E-1/, Y(3)/9.32E-1/,
- 1 Y(4) /9.36E-1/, Y(5) /9.25E-1/, Y(6)/9.08E-1/,
- 2 Y(7) /8.81E-1/, Y(8) /8.50E-1/, Y(9)/8.18E-1/,
- 3 Y(10)/7.84E-1/, Y(11)/7.51E-1/, Y(12)/7.18E-1/,
- 4 Y(13)/6.85E-1/, Y(14)/6.58E-1/, Y(15)/6.28E-1/,
- 5 Y(16)/6.03E-1/, Y(17)/5.80E-1/, Y(18)/5.58E-1/,
- 6 Y(19)/5.38E-1/, Y(20)/5.22E-1/, Y(21)/5.06E-1/,
- 7 Y(22)/4.90E-1/, Y(23)/4.78E-1/, Y(24)/4.67E-1/,
- 8 Y(25)/4.57E-1/, Y(26)/4.48E-1/, Y(27)/4.38E-1/,
- 9 Y(28)/4.31E-1/, Y(29)/4.24E-1/, Y(30)/4.20E-1/,
- A Y(31)/4.14E-1/, Y(32)/4.11E-1/, Y(33)/4.06E-1/
-C
-C *** T VALUES...
-C
- DO 10 I = 1, 33
- T(I) = -10.E+0 * FLOAT(I-1)
- 10 CONTINUE
-C
-C *** SET UP INC ***
-C
- DO 30 J = 1, 2
- DO 20 I = 1, 4
- 20 INC(I,J) = 0
- 30 CONTINUE
- INC(2,1) = 1
- INC(3,2) = 1
-C
-C *** SPECIFY ALL DEFAULT IV AND V INPUT COMPONENTS ***
-C
- IV(1) = 0
-C
-C ... TO SET THE MAXIMUM NUMBER OF ITERATIONS TO 100 AND TURN OFF
-C ... THE PRINTING OF THE ITERATION SUMMARY, WE WOULD REPLACE THE
-C ... ABOVE ASSIGNMENT OF 0 TO IV(1) WITH THE FOLLOWING THREE LINES...
-C
-C CALL IVSET(1, IV, LIV, LV, V)
-C IV(18) = 100
-C IV(19) = 0
-C
-C
-C *** SUPPLY INITIAL GUESS...
-C
- X(1) = 1.E-2
- X(2) = 2.E-2
-C
-C *** SET BIG TO LARGEST POSITIVE (MODEL) NUMBER...
-C
- BIG = R1MACH(2)
-C
-C *** SUPPLY BOUNDS -- INCLUDING LOWER BOUNDS OF -BIG AND UPPER
-C *** BOUNDS OF BIG WHERE WE DO NOT WISH TO IMPOSE BOUNDS...
-C
- BX(1,1) = -BIG
- BX(2,1) = .0125E+0
- BX(1,2) = .03E+0
- BX(2,2) = BIG
-C
-C *** SOLVE THE PROBLEM -- NSGB WILL PRINT THE SOLUTION FOR US...
-C
- CALL NSGB(33, 2, 3, X, BX, C, Y, OSB1A, OSB1B, INC, 4,
- 1 IV, LIV, LV, V, UI, T, DUMMY)
-C
-C *** FOR NSFB, THE CORRESPONDING CALL WOULD BE...
-C
-C CALL NSFB(33, 2, 3, X, BX, C, Y, OSB1A, INC, 4,
-C 1 IV, LIV, LV, V, UI, T, DUMMY)
-C
-C
-C *** NOTE -- ON MOST SYSTEMS, WE COULD SIMPLY PASS OSB1A (OR OSB1B)
-C *** AS THE UF PARAMETER, SINCE OSB1A AND OSB1B IGNORE THIS
-C *** PARAMETER. BUT THERE EXIST SYSTEMS (E.G. UNIVAC) THAT WOULD
-C *** GIVE A RUN-TIME ERROR IF WE DID THIS. HENCE WE PASS THE
-C *** IMMEDIATELY FOLLOWING DUMMY SUBROUTINE AS UF.
-C
- STOP
- END
- SUBROUTINE DUMMY
- RETURN
- END
- SUBROUTINE OSB1A(N, P, L, X, NF, A, UI, T, UF)
-C
-C *** THIS ROUTINE COMPUTES THE A MATRIX, A = A(X),
-C *** FOR TEST PROBLEM OSBORNE1.
-C
- INTEGER L, N, NF, P, UI(1)
- REAL A(N,1), T(N), X(P)
- EXTERNAL UF
-C
- INTEGER I
- REAL ONE, TI
- DATA ONE/1.E+0/
-C
- DO 10 I = 1, N
- TI = T(I)
- A(I,1) = ONE
- A(I,2) = EXP(TI*X(1))
- A(I,3) = EXP(TI*X(2))
- 10 CONTINUE
- RETURN
- END
- SUBROUTINE OSB1B(N, P, L, X, NF, B, UI, T, UF)
-C
-C *** THIS ROUTINE COMPUTES THE JACOBIAN TENSOR, B = B(X),
-C *** FOR TEST PROBLEM OSBORNE1.
-C
- INTEGER L, N, NF, P, UI(1)
- REAL B(N,2), T(N), X(P)
- EXTERNAL UF
-C
- INTEGER I
- REAL TI
-C
- DO 10 I = 1, N
- TI = T(I)
- B(I,1) = TI * EXP(TI*X(1))
- B(I,2) = TI * EXP(TI*X(2))
- 10 CONTINUE
- RETURN
- END
diff --git a/CEP/PyBDSM/src/port3/ex/np2a.f b/CEP/PyBDSM/src/port3/ex/np2a.f
deleted file mode 100644
index 7b4a5ce513b7fb911e62cc7835ccfecffdc54ace..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ex/np2a.f
+++ /dev/null
@@ -1,49 +0,0 @@
-C$TEST NP2A
-C TO RUN AS A MAIN PROGRAM REMOVE NEXT LINE
- SUBROUTINE NP2A
-C***********************************************************************
-C
-C EXAMPLE OF USE OF THE PORT PROGRAM SN2F
-C
-C***********************************************************************
- INTEGER N,P
- EXTERNAL OSBN
- REAL Y(10),T(10),YY(10),X(5)
- COMMON /YT/YY,T
-C GENERATE DATA FOR PROBLEM
- DATA Y(1)/8.44E-1/, Y(2) /9.36E-1/, Y(3) /8.81E-1/
- 1 Y(4)/7.84E-1/, Y(5)/ 6.85E-1/, Y(6)/6.03E-1/,
- 2 Y(7) /5.38E-1/ , Y(8) /4.90E-1/, Y(9)/4.57E-1/
- P=5
- N=9
- DO 10 I=1,9
- YY(I) = Y(I)
- T(I)=-30.E0*FLOAT(I-1)
- 10 CONTINUE
-C INITIALIZE X
- X(1)=0.5
- X(2)=1.5
- X(3)=-1.
- X(4)=.01
- X(5)=.02
-C
-C SOLVE THE PROBLEM
-C
- CALL SN2F(N, P, X, OSBN, 100, 1.E-4)
-C PRINT RESULTS ON STANDARD OUTPUT UNIT
- IWRITE = I1MACH(2)
- WRITE(IWRITE, 20)(X(I),I=1,P)
- 20 FORMAT(10H SOLUTION-,5E15.5)
- STOP
- END
- SUBROUTINE OSBN(N,P,X,NF,R)
-C THIS SUBROUTINE COMPUTES THE MODEL
- INTEGER P, N, NF
- REAL X(P), R(N)
- REAL Y(10), T(10)
- COMMON /YT/ Y, T
- DO 10 I=1,N
- R(I)=Y(I)-(X(1)+X(2)*EXP(X(4)*T(I))+X(3)*EXP(X(5)*T(I)))
- 10 CONTINUE
- RETURN
- END
diff --git a/CEP/PyBDSM/src/port3/ex/np2b.f b/CEP/PyBDSM/src/port3/ex/np2b.f
deleted file mode 100644
index 6792bf6ea268e35b9169ce04be43f9abaaba35b7..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ex/np2b.f
+++ /dev/null
@@ -1,59 +0,0 @@
-C$TEST NP2B
-C TO RUN AS A MAIN PROGRAM REMOVE NEXT LINE
- SUBROUTINE NP2B
-C***********************************************************************
-C
-C EXAMPLE OF USE OF THE PORT PROGRAM SN2FB
-C
-C***********************************************************************
- INTEGER N,P
- EXTERNAL OSBN
- REAL Y(10),YY(10),T(10),X(5),B(2,5)
- COMMON /YT/YY,T
-C GENERATE DATA FOR PROBLEM
- DATA Y(1)/8.44E-1/, Y(2) /9.36E-1/, Y(3) /8.81E-1/
- 1 Y(4)/7.84E-1/, Y(5)/ 6.85E-1/, Y(6)/6.03E-1/,
- 2 Y(7) /5.38E-1/ , Y(8) /4.90E-1/, Y(9)/4.57E-1/
- P=5
- N=9
- DO 10 I=1,9
- YY(I) = Y(I)
- T(I)=-30.E0*FLOAT(I-1)
- 10 CONTINUE
-C INITIALIZE X
- X(1)=0.5
- X(2)=1.5
- X(3)=-1.
- X(4)=.01
- X(5)=.03
-C SUPPLY BOUNDS
-C
-C SET VARIABLES WE DO NOT WANT TO BE BOUNDED TO BIGGEST AND
-C AND SMALLEST NUMBERS IN THE MACHINE
- BIG=R1MACH(2)
- DO 20 I=1, P
- B(1,I)=-BIG
- B(2,I)=BIG
- 20 CONTINUE
- B(2,4)=0.125
- B(1,5)=0.03
-C
-C SOLVE THE PROBLEM
-C
- CALL SN2FB(N, P, X, B, OSBN, 100, 1.E-4)
-C PRINT RESULTS ON STANDARD OUTPUT UNIT
- IWRITE = I1MACH(2)
- WRITE(IWRITE, 30)(X(I),I=1,P)
- 30 FORMAT(10H SOLUTION-,5E15.5)
- STOP
- END
- SUBROUTINE OSBN(N,P,X,NF,R)
- INTEGER P, N, NF
- REAL X(P), R(N)
- REAL Y(10), T(10)
- COMMON /YT/ Y, T
- DO 10 I=1,N
- R(I)=Y(I)-(X(1)+X(2)*EXP(X(4)*T(I))+X(3)*EXP(X(5)*T(I)))
- 10 CONTINUE
- RETURN
- END
diff --git a/CEP/PyBDSM/src/port3/ex/np2e.f b/CEP/PyBDSM/src/port3/ex/np2e.f
deleted file mode 100644
index 6f9eaa8630606d451e289d58abef50184de1b42b..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ex/np2e.f
+++ /dev/null
@@ -1,64 +0,0 @@
-C$TEST NP2E
-C TO RUN AS A MAIN PROGRAM REMOVE NEXT LINE
- SUBROUTINE NP2E
-C***********************************************************************
-C
-C EXAMPLE OF USE OF THE PORT PROGRAM SN2G
-C
-C***********************************************************************
- INTEGER N,P
- EXTERNAL OSBN, OSBNJ
- REAL Y(10),YY(10),T(10),X(5)
- COMMON /YT/YY,T
-C GENERATE DATA FOR PROBLEM
- DATA Y(1)/8.44E-1/, Y(2) /9.36E-1/, Y(3) /8.81E-1/
- 1 Y(4)/7.84E-1/, Y(5)/ 6.85E-1/, Y(6)/6.03E-1/,
- 2 Y(7) /5.38E-1/ , Y(8) /4.90E-1/, Y(9)/4.57E-1/
- P=5
- N=9
- DO 10 I=1,9
- YY(I) = Y(I)
- T(I)=-30.E0*FLOAT(I-1)
- 10 CONTINUE
-C INITIALIZE X
- X(1)=0.5
- X(2)=1.5
- X(3)=-1.
- X(4)=.01
- X(5)=.02
-C
-C SOLVE THE PROBLEM
-C
- CALL SN2G(N, P, X, OSBN, OSBNJ, 100, 1.E-4)
-C PRINT RESULTS ON STANDARD OUTPUT UNIT
- IWRITE = I1MACH(2)
- WRITE(IWRITE, 20)(X(I),I=1,P)
- 20 FORMAT(10H SOLUTION-,5E15.5)
- STOP
- END
- SUBROUTINE OSBN(N,P,X,NF,R)
-C THIS SUBROUTINE COMPUTES THE MODEL
- INTEGER P, N, NF
- REAL X(P), R(N)
- REAL Y(10), T(10)
- COMMON /YT/ Y, T
- DO 10 I=1,N
- R(I)=Y(I)-(X(1)+X(2)*EXP(X(4)*T(I))+X(3)*EXP(X(5)*T(I)))
- 10 CONTINUE
- RETURN
- END
- SUBROUTINE OSBNJ(N,P,X,NF,J)
-C THIS SUBROUTINE COMPUTES THE JACOBIAN OF THE MODEL
- INTEGER P, N, NF
- REAL X(P), J(N,P)
- REAL Y(10), T(10)
- COMMON /YT/ Y, T
- DO 10 I=1,N
- J(I,1)=-1.0E0
- J(I,2)=-EXP(X(4)*T(I))
- J(I,3)=-EXP(X(5)*T(I))
- J(I,4)=-T(I)*X(2)*EXP(X(4)*T(I))
- J(I,5)=-T(I)*X(3)*EXP(X(5)*T(I))
- 10 CONTINUE
- RETURN
- END
diff --git a/CEP/PyBDSM/src/port3/ex/np2f.f b/CEP/PyBDSM/src/port3/ex/np2f.f
deleted file mode 100644
index de8ab70d19ca84678778fa06528b14a1574b55c8..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ex/np2f.f
+++ /dev/null
@@ -1,75 +0,0 @@
-C$TEST NP2F
-C TO RUN AS A MAIN PROGRAM REMOVE NEXT LINE
- SUBROUTINE NP2F
-C***********************************************************************
-C
-C EXAMPLE OF USE OF THE PORT PROGRAM SN2GB
-C
-C***********************************************************************
- INTEGER N,P
- EXTERNAL OSBN,OSBNJ
- REAL Y(10),YY(10),T(10),X(5),B(2,5)
- COMMON /YT/YY,T
-C GENERATE DATA FOR PROBLEM
- DATA Y(1)/8.44E-1/, Y(2) /9.36E-1/, Y(3) /8.81E-1/
- 1 Y(4)/7.84E-1/, Y(5)/ 6.85E-1/, Y(6)/6.03E-1/,
- 2 Y(7) /5.38E-1/ , Y(8) /4.90E-1/, Y(9)/4.57E-1/
- P=5
- N=9
- DO 10 I=1,9
- YY(I) = Y(I)
- T(I)=-30.E0*FLOAT(I-1)
- 10 CONTINUE
-C INITIALIZE X
- X(1)=0.5
- X(2)=1.5
- X(3)=-1.
- X(4)=.01
- X(5)=.03
-C SUPPLY BOUNDS
-C
-C SET VARIABLES WE DO NOT WANT TO BE BOUNDED TO BIGGEST AND
-C AND SMALLEST NUMBERS IN THE MACHINE
- BIG=R1MACH(2)
- DO 20 I=1, P
- B(1,I)=-BIG
- B(2,I)=BIG
- 20 CONTINUE
- B(2,4)=0.125
- B(1,5)=0.03
-C
-C SOLVE THE PROBLEM
-C
- CALL SN2GB(N, P, X, B, OSBN, OSBNJ, 100, 1.E-4)
-C PRINT RESULTS ON STANDARD OUTPUT UNIT
- IWRITE = I1MACH(2)
- WRITE(IWRITE, 30)(X(I),I=1,P)
- 30 FORMAT(10H SOLUTION-,5E15.5)
- STOP
- END
- SUBROUTINE OSBN(N,P,X,NF,R)
-C THIS SUBROUTINE COMPUTES THE MODEL
- INTEGER P, N, NF
- REAL X(P), R(N)
- REAL Y(10), T(10)
- COMMON /YT/ Y, T
- DO 10 I=1,N
- R(I)=Y(I)-(X(1)+X(2)*EXP(X(4)*T(I))+X(3)*EXP(X(5)*T(I)))
- 10 CONTINUE
- RETURN
- END
- SUBROUTINE OSBNJ(N,P,X,NF,J)
-C THIS SUBROUTINE COMPUTES THE JACOBIAN OF THE MODEL
- INTEGER P, N, NF
- REAL X(P), J(N,P)
- REAL Y(10), T(10)
- COMMON /YT/ Y, T
- DO 10 I=1,N
- J(I,1)=-1.0E0
- J(I,2)=-EXP(X(4)*T(I))
- J(I,3)=-EXP(X(5)*T(I))
- J(I,4)=-T(I)*X(2)*EXP(X(4)*T(I))
- J(I,5)=-T(I)*X(3)*EXP(X(5)*T(I))
- 10 CONTINUE
- RETURN
- END
diff --git a/CEP/PyBDSM/src/port3/ex/nsfa.f b/CEP/PyBDSM/src/port3/ex/nsfa.f
deleted file mode 100644
index 798556bd1218a1fd7cd27fa7d0e192780a27c4c4..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ex/nsfa.f
+++ /dev/null
@@ -1,69 +0,0 @@
-C$TEST NSFA
-C TO RUN AS A MAIN PROGRAM REMOVE NEXT LINE
- SUBROUTINE NSFA
-C***********************************************************************
-C
-C EXAMPLE OF USE OF THE PORT PROGRAM NSF1
-C
-C***********************************************************************
-C EXAMPLE PROGRAM FOR NSF1 TO FIT
-C N DATA POINTS (T,Y) TO CURVE
-C C(1)*EXP(T*X) + C(2)
-C
- INTEGER IWRITE
- REAL C(2), T(8), Y(8), TT(8), YY(8)
- DOUBLE PRECISION S
- EXTERNAL GETAY
- COMMON /DATBLK/TT,YY
- DATA T(1) /12.0/, T(2) /20.0/ ,T(3) /28.0/, T(4) /48.0/,
- 1 T(5)/120.0/, T(6) /240.0/, T(7) /900.0/, T(8) /2400.0/
- DATA Y(1) /0.2342/, Y(2) /0.2244/ , Y(3) /0.2204/,
- 1 Y(4) /0.2149/, Y(5) /0.2063/, Y(6) /0.1983/,
- 2 Y(7) /0.1842/, Y(8)/0.1761/
-C
-C SET UP OUTPUT UNIT
-C
- IWRITE = I1MACH(2)
-C
-C MOVE T AND Y VECTORS TO COMMON
-C
- DO 2 I=1,8
- TT(I) = T(I)
- YY(I) = Y(I)
- 2 CONTINUE
-C
- N = 8
- L = 2
- X1 = -10.0
- X2 = 0.001
-C
-C DO THE FIT
-C
- CALL NSF1(N, L, X, X1, X2, 1.E-6, C)
- WRITE(IWRITE, 4) X, C(1), C(2)
- 4 FORMAT(5H X = , E20.10/8H C(1) = ,E20.10/8H C(2) = , E20.10)
-C
- WRITE(IWRITE, 5)
- 5 FORMAT(//,19X,1HT,14X,6HREAL Y,14X,5HEST.Y,15X,5HERROR,/)
- DO 100 I=1,N
- YEST = C(1)*EXP(T(I)*X)+C(2)
- YERR = ABS(Y(I)-YEST)
- WRITE(IWRITE, 6) T(I), Y(I), YEST, YERR
- 100 S = S + YERR*YERR
- 6 FORMAT (4E20.10)
- WRITE(IWRITE, 7) S
- 7 FORMAT(//,24HSUM OF ERRORS SQUARED = ,D20.10)
- STOP
- END
- SUBROUTINE GETAY(N,L,X,A,Y)
- INTEGER N,L
- REAL A(N,L),X,Y(N)
- REAL T(8),YY(8)
- COMMON /DATBLK/T,YY
- DO 100 I=1,N
- A(I,1)=EXP(X*T(I))
- A(I,2)=1.0
- Y(I)=YY(I)
- 100 CONTINUE
- RETURN
- END
diff --git a/CEP/PyBDSM/src/port3/ex/nsnm.f b/CEP/PyBDSM/src/port3/ex/nsnm.f
deleted file mode 100644
index f029cf03b55dc25afa3af9227bc3a36b9cf74501..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ex/nsnm.f
+++ /dev/null
@@ -1,105 +0,0 @@
-C$TEST NSNM
-C TO RUN AS A MAIN PROGRAM REMOVE NEXT LINE
- SUBROUTINE NSNM
-C***********************************************************************
-C
-C EXAMPLE OF USE OF THE PORT PROGRAM SMNSX
-C
-C***********************************************************************
-C *** SMNSX EXAMPLE PROGRAM ***
-C
-C *** MINIMIZE F(X) = 0.1*S(X)**4 + SUM(I = 1(1)3) (I * (X(I) - 10)**2),
-C *** WHERE S(X) = SUM(I = 1(1)3) X(I),
-C *** STARTING FROM X = (2, 30, 9).
-C
- INTEGER I, J, IWRITE, P
- REAL FX, S(3,4), STEP, TOL, X(3)
- EXTERNAL I1MACH, MNSX, QF, SMNSX
- INTEGER I1MACH
- REAL MNSX, SMNSX
-C
-C *** USE COMMON TO FIND NUMBER OF TIMES F(X) IS EVALUATED...
-C
- INTEGER NF
- COMMON /SXCOMN/ NF
-C
- DATA P/3/
-C
-C *** BODY ***
-C
-C
-C *** FIRST SOLVE THE PROBLEM USING SMNSX...
-C
- X(1) = 2.E0
- X(2) = 3.E1
- X(3) = 9.E0
-C
- NF = 0
-C *** STEP AND TOL ARE USED AS BOTH INPUT AND OUTPUT PARAMETERS,
-C *** SO WE MUST NOT PASS CONSTANTS FOR THEM.
- STEP = 1.E0
- TOL = 1.E-10
-C
- FX = SMNSX(QF, P, STEP, TOL, X)
-C
-C *** PRINT OUT THE SOLUTION (ON THE STANDARD OUTPUT UNIT) ***
-C
- IWRITE = I1MACH(2)
- WRITE(IWRITE,10) FX, TOL, STEP, X, NF
- 10 FORMAT(21H SMNSX RETURNS F(X) =, E13.6,7H, TOL =, E10.3/
- 1 11H AND STEP =, E10.3/7H AT X =, 3E14.6/6H AFTER, I5,
- 2 21H FUNCTION EVALUATIONS)
-C
-C *** SOLVE THE PROBLEM AGAIN, THIS TIME USING MNSX...
-C
- X(1) = 2.0E0
- X(2) = 30.0E0
- X(3) = 9.0E0
-C
-C
-C *** CREATE INITIAL SIMPLEX...
-C
- DO 30 J = 1, 4
- DO 20 I = 1, 3
- S(I,J) = X(I) - 0.5E0
- 20 CONTINUE
- IF (J .LE. 3) S(J,J) = X(J) + 0.5E0
- 30 CONTINUE
-C
- NF = 0
- TOL = 1.E-10
-C
- FX = MNSX(QF, 1000, P, P, S, TOL, X)
-C
-C *** PRINT OUT THE SOLUTION ***
-C
- WRITE(IWRITE,40) FX, TOL, X, NF
- 40 FORMAT(/20H MNSX RETURNS F(X) =, E13.6,10H AND TOL =, E10.3/
- 1 7H AT X =,3E14.6/6H AFTER, I5, 21H FUNCTION EVALUATIONS)
- 999 STOP
- END
- REAL FUNCTION QF(P, X)
-C
-C *** THIS ROUTINE COMPUTES THE OBJECTIVE FUNCTION, F(X)
-C
- INTEGER P
- REAL X(P)
-C
- INTEGER NF
- COMMON /SXCOMN/ NF
-C
- INTEGER I
- REAL PT1, TEN, ZERO
-C
- DATA PT1 /0.1E0/, TEN/1.E1/, ZERO/0.E0/
-C
-C
- NF = NF + 1
- QF = ZERO
- DO 10 I = 1, P
- 10 QF = QF + X(I)
- QF = PT1 * QF**4
- DO 20 I = 1, P
- 20 QF = QF + I*(X(I) - TEN)**2
- 999 RETURN
- END
diff --git a/CEP/PyBDSM/src/port3/ex/ntle.f b/CEP/PyBDSM/src/port3/ex/ntle.f
deleted file mode 100644
index c294acaa0fcd9ad466b126db9aa2e0ac07c9779d..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ex/ntle.f
+++ /dev/null
@@ -1,38 +0,0 @@
-C$TEST NTLE
-C TO RUN AS A MAIN PROGRAM REMOVE NEXT LINE
- SUBROUTINE NTLE
-C***********************************************************************
-C
-C EXAMPLE OF USE OF THE PORT PROGRAM SMNFB
-C
-C***********************************************************************
- INTEGER N
- EXTERNAL ROSN
- REAL X(2), B(2,2)
- N=2
-C INITIALIZE X
- X(1)=-1.2
- X(2)=1.0
-C SET UP THE BOUND ARRAY
-C R1MACH(2) CONTAINS THE LARGEST NUMBER IN THE MACHINE
- B(1,1)=-R1MACH(2)
- B(2,1)=0.5
- B(1,2)=0.0
- B(2,2)=1.0
-C
-C SOLVE THE PROBLEM
-C
- CALL SMNFB(N, X, B, ROSN, 100, 1.E-4)
-C PRINT RESULTS ON STANDARD OUTPUT UNIT
- IWRITE=I1MACH(2)
- WRITE(IWRITE,10)(X(I),I=1,N)
- 10 FORMAT(10H SOLUTION-,5E15.5)
- STOP
- END
- SUBROUTINE ROSN(N,X,NF,F)
-C THIS SUBROUTINE COMPUTES THE FUNCTION
- INTEGER N, NF
- REAL X(N), F
- F=100.0*(X(2)-X(1)*X(1))**2 + (1.0 - X(1))**2
- RETURN
- END
diff --git a/CEP/PyBDSM/src/port3/ex/ntlf.f b/CEP/PyBDSM/src/port3/ex/ntlf.f
deleted file mode 100644
index db5e671ed1c531f48d5533d833c07dc4a746b83b..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ex/ntlf.f
+++ /dev/null
@@ -1,40 +0,0 @@
-C$TEST NTLF
-C TO RUN AS A MAIN PROGRAM REMOVE NEXT LINE
- SUBROUTINE NTLF
-C***********************************************************************
-C
-C EXAMPLE OF USE OF THE PORT PROGRAM SMNG
-C
-C***********************************************************************
- INTEGER N
- EXTERNAL ROSN,ROSG
- REAL X(2)
- N=2
-C INITIALIZE X
- X(1)=-1.2
- X(2)=1.0
-C
-C SOLVE THE PROBLEM
-C
- CALL SMNG(N, X, ROSN, ROSG, 100, 1.E-4)
-C PRINT RESULTS ON STANDARD OUTPUT UNIT
- IWRITE=I1MACH(2)
- WRITE(IWRITE,10)(X(I),I=1,N)
- 10 FORMAT(10H SOLUTION-,5E15.5)
- STOP
- END
- SUBROUTINE ROSN(N,X,NF,F)
-C THIS SUBROUTINE COMPUTES THE FUNCTION
- INTEGER N, NF
- REAL X(N), F
- F=100.0*(X(2)-X(1)*X(1))**2 + (1.0 - X(1))**2
- RETURN
- END
- SUBROUTINE ROSG(N,X,NF,G)
-C THIS SUBROUTINE COMPUTES THE GRADIENT
- INTEGER N,NF
- REAL X(N), G(N)
- G(1)=200.0*(X(2)-X(1)*X(1))*(-2.0)*X(1) - 2.0*(1-X(1))
- G(2)=200.0*(X(2)-X(1)*X(1))
- RETURN
- END
diff --git a/CEP/PyBDSM/src/port3/ex/ntlh.f b/CEP/PyBDSM/src/port3/ex/ntlh.f
deleted file mode 100644
index 6aa3ce0c2cf06998670fdedfafd58a435b465942..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ex/ntlh.f
+++ /dev/null
@@ -1,46 +0,0 @@
-C$TEST NTLH
-C TO RUN AS A MAIN PROGRAM REMOVE NEXT LINE
- SUBROUTINE NTLH
-C***********************************************************************
-C
-C EXAMPLE OF USE OF THE PORT PROGRAM SMNGB
-C
-C***********************************************************************
- INTEGER N
- EXTERNAL ROSN, ROSG
- REAL X(2), B(2,2)
- N=2
-C INITIALIZE X
- X(1)=-1.2
- X(2)=1.0
-C SET UP THE BOUND ARRAY
-C R1MACH(2) CONTAINS THE LARGEST NUMBER IN THE MACHINE
- B(1,1)=-R1MACH(2)
- B(2,1)=0.5
- B(1,2)=0.0
- B(2,2)=1.0
-C
-C SOLVE THE PROBLEM
-C
- CALL SMNGB(N, X, B, ROSN, ROSG, 100, 1.E-4)
-C PRINT RESULTS ON STANDARD OUTPUT UNIT
- IWRITE=I1MACH(2)
- WRITE(IWRITE,10)(X(I),I=1,N)
- 10 FORMAT(10H SOLUTION-,5E15.5)
- STOP
- END
- SUBROUTINE ROSN(N,X,NF,F)
-C THIS SUBROUTINE COMPUTES THE FUNCTION
- INTEGER N, NF
- REAL X(N), F
- F=100.0*(X(2)-X(1)*X(1))**2 + (1.0 - X(1))**2
- RETURN
- END
- SUBROUTINE ROSG(N,X,NF,G)
-C THIS SUBROUTINE COMPUTES THE GRADIENT
- INTEGER N,NF
- REAL X(N), G(N)
- G(1)=200.0*(X(2)-X(1)*X(1))*(-2.0)*X(1) - 2.0*(1-X(1))
- G(2)=200.0*(X(2)-X(1)*X(1))
- RETURN
- END
diff --git a/CEP/PyBDSM/src/port3/ex/ntlk.f b/CEP/PyBDSM/src/port3/ex/ntlk.f
deleted file mode 100644
index b4d36776e3b760e4e27c2b2efe688c4f4b251013..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ex/ntlk.f
+++ /dev/null
@@ -1,45 +0,0 @@
-C$TEST NTLK
-C TO RUN AS A MAIN PROGRAM REMOVE NEXT LINE
- SUBROUTINE NTLK
-C***********************************************************************
-C
-C EXAMPLE OF USE OF THE PORT PROGRAM SMNH
-C
-C***********************************************************************
- INTEGER N
- EXTERNAL ROSN,ROSGH
- REAL X(2)
- N=2
-C INITIALIZE X
- X(1)=-1.2
- X(2)=1.0
-C
-C SOLVE THE PROBLEM
-C
- CALL SMNH(N, X, ROSN, ROSGH, 100, 1.E-4)
-C PRINT RESULTS ON STANDARD OUTPUT UNIT
- IWRITE=I1MACH(2)
- WRITE(IWRITE,10)(X(I),I=1,N)
- 10 FORMAT(10H SOLUTION-,5E15.5)
- STOP
- END
- SUBROUTINE ROSN(N,X,NF,F)
-C THIS SUBROUTINE COMPUTES THE FUNCTION
- INTEGER N, NF
- REAL X(N), F
- F=100.0*(X(2)-X(1)*X(1))**2 + (1.0 - X(1))**2
- RETURN
- END
- SUBROUTINE ROSGH(N,X,NF,G,H)
-C THIS SUBROUTINE COMPUTES THE GRADIENT AND THE HESSIAN
- INTEGER N,NF
- REAL X(N), G(N), H(1)
- G(1)=200.0*(X(2)-X(1)*X(1))*(-2.0)*X(1) - 2.0*(1-X(1))
- G(2)=200.0*(X(2)-X(1)*X(1))
-C H(1) HAS THE (1,1) ELEMENT, H(2) HAS THE (2,1) ELEMENT,
-C H(3) HAS THE (2,2) ELEMENT OF THE MATRIX OF SECOND PARTIALS
- H(1)=200.0*(X(2)-X(1)*X(1))*(-2.0)+800.0*X(1)*X(1)+2.0
- H(2)=-400.0*X(1)
- H(3)=200.0
- RETURN
- END
diff --git a/CEP/PyBDSM/src/port3/ex/ntlm.f b/CEP/PyBDSM/src/port3/ex/ntlm.f
deleted file mode 100644
index 83b42572b89ffab7bb78f2a5d1092d1152550a60..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ex/ntlm.f
+++ /dev/null
@@ -1,51 +0,0 @@
-C$TEST NTLM
-C TO RUN AS A MAIN PROGRAM REMOVE NEXT LINE
- SUBROUTINE NTLM
-C***********************************************************************
-C
-C EXAMPLE OF USE OF THE PORT PROGRAM SMNHB
-C
-C***********************************************************************
- INTEGER N
- EXTERNAL ROSN, ROSGH
- REAL X(2), B(2,2)
- N=2
-C INITIALIZE X
- X(1)=-1.2
- X(2)=1.0
-C SET UP THE BOUND ARRAY
-C R1MACH(2) CONTAINS THE LARGEST NUMBER IN THE MACHINE
- B(1,1)=-R1MACH(2)
- B(2,1)=0.5
- B(1,2)=0.0
- B(2,2)=1.0
-C
-C SOLVE THE PROBLEM
-C
- CALL SMNHB(N, X, B, ROSN, ROSGH, 100, 1.E-4)
-C PRINT RESULTS ON STANDARD OUTPUT UNIT
- IWRITE=I1MACH(2)
- WRITE(IWRITE,10)(X(I),I=1,N)
- 10 FORMAT(10H SOLUTION-,5E15.5)
- STOP
- END
- SUBROUTINE ROSN(N,X,NF,F)
-C THIS SUBROUTINE COMPUTES THE FUNCTION
- INTEGER N, NF
- REAL X(N), F
- F=100.0*(X(2)-X(1)*X(1))**2 + (1.0 - X(1))**2
- RETURN
- END
- SUBROUTINE ROSGH(N,X,NF,G,H)
-C THIS SUBROUTINE COMPUTES THE GRADIENT AND THE HESSIAN
- INTEGER N,NF
- REAL X(N), G(N), H(1)
- G(1)=200.0*(X(2)-X(1)*X(1))*(-2.0)*X(1) - 2.0*(1-X(1))
- G(2)=200.0*(X(2)-X(1)*X(1))
-C H(1) HAS THE (1,1) ELEMENT, H(2) HAS THE (2,1) ELEMENT,
-C H(3) HAS THE (2,2) ELEMENT OF THE MATRIX OF SECOND PARTIALS
- H(1)=200.0*(X(2)-X(1)*X(1))*(-2.0)+800.0*X(1)*X(1)+2.0
- H(2)=-400.0*X(1)
- H(3)=200.0
- RETURN
- END
diff --git a/CEP/PyBDSM/src/port3/ex/ntlp.f b/CEP/PyBDSM/src/port3/ex/ntlp.f
deleted file mode 100644
index 114f3a612a7c83085c58aa28698813eccc18f978..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ex/ntlp.f
+++ /dev/null
@@ -1,61 +0,0 @@
-C$TEST NTLP
-C TO RUN AS A MAIN PROGRAM REMOVE NEXT LINE
- SUBROUTINE NTLP
-C***********************************************************************
-C
-C EXAMPLE OF USE OF THE PORT PROGRAM SNSF
-C
-C***********************************************************************
- INTEGER N,P,L
- INTEGER LP1, IINC,INC(4,2)
- EXTERNAL OSBA
- REAL Y(10),T(10),X(2),C(3)
- COMMON /TT/T
-C GENERATE DATA FOR PROBLEM
- DATA Y(1)/8.44E-1/, Y(2) /9.36E-1/, Y(3) /8.81E-1/
- 1 Y(4)/7.84E-1/, Y(5)/ 6.85E-1/, Y(6)/6.03E-1/,
- 2 Y(7) /5.38E-1/ , Y(8) /4.90E-1/, Y(9)/4.57E-1/
- P=2
- N=9
- L=3
- DO 10 I=1,9
- T(I)=-30.E0*FLOAT(I-1)
- 10 CONTINUE
-C INITIALIZE X
- X(1)=.01
- X(2)=.02
-C GENERATE THE INCIDENCE MATRIX
- LP1=L+1
- DO 30 J=1,P
- DO 20 I=1,LP1
- INC(I,J)=0
- 20 CONTINUE
- 30 CONTINUE
- INC(2,1)=1
- INC(3,2)=1
- IINC=LP1
-C
-C SOLVE THE PROBLEM
-C
- CALL SNSF(N, P, L, X, C, Y, OSBA, INC, IINC, 100, 1.E-4)
-C PRINT RESULTS ON STANDARD OUTPUT UNIT
- IWRITE = I1MACH(2)
- WRITE(IWRITE, 40)(X(I),I=1,P)
- 40 FORMAT(22H NONLINEAR PARAMETERS-,2E15.5)
- WRITE(IWRITE, 50)(C(I),I=1,L)
- 50 FORMAT(19H LINEAR PARAMETERS-, 3E15.5)
- STOP
- END
- SUBROUTINE OSBA(N,P,L,X,NF,A)
-C THIS SUBROUTINE COMPUTES THE MODEL
- INTEGER P, N, NF, L
- REAL X(P), A(N,L)
- REAL T(10)
- COMMON /TT/ T
- DO 10 I=1,N
- A(I,1)=1.0
- A(I,2)=EXP(X(1)*T(I))
- A(I,3)=EXP(X(2)*T(I))
- 10 CONTINUE
- RETURN
- END
diff --git a/CEP/PyBDSM/src/port3/ex/ntlr.f b/CEP/PyBDSM/src/port3/ex/ntlr.f
deleted file mode 100644
index 64b43816292742d8bed4f55afb2a1b1745d214af..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ex/ntlr.f
+++ /dev/null
@@ -1,73 +0,0 @@
-C$TEST NTLR
-C TO RUN AS A MAIN PROGRAM REMOVE NEXT LINE
- SUBROUTINE NTLR
-C***********************************************************************
-C
-C EXAMPLE OF USE OF THE PORT PROGRAM SNSG
-C
-C***********************************************************************
- INTEGER N,P,L
- INTEGER LP1, IINC,INC(4,2)
- EXTERNAL OSBA, OSBB
- REAL Y(10),T(10),X(2),C(3)
- COMMON /TT/T
-C GENERATE DATA FOR PROBLEM
- DATA Y(1)/8.44E-1/, Y(2) /9.36E-1/, Y(3) /8.81E-1/
- 1 Y(4)/7.84E-1/, Y(5)/ 6.85E-1/, Y(6)/6.03E-1/,
- 2 Y(7) /5.38E-1/ , Y(8) /4.90E-1/, Y(9)/4.57E-1/
- P=2
- N=9
- L=3
- DO 10 I=1,9
- T(I)=-30.E0*FLOAT(I-1)
- 10 CONTINUE
-C INITIALIZE X
- X(1)=.01
- X(2)=.02
-C GENERATE THE INCIDENCE MATRIX
- LP1=L+1
- DO 30 J=1,P
- DO 20 I=1,LP1
- INC(I,J)=0
- 20 CONTINUE
- 30 CONTINUE
- INC(2,1)=1
- INC(3,2)=1
- IINC=LP1
-C
-C SOLVE THE PROBLEM
-C
- CALL SNSG(N, P, L, X, C, Y, OSBA, OSBB, INC, IINC, 100, 1.E-4)
-C PRINT RESULTS ON STANDARD OUTPUT UNIT
- IWRITE = I1MACH(2)
- WRITE(IWRITE, 40)(X(I),I=1,P)
- 40 FORMAT(22H NONLINEAR PARAMETERS-,2E15.5)
- WRITE(IWRITE, 50)(C(I),I=1,L)
- 50 FORMAT(19H LINEAR PARAMETERS-, 3E15.5)
- STOP
- END
- SUBROUTINE OSBA(N,P,L,X,NF,A)
-C THIS SUBROUTINE COMPUTES THE MODEL
- INTEGER P, N, NF, L
- REAL X(P), A(N,L)
- REAL T(10)
- COMMON /TT/ T
- DO 10 I=1,N
- A(I,1)=1.0
- A(I,2)=EXP(X(1)*T(I))
- A(I,3)=EXP(X(2)*T(I))
- 10 CONTINUE
- RETURN
- END
- SUBROUTINE OSBB(N,P,L,X,NF,B)
-C THIS SUBROUTINE COMPUTES THE NONZERO DERIVATIVES OF B
- INTEGER N,P,L,NF
- REAL X(P), B(N,L)
- REAL T(10)
- COMMON /TT/ T
- DO 10 I=1,N
- B(I,1)=T(I)*EXP(T(I)*X(1))
- B(I,2)=T(I)*EXP(T(I)*X(2))
- 10 CONTINUE
- RETURN
- END
diff --git a/CEP/PyBDSM/src/port3/ex/ntlt.f b/CEP/PyBDSM/src/port3/ex/ntlt.f
deleted file mode 100644
index 8063a9dd215474908c659dde7833da9c818bb1f8..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ex/ntlt.f
+++ /dev/null
@@ -1,66 +0,0 @@
-C$TEST NTLT
-C TO RUN AS A MAIN PROGRAM REMOVE NEXT LINE
- SUBROUTINE NTLT
-C***********************************************************************
-C
-C EXAMPLE OF USE OF THE PORT PROGRAM SNSFB
-C
-C***********************************************************************
- INTEGER N,P,L
- INTEGER LP1, IINC,INC(4,2)
- EXTERNAL OSBA
- REAL Y(10),T(10),X(2),C(3),B(2,2)
- COMMON /TT/T
-C GENERATE DATA FOR PROBLEM
- DATA Y(1)/8.44E-1/, Y(2) /9.36E-1/, Y(3) /8.81E-1/
- 1 Y(4)/7.84E-1/, Y(5)/ 6.85E-1/, Y(6)/6.03E-1/,
- 2 Y(7) /5.38E-1/ , Y(8) /4.90E-1/, Y(9)/4.57E-1/
- P=2
- N=9
- L=3
- DO 10 I=1,9
- T(I)=-30.E0*FLOAT(I-1)
- 10 CONTINUE
-C INITIALIZE X
- X(1)=.01
- X(2)=.03
-C GENERATE THE INCIDENCE MATRIX
- LP1=L+1
- DO 30 J=1,P
- DO 20 I=1,LP1
- INC(I,J)=0
- 20 CONTINUE
- 30 CONTINUE
- INC(2,1)=1
- INC(3,2)=1
- IINC=LP1
-C SUPPLY BOUNDS
- B(1,1)=-R1MACH(2)
- B(2,1)=0.125
- B(1,2)=.03
- B(2,2)=R1MACH(2)
-C
-C SOLVE THE PROBLEM
-C
- CALL SNSFB(N, P, L, X, B, C, Y, OSBA, INC, IINC, 100, 1.E-4)
-C PRINT RESULTS ON STANDARD OUTPUT UNIT
- IWRITE = I1MACH(2)
- WRITE(IWRITE, 40)(X(I),I=1,P)
- 40 FORMAT(22H NONLINEAR PARAMETERS-,2E15.5)
- WRITE(IWRITE, 50)(C(I),I=1,L)
- 50 FORMAT(19H LINEAR PARAMETERS-, 3E15.5)
- STOP
- END
- SUBROUTINE OSBA(N,P,L,X,NF,A)
-C THIS SUBROUTINE COMPUTES THE MODEL
- INTEGER P, N, NF, L
- REAL X(P), A(N,L)
- REAL T(10)
- COMMON /TT/ T
- DO 10 I=1,N
- A(I,1)=1.0
- A(I,2)=EXP(X(1)*T(I))
- A(I,3)=EXP(X(2)*T(I))
- 10 CONTINUE
- RETURN
- END
diff --git a/CEP/PyBDSM/src/port3/ex/ntlu.f b/CEP/PyBDSM/src/port3/ex/ntlu.f
deleted file mode 100644
index 293461966139ae228b09124ec599db749cae9e00..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ex/ntlu.f
+++ /dev/null
@@ -1,78 +0,0 @@
-C$TEST NTLU
-C TO RUN AS A MAIN PROGRAM REMOVE NEXT LINE
- SUBROUTINE NTLU
-C***********************************************************************
-C
-C EXAMPLE OF USE OF THE PORT PROGRAM SNSGB
-C
-C***********************************************************************
- INTEGER N,P,L
- INTEGER LP1, IINC,INC(4,2)
- EXTERNAL OSBA, OSBB
- REAL Y(10),T(10),X(2),C(3),B(2,2)
- COMMON /TT/T
-C GENERATE DATA FOR PROBLEM
- DATA Y(1)/8.44E-1/, Y(2) /9.36E-1/, Y(3) /8.81E-1/
- 1 Y(4)/7.84E-1/, Y(5)/ 6.85E-1/, Y(6)/6.03E-1/,
- 2 Y(7) /5.38E-1/ , Y(8) /4.90E-1/, Y(9)/4.57E-1/
- P=2
- N=9
- L=3
- DO 10 I=1,9
- T(I)=-30.E0*FLOAT(I-1)
- 10 CONTINUE
-C INITIALIZE X
- X(1)=.01
- X(2)=.03
-C GENERATE THE INCIDENCE MATRIX
- LP1=L+1
- DO 30 J=1,P
- DO 20 I=1,LP1
- INC(I,J)=0
- 20 CONTINUE
- 30 CONTINUE
- INC(2,1)=1
- INC(3,2)=1
- IINC=LP1
-C SPECIFY BOUNDS
- B(1,1)=-R1MACH(2)
- B(2,1)=0.125
- B(1,2)=.03
- B(2,2)=R1MACH(2)
-C
-C SOLVE THE PROBLEM
-C
- CALL SNSGB(N,P,L,X,B,C,Y,OSBA,OSBB,INC,IINC,100,1.E-4)
-C PRINT RESULTS ON STANDARD OUTPUT UNIT
- IWRITE = I1MACH(2)
- WRITE(IWRITE, 40)(X(I),I=1,P)
- 40 FORMAT(22H NONLINEAR PARAMETERS-,2E15.5)
- WRITE(IWRITE, 50)(C(I),I=1,L)
- 50 FORMAT(19H LINEAR PARAMETERS-, 3E15.5)
- STOP
- END
- SUBROUTINE OSBA(N,P,L,X,NF,A)
-C THIS SUBROUTINE COMPUTES THE MODEL
- INTEGER P, N, NF, L
- REAL X(P), A(N,L)
- REAL T(10)
- COMMON /TT/ T
- DO 10 I=1,N
- A(I,1)=1.0
- A(I,2)=EXP(X(1)*T(I))
- A(I,3)=EXP(X(2)*T(I))
- 10 CONTINUE
- RETURN
- END
- SUBROUTINE OSBB(N,P,L,X,NF,B)
-C THIS SUBROUTINE COMPUTES THE NONZERO DERIVATIVES OF B
- INTEGER N,P,L,NF
- REAL X(P), B(N,L)
- REAL T(10)
- COMMON /TT/ T
- DO 10 I=1,N
- B(I,1)=T(I)*EXP(T(I)*X(1))
- B(I,2)=T(I)*EXP(T(I)*X(2))
- 10 CONTINUE
- RETURN
- END
diff --git a/CEP/PyBDSM/src/port3/ex/pdea.f b/CEP/PyBDSM/src/port3/ex/pdea.f
deleted file mode 100644
index 2747d1e167ada7269129d415fa4918b7956dccc4..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ex/pdea.f
+++ /dev/null
@@ -1,134 +0,0 @@
-C$TEST PDEA
-C TO RUN AS A MAIN PROGRAM REMOVE NEXT LINE
- SUBROUTINE PDEA
-C***********************************************************************
-C
-C EXAMPLE OF USE OF THE PORT PROGRAM POST
-C
-C***********************************************************************
- REAL TSTOP,V( 1 ),DT,MESH( 100 ),U( 100 )
- REAL ERRPAR( 2 )
- INTEGER K,NMESH,NDX,NU,NV
- EXTERNAL AF,BC,DEE,HANDLE,UOFX
-C
- COMMON/TIME/TT
- REAL TT
- COMMON/CSTAK/DS( 2000 )
- DOUBLEPRECISION DS
- REAL WS( 1000 )
- REAL RS( 1000 )
- INTEGER IS( 1000 )
- LOGICAL LS( 1000 )
- EQUIVALENCE( DS( 1 ),WS( 1 ),RS( 1 ),IS( 1 ),LS( 1 ) )
-C
-C INITIALIZE THE PORT STACK LENGTH
-C
- CALL ISTKIN( 2000,4 )
-C
- NU = 1
- NV = 1
-C
-C SET THE ERROR CRITERION FOR ABSOLUTE ERROR
-C
- ERRPAR( 1 ) = 0
- ERRPAR( 2 ) = 1.E-2
-C
- TSTOP = 8.*ATAN( 1.E0 )
- DT = 0.4
-C
-C MAKE A MESH OF NDX UNIFORM POINTS ON (-PI, +PI)
-C
- K = 4
- NDX = 7
- CALL UMB( - 4.*ATAN( 1.E0 ), + 4.*ATAN( 1.E0 ),NDX,K,MESH,NMESH )
- TT = 0
-C
-C SET THE INITIAL CONDITIONS FOR U
-C
- CALL L2SFF( UOFX,K,MESH,NMESH,U )
-C
-C SET THE INITIAL CONDITIONS FOR V
-C
- V( 1 ) = - 1.
-C
- CALL POST( U,NU,K,MESH,NMESH,V,NV,0E0,TSTOP,DT,AF,BC,DEE,ERRPAR,HA
- *NDLE )
-C
- STOP
- END
- SUBROUTINE AF( T,X,NX,U,UX,UT,UTX,NU,V,VT,NV,A,AU,AUX,AUT,AUTX,AV,
- *AVT,F,FU,FUX,FUT,FUTX,FV,FVT )
- REAL T,X( NX ),U( NX,NU ),UX( NX,NU ),UT( NX,NU ),UTX( NX,NU ),V(
- *NV ),VT( NV ),A( NX,NU ),AU( NX,NU,NU ),AUX( NX,NU,NU ),AUT( NX,NU
- *,NU ),AUTX( NX,NU,NU ),AV( NX,NU,NV ),AVT( NX,NU,NV ),F( NX,NU ),F
- *U( NX,NU,NU ),FUX( NX,NU,NU ),FUT( NX,NU,NU ),FUTX( NX,NU,NU ),FV(
- * NX,NU,NV ),FVT( NX,NU,NV )
- INTEGER NU,NV,NX
- INTEGER I
- DO 23000 I = 1,NX
- A( I,1 ) = - UX( I,1 )
- AUX( I,1,1 ) = - 1
- F( I,1 ) = - UT( I,1 ) - U( I,1 )**3 + SIN( X( I ) )*( COS( T ) -
- * SIN( T ) + SIN( X( I ) )**2*COS( T )**3 )
- FUT( I,1,1 ) = - 1
- FU( I,1,1 ) = - 3*U( I,1 )**2
-23000 CONTINUE
- RETURN
- END
- SUBROUTINE BC( T,L,R,U,UX,UT,UTX,NU,V,VT,NV,B,BU,BUX,BUT,BUTX,BV,B
- *VT )
- REAL T,L,R,U( NU,2 ),UX( NU,2 ),UT( NU,2 ),UTX( NU,2 ),V( NV ),VT(
- * NV ),B( NU,2 ),BU( NU,NU,2 ),BUX( NU,NU,2 ),BUT( NU,NU,2 ),BUTX(
- *NU,NU,2 ),BV( NU,NV,2 ),BVT( NU,NV,2 )
- INTEGER NU,NV
- B( 1,1 ) = UX( 1,1 ) - V( 1 )
- B( 1,2 ) = UX( 1,2 ) - V( 1 )
- BUX( 1,1,1 ) = 1
- BV( 1,1,1 ) = - 1
- BUX( 1,1,2 ) = 1
- BV( 1,1,2 ) = - 1
- RETURN
- END
- SUBROUTINE DEE( T,K,X,NX,U,UT,NU,NXMK,V,VT,NV,D,DU,DUT,DV,DVT )
- REAL T,X( NX ),U( NXMK,NU ),UT( NXMK,NU ),V( NV ),VT( NV ),D( NV )
- *,DU( NV,NXMK,NU ),DUT( NV,NXMK,NU ),DV( NV,NV ),DVT( NV,NV )
- INTEGER K,NX,NU,NXMK,NV
- D( 1 ) = U( 1,1 ) - U( NX - K,1 )
- DU( 1,1,1 ) = 1
- DU( 1,NX - K,1 ) = - 1
- RETURN
- END
- SUBROUTINE HANDLE( T0,U0,V0,T,U,V,NU,NXMK,NV,K,X,NX,DT,TSTOP )
- REAL T0,U0( NXMK,NU ),V0( NV ),T,U( NXMK,NU ),V( NV ),X( NX ),DT,T
- *STOP
- INTEGER NU,NXMK,NV,K,NX
- COMMON/TIME/TT
- REAL TT
- REAL EU,EESFF,EV
- INTEGER I1MACH
- EXTERNAL UOFX
- IF( T0 .EQ. T )GO TO 23002
- GO TO 23003
-23002 CONTINUE
- RETURN
-23003 CONTINUE
- TT = T
- EU = EESFF( K,X,NX,U,UOFX )
- EV = V( 1 ) + COS( T )
- IWUNIT = I1MACH( 2 )
- WRITE( IWUNIT,9001 )T,EU,EV
-9001 FORMAT( 14H ERROR IN U(X,,1P1E10.2,4H ) =,1P1E10.2,6H V =,1P4E10
- *.2 )
- RETURN
- END
- SUBROUTINE UOFX( X,NX,U,W )
- REAL X( NX ),U( NX ),W( NX )
- INTEGER NX
- COMMON/TIME/T
- REAL T
- INTEGER I
- DO 23005 I = 1,NX
- U( I ) = SIN( X( I ) )*COS( T )
-23005 CONTINUE
- RETURN
- END
diff --git a/CEP/PyBDSM/src/port3/ex/pdew.f b/CEP/PyBDSM/src/port3/ex/pdew.f
deleted file mode 100644
index 6eaa5e4a83dd4251a1273af9c32693dd36d62889..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ex/pdew.f
+++ /dev/null
@@ -1,243 +0,0 @@
-C$TEST PDEW
-C TO RUN AS A MAIN PROGRAM REMOVE NEXT LINE
- SUBROUTINE PDEW
-C***********************************************************************
-C
-C EXAMPLE OF USE OF THE PORT PROGRAM POSTU
-C
-C***********************************************************************
-C THE PORT STACK
-C
- COMMON /CSTAK/ DS
- DOUBLE PRECISION DS(4000)
- REAL WS(1000)
- EQUIVALENCE (DS(1),WS(1))
-C
-C TIME FOR THE FUNCTION UOFX.
-C
- COMMON /TIME/ T
- REAL T
-C
-C MAPPING PARAMETERS FOR UOFX.
-C
- COMMON /PARAM/ VC, X
- REAL VC(4), X(3)
- EXTERNAL DEE, HANDLE, UOFX, BC, AF
- INTEGER NDX, K, IMMM, ISTKGT
- INTEGER NU, NV, IMESH, ILUMB, NMESH
- REAL ERRPAR(2), TSTART, TSTOP, V(4), DT, XB(3), U(1000)
-C INITIALIZE THE PORT LIBRARY STACK LENGTH.
- CALL ISTKIN(4000, 4)
- CALL ENTER(1)
- NU = 1
- NV = 4
- ERRPAR(1) = 0
-C ABSOLUTE ERROR.
- ERRPAR(2) = 1E-2
- TSTART = 0
- TSTOP = 3.14
- DT = 0.4
- K = 4
-C NDX UNIFORM MESH POINTS ON EACH INTERVAL OF XB.
- NDX = 6
- XB(1) = 0
- XB(2) = 1
- XB(3) = 2
-C GET MESH ON PORT STACK.
- IMESH = ILUMB(XB, 3, NDX, K, NMESH)
-C MAKE 1 OF MULTIPLICITY K-1.
- IMESH = IMMM(IMESH, NMESH, 1E0, K-1)
- X(1) = -3.14
- X(2) = 3.14/2.
- X(3) = 3.14
-C INITIAL VALUES FOR V.
- CALL LPLMG(3, X, VC)
-C GET U ON THE PORT STACK.
- IU = ISTKGT(NMESH-K, 3)
-C UOFX NEEDS TIME.
- T = TSTART
-C THE INITIAL HEIGHT OF THE JUMP.
- VC(4) = 1
-C UOFX NEEDS V FOR MAPPING.
- CALL MOVEFR(NV, VC, V)
-C INITIAL CONDITIONS FOR U.
- CALL L2SFF(UOFX, K, WS(IMESH), NMESH, U)
-C OUTPUT ICS.
- CALL HANDLE(T-1., U, V, T, U, V, NU, NMESH-K, NV, K, WS(
- 1 IMESH), NMESH, DT, TSTOP)
- CALL POST(U, NU, K, WS(IMESH), NMESH, V, NV, TSTART, TSTOP,
- 1 DT, AF, BC, DEE, ERRPAR, HANDLE)
- CALL LEAVE
- CALL WRAPUP
- STOP
- END
- SUBROUTINE AF(T, XI, NX, U, UX, UT, UTX, NU, V, VT, NV,
- * A, AU, AUX, AUT, AUTX, AV, AVT,
- * F, FU, FUX, FUT, FUTX, FV, FVT)
- INTEGER NU, NV, NX
- REAL T, XI(NX), U(NX, NU), UX(NX, NU), UT(NX, NU), UTX(NX, NU)
- REAL V(NV), VT(NV),
- * A(NX,NU),AU(NX,NU,NU),AUX(NX,NU,NU),AUT(NX,NU,NU),
- * AUTX(NX,NU,NU),AV(NX,NU,NV),AVT(NX,NU,NV),
- * F(NX,NU),FU(NX,NU,NU),FUX(NX,NU,NU),FUT(NX,NU,NU),
- * FUTX(NX,NU,NU),FV(NX,NU,NV),FVT(NX,NU,NV)
- COMMON /POSTF/ FAILED
- LOGICAL FAILED
- INTEGER I
- REAL COS, SIN, XXI(99), XTV(99), XVV(99), X(99)
- REAL XXIV(99), AX(99), FX(99), XT(99), XV(99)
- LOGICAL TEMP
- TEMP = V(2) .LE. V(1)
- IF (.NOT. TEMP) TEMP = V(2) .GE. V(3)
- IF (.NOT. TEMP) GOTO 1
- FAILED = .TRUE.
- RETURN
-C MAP XI INTO X.
- 1 CALL LPLM(XI, NX, V, 3, X, XXI, XXIV, XV, XVV, XT, XTV)
-C MAP U INTO X SYSTEM.
- CALL POSTU(XI, X, XT, XXI, XV, VT, NX, 3, UX, UT, NU, AX, FX)
- DO 4 I = 1, NX
- A(I, 1) = -U(I, 1)
- AU(I, 1, 1) = -1
- F(I, 1) = UT(I, 1)
- FUT(I, 1, 1) = 1
- IF (XI(I) .GT. 1.) GOTO 2
- F(I, 1) = F(I, 1)-2.*COS(X(I)+T)
- FX(I) = 2.*SIN(X(I)+T)
- GOTO 3
- 2 F(I, 1) = F(I, 1)-VT(4)
- FVT(I, 1, 4) = -1
- F(I, 1) = F(I, 1)+2.*SIN(X(I)+T)
- FX(I) = 2.*COS(X(I)+T)
- 3 CONTINUE
- 4 CONTINUE
-C MAP A AND F INTO XI SYSTEM.
- CALL POSTI(XI, X, XT, XXI, XV, XTV, XXIV, XVV, NX, UX, UT, NU, V
- 1 , VT, NV, 1, 3, A, AX, AU, AUX, AUT, AUTX, AV, AVT, F, FX, FU
- 2 , FUX, FUT, FUTX, FV, FVT)
- RETURN
- END
- SUBROUTINE BC(T, L, R, U, UX, UT, UTX, NU, V, VT, NV,
- * B, BU, BUX, BUT, BUTX, BV, BVT)
- INTEGER NU, NV
- REAL T,L,R,U(NU,2),UX(NU,2),UT(NU,2),UTX(NU,2),V(NV),VT(NV)
- REAL B(NU,2),BU(NU,NU,2),BUX(NU,NU,2),BUT(NU,NU,2),BUTX(NU,NU,2),
- * BV(NU,NV,2),BVT(NU,NV,2)
- B(1, 1) = U(1, 1)-SIN(T-3.14)
-C U(-PI,T) = SIN(-PI+T).
- BU(1, 1, 1) = 1
- RETURN
- END
- SUBROUTINE DEE(T, K, X, NX, U, UT, NU, NXMK, V, VT, NV,
- * D, DU, DUT, DV, DVT)
- INTEGER NXMK, NU, NV, NX, K
- REAL T, X(NX), U(NXMK, NU), UT(NXMK, NU), V(NV), VT(NV)
- REAL D(NV),DU(NV,NXMK,NU),DUT(NV,NXMK,NU),DV(NV,NV),DVT(NV,NV)
- INTEGER INTRVR, I, ILEFT
- REAL BX(10), XX(1), R1MACH
- INTEGER TEMP
- D(1) = V(1)+3.14
-C X(0,V) = -PI.
- DV(1, 1) = 1
-C XX(1) = 1 + A ROUNDING ERROR.
- XX(1) = R1MACH(4)+1.
- ILEFT = INTRVR(NX, X, XX(1))
-C GET THE B-SPLINE BASIS AT XX.
- CALL BSPLN(K, X, NX, XX, 1, ILEFT, BX)
- D(2) = -V(4)
-C U(X(T)+,T) - JUMP = 0.
- DV(2, 4) = -1
- DO 1 I = 1, K
- TEMP = ILEFT+I-K
- D(2) = D(2)+U(TEMP, 1)*BX(I)
- TEMP = ILEFT+I-K
- DU(2, TEMP, 1) = BX(I)
- 1 CONTINUE
- D(3) = V(3)-3.14
-C X(2,V) = +PI.
- DV(3, 3) = 1
-C JUMP + D( X(1,V(T)) )/DT = 0.
- D(4) = VT(2)+V(4)
- DVT(4, 2) = 1
- DV(4, 4) = 1
- RETURN
- END
- SUBROUTINE HANDLE(T0, U0, V0, T, U, V, NU, NXMK, NV,
- * K, X, NX, DT, TSTOP)
- INTEGER NXMK, NU, NV, NX, K
- REAL T0, U0(NXMK, NU), V0(NV), T, U(NXMK, NU), V(NV),
- * X(NX), DT, TSTOP
- COMMON /PARAM/ VC, XX
- REAL VC(4), XX(3)
- COMMON /TIME/ TT
- REAL TT
- EXTERNAL UOFX
- INTEGER I1MACH
- REAL EU, EESFF, EV(2)
- INTEGER TEMP
-C OUTPUT AND CHECKING ROUTINE.
- IF (T0 .NE. T) GOTO 2
- TEMP = I1MACH(2)
- WRITE (TEMP, 1) T, DT
- 1 FORMAT (16H RESTART FOR T =, 1PE10.2, 7H DT =, 1PE10.2)
- RETURN
- 2 TT = T
-C UOFX NEEDS V FOR MAPPING.
- CALL MOVEFR(NV, V, VC)
- EU = EESFF(K, X, NX, U, UOFX)
-C ERROR IN POSITION OF SHOCK.
- EV(1) = V(2)-(3.14/2.-T)
-C ERROR IN HEIGHT OF SHOCK.
- EV(2) = V(4)-1.
- TEMP = I1MACH(2)
- WRITE (TEMP, 3) T, EU, EV
- 3 FORMAT (14H ERROR IN U(X,, 1PE10.2, 4H ) =, 1PE10.2, 6H V =, 2(
- 1 1PE10.2))
- RETURN
- END
- SUBROUTINE UOFX(XI, NX, U, W)
- INTEGER NX
- REAL XI(NX), U(NX), W(NX)
- COMMON /CSTAK/ DS
- DOUBLE PRECISION DS(4000)
- COMMON /PARAM/ VC, X
- REAL VC(4), X(3)
- COMMON /TIME/ T
- REAL T
- INTEGER IXV, IXX, ISTKGT, I, IS(1000)
- REAL EWE, RS(1000), WS(1000)
- LOGICAL LS(1000)
- INTEGER TEMP
- EQUIVALENCE (DS(1), WS(1), RS(1), IS(1), LS(1))
-C THE PORT LIBRARY STACK AND ITS ALIASES.
- CALL ENTER(1)
- IXX = ISTKGT(NX, 3)
-C SPACE FOR X AND XV.
- IXV = ISTKGT(3*NX, 3)
-C MAP INTO USER SYSTEM.
- CALL LPLMX(XI, NX, VC, 3, WS(IXX), WS(IXV))
- DO 1 I = 1, NX
- TEMP = IXX+I
- U(I) = EWE(T, WS(TEMP-1), VC(2))
- IF (XI(I) .GT. 1.) U(I) = U(I)+1.
- 1 CONTINUE
- CALL LEAVE
- RETURN
- END
- REAL FUNCTION EWE(T, X, XBREAK)
- REAL T, X, XBREAK
- REAL COS, SIN
- IF (X .GE. XBREAK) GOTO 1
- EWE = SIN(X+T)
- RETURN
- 1 IF (X .LE. XBREAK) GOTO 2
- EWE = COS(X+T)
- RETURN
-C/6S
- 2 CALL SETERR(17HEWE - X == XBREAK, 17, 1, 2)
-C/7S
-C 2 CALL SETERR('EWE - X == XBREAK', 17, 1, 2)
-C/
- 3 CONTINUE
- 4 STOP
- END
diff --git a/CEP/PyBDSM/src/port3/ex/postx1.f b/CEP/PyBDSM/src/port3/ex/postx1.f
deleted file mode 100644
index b043c705b6602cce24af2a092fd7ae9d20f93244..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ex/postx1.f
+++ /dev/null
@@ -1,112 +0,0 @@
-C$TEST PST1
-C TO RUN AS A MAIN PROGRAM REMOVE NEXT LINE
- SUBROUTINE PST1
-C***********************************************************************
-C
-C EXAMPLE OF USE OF PORT PROGRAM POST
-C
-C***********************************************************************
- COMMON /CSTAK/ DS
- DOUBLE PRECISION DS(1000)
- EXTERNAL HANDLE, BC, AF, POSTD
- INTEGER NDX, K, IS(1000), NU, NV, NMESH
- REAL ERRPAR(2), U(100), V(1), MESH(100), DT, RS(1000)
- REAL WS(1000), TSTOP
- LOGICAL LS(1000)
- COMPLEX CS(500)
- EQUIVALENCE (DS(1), CS(1), WS(1), RS(1), IS(1), LS(1))
-C TO TEST POST ON
-C U SUB T = U SUB XX + F ON (0,1)
-C WHERE F IS CHOSEN SO THAT THE SOLUTION IS
-C U(X,T) = EXP(XT).
-C THE PORT LIBRARY STACK AND ITS ALIASES.
-C INITIALIZE THE PORT LIBRARY STACK LENGTH.
- CALL ISTKIN(1000, 4)
- NU = 1
- NV = 0
- ERRPAR(1) = 0
-C ABSOLUTE ERROR.
- ERRPAR(2) = 1E-2
- TSTOP = 1
- DT = 1E-2
- K = 4
-C NDX UNIFORM MESH POINTS ON (0,1).
- NDX = 4
- CALL UMB(0E0, 1E0, NDX, K, MESH, NMESH)
-C INITIAL CONDITIONS FOR U.
- CALL SETR(NMESH-K, 1E0, U)
- CALL POST(U, NU, K, MESH, NMESH, V, NV, 0E0, TSTOP, DT, AF, BC,
- 1 POSTD, ERRPAR, HANDLE)
-C CHECK FOR ERRORS AND STACK USAGE STATISTICS.
- CALL WRAPUP
- STOP
- END
- SUBROUTINE AF(T, X, NX, U, UX, UT, UTX, NU, V, VT, NV, A,
- 1 AU, AUX, AUT, AUTX, AV, AVT, F, FU, FUX, FUT, FUTX, FV, FVT)
- INTEGER NU, NX
- INTEGER NV
- REAL T, X(NX), U(NX, NU), UX(NX, NU), UT(NX, NU), UTX(NX, NU)
- REAL V(1), VT(1), A(NX, NU), AU(NX, NU, NU), AUX(NX, NU, NU), AUT(
- 1 NX, NU, NU)
- REAL AUTX(NX, NU, NU), AV(1), AVT(1), F(NX, NU), FU(NX, NU, NU),
- 1 FUX(NX, NU, NU)
- REAL FUT(NX, NU, NU), FUTX(NX, NU, NU), FV(1), FVT(1)
- INTEGER I
- REAL EXP
- DO 1 I = 1, NX
- A(I, 1) = -UX(I, 1)
- AUX(I, 1, 1) = -1
- F(I, 1) = (X(I)-T**2)*EXP(X(I)*T)-UT(I, 1)
- FUT(I, 1, 1) = -1
- 1 CONTINUE
- RETURN
- END
- SUBROUTINE BC(T, L, R, U, UX, UT, UTX, NU, V, VT, NV, B, BU,
- 1 BUX, BUT, BUTX, BV, BVT)
- INTEGER NU
- INTEGER NV
- REAL T, L, R, U(NU, 2), UX(NU, 2), UT(NU, 2)
- REAL UTX(NU, 2), V(1), VT(1), B(NU, 2), BU(NU, NU, 2), BUX(NU, NU,
- 1 2)
- REAL BUT(NU, NU, 2), BUTX(NU, NU, 2), BV(1), BVT(1)
- REAL EXP
- B(1, 1) = U(1, 1)-1.
- B(1, 2) = U(1, 2)-EXP(T)
- BU(1, 1, 1) = 1
- BU(1, 1, 2) = 1
- RETURN
- END
- SUBROUTINE HANDLE(T0, U0, V0, T, U, V, NU, NXMK, NV, K, X,
- 1 NX, DT, TSTOP)
- INTEGER NXMK, NU, NX
- INTEGER NV, K
- REAL T0, U0(NXMK, NU), V0(1), T, U(NXMK, NU), V(1)
- REAL X(NX), DT, TSTOP
- COMMON /TIME/ TT
- REAL TT
- EXTERNAL UOFX
- INTEGER I1MACH
- REAL EU, EESFF
- INTEGER TEMP
-C OUTPUT AND CHECKING ROUTINE.
- IF (T0 .EQ. T) RETURN
-C UOFX NEEDS TIME.
- TT = T
- EU = EESFF(K, X, NX, U, UOFX)
- TEMP = I1MACH(2)
- WRITE (TEMP, 1) T, EU
- 1 FORMAT (14H ERROR IN U(X,, 1PE10.2, 4H ) =, 1PE10.2)
- RETURN
- END
- SUBROUTINE UOFX(X, NX, U, W)
- INTEGER NX
- REAL X(NX), U(NX), W(NX)
- COMMON /TIME/ T
- REAL T
- INTEGER I
- REAL EXP
- DO 1 I = 1, NX
- U(I) = EXP(X(I)*T)
- 1 CONTINUE
- RETURN
- END
diff --git a/CEP/PyBDSM/src/port3/ex/postx10.f b/CEP/PyBDSM/src/port3/ex/postx10.f
deleted file mode 100644
index f22a2a3fd006926e4d01f6ba70a4bca42ff7a4f4..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ex/postx10.f
+++ /dev/null
@@ -1,155 +0,0 @@
-C$TEST PSTT
-C TO RUN AS A MAIN PROGRAM REMOVE NEXT LINE
- SUBROUTINE PSTT
-C***********************************************************************
-C
-C EXAMPLE OF USE OF PORT PROGRAM POST
-C
-C***********************************************************************
- COMMON /CSTAK/ DS
- DOUBLE PRECISION DS(2000)
- EXTERNAL HANDLE, BC, AF, POSTD
- INTEGER NDX, NXH, I, K, IS(1000), NU
- INTEGER NV, NX, I1MACH
- REAL ABS, ERR, ERRPAR(2), U(100), V(1), X(100)
- REAL AMAX1, DT, UE(100), EEBSF, UH(100), XH(100)
- REAL RS(1000), WS(1000), TSTOP
- LOGICAL LS(1000)
- COMPLEX CS(500)
- INTEGER TEMP
- EQUIVALENCE (DS(1), CS(1), WS(1), RS(1), IS(1), LS(1))
-C TO ESTIMATE X AND T ERROR AS SUM.
-C U SUB T = U SUB XX + F ON (0,1)
-C WHERE F IS CHOSEN SO THAT THE SOLUTION IS
-C U(X,T) = EXP(XT).
-C THE PORT LIBRARY STACK AND ITS ALIASES.
-C INITIALIZE THE PORT LIBRARY STACK LENGTH.
- CALL ISTKIN(2000, 4)
- NU = 1
- NV = 0
- ERRPAR(1) = 0
- ERRPAR(2) = 1E-2
- K = 4
- NDX = 4
- TSTOP = 1
- DT = 1E-2
-C CRUDE MESH.
- CALL UMB(0E0, 1E0, NDX, K, X, NX)
-C INITIAL CONDITIONS FOR U.
- CALL SETR(NX-K, 1E0, U)
- TEMP = I1MACH(2)
- WRITE (TEMP, 1)
- 1 FORMAT (36H SOLVING ON CRUDE MESH USING ERRPAR.)
- CALL POST(U, NU, K, X, NX, V, NV, 0E0, TSTOP, DT, AF, BC, POSTD,
- 1 ERRPAR, HANDLE)
-C GET RUN-TIME STATISTICS.
- CALL POSTX
-C HALVE THE MESH SPACING.
- CALL UMB(0E0, 1E0, 2*NDX-1, K, XH, NXH)
-C INITIAL CONDITIONS FOR UH.
- CALL SETR(NXH-K, 1E0, UH)
- DT = 1E-2
- TEMP = I1MACH(2)
- WRITE (TEMP, 2)
- 2 FORMAT (38H SOLVING ON REFINED MESH USING ERRPAR.)
- CALL POST(UH, NU, K, XH, NXH, V, NV, 0E0, TSTOP, DT, AF, BC,
- 1 POSTD, ERRPAR, HANDLE)
-C GET RUN-TIME STATISTICS.
- CALL POSTX
-C ESTIMATE U ERROR.
- ERR = EEBSF(K, X, NX, U, XH, NXH, UH)
- WRITE (6, 3) ERR
- 3 FORMAT (24H U ERROR FROM U AND UH =, 1PE10.2)
-C INITIAL CONDITIONS FOR UE.
- CALL SETR(NX-K, 1E0, UE)
- DT = 1E-2
- ERRPAR(1) = ERRPAR(1)/10.
- ERRPAR(2) = ERRPAR(2)/10.
- TEMP = I1MACH(2)
- WRITE (TEMP, 4)
- 4 FORMAT (39H SOLVING ON CRUDE MESH USING ERRPAR/10.)
- CALL POST(UE, NU, K, X, NX, V, NV, 0E0, TSTOP, DT, AF, BC, POSTD
- 1 , ERRPAR, HANDLE)
-C GET RUN-TIME STATISTICS.
- CALL POSTX
- ERR = 0
- TEMP = NX-K
- DO 5 I = 1, TEMP
- ERR = AMAX1(ERR, ABS(U(I)-UE(I)))
- 5 CONTINUE
- WRITE (6, 6) ERR
- 6 FORMAT (24H U ERROR FROM U AND UE =, 1PE10.2)
- STOP
- END
- SUBROUTINE AF(T, X, NX, U, UX, UT, UTX, NU, V, VT, NV, A,
- 1 AU, AUX, AUT, AUTX, AV, AVT, F, FU, FUX, FUT, FUTX, FV, FVT)
- INTEGER NU, NX
- INTEGER NV
- REAL T, X(NX), U(NX, NU), UX(NX, NU), UT(NX, NU), UTX(NX, NU)
- REAL V(1), VT(1), A(NX, NU), AU(NX, NU, NU), AUX(NX, NU, NU), AUT(
- 1 NX, NU, NU)
- REAL AUTX(NX, NU, NU), AV(1), AVT(1), F(NX, NU), FU(NX, NU, NU),
- 1 FUX(NX, NU, NU)
- REAL FUT(NX, NU, NU), FUTX(NX, NU, NU), FV(1), FVT(1)
- INTEGER I
- REAL EXP
- DO 1 I = 1, NX
- A(I, 1) = -UX(I, 1)
- AUX(I, 1, 1) = -1
- F(I, 1) = (X(I)-T**2)*EXP(X(I)*T)-UT(I, 1)
- FUT(I, 1, 1) = -1
- 1 CONTINUE
- RETURN
- END
- SUBROUTINE BC(T, L, R, U, UX, UT, UTX, NU, V, VT, NV, B, BU,
- 1 BUX, BUT, BUTX, BV, BVT)
- INTEGER NU
- INTEGER NV
- REAL T, L, R, U(NU, 2), UX(NU, 2), UT(NU, 2)
- REAL UTX(NU, 2), V(1), VT(1), B(NU, 2), BU(NU, NU, 2), BUX(NU, NU,
- 1 2)
- REAL BUT(NU, NU, 2), BUTX(NU, NU, 2), BV(1), BVT(1)
- REAL EXP
- B(1, 1) = U(1, 1)-1.
- B(1, 2) = U(1, 2)-EXP(T)
- BU(1, 1, 1) = 1
- BU(1, 1, 2) = 1
- RETURN
- END
- SUBROUTINE HANDLE(T0, U0, V0, T, U, V, NU, NXMK, NV, K, X,
- 1 NX, DT, TSTOP)
- INTEGER NXMK, NU, NX
- INTEGER NV, K
- REAL T0, U0(NXMK, NU), V0(1), T, U(NXMK, NU), V(1)
- REAL X(NX), DT, TSTOP
- COMMON /TIME/ TT
- REAL TT
- EXTERNAL UOFX
- INTEGER I1MACH
- REAL EU, EESFF
- INTEGER TEMP
-C OUTPUT AND CHECKING ROUTINE.
- IF (T0 .NE. T) GOTO 2
- TEMP = I1MACH(2)
- WRITE (TEMP, 1) T
- 1 FORMAT (16H RESTART FOR T =, 1PE10.2)
- RETURN
- 2 TT = T
- EU = EESFF(K, X, NX, U, UOFX)
- TEMP = I1MACH(2)
- WRITE (TEMP, 3) T, EU
- 3 FORMAT (14H ERROR IN U(X,, 1PE10.2, 4H ) =, 1PE10.2)
- RETURN
- END
- SUBROUTINE UOFX(X, NX, U, W)
- INTEGER NX
- REAL X(NX), U(NX), W(NX)
- COMMON /TIME/ T
- REAL T
- INTEGER I
- REAL EXP
- DO 1 I = 1, NX
- U(I) = EXP(X(I)*T)
- 1 CONTINUE
- RETURN
- END
diff --git a/CEP/PyBDSM/src/port3/ex/postx2.f b/CEP/PyBDSM/src/port3/ex/postx2.f
deleted file mode 100644
index 1028767e77b392f8d20bb6e8443ef80433f14b2d..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ex/postx2.f
+++ /dev/null
@@ -1,137 +0,0 @@
-C$TEST PST2
-C TO RUN AS A MAIN PROGRAM REMOVE NEXT LINE
- SUBROUTINE PST2
-C***********************************************************************
-C
-C EXAMPLE OF USE OF PORT PROGRAM POST
-C
-C***********************************************************************
- COMMON /CSTAK/ DS
- DOUBLE PRECISION DS(1100)
- EXTERNAL HANDLE, BC, AF, POSTD
- INTEGER NDX, K, IS(1000), NU, NV, NMESH
- REAL ERRPAR(2), U(200), V(1), MESH(100), DT, RS(1000)
- REAL WS(1000), TSTOP
- LOGICAL LS(1000)
- COMPLEX CS(500)
- INTEGER TEMP
- EQUIVALENCE (DS(1), CS(1), WS(1), RS(1), IS(1), LS(1))
-C TO TEST POST ON
-C U SUB T = U SUB XX + F ON (0,1)
-C BY SETTING U1 = U AND U2 = U1 SUB X AND SOLVING
-C U1 SUB T = U1 SUB XX + F
-C ON (0,1)
-C U1 SUB X = U2
-C WHERE F IS CHOSEN SO THAT THE SOLUTION IS
-C U(X,T) = EXP(XT).
-C THE PORT LIBRARY STACK AND ITS ALIASES.
-C INITIALIZE THE PORT LIBRARY STACK LENGTH.
- CALL ISTKIN(1100, 4)
- NU = 2
- NV = 0
- ERRPAR(1) = 0
-C ABSOLUTE ERROR.
- ERRPAR(2) = 1E-2
- TSTOP = 1
- DT = 1E-2
- K = 4
-C NDX UNIFORM MESH POINTS ON (0,1).
- NDX = 4
- CALL UMB(0E0, 1E0, NDX, K, MESH, NMESH)
-C INITIAL CONDITIONS FOR U1.
- CALL SETR(NMESH-K, 1E0, U)
-C INITIAL CONDITIONS FOR U2.
- TEMP = NMESH-K
- CALL SETR(NMESH-K, 0E0, U(TEMP+1))
- CALL POST(U, NU, K, MESH, NMESH, V, NV, 0E0, TSTOP, DT, AF, BC,
- 1 POSTD, ERRPAR, HANDLE)
-C CHECK FOR ERRORS AND STACK USAGE STATISTICS.
- CALL WRAPUP
- STOP
- END
- SUBROUTINE AF(T, X, NX, U, UX, UT, UTX, NU, V, VT, NV, A,
- 1 AU, AUX, AUT, AUTX, AV, AVT, F, FU, FUX, FUT, FUTX, FV, FVT)
- INTEGER NU, NX
- INTEGER NV
- REAL T, X(NX), U(NX, NU), UX(NX, NU), UT(NX, NU), UTX(NX, NU)
- REAL V(1), VT(1), A(NX, NU), AU(NX, NU, NU), AUX(NX, NU, NU), AUT(
- 1 NX, NU, NU)
- REAL AUTX(NX, NU, NU), AV(1), AVT(1), F(NX, NU), FU(NX, NU, NU),
- 1 FUX(NX, NU, NU)
- REAL FUT(NX, NU, NU), FUTX(NX, NU, NU), FV(1), FVT(1)
- INTEGER I
- REAL EXP
- DO 1 I = 1, NX
- A(I, 1) = -U(I, 2)
- AU(I, 1, 2) = -1
- F(I, 1) = (X(I)-T**2)*EXP(X(I)*T)-UT(I, 1)
- FUT(I, 1, 1) = -1
- A(I, 2) = U(I, 1)
- AU(I, 2, 1) = 1
- F(I, 2) = U(I, 2)
- FU(I, 2, 2) = 1
- 1 CONTINUE
- RETURN
- END
- SUBROUTINE BC(T, L, R, U, UX, UT, UTX, NU, V, VT, NV, B, BU,
- 1 BUX, BUT, BUTX, BV, BVT)
- INTEGER NU
- INTEGER NV
- REAL T, L, R, U(NU, 2), UX(NU, 2), UT(NU, 2)
- REAL UTX(NU, 2), V(1), VT(1), B(NU, 2), BU(NU, NU, 2), BUX(NU, NU,
- 1 2)
- REAL BUT(NU, NU, 2), BUTX(NU, NU, 2), BV(1), BVT(1)
- REAL EXP
- B(1, 1) = U(1, 1)-1.
- B(1, 2) = U(1, 2)-EXP(T)
- BU(1, 1, 1) = 1
- BU(1, 1, 2) = 1
- RETURN
- END
- SUBROUTINE HANDLE(T0, U0, V0, T, U, V, NU, NXMK, NV, K, X,
- 1 NX, DT, TSTOP)
- INTEGER NXMK, NU, NX
- INTEGER NV, K
- REAL T0, U0(NXMK, NU), V0(1), T, U(NXMK, NU), V(1)
- REAL X(NX), DT, TSTOP
- COMMON /TIME/ TT
- REAL TT
- EXTERNAL U1OFX, U2OFX
- INTEGER I1MACH
- REAL EU(2), EESFF
- INTEGER TEMP
-C OUTPUT AND CHECKING ROUTINE.
- IF (T0 .EQ. T) RETURN
-C U1OFX AND U2OFX NEED TIME.
- TT = T
- EU(1) = EESFF(K, X, NX, U, U1OFX)
- EU(2) = EESFF(K, X, NX, U(1, 2), U2OFX)
- TEMP = I1MACH(2)
- WRITE (TEMP, 1) T, EU
- 1 FORMAT (14H ERROR IN U(X,, 1PE10.2, 4H ) =, 2(1PE10.2))
- RETURN
- END
- SUBROUTINE U1OFX(X, NX, U, W)
- INTEGER NX
- REAL X(NX), U(NX), W(NX)
- COMMON /TIME/ T
- REAL T
- INTEGER I
- REAL EXP
- DO 1 I = 1, NX
- U(I) = EXP(X(I)*T)
- 1 CONTINUE
- RETURN
- END
- SUBROUTINE U2OFX(X, NX, U, W)
- INTEGER NX
- REAL X(NX), U(NX), W(NX)
- COMMON /TIME/ T
- REAL T
- INTEGER I
- REAL EXP
- DO 1 I = 1, NX
- U(I) = T*EXP(X(I)*T)
- 1 CONTINUE
- RETURN
- END
diff --git a/CEP/PyBDSM/src/port3/ex/postx3.f b/CEP/PyBDSM/src/port3/ex/postx3.f
deleted file mode 100644
index 3b3fdd50ea043a3c29f1ecf4d2244ddc172169af..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ex/postx3.f
+++ /dev/null
@@ -1,147 +0,0 @@
-C$TEST PST3
-C TO RUN AS A MAIN PROGRAM REMOVE NEXT LINE
- SUBROUTINE PST3
-C***********************************************************************
-C
-C EXAMPLE OF USE OF PORT PROGRAM POST
-C
-C***********************************************************************
- COMMON /CSTAK/ DS
- DOUBLE PRECISION DS(2000)
- EXTERNAL DEE, HANDLE, BC, AF
- INTEGER NDX, K, IS(1000), NU, NV, NMESH
- REAL ERRPAR(2), U(100), V(1), MESH(100), DT, RS(1000)
- REAL WS(1000), TSTOP
- LOGICAL LS(1000)
- COMPLEX CS(500)
- EQUIVALENCE (DS(1), CS(1), WS(1), RS(1), IS(1), LS(1))
-C TO TEST POST ON
-C U SUB T = U SUB XX + V + F ON (0,1)
-C V SUB T = U( 1/2, T )
-C WHERE F IS CHOSEN SO THAT THE SOLUTION IS
-C U(X,T) = COS(XT) AND V(T) = 2 SIN(T/2).
-C THE PORT LIBRARY STACK AND ITS ALIASES.
-C INITIALIZE THE PORT LIBRARY STACK LENGTH.
- CALL ISTKIN(2000, 4)
- NU = 1
- NV = 1
- ERRPAR(1) = 1E-2
-C ESSENTIALLY RELATIVE ERROR.
- ERRPAR(2) = 1E-6
- TSTOP = 1
- DT = 1E-6
- K = 4
- NDX = 4
-C NDX UNIFORM MESH POINTS ON (0,1).
- CALL UMB(0E0, 1E0, NDX, K, MESH, NMESH)
-C INITIAL CONDITIONS FOR U.
- CALL SETR(NMESH-K, 1E0, U)
-C INITIAL VALUE FOR V.
- V(1) = 0
- CALL POST(U, NU, K, MESH, NMESH, V, NV, 0E0, TSTOP, DT, AF, BC,
- 1 DEE, ERRPAR, HANDLE)
-C CHECK FOR ERRORS AND STACK USAGE STATISTICS.
- CALL WRAPUP
- STOP
- END
- SUBROUTINE AF(T, X, NX, U, UX, UT, UTX, NU, V, VT, NV, A,
- 1 AU, AUX, AUT, AUTX, AV, AVT, F, FU, FUX, FUT, FUTX, FV, FVT)
- INTEGER NU, NV, NX
- REAL T, X(NX), U(NX, NU), UX(NX, NU), UT(NX, NU), UTX(NX, NU)
- REAL V(NV), VT(NV), A(NX, NU), AU(NX, NU, NU), AUX(NX, NU, NU),
- 1 AUT(NX, NU, NU)
- REAL AUTX(NX, NU, NU), AV(NX, NU, NV), AVT(NX, NU, NV), F(NX, NU),
- 1 FU(NX, NU, NU), FUX(NX, NU, NU)
- REAL FUT(NX, NU, NU), FUTX(NX, NU, NU), FV(NX, NU, NV), FVT(NX,
- 1 NU, NV)
- INTEGER I
- REAL COS, SIN
- DO 1 I = 1, NX
- A(I, 1) = -UX(I, 1)
- AUX(I, 1, 1) = -1
- F(I, 1) = V(1)-UT(I, 1)-X(I)*SIN(X(I)*T)+T**2*COS(X(I)*T)-2.*
- 1 SIN(T/2.)
- FUT(I, 1, 1) = -1
- FV(I, 1, 1) = 1
- 1 CONTINUE
- RETURN
- END
- SUBROUTINE BC(T, L, R, U, UX, UT, UTX, NU, V, VT, NV, B, BU,
- 1 BUX, BUT, BUTX, BV, BVT)
- INTEGER NU, NV
- REAL T, L, R, U(NU, 2), UX(NU, 2), UT(NU, 2)
- REAL UTX(NU, 2), V(NV), VT(NV), B(NU, 2), BU(NU, NU, 2), BUX(NU,
- 1 NU, 2)
- REAL BUT(NU, NU, 2), BUTX(NU, NU, 2), BV(NU, NV, 2), BVT(NU, NV, 2
- 1 )
- REAL COS
- B(1, 1) = U(1, 1)-1.
- B(1, 2) = U(1, 2)-COS(T)
- BU(1, 1, 1) = 1
- BU(1, 1, 2) = 1
- RETURN
- END
- SUBROUTINE DEE(T, K, X, NX, U, UT, NU, NXMK, V, VT, NV, D,
- 1 DU, DUT, DV, DVT)
- INTEGER NXMK, NU, NV, NX
- INTEGER K
- REAL T, X(NX), U(NXMK, NU), UT(NXMK, NU), V(NV), VT(NV)
- REAL D(NV), DU(NV, NXMK, NU), DUT(NV, NXMK, NU), DV(NV, NV), DVT(
- 1 NV, NV)
- INTEGER INTRVR, I, ILEFT
- REAL XI(1), BASIS(10)
- INTEGER TEMP
- XI(1) = 0.5E0
-C FIND 0.5 IN MESH.
- ILEFT = INTRVR(NX, X, XI(1))
- IF (K .GT. 10) CALL SETERR(
- 1 41HDEE - K .GT. 10, NEED MORE SPACE IN BASIS, 41, 1, 2)
-C B-SPLINE BASIS AT XI(1).
- CALL BSPLN(K, X, NX, XI, 1, ILEFT, BASIS)
- D(1) = VT(1)
- DVT(1, 1) = 1
-C VT(1) - U(0.5,T) = 0.
- DO 1 I = 1, K
- TEMP = ILEFT+I-K
- D(1) = D(1)-U(TEMP, 1)*BASIS(I)
- TEMP = ILEFT+I-K
- DU(1, TEMP, 1) = DU(1, TEMP, 1)-BASIS(I)
- 1 CONTINUE
- RETURN
- END
- SUBROUTINE HANDLE(T0, U0, V0, T, U, V, NU, NXMK, NV, K, X,
- 1 NX, DT, TSTOP)
- INTEGER NXMK, NU, NV, NX
- INTEGER K
- REAL T0, U0(NXMK, NU), V0(NV), T, U(NXMK, NU), V(NV)
- REAL X(NX), DT, TSTOP
- COMMON /TIME/ TT
- REAL TT
- EXTERNAL UOFX
- INTEGER I1MACH
- REAL ABS, SIN, EU, EV, EESFF
- INTEGER TEMP
-C OUTPUT AND CHECKING ROUTINE.
- IF (T0 .EQ. T) RETURN
-C UOFX NEEDS TIME.
- TT = T
- EU = EESFF(K, X, NX, U, UOFX)
- EV = ABS(V(1)-2.*SIN(T/2.))
- TEMP = I1MACH(2)
- WRITE (TEMP, 1) T, EU, EV
- 1 FORMAT (14H ERROR IN U(X,, 1PE10.2, 4H ) =, 1PE10.2, 6H V =, 1P
- 1 E10.2)
- RETURN
- END
- SUBROUTINE UOFX(X, NX, U, W)
- INTEGER NX
- REAL X(NX), U(NX), W(NX)
- COMMON /TIME/ T
- REAL T
- INTEGER I
- REAL COS
- DO 1 I = 1, NX
- U(I) = COS(X(I)*T)
- 1 CONTINUE
- RETURN
- END
diff --git a/CEP/PyBDSM/src/port3/ex/postx4.f b/CEP/PyBDSM/src/port3/ex/postx4.f
deleted file mode 100644
index 935647d352b766558d2d1b0dd46fbe6435f4d832..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ex/postx4.f
+++ /dev/null
@@ -1,136 +0,0 @@
-C$TEST PST4
-C TO RUN AS A MAIN PROGRAM REMOVE NEXT LINE
- SUBROUTINE PST4
-C***********************************************************************
-C
-C EXAMPLE OF USE OF PORT PROGRAM POST
-C
-C***********************************************************************
- COMMON /CSTAK/ DS
- DOUBLE PRECISION DS(2000)
- EXTERNAL DEE, HANDLE, BC, AF
- INTEGER NDX, K, IS(1000), NU, NV, NMESH
- REAL ERRPAR(2), U(100), V(1), ATAN, MESH(100), DT
- REAL RS(1000), WS(1000), TSTOP
- LOGICAL LS(1000)
- COMPLEX CS(500)
- EQUIVALENCE (DS(1), CS(1), WS(1), RS(1), IS(1), LS(1))
-C TO TEST POST ON
-C U SUB T = U SUB XX - U**3 + F ON (-PI,+PI)
-C SUBJECT TO PERIODIC BOUNDARY CONDITIONS,
-C WHERE F IS CHOSEN SO THAT THE SOLUTION IS
-C U(X,T) = COS(X)*SIN(T).
-C THE PORT LIBRARY STACK AND ITS ALIASES.
-C INITIALIZE THE PORT LIBRARY STACK LENGTH.
- CALL ISTKIN(2000, 4)
- NU = 1
- NV = 1
- ERRPAR(1) = 0
-C ABSOLUTE ERROR.
- ERRPAR(2) = 1E-2
- TSTOP = 8.*ATAN(1E0)
- DT = 0.4
-C MAKE A MESH OF NDX UNIFORM POINTS ON (-PI,+PI).
- K = 4
- NDX = 7
- CALL UMB((-4.)*ATAN(1E0), 4.*ATAN(1E0), NDX, K, MESH, NMESH)
-C INITIAL CONDITIONS FOR U.
- CALL SETR(NMESH-K, 0E0, U)
-C INITIAL CONDITIONS FOR V.
- V(1) = 0
- CALL POST(U, NU, K, MESH, NMESH, V, NV, 0E0, TSTOP, DT, AF, BC,
- 1 DEE, ERRPAR, HANDLE)
-C CHECK FOR ERRORS AND STACK USAGE STATISTICS.
- CALL WRAPUP
- STOP
- END
- SUBROUTINE AF(T, X, NX, U, UX, UT, UTX, NU, V, VT, NV, A,
- 1 AU, AUX, AUT, AUTX, AV, AVT, F, FU, FUX, FUT, FUTX, FV, FVT)
- INTEGER NU, NV, NX
- REAL T, X(NX), U(NX, NU), UX(NX, NU), UT(NX, NU), UTX(NX, NU)
- REAL V(NV), VT(NV), A(NX, NU), AU(NX, NU, NU), AUX(NX, NU, NU),
- 1 AUT(NX, NU, NU)
- REAL AUTX(NX, NU, NU), AV(NX, NU, NV), AVT(NX, NU, NV), F(NX, NU),
- 1 FU(NX, NU, NU), FUX(NX, NU, NU)
- REAL FUT(NX, NU, NU), FUTX(NX, NU, NU), FV(NX, NU, NV), FVT(NX,
- 1 NU, NV)
- INTEGER I
- REAL COS, SIN
- DO 1 I = 1, NX
- A(I, 1) = -UX(I, 1)
- AUX(I, 1, 1) = -1
- F(I, 1) = (-UT(I, 1))-U(I, 1)**3+COS(X(I))*(COS(T)+SIN(T)+COS(X
- 1 (I))**2*SIN(T)**3)
- FUT(I, 1, 1) = -1
- FU(I, 1, 1) = (-3.)*U(I, 1)**2
- 1 CONTINUE
- RETURN
- END
- SUBROUTINE BC(T, L, R, U, UX, UT, UTX, NU, V, VT, NV, B, BU,
- 1 BUX, BUT, BUTX, BV, BVT)
- INTEGER NU, NV
- REAL T, L, R, U(NU, 2), UX(NU, 2), UT(NU, 2)
- REAL UTX(NU, 2), V(NV), VT(NV), B(NU, 2), BU(NU, NU, 2), BUX(NU,
- 1 NU, 2)
- REAL BUT(NU, NU, 2), BUTX(NU, NU, 2), BV(NU, NV, 2), BVT(NU, NV, 2
- 1 )
- B(1, 1) = UX(1, 1)-V(1)
- B(1, 2) = UX(1, 2)-V(1)
- BUX(1, 1, 1) = 1
- BV(1, 1, 1) = -1
- BUX(1, 1, 2) = 1
- BV(1, 1, 2) = -1
- RETURN
- END
- SUBROUTINE DEE(T, K, X, NX, U, UT, NU, NXMK, V, VT, NV, D,
- 1 DU, DUT, DV, DVT)
- INTEGER NXMK, NU, NV, NX
- INTEGER K
- REAL T, X(NX), U(NXMK, NU), UT(NXMK, NU), V(NV), VT(NV)
- REAL D(NV), DU(NV, NXMK, NU), DUT(NV, NXMK, NU), DV(NV, NV), DVT(
- 1 NV, NV)
- INTEGER TEMP
-C U(-PI,T) - U(+PI,T) = 0.
- TEMP = NX-K
- D(1) = U(1, 1)-U(TEMP, 1)
- DU(1, 1, 1) = 1
- TEMP = NX-K
- DU(1, TEMP, 1) = -1
- RETURN
- END
- SUBROUTINE HANDLE(T0, U0, V0, T, U, V, NU, NXMK, NV, K, X,
- 1 NX, DT, TSTOP)
- INTEGER NXMK, NU, NV, NX
- INTEGER K
- REAL T0, U0(NXMK, NU), V0(NV), T, U(NXMK, NU), V(NV)
- REAL X(NX), DT, TSTOP
- COMMON /TIME/ TT
- REAL TT
- EXTERNAL UOFX
- INTEGER I1MACH
- REAL EU, EESFF, EV
- INTEGER TEMP
-C OUTPUT AND CHECKING ROUTINE.
- IF (T0 .EQ. T) RETURN
-C UOFX NEEDS TIME.
- TT = T
- EU = EESFF(K, X, NX, U, UOFX)
- EV = V(1)
- TEMP = I1MACH(2)
- WRITE (TEMP, 1) T, EU, EV
- 1 FORMAT (14H ERROR IN U(X,, 1PE10.2, 4H ) =, 1PE10.2, 6H V =, 1P
- 1 E10.2)
- RETURN
- END
- SUBROUTINE UOFX(X, NX, U, W)
- INTEGER NX
- REAL X(NX), U(NX), W(NX)
- COMMON /TIME/ T
- REAL T
- INTEGER I
- REAL COS, SIN
- DO 1 I = 1, NX
- U(I) = COS(X(I))*SIN(T)
- 1 CONTINUE
- RETURN
- END
diff --git a/CEP/PyBDSM/src/port3/ex/postx5.f b/CEP/PyBDSM/src/port3/ex/postx5.f
deleted file mode 100644
index d022745e2b4f34df415fdfecd39a991510c078ce..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ex/postx5.f
+++ /dev/null
@@ -1,246 +0,0 @@
-C$TEST PST5
-C TO RUN AS A MAIN PROGRAM REMOVE NEXT LINE
- SUBROUTINE PST5
-C***********************************************************************
-C
-C EXAMPLE OF USE OF PORT PROGRAM POST
-C
-C***********************************************************************
- COMMON /CSTAK/ DS
- DOUBLE PRECISION DS(4000)
- COMMON /TIME/ T
- REAL T
- COMMON /PARAM/ VC, X
- REAL VC(3), X(3)
- EXTERNAL DEE, HANDLE, UOFX, BC, AF
- INTEGER NDX, ISTKGT, K, IMMM, IU, IS(1000)
- INTEGER NU, NV, IMESH, ILUMB, NMESH
- REAL ERRPAR(2), TSTART, V(3), DT, XB(3), RS(1000)
- REAL WS(1000), TSTOP
- LOGICAL LS(1000)
- COMPLEX CS(500)
- EQUIVALENCE (DS(1), CS(1), WS(1), RS(1), IS(1), LS(1))
-C TO TEST POST ON
-C U SUB T = ( K(T,X) * U SUB X ) SUB X + G ON (-1,+2) * (0,+1)
-C WITH A MOVING FRONT X(T) CHARACTERIZED BY U(X(T),T) == 1 AND
-C JUMP ACROSS X(T) OF K(T,X) U SUB X = - 3 * X'(T).
-C WHERE K(T,X) IS PIECEWISE CONSTANT, SAY
-C 1 FOR X < X(T)
-C K(T,X) =
-C 2 FOR X > X(T)
-C AND G IS CHOSEN SO THAT THE SOLUTION IS
-C EXP(X-X(T)) FOR X < X(T)
-C U(X,T) =
-C EXP(X(T)-X) FOR X > X(T)
-C AND X(1,T) = T. THE MOVING FRONT IS TRACKED
-C IMPLICITLY BY FORCING U(X(1,T),T) = 1 AS A PSEUDO-RANKINE-HEUGONIOT RE
-CLATION.
-C V(1,2,3) GIVES THE MOVING MESH.
-C THE PORT LIBRARY STACK AND ITS ALIASES.
-C INITIALIZE THE PORT LIBRARY STACK LENGTH.
- CALL ISTKIN(4000, 4)
- CALL ENTER(1)
- NU = 1
- NV = 3
- ERRPAR(1) = 0
-C ABSOLUTE ERROR.
- ERRPAR(2) = 1E-2
- TSTART = 0
- TSTOP = 1
- DT = 0.1
- K = 4
-C NDX UNIFORM MESH POINTS ON EACH INTERVAL OF XB ARRAY.
- NDX = 6
- XB(1) = 0
- XB(2) = 1
- XB(3) = 2
-C GET MESH ON PORT STACK.
- IMESH = ILUMB(XB, 3, NDX, K, NMESH)
-C MAKE 1 OF MULTIPLICITY K-1.
- IMESH = IMMM(IMESH, NMESH, 1E0, K-1)
- X(1) = -1
- X(2) = 0
- X(3) = 2
-C INITIAL VALUES FOR V.
- CALL LPLMG(3, X, VC)
-C GET U ON THE PORT STACK.
- IU = ISTKGT(NMESH-K, 3)
-C UOFX NEEDS TIME.
- T = TSTART
-C UOFX NEEDS V FOR MAPPING.
- CALL MOVEFR(NV, VC, V)
-C INITIAL CONDITIONS FOR U.
- CALL L2SFF(UOFX, K, WS(IMESH), NMESH, WS(IU))
-C OUTPUT THE ICS.
- CALL HANDLE(T-1., WS(IU), V, T, WS(IU), V, NU, NMESH-K, NV, K, WS(
- 1 IMESH), NMESH, DT, TSTOP)
- CALL POST(WS(IU), NU, K, WS(IMESH), NMESH, V, NV, TSTART, TSTOP,
- 1 DT, AF, BC, DEE, ERRPAR, HANDLE)
- CALL LEAVE
- CALL WRAPUP
- STOP
- END
- SUBROUTINE AF(T, XI, NX, U, UX, UT, UTX, NU, V, VT, NV, A,
- 1 AU, AUX, AUT, AUTX, AV, AVT, F, FU, FUX, FUT, FUTX, FV, FVT)
- INTEGER NU, NV, NX
- REAL T, XI(NX), U(NX, NU), UX(NX, NU), UT(NX, NU), UTX(NX, NU)
- REAL V(NV), VT(NV), A(NX, NU), AU(NX, NU, NU), AUX(NX, NU, NU),
- 1 AUT(NX, NU, NU)
- REAL AUTX(NX, NU, NU), AV(NX, NU, NV), AVT(NX, NU, NV), F(NX, NU),
- 1 FU(NX, NU, NU), FUX(NX, NU, NU)
- REAL FUT(NX, NU, NU), FUTX(NX, NU, NU), FV(NX, NU, NV), FVT(NX,
- 1 NU, NV)
- COMMON /POSTF/ FAILED
- LOGICAL FAILED
- INTEGER I
- REAL KAY, EXP, XXI(99), XTV(99), XVV(99), X(99)
- REAL XXIV(99), AX(99), FX(99), XT(99), XV(99)
- LOGICAL TEMP
- TEMP = V(2) .LE. V(1)
- IF (.NOT. TEMP) TEMP = V(2) .GE. V(3)
- IF (.NOT. TEMP) GOTO 1
- FAILED = .TRUE.
- RETURN
-C MAP XI INTO X.
- 1 CALL LPLM(XI, NX, V, 3, X, XXI, XXIV, XV, XVV, XT, XTV)
-C MAP U INTO X SYSTEM.
- CALL POSTU(XI, X, XT, XXI, XV, VT, NX, 3, UX, UT, NU, AX, FX)
- DO 7 I = 1, NX
- IF (XI(I) .GT. 1.) GOTO 2
- KAY = 1
- GOTO 3
- 2 KAY = 2
- 3 A(I, 1) = KAY*UX(I, 1)
- AUX(I, 1, 1) = KAY
- IF (XI(I) .GT. 1.) GOTO 4
- A(I, 1) = A(I, 1)-3.*VT(2)
- AVT(I, 1, 2) = -3
- 4 F(I, 1) = UT(I, 1)
- FUT(I, 1, 1) = 1
- IF (XI(I) .GT. 1.) GOTO 5
- F(I, 1) = F(I, 1)+2.*EXP(X(I)-T)
- FX(I) = 2.*EXP(X(I)-T)
- GOTO 6
- 5 F(I, 1) = F(I, 1)+EXP(T-X(I))
- FX(I) = -EXP(T-X(I))
- 6 CONTINUE
- 7 CONTINUE
-C MAP A AND F INTO XI SYSTEM.
- CALL POSTI(XI, X, XT, XXI, XV, XTV, XXIV, XVV, NX, UX, UT, NU, V
- 1 , VT, NV, 1, 3, A, AX, AU, AUX, AUT, AUTX, AV, AVT, F, FX, FU
- 2 , FUX, FUT, FUTX, FV, FVT)
- RETURN
- END
- SUBROUTINE BC(T, L, R, U, UX, UT, UTX, NU, V, VT, NV, B, BU,
- 1 BUX, BUT, BUTX, BV, BVT)
- INTEGER NU, NV
- REAL T, L, R, U(NU, 2), UX(NU, 2), UT(NU, 2)
- REAL UTX(NU, 2), V(NV), VT(NV), B(NU, 2), BU(NU, NU, 2), BUX(NU,
- 1 NU, 2)
- REAL BUT(NU, NU, 2), BUTX(NU, NU, 2), BV(NU, NV, 2), BVT(NU, NV, 2
- 1 )
- REAL EXP
- B(1, 1) = U(1, 1)-EXP((-1.)-T)
- B(1, 2) = U(1, 2)-EXP(T-2.)
- BU(1, 1, 1) = 1
- BU(1, 1, 2) = 1
- RETURN
- END
- SUBROUTINE DEE(T, K, X, NX, U, UT, NU, NXMK, V, VT, NV, D,
- 1 DU, DUT, DV, DVT)
- INTEGER NXMK, NU, NV, NX
- INTEGER K
- REAL T, X(NX), U(NXMK, NU), UT(NXMK, NU), V(NV), VT(NV)
- REAL D(NV), DU(NV, NXMK, NU), DUT(NV, NXMK, NU), DV(NV, NV), DVT(
- 1 NV, NV)
- INTEGER INTRVR, I, ILEFT
- REAL BX(10), XX(1)
- INTEGER TEMP
- D(1) = V(1)+1.
-C X(0,V) = -1.
- DV(1, 1) = 1
- XX(1) = 1
-C FIND 1 IN THE MESH.
- ILEFT = INTRVR(NX, X, XX(1))
-C GET THE B-SPLINE BASIS AT XX.
- CALL BSPLN(K, X, NX, XX, 1, ILEFT, BX)
-C U(X(1,V),T) = 1.
- D(2) = -1
- DO 1 I = 1, K
- TEMP = ILEFT+I-K
- D(2) = D(2)+U(TEMP, 1)*BX(I)
- TEMP = ILEFT+I-K
- DU(2, TEMP, 1) = BX(I)
- 1 CONTINUE
- D(3) = V(3)-2.
-C X(2,V) = +2.
- DV(3, 3) = 1
- RETURN
- END
- SUBROUTINE HANDLE(T0, U0, V0, T, U, V, NU, NXMK, NV, K, X,
- 1 NX, DT, TSTOP)
- INTEGER NXMK, NU, NV, NX
- INTEGER K
- REAL T0, U0(NXMK, NU), V0(NV), T, U(NXMK, NU), V(NV)
- REAL X(NX), DT, TSTOP
- COMMON /PARAM/ VC, XX
- REAL VC(3), XX(3)
- COMMON /TIME/ TT
- REAL TT
- EXTERNAL UOFX
- INTEGER I1MACH
- REAL EU, EESFF, EV(3)
- INTEGER TEMP
-C OUTPUT AND CHECKING ROUTINE.
- IF (T0 .NE. T) GOTO 2
- TEMP = I1MACH(2)
- WRITE (TEMP, 1) T
- 1 FORMAT (16H RESTART FOR T =, 1PE10.2)
- RETURN
- 2 TT = T
-C UOFX NEEDS V FOR MAPPING.
- CALL MOVEFR(NV, V, VC)
- EU = EESFF(K, X, NX, U, UOFX)
- EV(1) = V(1)+1.
- EV(2) = V(2)-T
- EV(3) = V(3)-2.
- TEMP = I1MACH(2)
- WRITE (TEMP, 3) T, EU, EV
- 3 FORMAT (14H ERROR IN U(X,, 1PE10.2, 4H ) =, 1PE10.2, 6H V =, 3(
- 1 1PE10.2))
- RETURN
- END
- SUBROUTINE UOFX(XI, NX, U, W)
- INTEGER NX
- REAL XI(NX), U(NX), W(NX)
- COMMON /CSTAK/ DS
- DOUBLE PRECISION DS(500)
- COMMON /PARAM/ VC, X
- REAL VC(3), X(3)
- COMMON /TIME/ T
- REAL T
- INTEGER IXV, IXX, ISTKGT, I, IS(1000)
- REAL EXP, RS(1000), WS(1000), XOFXI
- LOGICAL LS(1000)
- COMPLEX CS(500)
- INTEGER TEMP
- EQUIVALENCE (DS(1), CS(1), WS(1), RS(1), IS(1), LS(1))
-C THE PORT LIBRARY STACK AND ITS ALIASES.
- CALL ENTER(1)
- IXX = ISTKGT(NX, 3)
-C SPACE FOR X AND XV.
- IXV = ISTKGT(3*NX, 3)
-C MAP INTO USER SYSTEM.
- CALL LPLMX(XI, NX, VC, 3, WS(IXX), WS(IXV))
- DO 3 I = 1, NX
- TEMP = IXX+I
- XOFXI = WS(TEMP-1)
- IF (XI(I) .GT. 1.) GOTO 1
- U(I) = EXP(XOFXI-T)
- GOTO 2
- 1 U(I) = EXP(T-XOFXI)
- 2 CONTINUE
- 3 CONTINUE
- CALL LEAVE
- RETURN
- END
diff --git a/CEP/PyBDSM/src/port3/ex/postx6.f b/CEP/PyBDSM/src/port3/ex/postx6.f
deleted file mode 100644
index b0ad75c8052381852545e7471b1b6c69df4759dd..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ex/postx6.f
+++ /dev/null
@@ -1,252 +0,0 @@
-C$TEST PST6
-C TO RUN AS A MAIN PROGRAM REMOVE NEXT LINE
- SUBROUTINE PST6
-C***********************************************************************
-C
-C EXAMPLE OF USE OF PORT PROGRAM POST
-C
-C***********************************************************************
- COMMON /CSTAK/ DS
- DOUBLE PRECISION DS(4000)
- COMMON /TIME/ T
- REAL T
- COMMON /PARAM/ VC, X
- REAL VC(4), X(3)
- EXTERNAL DEE, HANDLE, UOFX, BC, AF
- INTEGER NDX, ISTKGT, K, IMMM, IU, IS(1000)
- INTEGER NU, NV, IMESH, ILUMB, NMESH
- REAL ERRPAR(2), TSTART, V(4), DT, XB(3), RS(1000)
- REAL WS(1000), TSTOP
- LOGICAL LS(1000)
- COMPLEX CS(500)
- EQUIVALENCE (DS(1), CS(1), WS(1), RS(1), IS(1), LS(1))
-C TO TEST POST ON THE HYPERBOLIC PROBLEM
-C U SUB T = - U SUB X + G ON (-PI,+PI) * (0,PI)
-C WITH A MOVING SHOCK X(T) CHARACTERIZED BY
-C U(X(T)+,T) = 0 AND
-C U(X(T)+,T) - U(X(T)-,T) = X'(T)
-C WHERE G IS CHOSEN SO THAT THE SOLUTION IS
-C SIN(X+T) FOR X < X(T)
-C U(X,T) =
-C COS(X+T) FOR X > X(T)
-C WITH X(T) = PI/2 -T .
-C V(1,2,3) GIVES THE MOVING MESH AND V(4) IS THE HEIGHT OF THE JUMP.
-C THE PORT LIBRARY STACK AND ITS ALIASES.
-C INITIALIZE THE PORT LIBRARY STACK LENGTH.
- CALL ISTKIN(4000, 4)
- CALL ENTER(1)
- NU = 1
- NV = 4
- ERRPAR(1) = 0
-C ABSOLUTE ERROR.
- ERRPAR(2) = 1E-2
- TSTART = 0
- TSTOP = 3.14
- DT = 0.4
- K = 4
-C NDX UNIFORM MESH POINTS ON EACH INTERVAL OF XB.
- NDX = 6
- XB(1) = 0
- XB(2) = 1
- XB(3) = 2
-C GET MESH ON PORT STACK.
- IMESH = ILUMB(XB, 3, NDX, K, NMESH)
-C MAKE 1 OF MULTIPLICITY K-1.
- IMESH = IMMM(IMESH, NMESH, 1E0, K-1)
- X(1) = -3.14
- X(2) = 3.14/2.
- X(3) = 3.14
-C INITIAL VALUES FOR V.
- CALL LPLMG(3, X, VC)
-C GET U ON THE PORT STACK.
- IU = ISTKGT(NMESH-K, 3)
-C UOFX NEEDS TIME.
- T = TSTART
-C THE INITIAL HEIGHT OF THE JUMP.
- VC(4) = 1
-C UOFX NEEDS V FOR MAPPING.
- CALL MOVEFR(NV, VC, V)
-C INITIAL CONDITIONS FOR U.
- CALL L2SFF(UOFX, K, WS(IMESH), NMESH, WS(IU))
-C OUTPUT ICS.
- CALL HANDLE(T-1., WS(IU), V, T, WS(IU), V, NU, NMESH-K, NV, K, WS(
- 1 IMESH), NMESH, DT, TSTOP)
- CALL POST(WS(IU), NU, K, WS(IMESH), NMESH, V, NV, TSTART, TSTOP,
- 1 DT, AF, BC, DEE, ERRPAR, HANDLE)
- CALL LEAVE
- CALL WRAPUP
- STOP
- END
- SUBROUTINE AF(T, XI, NX, U, UX, UT, UTX, NU, V, VT, NV, A,
- 1 AU, AUX, AUT, AUTX, AV, AVT, F, FU, FUX, FUT, FUTX, FV, FVT)
- INTEGER NU, NV, NX
- REAL T, XI(NX), U(NX, NU), UX(NX, NU), UT(NX, NU), UTX(NX, NU)
- REAL V(NV), VT(NV), A(NX, NU), AU(NX, NU, NU), AUX(NX, NU, NU),
- 1 AUT(NX, NU, NU)
- REAL AUTX(NX, NU, NU), AV(NX, NU, NV), AVT(NX, NU, NV), F(NX, NU),
- 1 FU(NX, NU, NU), FUX(NX, NU, NU)
- REAL FUT(NX, NU, NU), FUTX(NX, NU, NU), FV(NX, NU, NV), FVT(NX,
- 1 NU, NV)
- COMMON /POSTF/ FAILED
- LOGICAL FAILED
- INTEGER I
- REAL COS, SIN, XXI(99), XTV(99), XVV(99), X(99)
- REAL XXIV(99), AX(99), FX(99), XT(99), XV(99)
- LOGICAL TEMP
- TEMP = V(2) .LE. V(1)
- IF (.NOT. TEMP) TEMP = V(2) .GE. V(3)
- IF (.NOT. TEMP) GOTO 1
- FAILED = .TRUE.
- RETURN
-C MAP XI INTO X.
- 1 CALL LPLM(XI, NX, V, 3, X, XXI, XXIV, XV, XVV, XT, XTV)
-C MAP U INTO X SYSTEM.
- CALL POSTU(XI, X, XT, XXI, XV, VT, NX, 3, UX, UT, NU, AX, FX)
- DO 4 I = 1, NX
- A(I, 1) = -U(I, 1)
- AU(I, 1, 1) = -1
- F(I, 1) = UT(I, 1)
- FUT(I, 1, 1) = 1
- IF (XI(I) .GT. 1.) GOTO 2
- F(I, 1) = F(I, 1)-2.*COS(X(I)+T)
- FX(I) = 2.*SIN(X(I)+T)
- GOTO 3
- 2 F(I, 1) = F(I, 1)-VT(4)
- FVT(I, 1, 4) = -1
- F(I, 1) = F(I, 1)+2.*SIN(X(I)+T)
- FX(I) = 2.*COS(X(I)+T)
- 3 CONTINUE
- 4 CONTINUE
-C MAP A AND F INTO XI SYSTEM.
- CALL POSTI(XI, X, XT, XXI, XV, XTV, XXIV, XVV, NX, UX, UT, NU, V
- 1 , VT, NV, 1, 3, A, AX, AU, AUX, AUT, AUTX, AV, AVT, F, FX, FU
- 2 , FUX, FUT, FUTX, FV, FVT)
- RETURN
- END
- SUBROUTINE BC(T, L, R, U, UX, UT, UTX, NU, V, VT, NV, B, BU,
- 1 BUX, BUT, BUTX, BV, BVT)
- INTEGER NU, NV
- REAL T, L, R, U(NU, 2), UX(NU, 2), UT(NU, 2)
- REAL UTX(NU, 2), V(NV), VT(NV), B(NU, 2), BU(NU, NU, 2), BUX(NU,
- 1 NU, 2)
- REAL BUT(NU, NU, 2), BUTX(NU, NU, 2), BV(NU, NV, 2), BVT(NU, NV, 2
- 1 )
- REAL SIN
- B(1, 1) = U(1, 1)-SIN(T-3.14)
-C U(-PI,T) = SIN(-PI+T).
- BU(1, 1, 1) = 1
- RETURN
- END
- SUBROUTINE DEE(T, K, X, NX, U, UT, NU, NXMK, V, VT, NV, D,
- 1 DU, DUT, DV, DVT)
- INTEGER NXMK, NU, NV, NX
- INTEGER K
- REAL T, X(NX), U(NXMK, NU), UT(NXMK, NU), V(NV), VT(NV)
- REAL D(NV), DU(NV, NXMK, NU), DUT(NV, NXMK, NU), DV(NV, NV), DVT(
- 1 NV, NV)
- INTEGER INTRVR, I, ILEFT
- REAL BX(10), XX(1), R1MACH
- INTEGER TEMP
- D(1) = V(1)+3.14
-C X(0,V) = -PI.
- DV(1, 1) = 1
-C XX(1) = 1 + A ROUNDING ERROR.
- XX(1) = R1MACH(4)+1.
- ILEFT = INTRVR(NX, X, XX(1))
-C GET THE B-SPLINE BASIS AT XX.
- CALL BSPLN(K, X, NX, XX, 1, ILEFT, BX)
- D(2) = -V(4)
-C U(X(T)+,T) - JUMP = 0.
- DV(2, 4) = -1
- DO 1 I = 1, K
- TEMP = ILEFT+I-K
- D(2) = D(2)+U(TEMP, 1)*BX(I)
- TEMP = ILEFT+I-K
- DU(2, TEMP, 1) = BX(I)
- 1 CONTINUE
- D(3) = V(3)-3.14
-C X(2,V) = +PI.
- DV(3, 3) = 1
-C JUMP + D( X(1,V(T)) )/DT = 0.
- D(4) = VT(2)+V(4)
- DVT(4, 2) = 1
- DV(4, 4) = 1
- RETURN
- END
- SUBROUTINE HANDLE(T0, U0, V0, T, U, V, NU, NXMK, NV, K, X,
- 1 NX, DT, TSTOP)
- INTEGER NXMK, NU, NV, NX
- INTEGER K
- REAL T0, U0(NXMK, NU), V0(NV), T, U(NXMK, NU), V(NV)
- REAL X(NX), DT, TSTOP
- COMMON /PARAM/ VC, XX
- REAL VC(4), XX(3)
- COMMON /TIME/ TT
- REAL TT
- EXTERNAL UOFX
- INTEGER I1MACH
- REAL EU, EESFF, EV(2)
- INTEGER TEMP
-C OUTPUT AND CHECKING ROUTINE.
- IF (T0 .NE. T) GOTO 2
- TEMP = I1MACH(2)
- WRITE (TEMP, 1) T, DT
- 1 FORMAT (16H RESTART FOR T =, 1PE10.2, 7H DT =, 1PE10.2)
- RETURN
- 2 TT = T
-C UOFX NEEDS V FOR MAPPING.
- CALL MOVEFR(NV, V, VC)
- EU = EESFF(K, X, NX, U, UOFX)
-C ERROR IN POSITION OF SHOCK.
- EV(1) = V(2)-(3.14/2.-T)
-C ERROR IN HEIGHT OF SHOCK.
- EV(2) = V(4)-1.
- TEMP = I1MACH(2)
- WRITE (TEMP, 3) T, EU, EV
- 3 FORMAT (14H ERROR IN U(X,, 1PE10.2, 4H ) =, 1PE10.2, 6H V =, 2(
- 1 1PE10.2))
- RETURN
- END
- SUBROUTINE UOFX(XI, NX, U, W)
- INTEGER NX
- REAL XI(NX), U(NX), W(NX)
- COMMON /CSTAK/ DS
- DOUBLE PRECISION DS(500)
- COMMON /PARAM/ VC, X
- REAL VC(4), X(3)
- COMMON /TIME/ T
- REAL T
- INTEGER IXV, IXX, ISTKGT, I, IS(1000)
- REAL EWE, RS(1000), WS(1000)
- LOGICAL LS(1000)
- COMPLEX CS(500)
- INTEGER TEMP
- EQUIVALENCE (DS(1), CS(1), WS(1), RS(1), IS(1), LS(1))
-C THE PORT LIBRARY STACK AND ITS ALIASES.
- CALL ENTER(1)
- IXX = ISTKGT(NX, 3)
-C SPACE FOR X AND XV.
- IXV = ISTKGT(3*NX, 3)
-C MAP INTO USER SYSTEM.
- CALL LPLMX(XI, NX, VC, 3, WS(IXX), WS(IXV))
- DO 1 I = 1, NX
- TEMP = IXX+I
- U(I) = EWE(T, WS(TEMP-1), VC(2))
- IF (XI(I) .GT. 1.) U(I) = U(I)+1.
- 1 CONTINUE
- CALL LEAVE
- RETURN
- END
- REAL FUNCTION EWE(T, X, XBREAK)
- REAL T, X, XBREAK
- REAL COS, SIN
- IF (X .GE. XBREAK) GOTO 1
- EWE = SIN(X+T)
- RETURN
- 1 IF (X .LE. XBREAK) GOTO 2
- EWE = COS(X+T)
- RETURN
- 2 CALL SETERR(17HEWE - X == XBREAK, 17, 1, 2)
- 3 CONTINUE
- 4 STOP
- END
diff --git a/CEP/PyBDSM/src/port3/ex/postx7.f b/CEP/PyBDSM/src/port3/ex/postx7.f
deleted file mode 100644
index 8c5f58261367beb5d74bd6ffd277c54267de2d1f..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ex/postx7.f
+++ /dev/null
@@ -1,234 +0,0 @@
-C$TEST PST7
-C TO RUN AS A MAIN PROGRAM REMOVE NEXT LINE
- SUBROUTINE PST7
-C***********************************************************************
-C
-C EXAMPLE OF USE OF PORT PROGRAM POST
-C
-C***********************************************************************
- COMMON /CSTAK/ DS
- DOUBLE PRECISION DS(4000)
- COMMON /TIME/ T
- REAL T
- COMMON /PARAM/ VC, X, XI0
- REAL VC(4), X(3), XI0
- EXTERNAL DEE, HANDLE, UOFX, BC, AF
- INTEGER NDX, ISTKGT, K, IMMM, IU, IS(1000)
- INTEGER NU, NV, IMESH, ILUMB, NMESH
- REAL ERRPAR(2), TSTART, D, V(4), DT, XB(3)
- REAL RS(1000), WS(1000), TSTOP
- LOGICAL LS(1000)
- COMPLEX CS(500)
- EQUIVALENCE (DS(1), CS(1), WS(1), RS(1), IS(1), LS(1))
-C TO TEST POST ON
-C U SUB T = U SUB XX + F ON (20,10**6)
-C WHERE F IS CHOSEN SO THAT THE SOLUTION IS
-C U(X,T) = EXP(-X*T),
-C AND X(1,T) IS CHOSEN SO THAT THE BOUNDARY-LAYER IS TRACKED
-C IMPLICITLY BY FORCING U(X(1,T)/2.3/D,T) = 1/E.
-C THIS IS THE SAME AS REQUIRING THE EXACT SOLUTION TO HAVE
-C U(X(1,T),T) = 10 ** -D.
-C V(1,2,3) GIVES THE MOVING MESH, V(4) IS TIME.
-C THE PORT LIBRARY STACK AND ITS ALIASES.
-C INITIALIZE THE PORT LIBRARY STACK LENGTH.
- CALL ISTKIN(4000, 4)
- CALL ENTER(1)
- NU = 1
- NV = 4
- ERRPAR(1) = 1E-2
-C MIXED RELATIVE AND ABSOLUTE ERROR.
- ERRPAR(2) = 1E-2
- D = 3
-C W(XI0,T) = 1/E.
- XI0 = 1./2.3/D
- TSTART = 20
- TSTOP = 1E+6
- DT = 1E-2
- K = 4
-C NDX UNIFORM MESH POINTS ON EACH INTERVAL OF XB.
- NDX = 6
- XB(1) = 0
- XB(2) = 1
- XB(3) = 2
-C GET MESH ON PORT STACK.
- IMESH = ILUMB(XB, 3, NDX, K, NMESH)
-C MAKE 1D0 OF MULTIPLICITY K-1.
- IMESH = IMMM(IMESH, NMESH, 1E0, K-1)
- X(1) = 0
- X(2) = 2.3*D/TSTART
- X(3) = 1
-C INITIAL VALUES FOR V.
- CALL LPLMG(3, X, VC)
-C GET U ON PORT STACK.
- IU = ISTKGT(NMESH-K, 3)
-C UOFX NEEDS TIME.
- T = TSTART
- VC(4) = TSTART
-C UOFX NEEDS V FOR MAPPING.
- CALL MOVEFR(NV, VC, V)
-C INITIAL CONDITIONS FOR U.
- CALL L2SFF(UOFX, K, WS(IMESH), NMESH, WS(IU))
-C OUTPUT ICS.
- CALL HANDLE(T-1., WS(IU), V, T, WS(IU), V, NU, NMESH-K, NV, K, WS(
- 1 IMESH), NMESH, DT, TSTOP)
- CALL POST(WS(IU), NU, K, WS(IMESH), NMESH, V, NV, TSTART, TSTOP,
- 1 DT, AF, BC, DEE, ERRPAR, HANDLE)
- CALL LEAVE
- CALL WRAPUP
- STOP
- END
- SUBROUTINE AF(T, XI, NX, U, UX, UT, UTX, NU, V, VT, NV, A,
- 1 AU, AUX, AUT, AUTX, AV, AVT, F, FU, FUX, FUT, FUTX, FV, FVT)
- INTEGER NU, NV, NX
- REAL T, XI(NX), U(NX, NU), UX(NX, NU), UT(NX, NU), UTX(NX, NU)
- REAL V(NV), VT(NV), A(NX, NU), AU(NX, NU, NU), AUX(NX, NU, NU),
- 1 AUT(NX, NU, NU)
- REAL AUTX(NX, NU, NU), AV(NX, NU, NV), AVT(NX, NU, NV), F(NX, NU),
- 1 FU(NX, NU, NU), FUX(NX, NU, NU)
- REAL FUT(NX, NU, NU), FUTX(NX, NU, NU), FV(NX, NU, NV), FVT(NX,
- 1 NU, NV)
- COMMON /POSTF/ FAILED
- LOGICAL FAILED
- INTEGER I
- REAL XXI(99), XTV(99), XVV(99), X(99), EXPL, XXIV(99)
- REAL AX(99), FX(99), XT(99), XV(99)
- LOGICAL TEMP
- TEMP = V(2) .LE. V(1)
- IF (.NOT. TEMP) TEMP = V(2) .GE. V(3)
- IF (.NOT. TEMP) GOTO 1
- FAILED = .TRUE.
- RETURN
-C MAP XI INTO X.
- 1 CALL LPLM(XI, NX, V, 3, X, XXI, XXIV, XV, XVV, XT, XTV)
-C MAP U INTO X SYSTEM.
- CALL POSTU(XI, X, XT, XXI, XV, VT, NX, 3, UX, UT, NU, AX, FX)
- DO 2 I = 1, NX
- A(I, 1) = -UX(I, 1)
- AUX(I, 1, 1) = -1
- F(I, 1) = (-UT(I, 1))-EXPL((-X(I))*V(4))*(X(I)+V(4)**2)
- FUT(I, 1, 1) = -1
- FV(I, 1, 4) = (-EXPL((-X(I))*V(4)))*(2.*V(4)+(X(I)+V(4)**2)*(-X
- 1 (I)))
- FX(I) = (-EXPL((-X(I))*V(4)))*(1.-V(4)*X(I)-V(4)**3)
- 2 CONTINUE
-C MAP A AND F INTO XI SYSTEM.
- CALL POSTI(XI, X, XT, XXI, XV, XTV, XXIV, XVV, NX, UX, UT, NU, V
- 1 , VT, NV, 1, 3, A, AX, AU, AUX, AUT, AUTX, AV, AVT, F, FX, FU
- 2 , FUX, FUT, FUTX, FV, FVT)
- RETURN
- END
- SUBROUTINE BC(T, L, R, U, UX, UT, UTX, NU, V, VT, NV, B, BU,
- 1 BUX, BUT, BUTX, BV, BVT)
- INTEGER NU, NV
- REAL T, L, R, U(NU, 2), UX(NU, 2), UT(NU, 2)
- REAL UTX(NU, 2), V(NV), VT(NV), B(NU, 2), BU(NU, NU, 2), BUX(NU,
- 1 NU, 2)
- REAL BUT(NU, NU, 2), BUTX(NU, NU, 2), BV(NU, NV, 2), BVT(NU, NV, 2
- 1 )
- REAL EXPL
-C U(0,T) = 1
- B(1, 1) = U(1, 1)-1.
-C U(1,T) = EXP(-T)
- B(1, 2) = U(1, 2)-EXPL(-V(4))
- BU(1, 1, 1) = 1
- BU(1, 1, 2) = 1
- BV(1, 4, 2) = EXPL(-V(4))
- RETURN
- END
- SUBROUTINE DEE(T, K, X, NX, U, UT, NU, NXMK, V, VT, NV, D,
- 1 DU, DUT, DV, DVT)
- INTEGER NXMK, NU, NV, NX
- INTEGER K
- REAL T, X(NX), U(NXMK, NU), UT(NXMK, NU), V(NV), VT(NV)
- REAL D(NV), DU(NV, NXMK, NU), DUT(NV, NXMK, NU), DV(NV, NV), DVT(
- 1 NV, NV)
- COMMON /PARAM/ VC, XC, XI0
- REAL VC(4), XC(3), XI0
- INTEGER INTRVR, I, ILEFT
- REAL EXP, BX(10), XX(1)
- INTEGER TEMP
- D(1) = V(1)
-C X(0,V) = 0.
- DV(1, 1) = 1
- XX(1) = XI0
- ILEFT = INTRVR(NX, X, XX(1))
-C GET THE B-SPLINE BASIS AT XX.
- CALL BSPLN(K, X, NX, XX, 1, ILEFT, BX)
- D(2) = -EXP(-1E0)
-C D(2) = W(XI0,T) - EXP(-1).
- DO 1 I = 1, K
- TEMP = ILEFT+I-K
- D(2) = D(2)+U(TEMP, 1)*BX(I)
- TEMP = ILEFT+I-K
- DU(2, TEMP, 1) = BX(I)
- 1 CONTINUE
- D(3) = V(3)-1.
-C X(2,V) = 1.
- DV(3, 3) = 1
- D(4) = VT(4)-1.
- DVT(4, 4) = 1
- RETURN
- END
- SUBROUTINE HANDLE(T0, U0, V0, T, U, V, NU, NXMK, NV, K, X,
- 1 NX, DT, TSTOP)
- INTEGER NXMK, NU, NV, NX
- INTEGER K
- REAL T0, U0(NXMK, NU), V0(NV), T, U(NXMK, NU), V(NV)
- REAL X(NX), DT, TSTOP
- COMMON /PARAM/ VC, XX, XI0
- REAL VC(4), XX(3), XI0
- COMMON /TIME/ TT
- REAL TT
- EXTERNAL UOFX
- INTEGER I1MACH
- REAL EU, EESFF, EV, LPLMT
- INTEGER TEMP
-C OUTPUT AND CHECKING ROUTINE.
- IF (T0 .NE. T) GOTO 2
- TEMP = I1MACH(2)
- WRITE (TEMP, 1) T, DT
- 1 FORMAT (16H RESTART FOR T =, 1PE10.2, 7H DT =, 1PE10.2)
- RETURN
-C LET DT CARRY V(2) DOWN BY NO MORE THAN A FACTOR OF 10.
- 2 DT = LPLMT(T, V, NV, T0, V0, 1E-1, DT)
- TT = T
-C UOFX NEEDS V FOR MAPPING.
- CALL MOVEFR(NV, V, VC)
- EU = EESFF(K, X, NX, U, UOFX)
-C ERROR IN POSITION OF BOUNDARY LAYER.
- EV = V(2)-1./XI0/T
- TEMP = I1MACH(2)
- WRITE (TEMP, 3) T, EU, EV
- 3 FORMAT (14H ERROR IN U(X,, 1PE10.2, 4H ) =, 1PE10.2, 6H V =, 1P
- 1 E10.2)
- RETURN
- END
- SUBROUTINE UOFX(XI, NX, U, W)
- INTEGER NX
- REAL XI(NX), U(NX), W(NX)
- COMMON /CSTAK/ DS
- DOUBLE PRECISION DS(500)
- COMMON /PARAM/ VC, X, XI0
- REAL VC(4), X(3), XI0
- COMMON /TIME/ T
- REAL T
- INTEGER IXV, IXX, ISTKGT, I, IS(1000)
- REAL EXPL, RS(1000), WS(1000)
- LOGICAL LS(1000)
- COMPLEX CS(500)
- INTEGER TEMP
- EQUIVALENCE (DS(1), CS(1), WS(1), RS(1), IS(1), LS(1))
-C THE PORT LIBRARY STACK AND ITS ALIASES.
- CALL ENTER(1)
- IXX = ISTKGT(NX, 3)
-C SPACE FOR X AND XV.
- IXV = ISTKGT(3*NX, 3)
-C MAP INTO USER SYSTEM.
- CALL LPLMX(XI, NX, VC, 3, WS(IXX), WS(IXV))
- DO 1 I = 1, NX
- TEMP = IXX+I
- U(I) = EXPL((-WS(TEMP-1))*T)
- 1 CONTINUE
- CALL LEAVE
- RETURN
- END
diff --git a/CEP/PyBDSM/src/port3/ex/postx8.f b/CEP/PyBDSM/src/port3/ex/postx8.f
deleted file mode 100644
index b25ec41a9d65031f5852812ca200fb0a18845fe8..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ex/postx8.f
+++ /dev/null
@@ -1,217 +0,0 @@
-C$TEST PST8
-C TO RUN AS A MAIN PROGRAM REMOVE NEXT LINE
- SUBROUTINE PST8
-C***********************************************************************
-C
-C EXAMPLE OF USE OF PORT PROGRAM POST
-C
-C***********************************************************************
- COMMON /CSTAK/ DS
- DOUBLE PRECISION DS(5000)
- COMMON /TIME/ T
- REAL T
- COMMON /KMESH/ K, NMESH
- INTEGER K, NMESH
- COMMON /CMESH/ MESH
- REAL MESH(100)
- EXTERNAL DEE, HANDLE, UOFX, BC, AF
- INTEGER NDX, I, IS(1000), NU, NV
- REAL ERRPAR(2), U(100), V(100), DT, RS(1000), WS(1000)
- REAL TSTOP
- LOGICAL LS(1000)
- COMPLEX CS(500)
- INTEGER TEMP
- EQUIVALENCE (DS(1), CS(1), WS(1), RS(1), IS(1), LS(1))
-C TO TEST POST ON THE INTEGRO-PDE
-C U SUB T = 2 * U SUB XX - INT(0,1) EXP(X-Y)*U(Y) DY ON (0,1)
-C SUBJECT TO GIVEN DIRICHLET BCS, CHOSEN SO THAT THE SOLUTION IS
-C U(X,T) = EXP(T+X).
-C THE PORT LIBRARY STACK AND ITS ALIASES.
-C INITIALIZE THE PORT LIBRARY STACK LENGTH.
- CALL ISTKIN(5000, 4)
- NU = 1
- ERRPAR(1) = 0
-C ABSOLUTE ERROR.
- ERRPAR(2) = 1E-2
- TSTOP = 1
- DT = 1E-2
- K = 4
-C NDX UNIFORM MESH POINTS ON (0,1).
- NDX = 7
- CALL UMB(0E0, 1E0, NDX, K, MESH, NMESH)
- NV = NMESH-K
-C UOFX NEEDS T.
- T = 0
-C ICS FOR U.
- CALL L2SFF(UOFX, K, MESH, NMESH, U)
- TEMP = NMESH-K
- DO 1 I = 1, TEMP
- V(I) = U(I)
- 1 CONTINUE
-C ICS FOR V.
- CALL POST(U, NU, K, MESH, NMESH, V, NV, 0E0, TSTOP, DT, AF, BC,
- 1 DEE, ERRPAR, HANDLE)
- CALL WRAPUP
- STOP
- END
- SUBROUTINE AF(T, X, NX, U, UX, UT, UTX, NU, V, VT, NV, A,
- 1 AU, AUX, AUT, AUTX, AV, AVT, F, FU, FUX, FUT, FUTX, FV, FVT)
- INTEGER NU, NV, NX
- REAL T, X(NX), U(NX, NU), UX(NX, NU), UT(NX, NU), UTX(NX, NU)
- REAL V(NV), VT(NV), A(NX, NU), AU(NX, NU, NU), AUX(NX, NU, NU),
- 1 AUT(NX, NU, NU)
- REAL AUTX(NX, NU, NU), AV(NX, NU, NV), AVT(NX, NU, NV), F(NX, NU),
- 1 FU(NX, NU, NU), FUX(NX, NU, NU)
- REAL FUT(NX, NU, NU), FUTX(NX, NU, NU), FV(NX, NU, NV), FVT(NX,
- 1 NU, NV)
- COMMON /KMESH/ K, NMESH
- INTEGER K, NMESH
- COMMON /CMESH/ MESH
- REAL MESH(100)
- INTEGER I
- DO 1 I = 1, NX
- A(I, 1) = 2.*UX(I, 1)
- AUX(I, 1, 1) = 2
- F(I, 1) = UT(I, 1)
- FUT(I, 1, 1) = 1
- 1 CONTINUE
-C GET THE INTEGRAL.
- CALL INTGRL(K, MESH, NMESH, V, X, NX, F, FV)
- RETURN
- END
- SUBROUTINE BC(T, L, R, U, UX, UT, UTX, NU, V, VT, NV, B, BU,
- 1 BUX, BUT, BUTX, BV, BVT)
- INTEGER NU, NV
- REAL T, L, R, U(NU, 2), UX(NU, 2), UT(NU, 2)
- REAL UTX(NU, 2), V(NV), VT(NV), B(NU, 2), BU(NU, NU, 2), BUX(NU,
- 1 NU, 2)
- REAL BUT(NU, NU, 2), BUTX(NU, NU, 2), BV(NU, NV, 2), BVT(NU, NV, 2
- 1 )
- REAL EXP
- B(1, 1) = U(1, 1)-EXP(T)
- B(1, 2) = U(1, 2)-EXP(T+1.)
- BU(1, 1, 1) = 1
- BU(1, 1, 2) = 1
- RETURN
- END
- SUBROUTINE DEE(T, K, X, NX, U, UT, NU, NXMK, V, VT, NV, D,
- 1 DU, DUT, DV, DVT)
- INTEGER NXMK, NU, NV, NX
- INTEGER K
- REAL T, X(NX), U(NXMK, NU), UT(NXMK, NU), V(NV), VT(NV)
- REAL D(NV), DU(NV, NXMK, NU), DUT(NV, NXMK, NU), DV(NV, NV), DVT(
- 1 NV, NV)
- INTEGER I
- DO 1 I = 1, NXMK
- D(I) = U(I, 1)-V(I)
- DU(I, I, 1) = 1
- DV(I, I) = -1
- 1 CONTINUE
- RETURN
- END
- SUBROUTINE HANDLE(T0, U0, V0, T, U, V, NU, NXMK, NV, K, X,
- 1 NX, DT, TSTOP)
- INTEGER NXMK, NU, NV, NX
- INTEGER K
- REAL T0, U0(NXMK, NU), V0(NV), T, U(NXMK, NU), V(NV)
- REAL X(NX), DT, TSTOP
- COMMON /TIME/ TT
- REAL TT
- EXTERNAL UOFX
- INTEGER I1MACH
- REAL EU, EESFF
- INTEGER TEMP
-C OUTPUT AND CHECKING ROUTINE.
- IF (T0 .NE. T) GOTO 2
- TEMP = I1MACH(2)
- WRITE (TEMP, 1) T0, DT
- 1 FORMAT (16H RESTART FOR T =, 1PE10.2, 7H DT =, 1PE10.2)
- RETURN
- 2 TT = T
- EU = EESFF(K, X, NX, U, UOFX)
- TEMP = I1MACH(2)
- WRITE (TEMP, 3) T, EU
- 3 FORMAT (14H ERROR IN U(X,, 1PE10.2, 4H ) =, 1PE10.2)
- RETURN
- END
- SUBROUTINE UOFX(X, NX, U, W)
- INTEGER NX
- REAL X(NX), U(NX), W(NX)
- COMMON /TIME/ T
- REAL T
- INTEGER I
- REAL EXP
- DO 1 I = 1, NX
- U(I) = EXP(T+X(I))
- 1 CONTINUE
- RETURN
- END
- SUBROUTINE INTGRL(K, MESH, NMESH, V, X, NX, F, FV)
- INTEGER NX, NMESH
- INTEGER K
- REAL MESH(NMESH), V(1), X(NX), F(NX), FV(NX, 1)
- INTEGER MGQ, I, J, L, IX
- REAL EWE, KER, WGQ(3), XGQ(3), B(3, 4, 200), KERU
- REAL XX(3)
- LOGICAL FIRST
- INTEGER TEMP, TEMP1
- DATA FIRST/.TRUE./
-C TO COMPUTE
-C F = INTEGRAL FROM MESH(1) TO MESH(NMESH)
-C KERNEL(X,Y,SUM(I=1,...,NMESH-K) V(I)*B(I,Y)) DY
-C AND
-C FV = D(F)/D(V).
-C ASSUME THAT CALL KERNEL(X,Y,U,KER,KERU) RETURNS
-C KER = KERNEL(X,Y,U) AND
-C KERU = PARTIAL KERNEL / PARTIAL U.
-C V(NMESH-K),FV(NX,NMESH-K)
-C THE FOLLOWING DECLARATION IS SPECIFIC TO K = 4 SPLINES.
- IF (NMESH-K .GT. 200) CALL SETERR(27HINTGRL - NMESH-K .GT. NXMAX
- 1 , 27, 1, 2)
-C NEED MORE LOCAL SPACE.
- IF (K .NE. 4) CALL SETERR(17HINTGRL - K .NE. 4, 17, 2, 2)
-C USE K-1 POINT GAUSSIAN-QUADRATURE RULE ON EACH INTERVAL.
- MGQ = K-1
- IF (FIRST) CALL GQM11(MGQ, XGQ, WGQ)
-C ONLY GET GQ RULE ONCE, ITS EXPENSIVE.
-C THE GAUSSIAN QUADRATURE RULE.
-C DO INTEGRAL INTERVAL BY INTERVAL.
- TEMP = NMESH-K
- DO 6 I = K, TEMP
-C G.Q. POINTS ON (MESH(I), MESH(I+1)).
- DO 1 J = 1, MGQ
- XX(J) = 0.5*(MESH(I+1)+MESH(I))+0.5*(MESH(I+1)-MESH(I))*XGQ(
- 1 J)
- 1 CONTINUE
- IF (FIRST) CALL BSPLN(K, MESH, NMESH, XX, MGQ, I, B(1, 1, I))
-C ONLY GET B-SPLINE BASIS ONCE, ITS EXPENSIVE.
- DO 5 J = 1, MGQ
-C GET SUM() V()*B()(XX).
- EWE = 0
- DO 2 L = 1, K
- TEMP1 = I+L-K
- EWE = EWE+V(TEMP1)*B(J, L, I)
- 2 CONTINUE
- DO 4 IX = 1, NX
-C GET KERNEL AND PARTIAL.
- CALL KERNEL(X(IX), XX(J), EWE, KER, KERU)
- F(IX) = F(IX)+0.5*KER*(MESH(I+1)-MESH(I))*WGQ(J)
- DO 3 L = 1, K
- TEMP1 = I+L-K
- FV(IX, TEMP1) = FV(IX, TEMP1)+0.5*B(J, L, I)*KERU*(
- 1 MESH(I+1)-MESH(I))*WGQ(J)
- 3 CONTINUE
- 4 CONTINUE
- 5 CONTINUE
- 6 CONTINUE
- FIRST = .FALSE.
- RETURN
- END
- SUBROUTINE KERNEL(X, Y, U, KER, KERU)
- REAL X, Y, U, KER, KERU
- REAL EXP
-C TO EVALUATE THE KERNEL EXP(X-Y)*U(Y) AND ITS PARTIAL WRT. U.
- KERU = EXP(X-Y)
- KER = KERU*U
- RETURN
- END
diff --git a/CEP/PyBDSM/src/port3/ex/postx9.f b/CEP/PyBDSM/src/port3/ex/postx9.f
deleted file mode 100644
index c5ef792fc9762078b4d5d6c69ee7cb6d97542104..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ex/postx9.f
+++ /dev/null
@@ -1,157 +0,0 @@
-C$TEST PST9
-C TO RUN AS A MAIN PROGRAM REMOVE NEXT LINE
- SUBROUTINE PST9
-C***********************************************************************
-C
-C EXAMPLE OF USE OF PORT PROGRAM POST
-C
-C***********************************************************************
- COMMON /CSTAK/ DS
- DOUBLE PRECISION DS(2000)
- COMMON /PARAM/ C
- REAL C
- EXTERNAL HANDLE, BC, AF, POSTD
- INTEGER NDX, NXC, NXX, I, K, IS(1000)
- INTEGER NU, NV, NX, I1MACH
- REAL EWE(1000), ERR, ERRPAR(2), U(100), V(1), X(100)
- REAL ERRR, DT, XC(100), UC(100), EEBSF, RS(1000)
- REAL WS(1000), XX(1000), TSTOP, R1MACH
- LOGICAL LS(1000)
- COMPLEX CS(500)
- INTEGER TEMP
- EQUIVALENCE (DS(1), CS(1), WS(1), RS(1), IS(1), LS(1))
-C TO TEST POST ON AUTOMATIC, STATIC MESH REFINEMENT.
-C U SUB T = U SUB XX + C * U SUB X ON (0,1)
-C THE SOLUTION IS
-C U(X,T) = EXP(-C*X).
-C THE PORT LIBRARY STACK AND ITS ALIASES.
-C INITIALIZE THE PORT LIBRARY STACK LENGTH.
- CALL ISTKIN(2000, 4)
- C = 50
- NU = 1
- NV = 0
- ERRPAR(1) = 1E-1
- ERRPAR(2) = 1E-1
- K = 4
- NDX = 8
- CALL UMB(0E0, 1E0, NDX, K, XC, NXC)
-C INITIAL CONDITIONS FOR UC.
- CALL SETR(NXC-K, 0E0, UC)
-C INFINITY.
- ERR = R1MACH(2)
- 1 IF (ERR .LE. 1E-2) GOTO 6
-C HALVE THE CRUDE X.
- CALL LUMB(XC, NXC, 3, K, X, NX)
-C FITTING POINTS FOR REFINEMENT.
- CALL LUMD(X, NX, K, XX, NXX)
-C UC ON XX.
- CALL SPLNE(K, XC, NXC, UC, XX, NXX, EWE)
-C FIT U TO UC ON MESH.
- CALL DL2SF(XX, EWE, NXX, K, X, NX, U)
- TSTOP = 1./R1MACH(4)
- DT = 1E-6
- I = NX-2*(K-1)
- TEMP = I1MACH(2)
- WRITE (TEMP, 2) I
- 2 FORMAT (18H SOLVING FOR NDX =, I3)
- CALL POST(U, NU, K, X, NX, V, NV, 0E0, TSTOP, DT, AF, BC,
- 1 POSTD, ERRPAR, HANDLE)
-C GET RUN-TIME STATISTICS.
- CALL POSTX
-C ERROR ESTIMATE FOR UC.
- ERR = EEBSF(K, XC, NXC, UC, X, NX, U)
-C ERROR ESTIMATE FOR U.
- ERRR = ERR/16.
- TEMP = I1MACH(2)
- WRITE (TEMP, 3) ERR, ERRR
- 3 FORMAT (21H ERROR ESTIMATES UC =, 1PE10.2, 9H AND U =, 1P
- 1 E10.2)
- NXC = NX
- DO 4 I = 1, NX
- XC(I) = X(I)
- 4 CONTINUE
- TEMP = NX-K
- DO 5 I = 1, TEMP
- UC(I) = U(I)
- 5 CONTINUE
- GOTO 1
- 6 STOP
- END
- SUBROUTINE AF(T, X, NX, U, UX, UT, UTX, NU, V, VT, NV, A,
- 1 AU, AUX, AUT, AUTX, AV, AVT, F, FU, FUX, FUT, FUTX, FV, FVT)
- INTEGER NU, NX
- INTEGER NV
- REAL T, X(NX), U(NX, NU), UX(NX, NU), UT(NX, NU), UTX(NX, NU)
- REAL V(1), VT(1), A(NX, NU), AU(NX, NU, NU), AUX(NX, NU, NU), AUT(
- 1 NX, NU, NU)
- REAL AUTX(NX, NU, NU), AV(1), AVT(1), F(NX, NU), FU(NX, NU, NU),
- 1 FUX(NX, NU, NU)
- REAL FUT(NX, NU, NU), FUTX(NX, NU, NU), FV(1), FVT(1)
- COMMON /PARAM/ C
- REAL C
- INTEGER I
- DO 1 I = 1, NX
- A(I, 1) = UX(I, 1)+C*U(I, 1)
- AUX(I, 1, 1) = 1
- AU(I, 1, 1) = C
- F(I, 1) = UT(I, 1)
- FUT(I, 1, 1) = 1
- 1 CONTINUE
- RETURN
- END
- SUBROUTINE BC(T, L, R, U, UX, UT, UTX, NU, V, VT, NV, B, BU,
- 1 BUX, BUT, BUTX, BV, BVT)
- INTEGER NU
- INTEGER NV
- REAL T, L, R, U(NU, 2), UX(NU, 2), UT(NU, 2)
- REAL UTX(NU, 2), V(1), VT(1), B(NU, 2), BU(NU, NU, 2), BUX(NU, NU,
- 1 2)
- REAL BUT(NU, NU, 2), BUTX(NU, NU, 2), BV(1), BVT(1)
- COMMON /PARAM/ C
- REAL C
- REAL EXP
- B(1, 1) = U(1, 1)-1.
- B(1, 2) = U(1, 2)-EXP(-C)
- BU(1, 1, 1) = 1
- BU(1, 1, 2) = 1
- RETURN
- END
- SUBROUTINE HANDLE(T0, U0, V0, T, U, V, NU, NXMK, NV, K, X,
- 1 NX, DT, TSTOP)
- INTEGER NXMK, NU, NX
- INTEGER NV, K
- REAL T0, U0(NXMK, NU), V0(1), T, U(NXMK, NU), V(1)
- REAL X(NX), DT, TSTOP
- COMMON /TIME/ TT
- REAL TT
- EXTERNAL UOFX
- INTEGER I1MACH
- REAL EU, EESFF
- INTEGER TEMP
-C OUTPUT AND CHECKING ROUTINE.
- IF (T0 .NE. T) GOTO 2
- TEMP = I1MACH(2)
- WRITE (TEMP, 1) T
- 1 FORMAT (16H RESTART FOR T =, 1PE10.2)
- RETURN
- 2 TT = T
- EU = EESFF(K, X, NX, U, UOFX)
- TEMP = I1MACH(2)
- WRITE (TEMP, 3) T, EU
- 3 FORMAT (15H ERROR IN U(X, , 1PE10.2, 4H ) =, 1PE10.2)
- RETURN
- END
- SUBROUTINE UOFX(X, NX, U, W)
- INTEGER NX
- REAL X(NX), U(NX), W(NX)
- COMMON /PARAM/ C
- REAL C
- COMMON /TIME/ T
- REAL T
- INTEGER I
- REAL EXP
- DO 1 I = 1, NX
- U(I) = EXP((-C)*X(I))
- 1 CONTINUE
- RETURN
- END
diff --git a/CEP/PyBDSM/src/port3/ex/prea.f b/CEP/PyBDSM/src/port3/ex/prea.f
deleted file mode 100644
index b0fb182a65828c09733ca8b37e50c40d39993ec7..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ex/prea.f
+++ /dev/null
@@ -1,96 +0,0 @@
-C$TEST PREA
-C TO RUN AS A MAIN PROGRAM REMOVE NEXT LINE
- SUBROUTINE PREA
-C***********************************************************************
-C
-C EXAMPLE OF USE OF THE PORT PROGRAM SPFOR
-C
-C***********************************************************************
- INTEGER N1, N2, N, MCP(500), MRP(500), MAXIW, IW, I
- INTEGER I1MACH, IREAD, IWRITE, ISTAK(19000)
- EXTERNAL QUEI
- COMMON /QUE/ A1, A2, N1, N2, N
- COMMON /CSTAK/ ISTAK
- IREAD = I1MACH(1)
- IWRITE = I1MACH(2)
- CALL ISTKIN(19000, 2)
- 10 READ(IREAD,11)N1, N2
- 11 FORMAT(2I3)
- IF (N1. EQ. 0) STOP
- WRITE(IWRITE,12)N1, N2
- 12 FORMAT(4H N1=,I3,4H N2=,I3)
- N = (N1+1)*(N2+1)
-C
-C DETERMINE THE ORDERING
-C
- CALL SPFOR(N, QUEI, MCP)
-C
-C GET THE WORK SPACE FROM THE STORAGE STACK
-C
- MAXIW = ISTKQU(2)-3*N-50
- IW = ISTKGT(MAXIW, 2)
-C
-C DETERMINE THE SYMBOLIC FACTORIZATION
-C
- DO 20 I=1,N
- MRP(I) = MCP(I)
- 20 CONTINUE
- CALL SPFSF(N, MRP, MCP, QUEI, ISTAK(IW), MAXIW, ISIZE)
- WRITE(IWRITE,21)ISIZE
- 21 FORMAT(34H SPACE NEEDED FOR DECOMPOSITION - ,I8)
-C
-C REDO THE FACTORIZATION WITHOUT PIVOTING
-C
- DO 30 I = 1,N
- MCP(I) = I
- MRP(I) = I
- 30 CONTINUE
- CALL SPFSF(N, MRP, MCP, QUEI, ISTAK(IW), MAXIW, ISIZE)
- WRITE(IWRITE, 31) ISIZE
- 31 FORMAT(34H SPACE NEEDED WITHOUT ORDERING - ,I8)
- CALL ISTKRL(1)
- GO TO 10
- END
- SUBROUTINE QUEI(I, JCOL, NUM)
- INTEGER I, NUM, JCOL(100), N, N1, N2, II, JJ, J
- COMMON /QUE/ A1, A2, N1, N2, N
- IF (I.NE.N) GO TO 20
-C PROCESS LAST ROW
- DO 10 J=1, N
- JCOL(J) = J
- 10 CONTINUE
- NUM = N
- RETURN
- 20 N2P1=N2+1
-C DETERMINE WHICH BLOCK
- II=(I-1)/N2P1
-C DETERMINE THE POSITION IN THE BLOCK
- JJ = MOD(I-1, N2P1)
- JCOL(1) = I
-C INSERT THE DIAGONAL ELEMENT
- NUM = 1
- IF (II .EQ. 0) GO TO 30
-C THIS IS NOT THE FIRST ROW OF THE CURRENT BLOCK
- JCOL(2) = I-N2P1
- NUM = 2
- 30 IF (JJ.EQ.0) GO TO 40
-C THIS IS NOT THE FIRST ROW OF THE CURRENT BLOCK
- NUM = NUM+1
- JCOL(NUM) = I-1
- 40 IF (JJ.EQ. N2) GO TO 50
-C THIS IS NOT THE LAST ROW OF THE CURRENT BLOCK
- NUM=NUM+1
- JCOL(NUM)= I+1
- 50 IF (II .EQ. N1) RETURN
- NUM = NUM +1
- JCOL(NUM) = I+N2P1
- RETURN
- END
-C
-C DATA FOR THE EXAMPLE IN THE PORT SHEET... (REMOVE THE C
-C IN COLUMN 1 BEFORE FEEDING THIS DATA TO THE PROGRAM ABOVE.)
-C$DATA
-C10 10
-C15 15
-C19 19
-C 0 0
diff --git a/CEP/PyBDSM/src/port3/ex/prma.f b/CEP/PyBDSM/src/port3/ex/prma.f
deleted file mode 100644
index 7f5cd621ffded0713502e95382a765632e5986a0..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ex/prma.f
+++ /dev/null
@@ -1,47 +0,0 @@
-C$TEST PRMA
-C TO RUN AS A MAIN PROGRAM REMOVE NEXT LINE
- SUBROUTINE PRMA
-C***********************************************************************
-C
-C EXAMPLE OF USE OF THE PORT PROGRAM SPMSF
-C
-C***********************************************************************
- INTEGER MRP(32), MCP(32), INMCP(32)
- INTEGER IROW(33), JA(200), IWORK(500)
- IREAD = I1MACH(1)
- IWRITE = I1MACH(2)
- N = 32
- MAXIW = 500
-C
-C READ IN THE VECTORS DEFINING THE NONZERO BLOCKS
-C
- READ(IREAD,11)(IROW(I),I=1,33)
- 11 FORMAT(20I3)
- IEND=IROW(33) - 1
- READ(IREAD,11)(JA(I),I=1,IEND)
- WRITE(IWRITE,12)IEND
- 12 FORMAT(29H NUMBER OF NONZEROS IN MATRIX,I5)
-C
-C SET UP THE PERMUTATION VECTORS TO REFLECT NO REORDERING
-C
- DO 20 I=1, N
- MRP(I) = I
- MCP(I) = I
- INMCP(I) = I
- 20 CONTINUE
-C
-C DETERMINE THE SYMBOLIC FACTORIZATION
-C
- CALL SPMSF(N, MRP, INMCP, IROW, JA, IWORK, MAXIW, ISIZE)
- WRITE(IWRITE,21)ISIZE
- 21 FORMAT(35H BLOCKS NEEDED WITHOUT PERMUTATIONS,I5)
-C
-C FIND AN ORDERING WHICH WOULD DECREASE FILL-IN AND RECOMPUTE THE
-C SYMBOLIC FACTORIZATION
-C
- CALL SPMOR(N, IROW, JA, MCP, INMCP)
- CALL SPMSF(N, MCP, INMCP, IROW, JA, IWORK, MAXIW, ISIZE)
- WRITE(IWRITE,22)ISIZE
- 22 FORMAT(32H BLOCKS NEEDED WITH PERMUTATIONS,I5)
- STOP
- END
diff --git a/CEP/PyBDSM/src/port3/ex/prs1.f b/CEP/PyBDSM/src/port3/ex/prs1.f
deleted file mode 100644
index cede07ec5c142a30420829383308895197f21cb5..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ex/prs1.f
+++ /dev/null
@@ -1,71 +0,0 @@
-C$TEST PRS1
-C TO RUN AS A MAIN PROGRAM REMOVE NEXT LINE
- SUBROUTINE PRS1
-C***********************************************************************
-C
-C EXAMPLE OF USE OF THE PORT PROGRAM SPMML
-C
-C***********************************************************************
- INTEGER I, IWRITE, I1MACH, NEQ, J, NX, L
- INTEGER IROW(101), JCOL(500)
- REAL A(500)
- REAL X(100), B(100), ERR, SASUM
- REAL RSTACK(1800)
- COMMON/CSTAK/ RSTACK
- CALL ISTKIN(1800,3)
- NX = 10
-C
-C CONSTRUCT THE MATRIX
-C
- L=1
- NEQ=1
- DO 20 I=1, NX
- DO 10 J= 1,NX
- IROW(NEQ)=L
- JCOL(L)=NEQ
- A(L)=-4.0
- L=L+1
- JCOL(L)=NEQ-1
- A(L)=1.0
- IF (J.GT.1)L=L+1
- JCOL(L)=NEQ+1
- A(L)=1.0
- IF (J.LT.NX)L=L+1
- JCOL(L)=NEQ-NX
- A(L)=1.0
- IF (I.GT.1)L=L+1
- JCOL(L)=NEQ+NX
- A(L)=1.0
- IF(I.LT.NX)L=L+1
- NEQ=NEQ+1
- 10 CONTINUE
- 20 CONTINUE
- IROW(NEQ)=L
- NEQ=NEQ-1
-C
-C CONSTRUCT A RANDOM VECTOR FOR X
-C
- DO 30 I=1,NEQ
- X(I)=UNI(0)
- 30 CONTINUE
-C
-C FIND THE VECTOR B=AX
-C
- CALL SPMML(NEQ,IROW,JCOL,A,X,B)
-C
-C SOLVE THE SYSTEM AX=B
-C
- CALL SPMLE(NEQ,.TRUE.,IROW,JCOL,A,ISIZE,B,NEQ,1)
-C
-C FIND THE NORM OF THE ERROR OF THE SOLUTION
-C
- ERR=0.0
- IWRITE = I1MACH(2)
- DO 40 I=1,NEQ
- ERR=ERR + ABS(B(I)-X(I))
- 40 CONTINUE
- ERR=ERR/SASUM(NEQ,X,1)
- WRITE(IWRITE,41)ERR
- 41 FORMAT(19H RELATIVE ERROR IS ,1PE15.7)
- STOP
- END
diff --git a/CEP/PyBDSM/src/port3/ex/prs3.f b/CEP/PyBDSM/src/port3/ex/prs3.f
deleted file mode 100644
index 783ab5920f79403ff93a114f1aac412a93b795b0..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ex/prs3.f
+++ /dev/null
@@ -1,96 +0,0 @@
-C$TEST PRS3
-C TO RUN AS A MAIN PROGRAM REMOVE NEXT LINE
- SUBROUTINE PRS3
-C***********************************************************************
-C
-C EXAMPLE OF USE OF THE PORT PROGRAM SPMNF
-C
-C***********************************************************************
- INTEGER IROW(301), JCOL(2500), ISTAK(23000), I1MACH, IWRITE
- INTEGER MRP(300), MCP(300), ITEMP, INMCP(300), N
- INTEGER ILAPSZ, IT, IT2, IT3, IT4, IT5, IT6, I, NUMBER
- INTEGER NUM, IPOINT, NP1
- REAL RSTAK(23000), A(2500), GROWTH
- DOUBLE PRECISION DSTAK(11500)
- COMMON /CSTAK/DSTAK
- EQUIVALENCE(ISTAK(1), RSTAK(1), DSTAK(1))
- IWRITE = I1MACH(2)
- CALL ISTKIN(23000,2)
- DO 40 N=100,300,100
- CALL SETUP(N, IROW, JCOL, A)
- NUMBER = IROW(N+1)-1
- WRITE(IWRITE,11)N,NUMBER
- 11 FORMAT(/5H N = ,I4,22H NUMBER OF NONZEROS = ,I7)
-C
-C ORDER THE ROWS AND COLUMNS OF THE MATRIX
-C TO DECREASE FILL-IN
-C
- CALL SPMOR(N, IROW, JCOL, MRP, INMCP)
-C
-C ALLOCATE THE AVAILABLE SPACE FOR THE WORK VECTOR IN SPMSF
-C BUT MAKE SURE THERE IS ENOUGH FOR SPMSF'S ALLOCATIONS
-C
- MAXIW = ISTKQU(2)-3*N-5
- IW = ISTKGT(MAXIW,2)
-C
-C TIME THE SYMBOLIC FACTORIZATION
-C
- IT = ILAPSZ(0)
- CALL SPMSF(N, MRP, INMCP, IROW, JCOL, ISTAK(IW), MAXIW, ISIZE)
- IT2=ILAPSZ(0)-IT
- WRITE(IWRITE, 12)ISIZE
- 12 FORMAT(37H NUMBER OF NONZEROS IN DECOMPOSITION=,I5)
- WRITE(IWRITE,13)IT2
- 13 FORMAT(23H ELAPSED TIME FOR SPMSF,I7)
-C
-C MODIFY THE WORK STACK TO REFLECT THE AMOUNT NEEDED BY SPMSF
-C AND ALLOCATE SPACE FOR THE NUMERICAL FACTORIZATION
-C
- ISPAC= 2*N+2+ISIZE
- IW = ISTKMD(ISPAC,2)
- IUL = ISTKGT(ISIZE, 3)
-C
-C COMPUTE THE TIME NEEDED TO INSERT THE NUMERICAL ELEMENTS
-C IN THEIR PROPER PLACES
-C
- IT3 = ILAPSZ(0)
- DO 20 I=1, N
- MCP(I) = MRP(I)
- IR = MRP(I)
- NUM = IROW(IR+1)-IROW(IR)
- IPOINT = IROW(IR)
- CALL SPMIN(N, INMCP, ISTAK(IW), I, A(IPOINT),
- 1 JCOL(IPOINT), NUM, I, RSTAK(IUL))
- 20 CONTINUE
- IT4 = ILAPSZ(0)-IT3
- WRITE(IWRITE,21)IT4
- 21 FORMAT(23H ELAPSED TIME FOR SPMIN,I7)
-C
-C TIME THE SUBROUTINE WHICH COMPUTES THE NUMERICAL
-C FACTORIZATION
-C
- IT5 =ILAPSZ(0)
- CALL SPMNF(N, ISTAK(IW), RSTAK(IUL), 0.0, GROWTH)
- IT6 =ILAPSZ(0)-IT5
- WRITE(IWRITE, 22)IT6
- 22 FORMAT(23H ELAPSED TIME FOR SPMNF,I7)
- IT6 = IT2 + IT4 +IT6
- WRITE(6,23)IT6
- 23 FORMAT(26H ELAPSED TIME FOR SF-IN-NF,I7)
-C
-C REDO THE FACTORIZATION WITH THE SUBROUTINE THAT PERMITS
-C PIVOTING FOR STABILITY AND TIME IT
-C
- CALL MOVEFR(NUMBER,A,RSTAK(IUL))
- CALL MOVEFI(NUMBER,JCOL,ISTAK(IW))
- IL = ISTKGT(N+1,2)
- IT5 =ILAPSZ(0)
- CALL SPMLU(N, MRP, MCP, IROW, ISTAK(IW), RSTAK(IUL), ISPAC,
- 1 ISTAK(IL), 0.0, 0.0, ISIZE, GROWTH)
- IT6 = ILAPSZ(0)-IT5
- WRITE(IWRITE, 31)IT6
- 31 FORMAT(23H ELAPSED TIME FOR SPMLU, I7)
- CALL ISTKRL(3)
- 40 CONTINUE
- STOP
- END
diff --git a/CEP/PyBDSM/src/port3/ex/prsa.f b/CEP/PyBDSM/src/port3/ex/prsa.f
deleted file mode 100644
index 8fae3073dd34d666663a2d0095496555400b4c4e..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ex/prsa.f
+++ /dev/null
@@ -1,78 +0,0 @@
-C$TEST PRSA
-C TO RUN AS A MAIN PROGRAM REMOVE NEXT LINE
- SUBROUTINE PRSA
-C***********************************************************************
-C
-C EXAMPLE OF USE OF THE PORT PROGRAM SPMLE
-C
-C***********************************************************************
- INTEGER JCOL(5000),ISTAK(18000),IROW(626), IREAD, IWRITE, M
- INTEGER I1MACH, I, J, K, L, ISIZE, MP1
- REAL AROW(5000), B(625), SASUM, A1
- COMMON /CSTAK/ ISTAK
- CALL ISTKIN(18000,2)
- IREAD=I1MACH(1)
- IWRITE=I1MACH(2)
- 10 READ(IREAD,11)M,A1
- 11 FORMAT(I3,E15.5)
- IF (M .EQ. 0) STOP
- MP1=M+1
- N= MP1*MP1
-C
-C SET UP MATRIX OF SIZE N
-C
- IROW(1) = 1
- K=1
- L=0
- DO 70 I=1,MP1
- DO 60 J = 1, MP1
- L=L+1
- AROW(K) = -2.0*A1 - FLOAT(I+J-2)
- JCOL(K) = L
- K=K+1
- IF (J .EQ. 1) GO TO 20
- AROW(K) = A1
- JCOL(K) = L - 1
- K=K+1
- 20 IF (J .EQ. MP1) GO TO 30
- AROW(K) = J
- JCOL(K) = L+1
- K=K+1
- 30 IF (I.EQ.1) GO TO 40
- AROW(K) = A1
- JCOL(K) = L - MP1
- K=K+1
- 40 IF (I.EQ.MP1) GO TO 50
- AROW(K) = I
- JCOL(K) = L+MP1
- K=K+1
- 50 IROW(L+1)=K
- 60 CONTINUE
- 70 CONTINUE
-C
-C SET UP RIGHT HAND SIDE AND LAST ROW OF THE MATRIX
-C
- L=IROW(N)
- DO 80 I=1,N
- AROW(L)=1.0
- JCOL(L)=I
- L=L+1
- B(I)=0.0
- 80 CONTINUE
- IROW(N+1)=L
- B(N)=1.0
-C
-C SOLVE THE SYSTEM
-C
- CALL SPMLE(N,.TRUE.,IROW,JCOL,AROW,ISIZE,B,625,1)
-C
-C PRINT RESULTS
-C
- WRITE(IWRITE,81)N,L
- 81 FORMAT(/19HNO. OF EQUATIONS = ,I3,19HNO. OF NONZEROES = ,I5)
- WRITE(IWRITE,82)ISIZE
- 82 FORMAT(9H ISIZE = , I5)
- WRITE(IWRITE,83)B(N),SASUM(M,B(M),M)
- 83 FORMAT(6H L1 = ,E15.5,6H L2 = ,E15.5)
- GO TO 10
- END
diff --git a/CEP/PyBDSM/src/port3/ex/prsf.f b/CEP/PyBDSM/src/port3/ex/prsf.f
deleted file mode 100644
index 5c874b61ffb5965e0d83ae0fcfa84582ad67d595..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ex/prsf.f
+++ /dev/null
@@ -1,121 +0,0 @@
-C$TEST PRSF
-C TO RUN AS A MAIN PROGRAM REMOVE NEXT LINE
- SUBROUTINE PRSF
-C***********************************************************************
-C
-C EXAMPLE OF USE OF THE PORT PROGRAM SPFLE
-C
-C***********************************************************************
- INTEGER N1, N2, N, I, ITIME, ITIME1, ITIME2, ILAPSZ
- INTEGER I1MACH, IREAD, IWRITE, ISTAK(25000), ISIZE, ISIZE2
- REAL RSTAK(25000), B(500), A1, A2
- EXTERNAL QUEA
- COMMON /QUE/ A1, A2, N1, N2, N
- COMMON /CSTAK/ ISTAK
- EQUIVALENCE (ISTAK(1),RSTAK(1))
- IREAD = I1MACH(1)
- IWRITE = I1MACH(2)
- CALL ISTKIN(25000,2)
- 10 READ(IREAD, 11)N1, N2, A1, A2
- 11 FORMAT(2I3,2E15.5)
- IF (N1 .EQ. 0) STOP
- WRITE(IWRITE,12)N1, N2, A1, A2
- 12 FORMAT(/4H N1=,I3,4H N2=,I3,4H A1=,E15.5,4H A2=,E15.5)
- N = (N1+1)*(N2+1)
-C
-C GENERATE THE RIGHT HAND SIDE
-C
- DO 20 I=1, N
- B(I) = 0.0
- 20 CONTINUE
- B(N) = 1.0
-C
-C SOLVE THE SYSTEM WITH PIVOTING FOR SPARSITY AND TIME IT
-C
- ITIME=ILAPSZ(0)
- CALL SPFLE(N, .TRUE., QUEA, ISIZE, B, 500, 1)
- ITIME1=ILAPSZ(0)-ITIME
-C
-C FIND THE PROBABILITIES
-C
- IT = (N2+1)*N1+1
- WRITE(IWRITE,21)B(N),SASUM(N1+1,B(N2+1),N2+1),SASUM(N2,B(IT),1)
- 21 FORMAT(6H L1 = ,E15.5,6H L2 = ,E15.5,7H I12 = ,E15.5)
- WRITE(IWRITE,22)
- 22 FORMAT(22H PIVOTING FOR SPARSITY)
- WRITE(IWRITE,23)ISIZE
- 23 FORMAT(34H SPACE NEEDED FOR DECOMPOSITION - ,I8)
- WRITE(IWRITE,24)ITIME1
- 24 FORMAT(15H TIME NEEDED - ,I8)
-C
-C FOR COMPARISON, REDO PROBLEM WITHOUT REQUESTING PIVOTING
-C
- DO 30 I= 1,N
- B(I)=0.0
- 30 CONTINUE
- B(N)=1.0
- ITIM=ILAPSZ(0)
- CALL SPFLE(N,.FALSE.,QUEA, ISIZE2, B, 500, 1)
- ITIME2=ILAPSZ(0)-ITIME
- WRITE(IWRITE, 31)
- 31 FORMAT(25H NO PIVOTING FOR SPARSITY)
- WRITE(IWRITE,23)ISIZE2
- WRITE(IWRITE, 24)ITIME2
- GO TO 10
- END
- SUBROUTINE QUEA(I, ROW, JCOL, NUM)
- INTEGER I, NUM, JCOL(100), N, N1, N2, II, JJ, J
- REAL ROW(100)
- COMMON /QUE/ A1,A2, N1,N2, N
- IF (I.NE.N) GO TO 20
-C TREAT LAST ROW AS SPECIAL CASE
- DO 10 J=1, N
- JCOL(J) = J
- ROW(J) = 1.0
- 10 CONTINUE
- NUM = N
- RETURN
- 20 N2P1=N2+1
-C DETERMINE WHICH MAJOR BLOCK
- II=(I-1)/N2P1
-C DETERMINE POSITION IN BLOCK
- JJ = MOD(I-1, N2P1)
-C FILL IN DIAGONAL
- JCOL(1) = I
- ROW(1) = -A1-A2-FLOAT(II+JJ)
- IF (JJ.EQ.N2) ROW(1)=ROW(1)+A2
- NUM = 1
- IF (II .EQ. 0) GO TO 30
-C THIS IS NOT THE FIRST BLOCK
- JCOL(2) = I-N2P1
- ROW(2) = A1
- NUM = 2
- 30 IF (JJ.EQ.0) GO TO 40
-C THIS IS NOT FIRST ROW IN THE BLOCK
- NUM = NUM+1
- JCOL(NUM) = I-1
- ROW(NUM) = A2
- 40 IF (JJ.EQ. N2) GO TO 50
-C THIS IS NOT LAST ROW IN THE BLOCK
- NUM=NUM+1
- JCOL(NUM)= I+1
- ROW(NUM) = JJ+1
- 50 IF (II .EQ. N1) RETURN
-C THIS IS NOT THE LAST BLOCK
- NUM = NUM +1
- JCOL(NUM) = I+N2P1
- ROW(NUM)= II+1
- RETURN
- END
- INTEGER FUNCTION ILAPSZ(N)
- INTEGER N
- ILAPSZ = 0
- RETURN
- END
-C
-C DATA FOR THE EXAMPLE IN THE PORT SHEET... (REMOVE THE C
-C IN COLUMN 1 BEFORE FEEDING THIS DATA TO THE PROGRAM ABOVE.)
-C$DATA
-C10 10 9. 9.
-C20 20 19. 19.
-C 0 0 0. 0.
diff --git a/CEP/PyBDSM/src/port3/ex/prsj.f b/CEP/PyBDSM/src/port3/ex/prsj.f
deleted file mode 100644
index e72705350ba43e1c225d3497d574d2c641ee8be7..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ex/prsj.f
+++ /dev/null
@@ -1,81 +0,0 @@
-C$TEST PRSJ
-C TO RUN AS A MAIN PROGRAM REMOVE NEXT LINE
- SUBROUTINE PRSJ
-C***********************************************************************
-C
-C EXAMPLE OF USE OF THE PORT PROGRAM SPMCE
-C
-C***********************************************************************
- INTEGER JCOL(10000),IROW(626), IREAD, IWRITE, M
- INTEGER I1MACH, I, J, K, L, ISIZE, MP1
- INTEGER MRP(625), MCP(625), IL(625)
- REAL AROW(10000), A1, Z(625)
- COMMON /CSTAK/ D
- DOUBLE PRECISION D(3000)
- CALL ISTKIN(3000,4)
- IREAD=I1MACH(1)
- IWRITE=I1MACH(2)
- 10 READ(IREAD,11)M,A1
- 11 FORMAT(I3,E15.5)
- IF (M .EQ. 0) STOP
- MP1=M+1
- N= MP1*MP1-1
-C
-C SET UP MATRIX OF SIZE N
-C
- IROW(1) = 1
- K=1
- L=0
- DO 70 I=1,MP1
- DO 60 J = 1, MP1
- L=L+1
- AROW(K) = -2.0*A1 - FLOAT(I+J-2)
- IF (J. EQ. MP1)AROW(K)=AROW(K) + A1
- JCOL(K) = L
- K=K+1
- IF (J .EQ. 1) GO TO 20
- AROW(K) = A1
- JCOL(K) = L-1
- K=K+1
- 20 IF (J .EQ. MP1 .OR. J.EQ.M. AND .I.EQ.MP1) GO TO 30
- AROW(K) = J
- JCOL(K) = L+1
- K=K+1
- 30 IF (I.EQ.1) GO TO 40
- AROW(K) = A1
- JCOL(K) = L-MP1
- K=K+1
- 40 IF (I.EQ.MP1.OR.J.EQ.MP1. AND. I.EQ.M) GO TO 50
- AROW(K) = I
- JCOL(K) = L+MP1
- K=K+1
- 50 IROW(L+1)=K
- 60 CONTINUE
- 70 CONTINUE
-C
-C REORDER ROWS OF THE MATRIX
-C
- CALL SPMOR(N,IROW,JCOL,MRP,MCP)
-C
-C SOLVE THE SYSTEM
-C
- CALL SPMCE(N,MRP,MCP,AROW,IROW,JCOL,10000,IL,ISIZE,COND,Z)
-C
-C PRINT RESULTS
-C
- WRITE(IWRITE,71)N,IROW(N+1)
- 71 FORMAT(/19HNO. OF EQUATIONS = ,I3,20H NO. OF NONZEROES = ,I5)
- WRITE(IWRITE,72)A1,ISIZE
- 72 FORMAT(6H A1 = ,E15.5,9H ISIZE = , I5)
- WRITE(IWRITE,73)COND
- 73 FORMAT(16H CONDITION NO = ,E15.5)
- GO TO 10
- END
-C
-C DATA FOR THE EXAMPLE IN THE PORT SHEET... (REMOVE THE C
-C IN COLUMN 1 BEFORE FEEDING THIS DATA TO THE PROGRAM ABOVE.)
-C$DATA
-C10 2.0
-C20 2.0
-C22 3.0
-C 0 0.0
diff --git a/CEP/PyBDSM/src/port3/ex/prsm.f b/CEP/PyBDSM/src/port3/ex/prsm.f
deleted file mode 100644
index 163406772fa40b45548bcebb2951422486b2d45f..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ex/prsm.f
+++ /dev/null
@@ -1,53 +0,0 @@
-C$TEST PRSM
-C TO RUN AS A MAIN PROGRAM REMOVE NEXT LINE
- SUBROUTINE PRSM
-C***********************************************************************
-C
-C EXAMPLE OF USE OF THE PORT PROGRAM SPFCE
-C
-C***********************************************************************
- INTEGER N1, N2, N, MCP(500), MRP(500), MAXIW, IW, I
- INTEGER I1MACH, IREAD, IWRITE, TEMP, ISTAK(20000)
- REAL A1, RSTAK(20000)
- DOUBLE PRECISION DSTAK(10000)
- EXTERNAL QUEI, QUEA
- COMMON /QUE/ A1, K
- COMMON /CSTAK/ DSTAK
- EQUIVALENCE(RSTAK(1),DSTAK(1),ISTAK(1))
- CALL ISTKIN(10000,4)
- IREAD = I1MACH(1)
- IWRITE = I1MACH(2)
- CALL ISTKIN(20000, 2)
- READ(IREAD,11)K
- 11 FORMAT(I3)
- IF (K. EQ. 0) STOP
- N = K*K - 1
- WRITE(IWRITE,12)N
- 12 FORMAT(20H NO. OF EQUATIONS = ,I3)
-C
-C DETERMINE THE ORDERING
-C
- CALL SPFOR(N, QUEI, MRP)
-C
-C GET THE WORK SPACE FROM THE STORAGE STACK
-C
- MAXIW = (ISTKQU(2)-3*N-50)/2
- IW = ISTKGT(MAXIW, 2)
- IUL = ISTKGT(MAXIW, 3)
-C
-C READ IN PARAMETER
-C
- 20 READ(IREAD, 21)A1
- 21 FORMAT(E15.7)
- IF (A1.EQ.0.0E0) STOP
- WRITE(IWRITE, 22)A1
- 22 FORMAT(/4H A1=, E15.5)
-C
-C GET THE CONDITION NUMBER
-C
- CALL SPFCE(N, MRP, MCP, QUEA, ISTAK(IW), RSTAK(IUL), MAXIW,
- 1 ISIZE, COND)
- WRITE(IWRITE,23)COND
- 23 FORMAT(20H CONDITION NUMBER = ,E15.5)
- GO TO 20
- END
diff --git a/CEP/PyBDSM/src/port3/ex/prsp.f b/CEP/PyBDSM/src/port3/ex/prsp.f
deleted file mode 100644
index 089d4dc68db1855f0307aeb1196656fa2dbc8717..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ex/prsp.f
+++ /dev/null
@@ -1,97 +0,0 @@
-C$TEST PRSP
-C TO RUN AS A MAIN PROGRAM REMOVE NEXT LINE
- SUBROUTINE PRSP
-C***********************************************************************
-C
-C EXAMPLE OF USE OF THE PORT PROGRAM SPMLU
-C
-C***********************************************************************
- INTEGER IA(401), JA(2500), ISTAK(18500), I1MACH, IWRITE, N
- INTEGER MRP(400), MCP(400), ITEMP, INMCP(400)
- INTEGER ILAPSZ, IT, IT2, IT3, IT4, IT5, IT6, I, NUMBER
- INTEGER NUM, IPOINT, NP1
- REAL RSTAK(18500), A(2500), GROWTH
- DOUBLE PRECISION DSTAK(9250)
- COMMON /CSTAK/DSTAK
- EQUIVALENCE(ISTAK(1), RSTAK(1), DSTAK(1))
- IWRITE = I1MACH(2)
- CALL ISTKIN(18500,2)
- CALL ENTSRC(NEW,1)
- DO 40 K = 9,19,5
- N = (K+1)*(K+1)
- CALL SETUP(K, N, IA, JA, A)
- NUMBER = IA(N+1)-1
- WRITE(IWRITE,11)N,NUMBER
- 11 FORMAT(5H N = ,I4,22H NUMBER OF NONZEROS = ,I7)
-C
-C ORDER THE ROWS AND COLUMNS OF THE MATRIX
-C TO DECREASE FILL-IN
-C
- CALL SPMOR(N, IA, JA, MRP, INMCP)
-C ALLOCATE THE AVAILABLE SPACE FOR THE WORK SPACE IN SPMSF
-C BUT MAKE SURE THERE IS EMOUGH FOR SPMSF'S ALLOCATIONS
-C
- MAXIW = ISTKQU(2)-3*N-5
- IW = ISTKGT(MAXIW,2)
-C
-C TIME THE SYMBOLIC FACTORIZATION
-C
- IT = ILAPSZ(0)
- CALL SPMSF(N, MRP, INMCP, IA, JA, ISTAK(IW), MAXIW, ISIZE)
- IT2= ILAPSZ(0)-IT
- WRITE(IWRITE, 12)ISIZE
- 12 FORMAT(37H NUMBER OF NONZEROS IN DECOMPOSITION=,I5)
- WRITE(IWRITE,13)IT2
- 13 FORMAT(23H ELAPSED TIME FOR SPMSF,I7)
-C
-C MODIFY THE WORK STACK TO REFLECT THE AMOUNT NEEDED BY
-C SPMSF AND ALLOCATE SPACE FOR THE NUMERICAL FACTORIZATION
-C
- ISPAC= 2*N+2+ISIZE
- IW = ISTKMD(ISPAC,2)
- IUL = ISTKGT(ISIZE, 3)
-C
-C COMPUTE THE TIME NEEDED TO INSERT THE NUMERICAL ELEMENTS
-C IN THEIR PROPER PLACES
-C
- IT3 = ILAPSZ(0)
- DO 20 I=1, N
- MCP(I) = MRP(I)
- IR = MRP(I)
- NUM = IA(IR+1)-IA(IR)
- IPOINT = IA(IR)
- CALL SPMIN(N, INMCP, ISTAK(IW), I, A(IPOINT),
- 1 JA(IPOINT), NUM, I, RSTAK(IUL))
- 20 CONTINUE
- IT4 = ILAPSZ(0)-IT3
- WRITE(IWRITE,21)IT4
- 21 FORMAT(23H ELAPSED TIME FOR SPMIN,I7)
-C
-C TIME THE SUBROUTINE WHICH COMPUTES THE NUMERICAL
-C FACTORIZATION
-C
- IT5 =ILAPSZ(0)
- CALL SPMNF(N, ISTAK(IW), RSTAK(IUL), 0.0, GROWTH)
- IT6 =ILAPSZ(0)-IT5
- WRITE(IWRITE, 22)IT6
- 22 FORMAT(23H ELAPSED TIME FOR SPMNF,I7)
- IT6 = IT2 + IT4 +IT6
- WRITE(6,23)IT6
- 23 FORMAT(26H ELAPSED TIME FOR SF-IN-NF,I7)
- NP1 = N+1
-C
-C REDO THE FACTORIZATION WITH SPMLU AND TIME IT
-C
- CALL MOVEFR(NUMBER,A,RSTAK(IUL))
- CALL MOVEFI(NUMBER,JA,ISTAK(IW))
- IL = ISTKGT(N+1,2)
- IT5 =ILAPSZ(0)
- CALL SPMLU(N, MRP, MCP, IA, ISTAK(IW), RSTAK(IUL), ISPAC,
- 1 ISTAK(IL), 0.0, 0.0, ISIZE, GROWTH)
- IT6 = ILAPSZ(0)-IT5
- WRITE(IWRITE, 31)IT6
- 31 FORMAT(23H ELAPSED TIME FOR SPMLU, I7)
- CALL ISTKRL(3)
- 40 CONTINUE
- STOP
- END
diff --git a/CEP/PyBDSM/src/port3/ex/prst.f b/CEP/PyBDSM/src/port3/ex/prst.f
deleted file mode 100644
index fb07efda4dad5c60e4b09dc7f983501207553a4f..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ex/prst.f
+++ /dev/null
@@ -1,102 +0,0 @@
-C$TEST PRST
-C TO RUN AS A MAIN PROGRAM REMOVE NEXT LINE
- SUBROUTINE PRST
-C***********************************************************************
-C
-C EXAMPLE OF USE OF THE PORT PROGRAM SPFLU
-C
-C***********************************************************************
- INTEGER K, N, I1MACH, IWRITE, MAXUL, I, NEW, IREAD, IERR
- INTEGER MRP(101), MCP(101), IWORK(5000), ISIZE, NERROR
- DOUBLE PRECISION UL(5000), THRESH, EPS, GROWTH
- DOUBLE PRECISION B(101), ERROR, X
- EXTERNAL TOY
- COMMON /TOYS/ X, N, K
- MAXUL = 4000
- IREAD = I1MACH(1)
- IWRITE = I1MACH(2)
-C SET THE RECOVERY MODE
- CALL ENTSRC(NEW, 1)
- 10 READ(IREAD,11)K
- 11 FORMAT(I2)
- IF (K .EQ. 0) STOP
- N = K*K + 1
-C
- READ(IREAD,12)X, THRESH, EPS
- 12 FORMAT(3D10.2)
- WRITE(IWRITE,13)K, N, X, THRESH, EPS
- 13 FORMAT(3H K=,I3,3H N=,I3,3H X=,D10.2,8H THRESH=,D10.2,
- 1 5H EPS=,D10.2)
-C SET UP PERMUTATION VECTORS TO INDICATE NO PRIOR PIVOTING
- DO 20 I=1,N
- MRP(I) = I
- MCP(I) = I
- 20 CONTINUE
- CALL DSPFLU(N, MRP, MCP, TOY, IWORK, UL, MAXUL, THRESH, EPS,
- 1 ISIZE, GROWTH)
- IF (NERROR(IERR) .EQ. 0) GO TO 30
-C
-C TEST FOR SINGULARITY
-C
- CALL ERROFF
- WRITE(IWRITE,21)
- 21 FORMAT(16H SINGULAR MATRIX)
- GO TO 10
-C
- 30 WRITE(IWRITE,31) ISIZE, GROWTH
- 31 FORMAT(7H ISIZE=,I5,8H GROWTH=,1PD25.15)
- CALL GETB(N, K, B, X)
-C
-C GENERATE THE RIGHT HAND SIDE AND SOLVE THE SYSTEM
-C
- CALL DSPFSL(N, MRP, MCP, IWORK, UL, B, N, 1)
- ERROR = 0.0D0
-C
-C COMPUTE THE ERROR IN THE SOLUTION
-C
- DO 40 I = 1, N
- ERROR = DMAX1(ERROR, DABS(B(I)-1.D0))
- 40 CONTINUE
- WRITE(IWRITE,41)ERROR
- 41 FORMAT(19H ERROR IN SOLUTION=,1PD25.15)
- GO TO 10
- END
- SUBROUTINE TOY(I, ROW, JCOL, NUM)
- INTEGER I, NUM, JCOL(101)
- INTEGER N, K, J, MODK
- DOUBLE PRECISION ROW(101)
- DOUBLE PRECISION X
- COMMON /TOYS/ X, N, K
- IF (I .LT. N) GO TO 20
-C LAST ROW
- DO 10 J=1,N
- ROW(J) = 1.D0
- JCOL(J) = J
- 10 CONTINUE
- NUM = N
- RETURN
- 20 JCOL(1) = I
- JCOL(2) = N
- ROW(1) = 2.D0
- ROW(2) = 1.D0
- MODK = MOD(I, K)
- JCOL(3) = I-1
- ROW(3) = -1.D0
- JCOL(4) = I+1
- ROW(4) = -1.D0
- NUM = 4
- IF (MODK .GT. 1) GO TO 30
- ROW(1) = 1.D0 + X
- IF (MODK .EQ. 1) JCOL(3) = I+1
- NUM = 3
- 30 IF (I .LE. K) RETURN
- IF ((I-1)/K .EQ. 1) GO TO 40
- NUM = NUM + 1
- JCOL(NUM) = I-K
- ROW(NUM) = 1.D0
- 40 IF (I .GE. N-K) RETURN
- NUM = NUM + 1
- JCOL(NUM) = I+K
- ROW(NUM) = 2.D0
- RETURN
- END
diff --git a/CEP/PyBDSM/src/port3/ex/prsy.f b/CEP/PyBDSM/src/port3/ex/prsy.f
deleted file mode 100644
index 480287dc5460cc2fa4828637e738143b23609855..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ex/prsy.f
+++ /dev/null
@@ -1,88 +0,0 @@
-C$TEST PRSY
-C TO RUN AS A MAIN PROGRAM REMOVE NEXT LINE
- SUBROUTINE PRSY
-C***********************************************************************
-C
-C EXAMPLE OF USE OF THE PORT PROGRAM SPFNF
-C
-C***********************************************************************
- INTEGER N1, N2, N, MCP(500), MRP(500)
- INTEGER I1MACH, IREAD, IWRITE, TEMP, ISTAK(19000)
- REAL A1, A2, GROWTH
- INTEGER ISPAC,IW,MAXIW, IUL
- REAL EL1, EL2, TR, SASUM, RSTAK(19000), B(500)
- EXTERNAL QUEI, QUEA
- DOUBLE PRECISION DSTAK(9500)
- COMMON /CSTAK/ DSTAK
- COMMON /QUE/ A1, A2, N1, N2, N
- EQUIVALENCE(RSTAK(1), ISTAK(1), DSTAK(1))
- IREAD = I1MACH(1)
- IWRITE = I1MACH(2)
- CALL ISTKIN(19000, 2)
- 10 READ(IREAD,11)N1, N2
- 11 FORMAT(2I3)
- IF (N1. EQ. 0) STOP
- WRITE(IWRITE,12)N1, N2
- 12 FORMAT(/4H N1=,I3,4H N2=,I3)
- N = (N1+1)*(N2+1)
-C
-C DETERMINE THE ORDERING
-C
- CALL SPFOR(N, QUEI, MCP)
-C
-C GET THE WORK SPACE FROM THE STORAGE STACK
-C
- MAXIW = ISTKQU(2)-3*N-50
- IW = ISTKGT(MAXIW, 2)
-C
-C DETERMINE THE SYMBOLIC FACTORIZATION
-C
- DO 20 I=1,N
- MRP(I) = MCP(I)
- 20 CONTINUE
- CALL SPFSF(N, MRP, MCP, QUEI, ISTAK(IW), MAXIW, ISIZE)
-C
-C DETERMINE THE ACTUAL AMOUNT OF SPACE USED, MODIFY THE
-C INTEGER WORK SPACE AND ALLOCATE SPACE TO SAVE THE
-C FACTORIZATION
-C
- ISPAC = 2*N+1+ISIZE
- IW = ISTKMD(ISPAC,2)
- IUL= ISTKGT(ISIZE,3)
- 30 READ(IREAD,31)A1, A2
- 31 FORMAT(2F10.3)
- IF (A1.EQ.0.0)GO TO 50
- WRITE(IWRITE,32)A1, A2
- 32 FORMAT(/4H A1=,F10.3,4H A2=,F10.3)
-C
-C COMPUTE THE NUMERICAL FACTORIZATION
-C
- CALL SPFNF(N, MRP, MCP, QUEA, ISTAK(IW), RSTAK(IUL),
- 1 GROWTH, 0.0)
- WRITE(IWRITE,33)GROWTH
- 33 FORMAT(7H GROWTH,E25.7)
-C
-C GENERATE RIGHT HAND SIDE
-C
- DO 40 I=1,N
- B(I) = 0.0
- 40 CONTINUE
- B(N) = 1.0
-C
-C SOLVE THE PROBLEM
-C
- CALL SPSOL(N, MRP, MCP, ISTAK(IW), RSTAK(IUL), B, N, 1)
-C
-C FIND PROBABILITY OF BEING LOST
-C
- EL1 = B(N)
- EL2 = SASUM(N1+1,B(N2+1),N2+1)
- TEMP = (N2+1)*N1+1
- TR = SASUM(N2,B(TEMP),1)
- WRITE(IWRITE,41)EL1,EL2,TR
- 41 FORMAT(6H L1 = ,E15.5,6H L2 = ,E15.5,7H I12 = ,E15.5)
- GO TO 30
-C RELEASE STACK SPACE
- 50 CALL ISTKRL(2)
- GO TO 10
- END
diff --git a/CEP/PyBDSM/src/port3/ex/prsz.f b/CEP/PyBDSM/src/port3/ex/prsz.f
deleted file mode 100644
index 3ed9e3f57b703a89fd8f84560fc1357c613ee8c8..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ex/prsz.f
+++ /dev/null
@@ -1,83 +0,0 @@
-C$TEST PRSZ
-C TO RUN AS A MAIN PROGRAM REMOVE NEXT LINE
- SUBROUTINE PRSZ
-C***********************************************************************
-C
-C EXAMPLE OF USE OF THE PORT PROGRAM SPFML
-C
-C***********************************************************************
- INTEGER I, IWRITE, I1MACH, NEQ
- REAL X(100), B(100), ERR, SASUM
- EXTERNAL AROW
- REAL RSTACK(2500)
- COMMON/CSTAK/ RSTACK
- COMMON /NN/ NX
- CALL ISTKIN(2500,3)
- NX = 10
- NEQ = 100
-C
-C CONSTRUCT A RANDOM VECTOR FOR X
-C
- DO 10 I=1,NEQ
- X(I)=UNI(0)
- 10 CONTINUE
-C
-C FIND THE VECTOR B=AX
-C
- CALL SPFML(NEQ,AROW,X,B)
-C
-C SOLVE THE SYSTEM AX=B
-C
- CALL SPFLE(NEQ,.TRUE.,AROW,ISIZE,B,NEQ,1)
-C
-C FIND THE NORM OF THE ERROR OF THE SOLUTION
-C
- ERR=0.0
- IWRITE = I1MACH(2)
- DO 20 I=1,NEQ
- ERR=ERR + ABS(B(I)-X(I))
- 20 CONTINUE
- ERR=ERR/SASUM(NEQ,X,1)
- WRITE(IWRITE,21)ERR
- 21 FORMAT(19H RELATIVE ERROR IS ,1PE15.7)
- STOP
- END
- SUBROUTINE AROW(I, ROW, JCOL, NUM)
- REAL ROW(5)
- INTEGER JCOL(5)
- COMMON /NN/ N
-C
-C IN THE BLOCK TRIDIAGONAL MATRIX THERE ARE AT MOST 5
-C NONZERO ELEMENTS PER ROW AND EACH ROW HAS A DIAGONAL
-C OF -4.
-C THE VARIABLE IN INDICATES WHICH BLOCK ONE IS IN AND
-C THE VARIABLE JN INDICATES WHERE IN THE BLOCK ONE IS AT
-C
- IN = (I-1)/N+1
- JN = I - (IN-1) * N
- JCOL(1)=I
- ROW(1)=-4.0
- NUM=2
-C
-C DO THE OFF DIAGONAL ELEMENTS IN THE CURRENT BLOCK
-C
- JCOL(2)=I-1
- ROW(2)=1.0
- IF (JN.GT.1) NUM=NUM+1
- JCOL(NUM)=I+1
- ROW(NUM)=1.0
- IF (JN.LT.N)NUM=NUM+1
-C
-C DO THE BLOCK TO THE LEFT
-C
- JCOL(NUM)=I-N
- ROW(NUM)=1.0
- IF (IN.GT.1)NUM=NUM+1
-C
-C DO THE BLOCK TO THE RIGHT
-C
- JCOL(NUM)=I+N
- ROW(NUM)=1.0
- IF(IN.EQ.N) NUM=NUM-1
- RETURN
- END
diff --git a/CEP/PyBDSM/src/port3/ex/pst1.f b/CEP/PyBDSM/src/port3/ex/pst1.f
deleted file mode 100644
index b043c705b6602cce24af2a092fd7ae9d20f93244..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ex/pst1.f
+++ /dev/null
@@ -1,112 +0,0 @@
-C$TEST PST1
-C TO RUN AS A MAIN PROGRAM REMOVE NEXT LINE
- SUBROUTINE PST1
-C***********************************************************************
-C
-C EXAMPLE OF USE OF PORT PROGRAM POST
-C
-C***********************************************************************
- COMMON /CSTAK/ DS
- DOUBLE PRECISION DS(1000)
- EXTERNAL HANDLE, BC, AF, POSTD
- INTEGER NDX, K, IS(1000), NU, NV, NMESH
- REAL ERRPAR(2), U(100), V(1), MESH(100), DT, RS(1000)
- REAL WS(1000), TSTOP
- LOGICAL LS(1000)
- COMPLEX CS(500)
- EQUIVALENCE (DS(1), CS(1), WS(1), RS(1), IS(1), LS(1))
-C TO TEST POST ON
-C U SUB T = U SUB XX + F ON (0,1)
-C WHERE F IS CHOSEN SO THAT THE SOLUTION IS
-C U(X,T) = EXP(XT).
-C THE PORT LIBRARY STACK AND ITS ALIASES.
-C INITIALIZE THE PORT LIBRARY STACK LENGTH.
- CALL ISTKIN(1000, 4)
- NU = 1
- NV = 0
- ERRPAR(1) = 0
-C ABSOLUTE ERROR.
- ERRPAR(2) = 1E-2
- TSTOP = 1
- DT = 1E-2
- K = 4
-C NDX UNIFORM MESH POINTS ON (0,1).
- NDX = 4
- CALL UMB(0E0, 1E0, NDX, K, MESH, NMESH)
-C INITIAL CONDITIONS FOR U.
- CALL SETR(NMESH-K, 1E0, U)
- CALL POST(U, NU, K, MESH, NMESH, V, NV, 0E0, TSTOP, DT, AF, BC,
- 1 POSTD, ERRPAR, HANDLE)
-C CHECK FOR ERRORS AND STACK USAGE STATISTICS.
- CALL WRAPUP
- STOP
- END
- SUBROUTINE AF(T, X, NX, U, UX, UT, UTX, NU, V, VT, NV, A,
- 1 AU, AUX, AUT, AUTX, AV, AVT, F, FU, FUX, FUT, FUTX, FV, FVT)
- INTEGER NU, NX
- INTEGER NV
- REAL T, X(NX), U(NX, NU), UX(NX, NU), UT(NX, NU), UTX(NX, NU)
- REAL V(1), VT(1), A(NX, NU), AU(NX, NU, NU), AUX(NX, NU, NU), AUT(
- 1 NX, NU, NU)
- REAL AUTX(NX, NU, NU), AV(1), AVT(1), F(NX, NU), FU(NX, NU, NU),
- 1 FUX(NX, NU, NU)
- REAL FUT(NX, NU, NU), FUTX(NX, NU, NU), FV(1), FVT(1)
- INTEGER I
- REAL EXP
- DO 1 I = 1, NX
- A(I, 1) = -UX(I, 1)
- AUX(I, 1, 1) = -1
- F(I, 1) = (X(I)-T**2)*EXP(X(I)*T)-UT(I, 1)
- FUT(I, 1, 1) = -1
- 1 CONTINUE
- RETURN
- END
- SUBROUTINE BC(T, L, R, U, UX, UT, UTX, NU, V, VT, NV, B, BU,
- 1 BUX, BUT, BUTX, BV, BVT)
- INTEGER NU
- INTEGER NV
- REAL T, L, R, U(NU, 2), UX(NU, 2), UT(NU, 2)
- REAL UTX(NU, 2), V(1), VT(1), B(NU, 2), BU(NU, NU, 2), BUX(NU, NU,
- 1 2)
- REAL BUT(NU, NU, 2), BUTX(NU, NU, 2), BV(1), BVT(1)
- REAL EXP
- B(1, 1) = U(1, 1)-1.
- B(1, 2) = U(1, 2)-EXP(T)
- BU(1, 1, 1) = 1
- BU(1, 1, 2) = 1
- RETURN
- END
- SUBROUTINE HANDLE(T0, U0, V0, T, U, V, NU, NXMK, NV, K, X,
- 1 NX, DT, TSTOP)
- INTEGER NXMK, NU, NX
- INTEGER NV, K
- REAL T0, U0(NXMK, NU), V0(1), T, U(NXMK, NU), V(1)
- REAL X(NX), DT, TSTOP
- COMMON /TIME/ TT
- REAL TT
- EXTERNAL UOFX
- INTEGER I1MACH
- REAL EU, EESFF
- INTEGER TEMP
-C OUTPUT AND CHECKING ROUTINE.
- IF (T0 .EQ. T) RETURN
-C UOFX NEEDS TIME.
- TT = T
- EU = EESFF(K, X, NX, U, UOFX)
- TEMP = I1MACH(2)
- WRITE (TEMP, 1) T, EU
- 1 FORMAT (14H ERROR IN U(X,, 1PE10.2, 4H ) =, 1PE10.2)
- RETURN
- END
- SUBROUTINE UOFX(X, NX, U, W)
- INTEGER NX
- REAL X(NX), U(NX), W(NX)
- COMMON /TIME/ T
- REAL T
- INTEGER I
- REAL EXP
- DO 1 I = 1, NX
- U(I) = EXP(X(I)*T)
- 1 CONTINUE
- RETURN
- END
diff --git a/CEP/PyBDSM/src/port3/ex/pst2.f b/CEP/PyBDSM/src/port3/ex/pst2.f
deleted file mode 100644
index 1028767e77b392f8d20bb6e8443ef80433f14b2d..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ex/pst2.f
+++ /dev/null
@@ -1,137 +0,0 @@
-C$TEST PST2
-C TO RUN AS A MAIN PROGRAM REMOVE NEXT LINE
- SUBROUTINE PST2
-C***********************************************************************
-C
-C EXAMPLE OF USE OF PORT PROGRAM POST
-C
-C***********************************************************************
- COMMON /CSTAK/ DS
- DOUBLE PRECISION DS(1100)
- EXTERNAL HANDLE, BC, AF, POSTD
- INTEGER NDX, K, IS(1000), NU, NV, NMESH
- REAL ERRPAR(2), U(200), V(1), MESH(100), DT, RS(1000)
- REAL WS(1000), TSTOP
- LOGICAL LS(1000)
- COMPLEX CS(500)
- INTEGER TEMP
- EQUIVALENCE (DS(1), CS(1), WS(1), RS(1), IS(1), LS(1))
-C TO TEST POST ON
-C U SUB T = U SUB XX + F ON (0,1)
-C BY SETTING U1 = U AND U2 = U1 SUB X AND SOLVING
-C U1 SUB T = U1 SUB XX + F
-C ON (0,1)
-C U1 SUB X = U2
-C WHERE F IS CHOSEN SO THAT THE SOLUTION IS
-C U(X,T) = EXP(XT).
-C THE PORT LIBRARY STACK AND ITS ALIASES.
-C INITIALIZE THE PORT LIBRARY STACK LENGTH.
- CALL ISTKIN(1100, 4)
- NU = 2
- NV = 0
- ERRPAR(1) = 0
-C ABSOLUTE ERROR.
- ERRPAR(2) = 1E-2
- TSTOP = 1
- DT = 1E-2
- K = 4
-C NDX UNIFORM MESH POINTS ON (0,1).
- NDX = 4
- CALL UMB(0E0, 1E0, NDX, K, MESH, NMESH)
-C INITIAL CONDITIONS FOR U1.
- CALL SETR(NMESH-K, 1E0, U)
-C INITIAL CONDITIONS FOR U2.
- TEMP = NMESH-K
- CALL SETR(NMESH-K, 0E0, U(TEMP+1))
- CALL POST(U, NU, K, MESH, NMESH, V, NV, 0E0, TSTOP, DT, AF, BC,
- 1 POSTD, ERRPAR, HANDLE)
-C CHECK FOR ERRORS AND STACK USAGE STATISTICS.
- CALL WRAPUP
- STOP
- END
- SUBROUTINE AF(T, X, NX, U, UX, UT, UTX, NU, V, VT, NV, A,
- 1 AU, AUX, AUT, AUTX, AV, AVT, F, FU, FUX, FUT, FUTX, FV, FVT)
- INTEGER NU, NX
- INTEGER NV
- REAL T, X(NX), U(NX, NU), UX(NX, NU), UT(NX, NU), UTX(NX, NU)
- REAL V(1), VT(1), A(NX, NU), AU(NX, NU, NU), AUX(NX, NU, NU), AUT(
- 1 NX, NU, NU)
- REAL AUTX(NX, NU, NU), AV(1), AVT(1), F(NX, NU), FU(NX, NU, NU),
- 1 FUX(NX, NU, NU)
- REAL FUT(NX, NU, NU), FUTX(NX, NU, NU), FV(1), FVT(1)
- INTEGER I
- REAL EXP
- DO 1 I = 1, NX
- A(I, 1) = -U(I, 2)
- AU(I, 1, 2) = -1
- F(I, 1) = (X(I)-T**2)*EXP(X(I)*T)-UT(I, 1)
- FUT(I, 1, 1) = -1
- A(I, 2) = U(I, 1)
- AU(I, 2, 1) = 1
- F(I, 2) = U(I, 2)
- FU(I, 2, 2) = 1
- 1 CONTINUE
- RETURN
- END
- SUBROUTINE BC(T, L, R, U, UX, UT, UTX, NU, V, VT, NV, B, BU,
- 1 BUX, BUT, BUTX, BV, BVT)
- INTEGER NU
- INTEGER NV
- REAL T, L, R, U(NU, 2), UX(NU, 2), UT(NU, 2)
- REAL UTX(NU, 2), V(1), VT(1), B(NU, 2), BU(NU, NU, 2), BUX(NU, NU,
- 1 2)
- REAL BUT(NU, NU, 2), BUTX(NU, NU, 2), BV(1), BVT(1)
- REAL EXP
- B(1, 1) = U(1, 1)-1.
- B(1, 2) = U(1, 2)-EXP(T)
- BU(1, 1, 1) = 1
- BU(1, 1, 2) = 1
- RETURN
- END
- SUBROUTINE HANDLE(T0, U0, V0, T, U, V, NU, NXMK, NV, K, X,
- 1 NX, DT, TSTOP)
- INTEGER NXMK, NU, NX
- INTEGER NV, K
- REAL T0, U0(NXMK, NU), V0(1), T, U(NXMK, NU), V(1)
- REAL X(NX), DT, TSTOP
- COMMON /TIME/ TT
- REAL TT
- EXTERNAL U1OFX, U2OFX
- INTEGER I1MACH
- REAL EU(2), EESFF
- INTEGER TEMP
-C OUTPUT AND CHECKING ROUTINE.
- IF (T0 .EQ. T) RETURN
-C U1OFX AND U2OFX NEED TIME.
- TT = T
- EU(1) = EESFF(K, X, NX, U, U1OFX)
- EU(2) = EESFF(K, X, NX, U(1, 2), U2OFX)
- TEMP = I1MACH(2)
- WRITE (TEMP, 1) T, EU
- 1 FORMAT (14H ERROR IN U(X,, 1PE10.2, 4H ) =, 2(1PE10.2))
- RETURN
- END
- SUBROUTINE U1OFX(X, NX, U, W)
- INTEGER NX
- REAL X(NX), U(NX), W(NX)
- COMMON /TIME/ T
- REAL T
- INTEGER I
- REAL EXP
- DO 1 I = 1, NX
- U(I) = EXP(X(I)*T)
- 1 CONTINUE
- RETURN
- END
- SUBROUTINE U2OFX(X, NX, U, W)
- INTEGER NX
- REAL X(NX), U(NX), W(NX)
- COMMON /TIME/ T
- REAL T
- INTEGER I
- REAL EXP
- DO 1 I = 1, NX
- U(I) = T*EXP(X(I)*T)
- 1 CONTINUE
- RETURN
- END
diff --git a/CEP/PyBDSM/src/port3/ex/pst3.f b/CEP/PyBDSM/src/port3/ex/pst3.f
deleted file mode 100644
index 3b3fdd50ea043a3c29f1ecf4d2244ddc172169af..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ex/pst3.f
+++ /dev/null
@@ -1,147 +0,0 @@
-C$TEST PST3
-C TO RUN AS A MAIN PROGRAM REMOVE NEXT LINE
- SUBROUTINE PST3
-C***********************************************************************
-C
-C EXAMPLE OF USE OF PORT PROGRAM POST
-C
-C***********************************************************************
- COMMON /CSTAK/ DS
- DOUBLE PRECISION DS(2000)
- EXTERNAL DEE, HANDLE, BC, AF
- INTEGER NDX, K, IS(1000), NU, NV, NMESH
- REAL ERRPAR(2), U(100), V(1), MESH(100), DT, RS(1000)
- REAL WS(1000), TSTOP
- LOGICAL LS(1000)
- COMPLEX CS(500)
- EQUIVALENCE (DS(1), CS(1), WS(1), RS(1), IS(1), LS(1))
-C TO TEST POST ON
-C U SUB T = U SUB XX + V + F ON (0,1)
-C V SUB T = U( 1/2, T )
-C WHERE F IS CHOSEN SO THAT THE SOLUTION IS
-C U(X,T) = COS(XT) AND V(T) = 2 SIN(T/2).
-C THE PORT LIBRARY STACK AND ITS ALIASES.
-C INITIALIZE THE PORT LIBRARY STACK LENGTH.
- CALL ISTKIN(2000, 4)
- NU = 1
- NV = 1
- ERRPAR(1) = 1E-2
-C ESSENTIALLY RELATIVE ERROR.
- ERRPAR(2) = 1E-6
- TSTOP = 1
- DT = 1E-6
- K = 4
- NDX = 4
-C NDX UNIFORM MESH POINTS ON (0,1).
- CALL UMB(0E0, 1E0, NDX, K, MESH, NMESH)
-C INITIAL CONDITIONS FOR U.
- CALL SETR(NMESH-K, 1E0, U)
-C INITIAL VALUE FOR V.
- V(1) = 0
- CALL POST(U, NU, K, MESH, NMESH, V, NV, 0E0, TSTOP, DT, AF, BC,
- 1 DEE, ERRPAR, HANDLE)
-C CHECK FOR ERRORS AND STACK USAGE STATISTICS.
- CALL WRAPUP
- STOP
- END
- SUBROUTINE AF(T, X, NX, U, UX, UT, UTX, NU, V, VT, NV, A,
- 1 AU, AUX, AUT, AUTX, AV, AVT, F, FU, FUX, FUT, FUTX, FV, FVT)
- INTEGER NU, NV, NX
- REAL T, X(NX), U(NX, NU), UX(NX, NU), UT(NX, NU), UTX(NX, NU)
- REAL V(NV), VT(NV), A(NX, NU), AU(NX, NU, NU), AUX(NX, NU, NU),
- 1 AUT(NX, NU, NU)
- REAL AUTX(NX, NU, NU), AV(NX, NU, NV), AVT(NX, NU, NV), F(NX, NU),
- 1 FU(NX, NU, NU), FUX(NX, NU, NU)
- REAL FUT(NX, NU, NU), FUTX(NX, NU, NU), FV(NX, NU, NV), FVT(NX,
- 1 NU, NV)
- INTEGER I
- REAL COS, SIN
- DO 1 I = 1, NX
- A(I, 1) = -UX(I, 1)
- AUX(I, 1, 1) = -1
- F(I, 1) = V(1)-UT(I, 1)-X(I)*SIN(X(I)*T)+T**2*COS(X(I)*T)-2.*
- 1 SIN(T/2.)
- FUT(I, 1, 1) = -1
- FV(I, 1, 1) = 1
- 1 CONTINUE
- RETURN
- END
- SUBROUTINE BC(T, L, R, U, UX, UT, UTX, NU, V, VT, NV, B, BU,
- 1 BUX, BUT, BUTX, BV, BVT)
- INTEGER NU, NV
- REAL T, L, R, U(NU, 2), UX(NU, 2), UT(NU, 2)
- REAL UTX(NU, 2), V(NV), VT(NV), B(NU, 2), BU(NU, NU, 2), BUX(NU,
- 1 NU, 2)
- REAL BUT(NU, NU, 2), BUTX(NU, NU, 2), BV(NU, NV, 2), BVT(NU, NV, 2
- 1 )
- REAL COS
- B(1, 1) = U(1, 1)-1.
- B(1, 2) = U(1, 2)-COS(T)
- BU(1, 1, 1) = 1
- BU(1, 1, 2) = 1
- RETURN
- END
- SUBROUTINE DEE(T, K, X, NX, U, UT, NU, NXMK, V, VT, NV, D,
- 1 DU, DUT, DV, DVT)
- INTEGER NXMK, NU, NV, NX
- INTEGER K
- REAL T, X(NX), U(NXMK, NU), UT(NXMK, NU), V(NV), VT(NV)
- REAL D(NV), DU(NV, NXMK, NU), DUT(NV, NXMK, NU), DV(NV, NV), DVT(
- 1 NV, NV)
- INTEGER INTRVR, I, ILEFT
- REAL XI(1), BASIS(10)
- INTEGER TEMP
- XI(1) = 0.5E0
-C FIND 0.5 IN MESH.
- ILEFT = INTRVR(NX, X, XI(1))
- IF (K .GT. 10) CALL SETERR(
- 1 41HDEE - K .GT. 10, NEED MORE SPACE IN BASIS, 41, 1, 2)
-C B-SPLINE BASIS AT XI(1).
- CALL BSPLN(K, X, NX, XI, 1, ILEFT, BASIS)
- D(1) = VT(1)
- DVT(1, 1) = 1
-C VT(1) - U(0.5,T) = 0.
- DO 1 I = 1, K
- TEMP = ILEFT+I-K
- D(1) = D(1)-U(TEMP, 1)*BASIS(I)
- TEMP = ILEFT+I-K
- DU(1, TEMP, 1) = DU(1, TEMP, 1)-BASIS(I)
- 1 CONTINUE
- RETURN
- END
- SUBROUTINE HANDLE(T0, U0, V0, T, U, V, NU, NXMK, NV, K, X,
- 1 NX, DT, TSTOP)
- INTEGER NXMK, NU, NV, NX
- INTEGER K
- REAL T0, U0(NXMK, NU), V0(NV), T, U(NXMK, NU), V(NV)
- REAL X(NX), DT, TSTOP
- COMMON /TIME/ TT
- REAL TT
- EXTERNAL UOFX
- INTEGER I1MACH
- REAL ABS, SIN, EU, EV, EESFF
- INTEGER TEMP
-C OUTPUT AND CHECKING ROUTINE.
- IF (T0 .EQ. T) RETURN
-C UOFX NEEDS TIME.
- TT = T
- EU = EESFF(K, X, NX, U, UOFX)
- EV = ABS(V(1)-2.*SIN(T/2.))
- TEMP = I1MACH(2)
- WRITE (TEMP, 1) T, EU, EV
- 1 FORMAT (14H ERROR IN U(X,, 1PE10.2, 4H ) =, 1PE10.2, 6H V =, 1P
- 1 E10.2)
- RETURN
- END
- SUBROUTINE UOFX(X, NX, U, W)
- INTEGER NX
- REAL X(NX), U(NX), W(NX)
- COMMON /TIME/ T
- REAL T
- INTEGER I
- REAL COS
- DO 1 I = 1, NX
- U(I) = COS(X(I)*T)
- 1 CONTINUE
- RETURN
- END
diff --git a/CEP/PyBDSM/src/port3/ex/pst4.f b/CEP/PyBDSM/src/port3/ex/pst4.f
deleted file mode 100644
index 935647d352b766558d2d1b0dd46fbe6435f4d832..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ex/pst4.f
+++ /dev/null
@@ -1,136 +0,0 @@
-C$TEST PST4
-C TO RUN AS A MAIN PROGRAM REMOVE NEXT LINE
- SUBROUTINE PST4
-C***********************************************************************
-C
-C EXAMPLE OF USE OF PORT PROGRAM POST
-C
-C***********************************************************************
- COMMON /CSTAK/ DS
- DOUBLE PRECISION DS(2000)
- EXTERNAL DEE, HANDLE, BC, AF
- INTEGER NDX, K, IS(1000), NU, NV, NMESH
- REAL ERRPAR(2), U(100), V(1), ATAN, MESH(100), DT
- REAL RS(1000), WS(1000), TSTOP
- LOGICAL LS(1000)
- COMPLEX CS(500)
- EQUIVALENCE (DS(1), CS(1), WS(1), RS(1), IS(1), LS(1))
-C TO TEST POST ON
-C U SUB T = U SUB XX - U**3 + F ON (-PI,+PI)
-C SUBJECT TO PERIODIC BOUNDARY CONDITIONS,
-C WHERE F IS CHOSEN SO THAT THE SOLUTION IS
-C U(X,T) = COS(X)*SIN(T).
-C THE PORT LIBRARY STACK AND ITS ALIASES.
-C INITIALIZE THE PORT LIBRARY STACK LENGTH.
- CALL ISTKIN(2000, 4)
- NU = 1
- NV = 1
- ERRPAR(1) = 0
-C ABSOLUTE ERROR.
- ERRPAR(2) = 1E-2
- TSTOP = 8.*ATAN(1E0)
- DT = 0.4
-C MAKE A MESH OF NDX UNIFORM POINTS ON (-PI,+PI).
- K = 4
- NDX = 7
- CALL UMB((-4.)*ATAN(1E0), 4.*ATAN(1E0), NDX, K, MESH, NMESH)
-C INITIAL CONDITIONS FOR U.
- CALL SETR(NMESH-K, 0E0, U)
-C INITIAL CONDITIONS FOR V.
- V(1) = 0
- CALL POST(U, NU, K, MESH, NMESH, V, NV, 0E0, TSTOP, DT, AF, BC,
- 1 DEE, ERRPAR, HANDLE)
-C CHECK FOR ERRORS AND STACK USAGE STATISTICS.
- CALL WRAPUP
- STOP
- END
- SUBROUTINE AF(T, X, NX, U, UX, UT, UTX, NU, V, VT, NV, A,
- 1 AU, AUX, AUT, AUTX, AV, AVT, F, FU, FUX, FUT, FUTX, FV, FVT)
- INTEGER NU, NV, NX
- REAL T, X(NX), U(NX, NU), UX(NX, NU), UT(NX, NU), UTX(NX, NU)
- REAL V(NV), VT(NV), A(NX, NU), AU(NX, NU, NU), AUX(NX, NU, NU),
- 1 AUT(NX, NU, NU)
- REAL AUTX(NX, NU, NU), AV(NX, NU, NV), AVT(NX, NU, NV), F(NX, NU),
- 1 FU(NX, NU, NU), FUX(NX, NU, NU)
- REAL FUT(NX, NU, NU), FUTX(NX, NU, NU), FV(NX, NU, NV), FVT(NX,
- 1 NU, NV)
- INTEGER I
- REAL COS, SIN
- DO 1 I = 1, NX
- A(I, 1) = -UX(I, 1)
- AUX(I, 1, 1) = -1
- F(I, 1) = (-UT(I, 1))-U(I, 1)**3+COS(X(I))*(COS(T)+SIN(T)+COS(X
- 1 (I))**2*SIN(T)**3)
- FUT(I, 1, 1) = -1
- FU(I, 1, 1) = (-3.)*U(I, 1)**2
- 1 CONTINUE
- RETURN
- END
- SUBROUTINE BC(T, L, R, U, UX, UT, UTX, NU, V, VT, NV, B, BU,
- 1 BUX, BUT, BUTX, BV, BVT)
- INTEGER NU, NV
- REAL T, L, R, U(NU, 2), UX(NU, 2), UT(NU, 2)
- REAL UTX(NU, 2), V(NV), VT(NV), B(NU, 2), BU(NU, NU, 2), BUX(NU,
- 1 NU, 2)
- REAL BUT(NU, NU, 2), BUTX(NU, NU, 2), BV(NU, NV, 2), BVT(NU, NV, 2
- 1 )
- B(1, 1) = UX(1, 1)-V(1)
- B(1, 2) = UX(1, 2)-V(1)
- BUX(1, 1, 1) = 1
- BV(1, 1, 1) = -1
- BUX(1, 1, 2) = 1
- BV(1, 1, 2) = -1
- RETURN
- END
- SUBROUTINE DEE(T, K, X, NX, U, UT, NU, NXMK, V, VT, NV, D,
- 1 DU, DUT, DV, DVT)
- INTEGER NXMK, NU, NV, NX
- INTEGER K
- REAL T, X(NX), U(NXMK, NU), UT(NXMK, NU), V(NV), VT(NV)
- REAL D(NV), DU(NV, NXMK, NU), DUT(NV, NXMK, NU), DV(NV, NV), DVT(
- 1 NV, NV)
- INTEGER TEMP
-C U(-PI,T) - U(+PI,T) = 0.
- TEMP = NX-K
- D(1) = U(1, 1)-U(TEMP, 1)
- DU(1, 1, 1) = 1
- TEMP = NX-K
- DU(1, TEMP, 1) = -1
- RETURN
- END
- SUBROUTINE HANDLE(T0, U0, V0, T, U, V, NU, NXMK, NV, K, X,
- 1 NX, DT, TSTOP)
- INTEGER NXMK, NU, NV, NX
- INTEGER K
- REAL T0, U0(NXMK, NU), V0(NV), T, U(NXMK, NU), V(NV)
- REAL X(NX), DT, TSTOP
- COMMON /TIME/ TT
- REAL TT
- EXTERNAL UOFX
- INTEGER I1MACH
- REAL EU, EESFF, EV
- INTEGER TEMP
-C OUTPUT AND CHECKING ROUTINE.
- IF (T0 .EQ. T) RETURN
-C UOFX NEEDS TIME.
- TT = T
- EU = EESFF(K, X, NX, U, UOFX)
- EV = V(1)
- TEMP = I1MACH(2)
- WRITE (TEMP, 1) T, EU, EV
- 1 FORMAT (14H ERROR IN U(X,, 1PE10.2, 4H ) =, 1PE10.2, 6H V =, 1P
- 1 E10.2)
- RETURN
- END
- SUBROUTINE UOFX(X, NX, U, W)
- INTEGER NX
- REAL X(NX), U(NX), W(NX)
- COMMON /TIME/ T
- REAL T
- INTEGER I
- REAL COS, SIN
- DO 1 I = 1, NX
- U(I) = COS(X(I))*SIN(T)
- 1 CONTINUE
- RETURN
- END
diff --git a/CEP/PyBDSM/src/port3/ex/pst5.f b/CEP/PyBDSM/src/port3/ex/pst5.f
deleted file mode 100644
index d022745e2b4f34df415fdfecd39a991510c078ce..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ex/pst5.f
+++ /dev/null
@@ -1,246 +0,0 @@
-C$TEST PST5
-C TO RUN AS A MAIN PROGRAM REMOVE NEXT LINE
- SUBROUTINE PST5
-C***********************************************************************
-C
-C EXAMPLE OF USE OF PORT PROGRAM POST
-C
-C***********************************************************************
- COMMON /CSTAK/ DS
- DOUBLE PRECISION DS(4000)
- COMMON /TIME/ T
- REAL T
- COMMON /PARAM/ VC, X
- REAL VC(3), X(3)
- EXTERNAL DEE, HANDLE, UOFX, BC, AF
- INTEGER NDX, ISTKGT, K, IMMM, IU, IS(1000)
- INTEGER NU, NV, IMESH, ILUMB, NMESH
- REAL ERRPAR(2), TSTART, V(3), DT, XB(3), RS(1000)
- REAL WS(1000), TSTOP
- LOGICAL LS(1000)
- COMPLEX CS(500)
- EQUIVALENCE (DS(1), CS(1), WS(1), RS(1), IS(1), LS(1))
-C TO TEST POST ON
-C U SUB T = ( K(T,X) * U SUB X ) SUB X + G ON (-1,+2) * (0,+1)
-C WITH A MOVING FRONT X(T) CHARACTERIZED BY U(X(T),T) == 1 AND
-C JUMP ACROSS X(T) OF K(T,X) U SUB X = - 3 * X'(T).
-C WHERE K(T,X) IS PIECEWISE CONSTANT, SAY
-C 1 FOR X < X(T)
-C K(T,X) =
-C 2 FOR X > X(T)
-C AND G IS CHOSEN SO THAT THE SOLUTION IS
-C EXP(X-X(T)) FOR X < X(T)
-C U(X,T) =
-C EXP(X(T)-X) FOR X > X(T)
-C AND X(1,T) = T. THE MOVING FRONT IS TRACKED
-C IMPLICITLY BY FORCING U(X(1,T),T) = 1 AS A PSEUDO-RANKINE-HEUGONIOT RE
-CLATION.
-C V(1,2,3) GIVES THE MOVING MESH.
-C THE PORT LIBRARY STACK AND ITS ALIASES.
-C INITIALIZE THE PORT LIBRARY STACK LENGTH.
- CALL ISTKIN(4000, 4)
- CALL ENTER(1)
- NU = 1
- NV = 3
- ERRPAR(1) = 0
-C ABSOLUTE ERROR.
- ERRPAR(2) = 1E-2
- TSTART = 0
- TSTOP = 1
- DT = 0.1
- K = 4
-C NDX UNIFORM MESH POINTS ON EACH INTERVAL OF XB ARRAY.
- NDX = 6
- XB(1) = 0
- XB(2) = 1
- XB(3) = 2
-C GET MESH ON PORT STACK.
- IMESH = ILUMB(XB, 3, NDX, K, NMESH)
-C MAKE 1 OF MULTIPLICITY K-1.
- IMESH = IMMM(IMESH, NMESH, 1E0, K-1)
- X(1) = -1
- X(2) = 0
- X(3) = 2
-C INITIAL VALUES FOR V.
- CALL LPLMG(3, X, VC)
-C GET U ON THE PORT STACK.
- IU = ISTKGT(NMESH-K, 3)
-C UOFX NEEDS TIME.
- T = TSTART
-C UOFX NEEDS V FOR MAPPING.
- CALL MOVEFR(NV, VC, V)
-C INITIAL CONDITIONS FOR U.
- CALL L2SFF(UOFX, K, WS(IMESH), NMESH, WS(IU))
-C OUTPUT THE ICS.
- CALL HANDLE(T-1., WS(IU), V, T, WS(IU), V, NU, NMESH-K, NV, K, WS(
- 1 IMESH), NMESH, DT, TSTOP)
- CALL POST(WS(IU), NU, K, WS(IMESH), NMESH, V, NV, TSTART, TSTOP,
- 1 DT, AF, BC, DEE, ERRPAR, HANDLE)
- CALL LEAVE
- CALL WRAPUP
- STOP
- END
- SUBROUTINE AF(T, XI, NX, U, UX, UT, UTX, NU, V, VT, NV, A,
- 1 AU, AUX, AUT, AUTX, AV, AVT, F, FU, FUX, FUT, FUTX, FV, FVT)
- INTEGER NU, NV, NX
- REAL T, XI(NX), U(NX, NU), UX(NX, NU), UT(NX, NU), UTX(NX, NU)
- REAL V(NV), VT(NV), A(NX, NU), AU(NX, NU, NU), AUX(NX, NU, NU),
- 1 AUT(NX, NU, NU)
- REAL AUTX(NX, NU, NU), AV(NX, NU, NV), AVT(NX, NU, NV), F(NX, NU),
- 1 FU(NX, NU, NU), FUX(NX, NU, NU)
- REAL FUT(NX, NU, NU), FUTX(NX, NU, NU), FV(NX, NU, NV), FVT(NX,
- 1 NU, NV)
- COMMON /POSTF/ FAILED
- LOGICAL FAILED
- INTEGER I
- REAL KAY, EXP, XXI(99), XTV(99), XVV(99), X(99)
- REAL XXIV(99), AX(99), FX(99), XT(99), XV(99)
- LOGICAL TEMP
- TEMP = V(2) .LE. V(1)
- IF (.NOT. TEMP) TEMP = V(2) .GE. V(3)
- IF (.NOT. TEMP) GOTO 1
- FAILED = .TRUE.
- RETURN
-C MAP XI INTO X.
- 1 CALL LPLM(XI, NX, V, 3, X, XXI, XXIV, XV, XVV, XT, XTV)
-C MAP U INTO X SYSTEM.
- CALL POSTU(XI, X, XT, XXI, XV, VT, NX, 3, UX, UT, NU, AX, FX)
- DO 7 I = 1, NX
- IF (XI(I) .GT. 1.) GOTO 2
- KAY = 1
- GOTO 3
- 2 KAY = 2
- 3 A(I, 1) = KAY*UX(I, 1)
- AUX(I, 1, 1) = KAY
- IF (XI(I) .GT. 1.) GOTO 4
- A(I, 1) = A(I, 1)-3.*VT(2)
- AVT(I, 1, 2) = -3
- 4 F(I, 1) = UT(I, 1)
- FUT(I, 1, 1) = 1
- IF (XI(I) .GT. 1.) GOTO 5
- F(I, 1) = F(I, 1)+2.*EXP(X(I)-T)
- FX(I) = 2.*EXP(X(I)-T)
- GOTO 6
- 5 F(I, 1) = F(I, 1)+EXP(T-X(I))
- FX(I) = -EXP(T-X(I))
- 6 CONTINUE
- 7 CONTINUE
-C MAP A AND F INTO XI SYSTEM.
- CALL POSTI(XI, X, XT, XXI, XV, XTV, XXIV, XVV, NX, UX, UT, NU, V
- 1 , VT, NV, 1, 3, A, AX, AU, AUX, AUT, AUTX, AV, AVT, F, FX, FU
- 2 , FUX, FUT, FUTX, FV, FVT)
- RETURN
- END
- SUBROUTINE BC(T, L, R, U, UX, UT, UTX, NU, V, VT, NV, B, BU,
- 1 BUX, BUT, BUTX, BV, BVT)
- INTEGER NU, NV
- REAL T, L, R, U(NU, 2), UX(NU, 2), UT(NU, 2)
- REAL UTX(NU, 2), V(NV), VT(NV), B(NU, 2), BU(NU, NU, 2), BUX(NU,
- 1 NU, 2)
- REAL BUT(NU, NU, 2), BUTX(NU, NU, 2), BV(NU, NV, 2), BVT(NU, NV, 2
- 1 )
- REAL EXP
- B(1, 1) = U(1, 1)-EXP((-1.)-T)
- B(1, 2) = U(1, 2)-EXP(T-2.)
- BU(1, 1, 1) = 1
- BU(1, 1, 2) = 1
- RETURN
- END
- SUBROUTINE DEE(T, K, X, NX, U, UT, NU, NXMK, V, VT, NV, D,
- 1 DU, DUT, DV, DVT)
- INTEGER NXMK, NU, NV, NX
- INTEGER K
- REAL T, X(NX), U(NXMK, NU), UT(NXMK, NU), V(NV), VT(NV)
- REAL D(NV), DU(NV, NXMK, NU), DUT(NV, NXMK, NU), DV(NV, NV), DVT(
- 1 NV, NV)
- INTEGER INTRVR, I, ILEFT
- REAL BX(10), XX(1)
- INTEGER TEMP
- D(1) = V(1)+1.
-C X(0,V) = -1.
- DV(1, 1) = 1
- XX(1) = 1
-C FIND 1 IN THE MESH.
- ILEFT = INTRVR(NX, X, XX(1))
-C GET THE B-SPLINE BASIS AT XX.
- CALL BSPLN(K, X, NX, XX, 1, ILEFT, BX)
-C U(X(1,V),T) = 1.
- D(2) = -1
- DO 1 I = 1, K
- TEMP = ILEFT+I-K
- D(2) = D(2)+U(TEMP, 1)*BX(I)
- TEMP = ILEFT+I-K
- DU(2, TEMP, 1) = BX(I)
- 1 CONTINUE
- D(3) = V(3)-2.
-C X(2,V) = +2.
- DV(3, 3) = 1
- RETURN
- END
- SUBROUTINE HANDLE(T0, U0, V0, T, U, V, NU, NXMK, NV, K, X,
- 1 NX, DT, TSTOP)
- INTEGER NXMK, NU, NV, NX
- INTEGER K
- REAL T0, U0(NXMK, NU), V0(NV), T, U(NXMK, NU), V(NV)
- REAL X(NX), DT, TSTOP
- COMMON /PARAM/ VC, XX
- REAL VC(3), XX(3)
- COMMON /TIME/ TT
- REAL TT
- EXTERNAL UOFX
- INTEGER I1MACH
- REAL EU, EESFF, EV(3)
- INTEGER TEMP
-C OUTPUT AND CHECKING ROUTINE.
- IF (T0 .NE. T) GOTO 2
- TEMP = I1MACH(2)
- WRITE (TEMP, 1) T
- 1 FORMAT (16H RESTART FOR T =, 1PE10.2)
- RETURN
- 2 TT = T
-C UOFX NEEDS V FOR MAPPING.
- CALL MOVEFR(NV, V, VC)
- EU = EESFF(K, X, NX, U, UOFX)
- EV(1) = V(1)+1.
- EV(2) = V(2)-T
- EV(3) = V(3)-2.
- TEMP = I1MACH(2)
- WRITE (TEMP, 3) T, EU, EV
- 3 FORMAT (14H ERROR IN U(X,, 1PE10.2, 4H ) =, 1PE10.2, 6H V =, 3(
- 1 1PE10.2))
- RETURN
- END
- SUBROUTINE UOFX(XI, NX, U, W)
- INTEGER NX
- REAL XI(NX), U(NX), W(NX)
- COMMON /CSTAK/ DS
- DOUBLE PRECISION DS(500)
- COMMON /PARAM/ VC, X
- REAL VC(3), X(3)
- COMMON /TIME/ T
- REAL T
- INTEGER IXV, IXX, ISTKGT, I, IS(1000)
- REAL EXP, RS(1000), WS(1000), XOFXI
- LOGICAL LS(1000)
- COMPLEX CS(500)
- INTEGER TEMP
- EQUIVALENCE (DS(1), CS(1), WS(1), RS(1), IS(1), LS(1))
-C THE PORT LIBRARY STACK AND ITS ALIASES.
- CALL ENTER(1)
- IXX = ISTKGT(NX, 3)
-C SPACE FOR X AND XV.
- IXV = ISTKGT(3*NX, 3)
-C MAP INTO USER SYSTEM.
- CALL LPLMX(XI, NX, VC, 3, WS(IXX), WS(IXV))
- DO 3 I = 1, NX
- TEMP = IXX+I
- XOFXI = WS(TEMP-1)
- IF (XI(I) .GT. 1.) GOTO 1
- U(I) = EXP(XOFXI-T)
- GOTO 2
- 1 U(I) = EXP(T-XOFXI)
- 2 CONTINUE
- 3 CONTINUE
- CALL LEAVE
- RETURN
- END
diff --git a/CEP/PyBDSM/src/port3/ex/pst6.f b/CEP/PyBDSM/src/port3/ex/pst6.f
deleted file mode 100644
index b0ad75c8052381852545e7471b1b6c69df4759dd..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ex/pst6.f
+++ /dev/null
@@ -1,252 +0,0 @@
-C$TEST PST6
-C TO RUN AS A MAIN PROGRAM REMOVE NEXT LINE
- SUBROUTINE PST6
-C***********************************************************************
-C
-C EXAMPLE OF USE OF PORT PROGRAM POST
-C
-C***********************************************************************
- COMMON /CSTAK/ DS
- DOUBLE PRECISION DS(4000)
- COMMON /TIME/ T
- REAL T
- COMMON /PARAM/ VC, X
- REAL VC(4), X(3)
- EXTERNAL DEE, HANDLE, UOFX, BC, AF
- INTEGER NDX, ISTKGT, K, IMMM, IU, IS(1000)
- INTEGER NU, NV, IMESH, ILUMB, NMESH
- REAL ERRPAR(2), TSTART, V(4), DT, XB(3), RS(1000)
- REAL WS(1000), TSTOP
- LOGICAL LS(1000)
- COMPLEX CS(500)
- EQUIVALENCE (DS(1), CS(1), WS(1), RS(1), IS(1), LS(1))
-C TO TEST POST ON THE HYPERBOLIC PROBLEM
-C U SUB T = - U SUB X + G ON (-PI,+PI) * (0,PI)
-C WITH A MOVING SHOCK X(T) CHARACTERIZED BY
-C U(X(T)+,T) = 0 AND
-C U(X(T)+,T) - U(X(T)-,T) = X'(T)
-C WHERE G IS CHOSEN SO THAT THE SOLUTION IS
-C SIN(X+T) FOR X < X(T)
-C U(X,T) =
-C COS(X+T) FOR X > X(T)
-C WITH X(T) = PI/2 -T .
-C V(1,2,3) GIVES THE MOVING MESH AND V(4) IS THE HEIGHT OF THE JUMP.
-C THE PORT LIBRARY STACK AND ITS ALIASES.
-C INITIALIZE THE PORT LIBRARY STACK LENGTH.
- CALL ISTKIN(4000, 4)
- CALL ENTER(1)
- NU = 1
- NV = 4
- ERRPAR(1) = 0
-C ABSOLUTE ERROR.
- ERRPAR(2) = 1E-2
- TSTART = 0
- TSTOP = 3.14
- DT = 0.4
- K = 4
-C NDX UNIFORM MESH POINTS ON EACH INTERVAL OF XB.
- NDX = 6
- XB(1) = 0
- XB(2) = 1
- XB(3) = 2
-C GET MESH ON PORT STACK.
- IMESH = ILUMB(XB, 3, NDX, K, NMESH)
-C MAKE 1 OF MULTIPLICITY K-1.
- IMESH = IMMM(IMESH, NMESH, 1E0, K-1)
- X(1) = -3.14
- X(2) = 3.14/2.
- X(3) = 3.14
-C INITIAL VALUES FOR V.
- CALL LPLMG(3, X, VC)
-C GET U ON THE PORT STACK.
- IU = ISTKGT(NMESH-K, 3)
-C UOFX NEEDS TIME.
- T = TSTART
-C THE INITIAL HEIGHT OF THE JUMP.
- VC(4) = 1
-C UOFX NEEDS V FOR MAPPING.
- CALL MOVEFR(NV, VC, V)
-C INITIAL CONDITIONS FOR U.
- CALL L2SFF(UOFX, K, WS(IMESH), NMESH, WS(IU))
-C OUTPUT ICS.
- CALL HANDLE(T-1., WS(IU), V, T, WS(IU), V, NU, NMESH-K, NV, K, WS(
- 1 IMESH), NMESH, DT, TSTOP)
- CALL POST(WS(IU), NU, K, WS(IMESH), NMESH, V, NV, TSTART, TSTOP,
- 1 DT, AF, BC, DEE, ERRPAR, HANDLE)
- CALL LEAVE
- CALL WRAPUP
- STOP
- END
- SUBROUTINE AF(T, XI, NX, U, UX, UT, UTX, NU, V, VT, NV, A,
- 1 AU, AUX, AUT, AUTX, AV, AVT, F, FU, FUX, FUT, FUTX, FV, FVT)
- INTEGER NU, NV, NX
- REAL T, XI(NX), U(NX, NU), UX(NX, NU), UT(NX, NU), UTX(NX, NU)
- REAL V(NV), VT(NV), A(NX, NU), AU(NX, NU, NU), AUX(NX, NU, NU),
- 1 AUT(NX, NU, NU)
- REAL AUTX(NX, NU, NU), AV(NX, NU, NV), AVT(NX, NU, NV), F(NX, NU),
- 1 FU(NX, NU, NU), FUX(NX, NU, NU)
- REAL FUT(NX, NU, NU), FUTX(NX, NU, NU), FV(NX, NU, NV), FVT(NX,
- 1 NU, NV)
- COMMON /POSTF/ FAILED
- LOGICAL FAILED
- INTEGER I
- REAL COS, SIN, XXI(99), XTV(99), XVV(99), X(99)
- REAL XXIV(99), AX(99), FX(99), XT(99), XV(99)
- LOGICAL TEMP
- TEMP = V(2) .LE. V(1)
- IF (.NOT. TEMP) TEMP = V(2) .GE. V(3)
- IF (.NOT. TEMP) GOTO 1
- FAILED = .TRUE.
- RETURN
-C MAP XI INTO X.
- 1 CALL LPLM(XI, NX, V, 3, X, XXI, XXIV, XV, XVV, XT, XTV)
-C MAP U INTO X SYSTEM.
- CALL POSTU(XI, X, XT, XXI, XV, VT, NX, 3, UX, UT, NU, AX, FX)
- DO 4 I = 1, NX
- A(I, 1) = -U(I, 1)
- AU(I, 1, 1) = -1
- F(I, 1) = UT(I, 1)
- FUT(I, 1, 1) = 1
- IF (XI(I) .GT. 1.) GOTO 2
- F(I, 1) = F(I, 1)-2.*COS(X(I)+T)
- FX(I) = 2.*SIN(X(I)+T)
- GOTO 3
- 2 F(I, 1) = F(I, 1)-VT(4)
- FVT(I, 1, 4) = -1
- F(I, 1) = F(I, 1)+2.*SIN(X(I)+T)
- FX(I) = 2.*COS(X(I)+T)
- 3 CONTINUE
- 4 CONTINUE
-C MAP A AND F INTO XI SYSTEM.
- CALL POSTI(XI, X, XT, XXI, XV, XTV, XXIV, XVV, NX, UX, UT, NU, V
- 1 , VT, NV, 1, 3, A, AX, AU, AUX, AUT, AUTX, AV, AVT, F, FX, FU
- 2 , FUX, FUT, FUTX, FV, FVT)
- RETURN
- END
- SUBROUTINE BC(T, L, R, U, UX, UT, UTX, NU, V, VT, NV, B, BU,
- 1 BUX, BUT, BUTX, BV, BVT)
- INTEGER NU, NV
- REAL T, L, R, U(NU, 2), UX(NU, 2), UT(NU, 2)
- REAL UTX(NU, 2), V(NV), VT(NV), B(NU, 2), BU(NU, NU, 2), BUX(NU,
- 1 NU, 2)
- REAL BUT(NU, NU, 2), BUTX(NU, NU, 2), BV(NU, NV, 2), BVT(NU, NV, 2
- 1 )
- REAL SIN
- B(1, 1) = U(1, 1)-SIN(T-3.14)
-C U(-PI,T) = SIN(-PI+T).
- BU(1, 1, 1) = 1
- RETURN
- END
- SUBROUTINE DEE(T, K, X, NX, U, UT, NU, NXMK, V, VT, NV, D,
- 1 DU, DUT, DV, DVT)
- INTEGER NXMK, NU, NV, NX
- INTEGER K
- REAL T, X(NX), U(NXMK, NU), UT(NXMK, NU), V(NV), VT(NV)
- REAL D(NV), DU(NV, NXMK, NU), DUT(NV, NXMK, NU), DV(NV, NV), DVT(
- 1 NV, NV)
- INTEGER INTRVR, I, ILEFT
- REAL BX(10), XX(1), R1MACH
- INTEGER TEMP
- D(1) = V(1)+3.14
-C X(0,V) = -PI.
- DV(1, 1) = 1
-C XX(1) = 1 + A ROUNDING ERROR.
- XX(1) = R1MACH(4)+1.
- ILEFT = INTRVR(NX, X, XX(1))
-C GET THE B-SPLINE BASIS AT XX.
- CALL BSPLN(K, X, NX, XX, 1, ILEFT, BX)
- D(2) = -V(4)
-C U(X(T)+,T) - JUMP = 0.
- DV(2, 4) = -1
- DO 1 I = 1, K
- TEMP = ILEFT+I-K
- D(2) = D(2)+U(TEMP, 1)*BX(I)
- TEMP = ILEFT+I-K
- DU(2, TEMP, 1) = BX(I)
- 1 CONTINUE
- D(3) = V(3)-3.14
-C X(2,V) = +PI.
- DV(3, 3) = 1
-C JUMP + D( X(1,V(T)) )/DT = 0.
- D(4) = VT(2)+V(4)
- DVT(4, 2) = 1
- DV(4, 4) = 1
- RETURN
- END
- SUBROUTINE HANDLE(T0, U0, V0, T, U, V, NU, NXMK, NV, K, X,
- 1 NX, DT, TSTOP)
- INTEGER NXMK, NU, NV, NX
- INTEGER K
- REAL T0, U0(NXMK, NU), V0(NV), T, U(NXMK, NU), V(NV)
- REAL X(NX), DT, TSTOP
- COMMON /PARAM/ VC, XX
- REAL VC(4), XX(3)
- COMMON /TIME/ TT
- REAL TT
- EXTERNAL UOFX
- INTEGER I1MACH
- REAL EU, EESFF, EV(2)
- INTEGER TEMP
-C OUTPUT AND CHECKING ROUTINE.
- IF (T0 .NE. T) GOTO 2
- TEMP = I1MACH(2)
- WRITE (TEMP, 1) T, DT
- 1 FORMAT (16H RESTART FOR T =, 1PE10.2, 7H DT =, 1PE10.2)
- RETURN
- 2 TT = T
-C UOFX NEEDS V FOR MAPPING.
- CALL MOVEFR(NV, V, VC)
- EU = EESFF(K, X, NX, U, UOFX)
-C ERROR IN POSITION OF SHOCK.
- EV(1) = V(2)-(3.14/2.-T)
-C ERROR IN HEIGHT OF SHOCK.
- EV(2) = V(4)-1.
- TEMP = I1MACH(2)
- WRITE (TEMP, 3) T, EU, EV
- 3 FORMAT (14H ERROR IN U(X,, 1PE10.2, 4H ) =, 1PE10.2, 6H V =, 2(
- 1 1PE10.2))
- RETURN
- END
- SUBROUTINE UOFX(XI, NX, U, W)
- INTEGER NX
- REAL XI(NX), U(NX), W(NX)
- COMMON /CSTAK/ DS
- DOUBLE PRECISION DS(500)
- COMMON /PARAM/ VC, X
- REAL VC(4), X(3)
- COMMON /TIME/ T
- REAL T
- INTEGER IXV, IXX, ISTKGT, I, IS(1000)
- REAL EWE, RS(1000), WS(1000)
- LOGICAL LS(1000)
- COMPLEX CS(500)
- INTEGER TEMP
- EQUIVALENCE (DS(1), CS(1), WS(1), RS(1), IS(1), LS(1))
-C THE PORT LIBRARY STACK AND ITS ALIASES.
- CALL ENTER(1)
- IXX = ISTKGT(NX, 3)
-C SPACE FOR X AND XV.
- IXV = ISTKGT(3*NX, 3)
-C MAP INTO USER SYSTEM.
- CALL LPLMX(XI, NX, VC, 3, WS(IXX), WS(IXV))
- DO 1 I = 1, NX
- TEMP = IXX+I
- U(I) = EWE(T, WS(TEMP-1), VC(2))
- IF (XI(I) .GT. 1.) U(I) = U(I)+1.
- 1 CONTINUE
- CALL LEAVE
- RETURN
- END
- REAL FUNCTION EWE(T, X, XBREAK)
- REAL T, X, XBREAK
- REAL COS, SIN
- IF (X .GE. XBREAK) GOTO 1
- EWE = SIN(X+T)
- RETURN
- 1 IF (X .LE. XBREAK) GOTO 2
- EWE = COS(X+T)
- RETURN
- 2 CALL SETERR(17HEWE - X == XBREAK, 17, 1, 2)
- 3 CONTINUE
- 4 STOP
- END
diff --git a/CEP/PyBDSM/src/port3/ex/pst7.f b/CEP/PyBDSM/src/port3/ex/pst7.f
deleted file mode 100644
index 8c5f58261367beb5d74bd6ffd277c54267de2d1f..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ex/pst7.f
+++ /dev/null
@@ -1,234 +0,0 @@
-C$TEST PST7
-C TO RUN AS A MAIN PROGRAM REMOVE NEXT LINE
- SUBROUTINE PST7
-C***********************************************************************
-C
-C EXAMPLE OF USE OF PORT PROGRAM POST
-C
-C***********************************************************************
- COMMON /CSTAK/ DS
- DOUBLE PRECISION DS(4000)
- COMMON /TIME/ T
- REAL T
- COMMON /PARAM/ VC, X, XI0
- REAL VC(4), X(3), XI0
- EXTERNAL DEE, HANDLE, UOFX, BC, AF
- INTEGER NDX, ISTKGT, K, IMMM, IU, IS(1000)
- INTEGER NU, NV, IMESH, ILUMB, NMESH
- REAL ERRPAR(2), TSTART, D, V(4), DT, XB(3)
- REAL RS(1000), WS(1000), TSTOP
- LOGICAL LS(1000)
- COMPLEX CS(500)
- EQUIVALENCE (DS(1), CS(1), WS(1), RS(1), IS(1), LS(1))
-C TO TEST POST ON
-C U SUB T = U SUB XX + F ON (20,10**6)
-C WHERE F IS CHOSEN SO THAT THE SOLUTION IS
-C U(X,T) = EXP(-X*T),
-C AND X(1,T) IS CHOSEN SO THAT THE BOUNDARY-LAYER IS TRACKED
-C IMPLICITLY BY FORCING U(X(1,T)/2.3/D,T) = 1/E.
-C THIS IS THE SAME AS REQUIRING THE EXACT SOLUTION TO HAVE
-C U(X(1,T),T) = 10 ** -D.
-C V(1,2,3) GIVES THE MOVING MESH, V(4) IS TIME.
-C THE PORT LIBRARY STACK AND ITS ALIASES.
-C INITIALIZE THE PORT LIBRARY STACK LENGTH.
- CALL ISTKIN(4000, 4)
- CALL ENTER(1)
- NU = 1
- NV = 4
- ERRPAR(1) = 1E-2
-C MIXED RELATIVE AND ABSOLUTE ERROR.
- ERRPAR(2) = 1E-2
- D = 3
-C W(XI0,T) = 1/E.
- XI0 = 1./2.3/D
- TSTART = 20
- TSTOP = 1E+6
- DT = 1E-2
- K = 4
-C NDX UNIFORM MESH POINTS ON EACH INTERVAL OF XB.
- NDX = 6
- XB(1) = 0
- XB(2) = 1
- XB(3) = 2
-C GET MESH ON PORT STACK.
- IMESH = ILUMB(XB, 3, NDX, K, NMESH)
-C MAKE 1D0 OF MULTIPLICITY K-1.
- IMESH = IMMM(IMESH, NMESH, 1E0, K-1)
- X(1) = 0
- X(2) = 2.3*D/TSTART
- X(3) = 1
-C INITIAL VALUES FOR V.
- CALL LPLMG(3, X, VC)
-C GET U ON PORT STACK.
- IU = ISTKGT(NMESH-K, 3)
-C UOFX NEEDS TIME.
- T = TSTART
- VC(4) = TSTART
-C UOFX NEEDS V FOR MAPPING.
- CALL MOVEFR(NV, VC, V)
-C INITIAL CONDITIONS FOR U.
- CALL L2SFF(UOFX, K, WS(IMESH), NMESH, WS(IU))
-C OUTPUT ICS.
- CALL HANDLE(T-1., WS(IU), V, T, WS(IU), V, NU, NMESH-K, NV, K, WS(
- 1 IMESH), NMESH, DT, TSTOP)
- CALL POST(WS(IU), NU, K, WS(IMESH), NMESH, V, NV, TSTART, TSTOP,
- 1 DT, AF, BC, DEE, ERRPAR, HANDLE)
- CALL LEAVE
- CALL WRAPUP
- STOP
- END
- SUBROUTINE AF(T, XI, NX, U, UX, UT, UTX, NU, V, VT, NV, A,
- 1 AU, AUX, AUT, AUTX, AV, AVT, F, FU, FUX, FUT, FUTX, FV, FVT)
- INTEGER NU, NV, NX
- REAL T, XI(NX), U(NX, NU), UX(NX, NU), UT(NX, NU), UTX(NX, NU)
- REAL V(NV), VT(NV), A(NX, NU), AU(NX, NU, NU), AUX(NX, NU, NU),
- 1 AUT(NX, NU, NU)
- REAL AUTX(NX, NU, NU), AV(NX, NU, NV), AVT(NX, NU, NV), F(NX, NU),
- 1 FU(NX, NU, NU), FUX(NX, NU, NU)
- REAL FUT(NX, NU, NU), FUTX(NX, NU, NU), FV(NX, NU, NV), FVT(NX,
- 1 NU, NV)
- COMMON /POSTF/ FAILED
- LOGICAL FAILED
- INTEGER I
- REAL XXI(99), XTV(99), XVV(99), X(99), EXPL, XXIV(99)
- REAL AX(99), FX(99), XT(99), XV(99)
- LOGICAL TEMP
- TEMP = V(2) .LE. V(1)
- IF (.NOT. TEMP) TEMP = V(2) .GE. V(3)
- IF (.NOT. TEMP) GOTO 1
- FAILED = .TRUE.
- RETURN
-C MAP XI INTO X.
- 1 CALL LPLM(XI, NX, V, 3, X, XXI, XXIV, XV, XVV, XT, XTV)
-C MAP U INTO X SYSTEM.
- CALL POSTU(XI, X, XT, XXI, XV, VT, NX, 3, UX, UT, NU, AX, FX)
- DO 2 I = 1, NX
- A(I, 1) = -UX(I, 1)
- AUX(I, 1, 1) = -1
- F(I, 1) = (-UT(I, 1))-EXPL((-X(I))*V(4))*(X(I)+V(4)**2)
- FUT(I, 1, 1) = -1
- FV(I, 1, 4) = (-EXPL((-X(I))*V(4)))*(2.*V(4)+(X(I)+V(4)**2)*(-X
- 1 (I)))
- FX(I) = (-EXPL((-X(I))*V(4)))*(1.-V(4)*X(I)-V(4)**3)
- 2 CONTINUE
-C MAP A AND F INTO XI SYSTEM.
- CALL POSTI(XI, X, XT, XXI, XV, XTV, XXIV, XVV, NX, UX, UT, NU, V
- 1 , VT, NV, 1, 3, A, AX, AU, AUX, AUT, AUTX, AV, AVT, F, FX, FU
- 2 , FUX, FUT, FUTX, FV, FVT)
- RETURN
- END
- SUBROUTINE BC(T, L, R, U, UX, UT, UTX, NU, V, VT, NV, B, BU,
- 1 BUX, BUT, BUTX, BV, BVT)
- INTEGER NU, NV
- REAL T, L, R, U(NU, 2), UX(NU, 2), UT(NU, 2)
- REAL UTX(NU, 2), V(NV), VT(NV), B(NU, 2), BU(NU, NU, 2), BUX(NU,
- 1 NU, 2)
- REAL BUT(NU, NU, 2), BUTX(NU, NU, 2), BV(NU, NV, 2), BVT(NU, NV, 2
- 1 )
- REAL EXPL
-C U(0,T) = 1
- B(1, 1) = U(1, 1)-1.
-C U(1,T) = EXP(-T)
- B(1, 2) = U(1, 2)-EXPL(-V(4))
- BU(1, 1, 1) = 1
- BU(1, 1, 2) = 1
- BV(1, 4, 2) = EXPL(-V(4))
- RETURN
- END
- SUBROUTINE DEE(T, K, X, NX, U, UT, NU, NXMK, V, VT, NV, D,
- 1 DU, DUT, DV, DVT)
- INTEGER NXMK, NU, NV, NX
- INTEGER K
- REAL T, X(NX), U(NXMK, NU), UT(NXMK, NU), V(NV), VT(NV)
- REAL D(NV), DU(NV, NXMK, NU), DUT(NV, NXMK, NU), DV(NV, NV), DVT(
- 1 NV, NV)
- COMMON /PARAM/ VC, XC, XI0
- REAL VC(4), XC(3), XI0
- INTEGER INTRVR, I, ILEFT
- REAL EXP, BX(10), XX(1)
- INTEGER TEMP
- D(1) = V(1)
-C X(0,V) = 0.
- DV(1, 1) = 1
- XX(1) = XI0
- ILEFT = INTRVR(NX, X, XX(1))
-C GET THE B-SPLINE BASIS AT XX.
- CALL BSPLN(K, X, NX, XX, 1, ILEFT, BX)
- D(2) = -EXP(-1E0)
-C D(2) = W(XI0,T) - EXP(-1).
- DO 1 I = 1, K
- TEMP = ILEFT+I-K
- D(2) = D(2)+U(TEMP, 1)*BX(I)
- TEMP = ILEFT+I-K
- DU(2, TEMP, 1) = BX(I)
- 1 CONTINUE
- D(3) = V(3)-1.
-C X(2,V) = 1.
- DV(3, 3) = 1
- D(4) = VT(4)-1.
- DVT(4, 4) = 1
- RETURN
- END
- SUBROUTINE HANDLE(T0, U0, V0, T, U, V, NU, NXMK, NV, K, X,
- 1 NX, DT, TSTOP)
- INTEGER NXMK, NU, NV, NX
- INTEGER K
- REAL T0, U0(NXMK, NU), V0(NV), T, U(NXMK, NU), V(NV)
- REAL X(NX), DT, TSTOP
- COMMON /PARAM/ VC, XX, XI0
- REAL VC(4), XX(3), XI0
- COMMON /TIME/ TT
- REAL TT
- EXTERNAL UOFX
- INTEGER I1MACH
- REAL EU, EESFF, EV, LPLMT
- INTEGER TEMP
-C OUTPUT AND CHECKING ROUTINE.
- IF (T0 .NE. T) GOTO 2
- TEMP = I1MACH(2)
- WRITE (TEMP, 1) T, DT
- 1 FORMAT (16H RESTART FOR T =, 1PE10.2, 7H DT =, 1PE10.2)
- RETURN
-C LET DT CARRY V(2) DOWN BY NO MORE THAN A FACTOR OF 10.
- 2 DT = LPLMT(T, V, NV, T0, V0, 1E-1, DT)
- TT = T
-C UOFX NEEDS V FOR MAPPING.
- CALL MOVEFR(NV, V, VC)
- EU = EESFF(K, X, NX, U, UOFX)
-C ERROR IN POSITION OF BOUNDARY LAYER.
- EV = V(2)-1./XI0/T
- TEMP = I1MACH(2)
- WRITE (TEMP, 3) T, EU, EV
- 3 FORMAT (14H ERROR IN U(X,, 1PE10.2, 4H ) =, 1PE10.2, 6H V =, 1P
- 1 E10.2)
- RETURN
- END
- SUBROUTINE UOFX(XI, NX, U, W)
- INTEGER NX
- REAL XI(NX), U(NX), W(NX)
- COMMON /CSTAK/ DS
- DOUBLE PRECISION DS(500)
- COMMON /PARAM/ VC, X, XI0
- REAL VC(4), X(3), XI0
- COMMON /TIME/ T
- REAL T
- INTEGER IXV, IXX, ISTKGT, I, IS(1000)
- REAL EXPL, RS(1000), WS(1000)
- LOGICAL LS(1000)
- COMPLEX CS(500)
- INTEGER TEMP
- EQUIVALENCE (DS(1), CS(1), WS(1), RS(1), IS(1), LS(1))
-C THE PORT LIBRARY STACK AND ITS ALIASES.
- CALL ENTER(1)
- IXX = ISTKGT(NX, 3)
-C SPACE FOR X AND XV.
- IXV = ISTKGT(3*NX, 3)
-C MAP INTO USER SYSTEM.
- CALL LPLMX(XI, NX, VC, 3, WS(IXX), WS(IXV))
- DO 1 I = 1, NX
- TEMP = IXX+I
- U(I) = EXPL((-WS(TEMP-1))*T)
- 1 CONTINUE
- CALL LEAVE
- RETURN
- END
diff --git a/CEP/PyBDSM/src/port3/ex/pst8.f b/CEP/PyBDSM/src/port3/ex/pst8.f
deleted file mode 100644
index b25ec41a9d65031f5852812ca200fb0a18845fe8..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ex/pst8.f
+++ /dev/null
@@ -1,217 +0,0 @@
-C$TEST PST8
-C TO RUN AS A MAIN PROGRAM REMOVE NEXT LINE
- SUBROUTINE PST8
-C***********************************************************************
-C
-C EXAMPLE OF USE OF PORT PROGRAM POST
-C
-C***********************************************************************
- COMMON /CSTAK/ DS
- DOUBLE PRECISION DS(5000)
- COMMON /TIME/ T
- REAL T
- COMMON /KMESH/ K, NMESH
- INTEGER K, NMESH
- COMMON /CMESH/ MESH
- REAL MESH(100)
- EXTERNAL DEE, HANDLE, UOFX, BC, AF
- INTEGER NDX, I, IS(1000), NU, NV
- REAL ERRPAR(2), U(100), V(100), DT, RS(1000), WS(1000)
- REAL TSTOP
- LOGICAL LS(1000)
- COMPLEX CS(500)
- INTEGER TEMP
- EQUIVALENCE (DS(1), CS(1), WS(1), RS(1), IS(1), LS(1))
-C TO TEST POST ON THE INTEGRO-PDE
-C U SUB T = 2 * U SUB XX - INT(0,1) EXP(X-Y)*U(Y) DY ON (0,1)
-C SUBJECT TO GIVEN DIRICHLET BCS, CHOSEN SO THAT THE SOLUTION IS
-C U(X,T) = EXP(T+X).
-C THE PORT LIBRARY STACK AND ITS ALIASES.
-C INITIALIZE THE PORT LIBRARY STACK LENGTH.
- CALL ISTKIN(5000, 4)
- NU = 1
- ERRPAR(1) = 0
-C ABSOLUTE ERROR.
- ERRPAR(2) = 1E-2
- TSTOP = 1
- DT = 1E-2
- K = 4
-C NDX UNIFORM MESH POINTS ON (0,1).
- NDX = 7
- CALL UMB(0E0, 1E0, NDX, K, MESH, NMESH)
- NV = NMESH-K
-C UOFX NEEDS T.
- T = 0
-C ICS FOR U.
- CALL L2SFF(UOFX, K, MESH, NMESH, U)
- TEMP = NMESH-K
- DO 1 I = 1, TEMP
- V(I) = U(I)
- 1 CONTINUE
-C ICS FOR V.
- CALL POST(U, NU, K, MESH, NMESH, V, NV, 0E0, TSTOP, DT, AF, BC,
- 1 DEE, ERRPAR, HANDLE)
- CALL WRAPUP
- STOP
- END
- SUBROUTINE AF(T, X, NX, U, UX, UT, UTX, NU, V, VT, NV, A,
- 1 AU, AUX, AUT, AUTX, AV, AVT, F, FU, FUX, FUT, FUTX, FV, FVT)
- INTEGER NU, NV, NX
- REAL T, X(NX), U(NX, NU), UX(NX, NU), UT(NX, NU), UTX(NX, NU)
- REAL V(NV), VT(NV), A(NX, NU), AU(NX, NU, NU), AUX(NX, NU, NU),
- 1 AUT(NX, NU, NU)
- REAL AUTX(NX, NU, NU), AV(NX, NU, NV), AVT(NX, NU, NV), F(NX, NU),
- 1 FU(NX, NU, NU), FUX(NX, NU, NU)
- REAL FUT(NX, NU, NU), FUTX(NX, NU, NU), FV(NX, NU, NV), FVT(NX,
- 1 NU, NV)
- COMMON /KMESH/ K, NMESH
- INTEGER K, NMESH
- COMMON /CMESH/ MESH
- REAL MESH(100)
- INTEGER I
- DO 1 I = 1, NX
- A(I, 1) = 2.*UX(I, 1)
- AUX(I, 1, 1) = 2
- F(I, 1) = UT(I, 1)
- FUT(I, 1, 1) = 1
- 1 CONTINUE
-C GET THE INTEGRAL.
- CALL INTGRL(K, MESH, NMESH, V, X, NX, F, FV)
- RETURN
- END
- SUBROUTINE BC(T, L, R, U, UX, UT, UTX, NU, V, VT, NV, B, BU,
- 1 BUX, BUT, BUTX, BV, BVT)
- INTEGER NU, NV
- REAL T, L, R, U(NU, 2), UX(NU, 2), UT(NU, 2)
- REAL UTX(NU, 2), V(NV), VT(NV), B(NU, 2), BU(NU, NU, 2), BUX(NU,
- 1 NU, 2)
- REAL BUT(NU, NU, 2), BUTX(NU, NU, 2), BV(NU, NV, 2), BVT(NU, NV, 2
- 1 )
- REAL EXP
- B(1, 1) = U(1, 1)-EXP(T)
- B(1, 2) = U(1, 2)-EXP(T+1.)
- BU(1, 1, 1) = 1
- BU(1, 1, 2) = 1
- RETURN
- END
- SUBROUTINE DEE(T, K, X, NX, U, UT, NU, NXMK, V, VT, NV, D,
- 1 DU, DUT, DV, DVT)
- INTEGER NXMK, NU, NV, NX
- INTEGER K
- REAL T, X(NX), U(NXMK, NU), UT(NXMK, NU), V(NV), VT(NV)
- REAL D(NV), DU(NV, NXMK, NU), DUT(NV, NXMK, NU), DV(NV, NV), DVT(
- 1 NV, NV)
- INTEGER I
- DO 1 I = 1, NXMK
- D(I) = U(I, 1)-V(I)
- DU(I, I, 1) = 1
- DV(I, I) = -1
- 1 CONTINUE
- RETURN
- END
- SUBROUTINE HANDLE(T0, U0, V0, T, U, V, NU, NXMK, NV, K, X,
- 1 NX, DT, TSTOP)
- INTEGER NXMK, NU, NV, NX
- INTEGER K
- REAL T0, U0(NXMK, NU), V0(NV), T, U(NXMK, NU), V(NV)
- REAL X(NX), DT, TSTOP
- COMMON /TIME/ TT
- REAL TT
- EXTERNAL UOFX
- INTEGER I1MACH
- REAL EU, EESFF
- INTEGER TEMP
-C OUTPUT AND CHECKING ROUTINE.
- IF (T0 .NE. T) GOTO 2
- TEMP = I1MACH(2)
- WRITE (TEMP, 1) T0, DT
- 1 FORMAT (16H RESTART FOR T =, 1PE10.2, 7H DT =, 1PE10.2)
- RETURN
- 2 TT = T
- EU = EESFF(K, X, NX, U, UOFX)
- TEMP = I1MACH(2)
- WRITE (TEMP, 3) T, EU
- 3 FORMAT (14H ERROR IN U(X,, 1PE10.2, 4H ) =, 1PE10.2)
- RETURN
- END
- SUBROUTINE UOFX(X, NX, U, W)
- INTEGER NX
- REAL X(NX), U(NX), W(NX)
- COMMON /TIME/ T
- REAL T
- INTEGER I
- REAL EXP
- DO 1 I = 1, NX
- U(I) = EXP(T+X(I))
- 1 CONTINUE
- RETURN
- END
- SUBROUTINE INTGRL(K, MESH, NMESH, V, X, NX, F, FV)
- INTEGER NX, NMESH
- INTEGER K
- REAL MESH(NMESH), V(1), X(NX), F(NX), FV(NX, 1)
- INTEGER MGQ, I, J, L, IX
- REAL EWE, KER, WGQ(3), XGQ(3), B(3, 4, 200), KERU
- REAL XX(3)
- LOGICAL FIRST
- INTEGER TEMP, TEMP1
- DATA FIRST/.TRUE./
-C TO COMPUTE
-C F = INTEGRAL FROM MESH(1) TO MESH(NMESH)
-C KERNEL(X,Y,SUM(I=1,...,NMESH-K) V(I)*B(I,Y)) DY
-C AND
-C FV = D(F)/D(V).
-C ASSUME THAT CALL KERNEL(X,Y,U,KER,KERU) RETURNS
-C KER = KERNEL(X,Y,U) AND
-C KERU = PARTIAL KERNEL / PARTIAL U.
-C V(NMESH-K),FV(NX,NMESH-K)
-C THE FOLLOWING DECLARATION IS SPECIFIC TO K = 4 SPLINES.
- IF (NMESH-K .GT. 200) CALL SETERR(27HINTGRL - NMESH-K .GT. NXMAX
- 1 , 27, 1, 2)
-C NEED MORE LOCAL SPACE.
- IF (K .NE. 4) CALL SETERR(17HINTGRL - K .NE. 4, 17, 2, 2)
-C USE K-1 POINT GAUSSIAN-QUADRATURE RULE ON EACH INTERVAL.
- MGQ = K-1
- IF (FIRST) CALL GQM11(MGQ, XGQ, WGQ)
-C ONLY GET GQ RULE ONCE, ITS EXPENSIVE.
-C THE GAUSSIAN QUADRATURE RULE.
-C DO INTEGRAL INTERVAL BY INTERVAL.
- TEMP = NMESH-K
- DO 6 I = K, TEMP
-C G.Q. POINTS ON (MESH(I), MESH(I+1)).
- DO 1 J = 1, MGQ
- XX(J) = 0.5*(MESH(I+1)+MESH(I))+0.5*(MESH(I+1)-MESH(I))*XGQ(
- 1 J)
- 1 CONTINUE
- IF (FIRST) CALL BSPLN(K, MESH, NMESH, XX, MGQ, I, B(1, 1, I))
-C ONLY GET B-SPLINE BASIS ONCE, ITS EXPENSIVE.
- DO 5 J = 1, MGQ
-C GET SUM() V()*B()(XX).
- EWE = 0
- DO 2 L = 1, K
- TEMP1 = I+L-K
- EWE = EWE+V(TEMP1)*B(J, L, I)
- 2 CONTINUE
- DO 4 IX = 1, NX
-C GET KERNEL AND PARTIAL.
- CALL KERNEL(X(IX), XX(J), EWE, KER, KERU)
- F(IX) = F(IX)+0.5*KER*(MESH(I+1)-MESH(I))*WGQ(J)
- DO 3 L = 1, K
- TEMP1 = I+L-K
- FV(IX, TEMP1) = FV(IX, TEMP1)+0.5*B(J, L, I)*KERU*(
- 1 MESH(I+1)-MESH(I))*WGQ(J)
- 3 CONTINUE
- 4 CONTINUE
- 5 CONTINUE
- 6 CONTINUE
- FIRST = .FALSE.
- RETURN
- END
- SUBROUTINE KERNEL(X, Y, U, KER, KERU)
- REAL X, Y, U, KER, KERU
- REAL EXP
-C TO EVALUATE THE KERNEL EXP(X-Y)*U(Y) AND ITS PARTIAL WRT. U.
- KERU = EXP(X-Y)
- KER = KERU*U
- RETURN
- END
diff --git a/CEP/PyBDSM/src/port3/ex/pst9.f b/CEP/PyBDSM/src/port3/ex/pst9.f
deleted file mode 100644
index c5ef792fc9762078b4d5d6c69ee7cb6d97542104..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ex/pst9.f
+++ /dev/null
@@ -1,157 +0,0 @@
-C$TEST PST9
-C TO RUN AS A MAIN PROGRAM REMOVE NEXT LINE
- SUBROUTINE PST9
-C***********************************************************************
-C
-C EXAMPLE OF USE OF PORT PROGRAM POST
-C
-C***********************************************************************
- COMMON /CSTAK/ DS
- DOUBLE PRECISION DS(2000)
- COMMON /PARAM/ C
- REAL C
- EXTERNAL HANDLE, BC, AF, POSTD
- INTEGER NDX, NXC, NXX, I, K, IS(1000)
- INTEGER NU, NV, NX, I1MACH
- REAL EWE(1000), ERR, ERRPAR(2), U(100), V(1), X(100)
- REAL ERRR, DT, XC(100), UC(100), EEBSF, RS(1000)
- REAL WS(1000), XX(1000), TSTOP, R1MACH
- LOGICAL LS(1000)
- COMPLEX CS(500)
- INTEGER TEMP
- EQUIVALENCE (DS(1), CS(1), WS(1), RS(1), IS(1), LS(1))
-C TO TEST POST ON AUTOMATIC, STATIC MESH REFINEMENT.
-C U SUB T = U SUB XX + C * U SUB X ON (0,1)
-C THE SOLUTION IS
-C U(X,T) = EXP(-C*X).
-C THE PORT LIBRARY STACK AND ITS ALIASES.
-C INITIALIZE THE PORT LIBRARY STACK LENGTH.
- CALL ISTKIN(2000, 4)
- C = 50
- NU = 1
- NV = 0
- ERRPAR(1) = 1E-1
- ERRPAR(2) = 1E-1
- K = 4
- NDX = 8
- CALL UMB(0E0, 1E0, NDX, K, XC, NXC)
-C INITIAL CONDITIONS FOR UC.
- CALL SETR(NXC-K, 0E0, UC)
-C INFINITY.
- ERR = R1MACH(2)
- 1 IF (ERR .LE. 1E-2) GOTO 6
-C HALVE THE CRUDE X.
- CALL LUMB(XC, NXC, 3, K, X, NX)
-C FITTING POINTS FOR REFINEMENT.
- CALL LUMD(X, NX, K, XX, NXX)
-C UC ON XX.
- CALL SPLNE(K, XC, NXC, UC, XX, NXX, EWE)
-C FIT U TO UC ON MESH.
- CALL DL2SF(XX, EWE, NXX, K, X, NX, U)
- TSTOP = 1./R1MACH(4)
- DT = 1E-6
- I = NX-2*(K-1)
- TEMP = I1MACH(2)
- WRITE (TEMP, 2) I
- 2 FORMAT (18H SOLVING FOR NDX =, I3)
- CALL POST(U, NU, K, X, NX, V, NV, 0E0, TSTOP, DT, AF, BC,
- 1 POSTD, ERRPAR, HANDLE)
-C GET RUN-TIME STATISTICS.
- CALL POSTX
-C ERROR ESTIMATE FOR UC.
- ERR = EEBSF(K, XC, NXC, UC, X, NX, U)
-C ERROR ESTIMATE FOR U.
- ERRR = ERR/16.
- TEMP = I1MACH(2)
- WRITE (TEMP, 3) ERR, ERRR
- 3 FORMAT (21H ERROR ESTIMATES UC =, 1PE10.2, 9H AND U =, 1P
- 1 E10.2)
- NXC = NX
- DO 4 I = 1, NX
- XC(I) = X(I)
- 4 CONTINUE
- TEMP = NX-K
- DO 5 I = 1, TEMP
- UC(I) = U(I)
- 5 CONTINUE
- GOTO 1
- 6 STOP
- END
- SUBROUTINE AF(T, X, NX, U, UX, UT, UTX, NU, V, VT, NV, A,
- 1 AU, AUX, AUT, AUTX, AV, AVT, F, FU, FUX, FUT, FUTX, FV, FVT)
- INTEGER NU, NX
- INTEGER NV
- REAL T, X(NX), U(NX, NU), UX(NX, NU), UT(NX, NU), UTX(NX, NU)
- REAL V(1), VT(1), A(NX, NU), AU(NX, NU, NU), AUX(NX, NU, NU), AUT(
- 1 NX, NU, NU)
- REAL AUTX(NX, NU, NU), AV(1), AVT(1), F(NX, NU), FU(NX, NU, NU),
- 1 FUX(NX, NU, NU)
- REAL FUT(NX, NU, NU), FUTX(NX, NU, NU), FV(1), FVT(1)
- COMMON /PARAM/ C
- REAL C
- INTEGER I
- DO 1 I = 1, NX
- A(I, 1) = UX(I, 1)+C*U(I, 1)
- AUX(I, 1, 1) = 1
- AU(I, 1, 1) = C
- F(I, 1) = UT(I, 1)
- FUT(I, 1, 1) = 1
- 1 CONTINUE
- RETURN
- END
- SUBROUTINE BC(T, L, R, U, UX, UT, UTX, NU, V, VT, NV, B, BU,
- 1 BUX, BUT, BUTX, BV, BVT)
- INTEGER NU
- INTEGER NV
- REAL T, L, R, U(NU, 2), UX(NU, 2), UT(NU, 2)
- REAL UTX(NU, 2), V(1), VT(1), B(NU, 2), BU(NU, NU, 2), BUX(NU, NU,
- 1 2)
- REAL BUT(NU, NU, 2), BUTX(NU, NU, 2), BV(1), BVT(1)
- COMMON /PARAM/ C
- REAL C
- REAL EXP
- B(1, 1) = U(1, 1)-1.
- B(1, 2) = U(1, 2)-EXP(-C)
- BU(1, 1, 1) = 1
- BU(1, 1, 2) = 1
- RETURN
- END
- SUBROUTINE HANDLE(T0, U0, V0, T, U, V, NU, NXMK, NV, K, X,
- 1 NX, DT, TSTOP)
- INTEGER NXMK, NU, NX
- INTEGER NV, K
- REAL T0, U0(NXMK, NU), V0(1), T, U(NXMK, NU), V(1)
- REAL X(NX), DT, TSTOP
- COMMON /TIME/ TT
- REAL TT
- EXTERNAL UOFX
- INTEGER I1MACH
- REAL EU, EESFF
- INTEGER TEMP
-C OUTPUT AND CHECKING ROUTINE.
- IF (T0 .NE. T) GOTO 2
- TEMP = I1MACH(2)
- WRITE (TEMP, 1) T
- 1 FORMAT (16H RESTART FOR T =, 1PE10.2)
- RETURN
- 2 TT = T
- EU = EESFF(K, X, NX, U, UOFX)
- TEMP = I1MACH(2)
- WRITE (TEMP, 3) T, EU
- 3 FORMAT (15H ERROR IN U(X, , 1PE10.2, 4H ) =, 1PE10.2)
- RETURN
- END
- SUBROUTINE UOFX(X, NX, U, W)
- INTEGER NX
- REAL X(NX), U(NX), W(NX)
- COMMON /PARAM/ C
- REAL C
- COMMON /TIME/ T
- REAL T
- INTEGER I
- REAL EXP
- DO 1 I = 1, NX
- U(I) = EXP((-C)*X(I))
- 1 CONTINUE
- RETURN
- END
diff --git a/CEP/PyBDSM/src/port3/ex/pstt.f b/CEP/PyBDSM/src/port3/ex/pstt.f
deleted file mode 100644
index f22a2a3fd006926e4d01f6ba70a4bca42ff7a4f4..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ex/pstt.f
+++ /dev/null
@@ -1,155 +0,0 @@
-C$TEST PSTT
-C TO RUN AS A MAIN PROGRAM REMOVE NEXT LINE
- SUBROUTINE PSTT
-C***********************************************************************
-C
-C EXAMPLE OF USE OF PORT PROGRAM POST
-C
-C***********************************************************************
- COMMON /CSTAK/ DS
- DOUBLE PRECISION DS(2000)
- EXTERNAL HANDLE, BC, AF, POSTD
- INTEGER NDX, NXH, I, K, IS(1000), NU
- INTEGER NV, NX, I1MACH
- REAL ABS, ERR, ERRPAR(2), U(100), V(1), X(100)
- REAL AMAX1, DT, UE(100), EEBSF, UH(100), XH(100)
- REAL RS(1000), WS(1000), TSTOP
- LOGICAL LS(1000)
- COMPLEX CS(500)
- INTEGER TEMP
- EQUIVALENCE (DS(1), CS(1), WS(1), RS(1), IS(1), LS(1))
-C TO ESTIMATE X AND T ERROR AS SUM.
-C U SUB T = U SUB XX + F ON (0,1)
-C WHERE F IS CHOSEN SO THAT THE SOLUTION IS
-C U(X,T) = EXP(XT).
-C THE PORT LIBRARY STACK AND ITS ALIASES.
-C INITIALIZE THE PORT LIBRARY STACK LENGTH.
- CALL ISTKIN(2000, 4)
- NU = 1
- NV = 0
- ERRPAR(1) = 0
- ERRPAR(2) = 1E-2
- K = 4
- NDX = 4
- TSTOP = 1
- DT = 1E-2
-C CRUDE MESH.
- CALL UMB(0E0, 1E0, NDX, K, X, NX)
-C INITIAL CONDITIONS FOR U.
- CALL SETR(NX-K, 1E0, U)
- TEMP = I1MACH(2)
- WRITE (TEMP, 1)
- 1 FORMAT (36H SOLVING ON CRUDE MESH USING ERRPAR.)
- CALL POST(U, NU, K, X, NX, V, NV, 0E0, TSTOP, DT, AF, BC, POSTD,
- 1 ERRPAR, HANDLE)
-C GET RUN-TIME STATISTICS.
- CALL POSTX
-C HALVE THE MESH SPACING.
- CALL UMB(0E0, 1E0, 2*NDX-1, K, XH, NXH)
-C INITIAL CONDITIONS FOR UH.
- CALL SETR(NXH-K, 1E0, UH)
- DT = 1E-2
- TEMP = I1MACH(2)
- WRITE (TEMP, 2)
- 2 FORMAT (38H SOLVING ON REFINED MESH USING ERRPAR.)
- CALL POST(UH, NU, K, XH, NXH, V, NV, 0E0, TSTOP, DT, AF, BC,
- 1 POSTD, ERRPAR, HANDLE)
-C GET RUN-TIME STATISTICS.
- CALL POSTX
-C ESTIMATE U ERROR.
- ERR = EEBSF(K, X, NX, U, XH, NXH, UH)
- WRITE (6, 3) ERR
- 3 FORMAT (24H U ERROR FROM U AND UH =, 1PE10.2)
-C INITIAL CONDITIONS FOR UE.
- CALL SETR(NX-K, 1E0, UE)
- DT = 1E-2
- ERRPAR(1) = ERRPAR(1)/10.
- ERRPAR(2) = ERRPAR(2)/10.
- TEMP = I1MACH(2)
- WRITE (TEMP, 4)
- 4 FORMAT (39H SOLVING ON CRUDE MESH USING ERRPAR/10.)
- CALL POST(UE, NU, K, X, NX, V, NV, 0E0, TSTOP, DT, AF, BC, POSTD
- 1 , ERRPAR, HANDLE)
-C GET RUN-TIME STATISTICS.
- CALL POSTX
- ERR = 0
- TEMP = NX-K
- DO 5 I = 1, TEMP
- ERR = AMAX1(ERR, ABS(U(I)-UE(I)))
- 5 CONTINUE
- WRITE (6, 6) ERR
- 6 FORMAT (24H U ERROR FROM U AND UE =, 1PE10.2)
- STOP
- END
- SUBROUTINE AF(T, X, NX, U, UX, UT, UTX, NU, V, VT, NV, A,
- 1 AU, AUX, AUT, AUTX, AV, AVT, F, FU, FUX, FUT, FUTX, FV, FVT)
- INTEGER NU, NX
- INTEGER NV
- REAL T, X(NX), U(NX, NU), UX(NX, NU), UT(NX, NU), UTX(NX, NU)
- REAL V(1), VT(1), A(NX, NU), AU(NX, NU, NU), AUX(NX, NU, NU), AUT(
- 1 NX, NU, NU)
- REAL AUTX(NX, NU, NU), AV(1), AVT(1), F(NX, NU), FU(NX, NU, NU),
- 1 FUX(NX, NU, NU)
- REAL FUT(NX, NU, NU), FUTX(NX, NU, NU), FV(1), FVT(1)
- INTEGER I
- REAL EXP
- DO 1 I = 1, NX
- A(I, 1) = -UX(I, 1)
- AUX(I, 1, 1) = -1
- F(I, 1) = (X(I)-T**2)*EXP(X(I)*T)-UT(I, 1)
- FUT(I, 1, 1) = -1
- 1 CONTINUE
- RETURN
- END
- SUBROUTINE BC(T, L, R, U, UX, UT, UTX, NU, V, VT, NV, B, BU,
- 1 BUX, BUT, BUTX, BV, BVT)
- INTEGER NU
- INTEGER NV
- REAL T, L, R, U(NU, 2), UX(NU, 2), UT(NU, 2)
- REAL UTX(NU, 2), V(1), VT(1), B(NU, 2), BU(NU, NU, 2), BUX(NU, NU,
- 1 2)
- REAL BUT(NU, NU, 2), BUTX(NU, NU, 2), BV(1), BVT(1)
- REAL EXP
- B(1, 1) = U(1, 1)-1.
- B(1, 2) = U(1, 2)-EXP(T)
- BU(1, 1, 1) = 1
- BU(1, 1, 2) = 1
- RETURN
- END
- SUBROUTINE HANDLE(T0, U0, V0, T, U, V, NU, NXMK, NV, K, X,
- 1 NX, DT, TSTOP)
- INTEGER NXMK, NU, NX
- INTEGER NV, K
- REAL T0, U0(NXMK, NU), V0(1), T, U(NXMK, NU), V(1)
- REAL X(NX), DT, TSTOP
- COMMON /TIME/ TT
- REAL TT
- EXTERNAL UOFX
- INTEGER I1MACH
- REAL EU, EESFF
- INTEGER TEMP
-C OUTPUT AND CHECKING ROUTINE.
- IF (T0 .NE. T) GOTO 2
- TEMP = I1MACH(2)
- WRITE (TEMP, 1) T
- 1 FORMAT (16H RESTART FOR T =, 1PE10.2)
- RETURN
- 2 TT = T
- EU = EESFF(K, X, NX, U, UOFX)
- TEMP = I1MACH(2)
- WRITE (TEMP, 3) T, EU
- 3 FORMAT (14H ERROR IN U(X,, 1PE10.2, 4H ) =, 1PE10.2)
- RETURN
- END
- SUBROUTINE UOFX(X, NX, U, W)
- INTEGER NX
- REAL X(NX), U(NX), W(NX)
- COMMON /TIME/ T
- REAL T
- INTEGER I
- REAL EXP
- DO 1 I = 1, NX
- U(I) = EXP(X(I)*T)
- 1 CONTINUE
- RETURN
- END
diff --git a/CEP/PyBDSM/src/port3/ex/qbla.f b/CEP/PyBDSM/src/port3/ex/qbla.f
deleted file mode 100644
index 886b22f7b4a2ac758e5914035de2ae8cb3ec8953..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ex/qbla.f
+++ /dev/null
@@ -1,43 +0,0 @@
-C$TEST QBLA
-C TO RUN AS A MAIN PROGRAM REMOVE NEXT LINE
- SUBROUTINE QBLA
-C***********************************************************************
-C
-C EXAMPLE OF USE OF THE PORT PROGRAM RQUAD
-C
-C***********************************************************************
- EXTERNAL F
- COMMON /COUNTS/NMEVAL
- INTEGER NMEVAL,IWRITE,I1MACH
- REAL F,RESULT,ERROR
-C
-C INITIALIZE COUNT TO ZERO
- NMEVAL = 0
-C
-C SET OUTPUT UNIT TO IWRITE
- IWRITE = I1MACH(2)
-C
- CALL RQUAD(F, 0.0, 1.0, 0.0, 1.0E-7, RESULT, ERROR)
-C
- WRITE (IWRITE, 9996)
- 9996 FORMAT(13X, 42H THE INTEGRAL OF EXP(X) BETWEEN 0 AND 1 IS)
- WRITE (IWRITE, 9997) RESULT, ERROR
- 9997 FORMAT(1H0,11X, 1PE15.8, 20H WITH RELATIVE ERROR, 1PE9.2)
- WRITE (IWRITE,9998) NMEVAL
- 9998 FORMAT(1H0, 13X,1H(,I2,38H FUNCTION EVALUATIONS WERE REQUIRED TO)
- WRITE (IWRITE,9999)
- 9999 FORMAT(17X, 26H PERFORM THE QUADRATURE) )
- STOP
- END
- REAL FUNCTION F(X)
- COMMON /COUNTS/NMEVAL
- INTEGER NMEVAL
- REAL X
-C
-C COMPUTE THE INTEGRAND
- F = EXP( X )
-C
-C COUNT THE NUMBER OF TIMES F WAS CALLED
- NMEVAL = NMEVAL + 1
- RETURN
- END
diff --git a/CEP/PyBDSM/src/port3/ex/qblc.f b/CEP/PyBDSM/src/port3/ex/qblc.f
deleted file mode 100644
index 8f30e72fbe610bfbaabe534c19fd269c3070c82d..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ex/qblc.f
+++ /dev/null
@@ -1,34 +0,0 @@
-C$TEST QBLC
-C TO RUN AS A MAIN PROGRAM REMOVE NEXT LINE
- SUBROUTINE QBLC
-C***********************************************************************
-C
-C EXAMPLE OF USE OF THE PORT PROGRAM BQUAD
-C
-C***********************************************************************
- INTEGER NCALL,IWRITE,I1MACH
- REAL SFUNC,X(3),ANS,ERREST,TRUERR
- EXTERNAL SFUNC
- COMMON/COUNT/NCALL
- NCALL=0
- X(1) = -1.0E0
- X(2) = 0.0E0
- X(3) = +1.0E0
-C
-C BQUAD WILL TAKE INTO ACCOUNT THE BREAK AT X=0
-C
- CALL BQUAD (SFUNC,3,X,1.E-6,ANS,ERREST)
- TRUERR=EXP(1.E0) - ANS
- IWRITE=I1MACH(2)
- WRITE(IWRITE, 99) ANS, ERREST, TRUERR, NCALL
- 99 FORMAT(1X,4HANS=,1PE15.7,10H ERREST=,1PE12.3,
- 1 10H TRUERR=,1PE12.3/1X,6HNCALL=,I4)
- STOP
- END
- REAL FUNCTION SFUNC(X)
- REAL X
- COMMON/COUNT/NCALL
- NCALL = NCALL+1
- SFUNC = AMAX1(1.E0, EXP(X))
- RETURN
- END
diff --git a/CEP/PyBDSM/src/port3/ex/qblg.f b/CEP/PyBDSM/src/port3/ex/qblg.f
deleted file mode 100644
index 2680fe62c3885c20ecb768d543ad9bba07d3dcf3..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ex/qblg.f
+++ /dev/null
@@ -1,41 +0,0 @@
-C$TEST QBLG
-C TO RUN AS A MAIN PROGRAM REMOVE NEXT LINE
- SUBROUTINE QBLG
-C***********************************************************************
-C
-C EXAMPLE OF USE OF THE PORT PROGRAM QUAD
-C
-C***********************************************************************
- EXTERNAL F
- COMMON /COUNTS/NMEVAL
- INTEGER NMEVAL,IWRITE,I1MACH
- REAL ERROR,RESULT
-C
-C INITIALIZE COUNT TO ZERO
- NMEVAL = 0
-C
- CALL QUAD(F, 0.0, 1.0, 1.0E-4, RESULT, ERROR)
-C
- IWRITE = I1MACH(2)
- WRITE (IWRITE, 10)
- 10 FORMAT(11X, 48H THE INTEGRAL OF X**0.5(LOGX) BETWEEN 0 AND 1 IS)
- WRITE (IWRITE, 20) RESULT, ERROR
- 20 FORMAT(1H0,10X, E15.7, 21H WITH ESTIMATED ERROR, 1PE9.2)
- WRITE (IWRITE, 30) NMEVAL
- 30 FORMAT(1H0, 14X,1H(,I2,38H FUNCTION EVALUATIONS WERE REQUIRED TO
- 1 /17X, 26H PERFORM THE QUADRATURE) )
- STOP
- END
- REAL FUNCTION F(X)
- COMMON /COUNTS/NMEVAL
- INTEGER NMEVAL
- REAL X
-C
-C COMPUTE THE INTEGRAND
- F = 0.0
- IF (X .NE. 0.0) F = SQRT(X)*ALOG(X)
-C
-C COUNT THE NUMBER OF TIMES F WAS CALLED
- NMEVAL = NMEVAL + 1
- RETURN
- END
diff --git a/CEP/PyBDSM/src/port3/ex/qgsg.f b/CEP/PyBDSM/src/port3/ex/qgsg.f
deleted file mode 100644
index 5fee5687d139fa08f2e0ccd548eae34971b67d66..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ex/qgsg.f
+++ /dev/null
@@ -1,27 +0,0 @@
-C$TEST QGSG
-C TO RUN AS A MAIN PROGRAM REMOVE NEXT LINE
- SUBROUTINE QGSG
-C***********************************************************************
-C
-C EXAMPLE OF USE OF THE PORT PROGRAM GQ1
-C
-C***********************************************************************
- REAL X(5),W(5),CALC,TRUE,ERR
-C
- CALL GQ1(5,X,W)
- IWRITE=I1MACH(2)
- WRITE(IWRITE,30)
- DO 10 J=1,5
- 10 WRITE(IWRITE,40) J, X(J),W(J)
- CALC = 0.E0
- DO 20 J=1,5
- 20 CALC = CALC+W(J)*(1.0/(2.0+X(J)))
- TRUE = ALOG(3.E0)
- ERR = TRUE-CALC
- WRITE(IWRITE,50) TRUE,CALC,ERR
- STOP
- 30 FORMAT(///13H TEST OF GQ1//30H0ABSCISSAS AND WEIGHTS FOR N=5)
- 40 FORMAT(I4,0P2E16.7)
- 50 FORMAT(15H0SAMPLE PROBLEM/6H TRUE=,1PE16.7/
- X 6H CALC=,1PE16.7/6H ERR =,1PE11.2)
- END
diff --git a/CEP/PyBDSM/src/port3/ex/qgsh.f b/CEP/PyBDSM/src/port3/ex/qgsh.f
deleted file mode 100644
index 075998901c61cbc8686ad432fb48ab51a10b054e..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ex/qgsh.f
+++ /dev/null
@@ -1,28 +0,0 @@
-C$TEST QGSH
-C TO RUN AS A MAIN PROGRAM REMOVE NEXT LINE
- SUBROUTINE QGSH
-C***********************************************************************
-C
-C EXAMPLE OF USE OF THE PORT PROGRAM GQEX
-C
-C***********************************************************************
- REAL X(5),W(5),CALC,TRUE,PI,ERR
-C
- CALL GQEX(5,X,W)
- IWRITE=I1MACH(2)
- WRITE(IWRITE,30)
- DO 10 J=1,5
- 10 WRITE(IWRITE,40) J, X(J),W(J)
- CALC = 0.E0
- DO 20 J=1,5
- 20 CALC = CALC+W(J)*X(J)/(1.0 - EXP(-X(J)))
- PI = 2.E0*ATAN2(1.E0,0.E0)
- TRUE = PI**2/6.E0
- ERR = TRUE - CALC
- WRITE(IWRITE,50) TRUE,CALC,ERR
- STOP
- 30 FORMAT(///14H TEST OF GQEX//30H0ABSCISSAS AND WEIGHTS FOR N=5)
- 40 FORMAT(I4,0P2E16.7)
- 50 FORMAT(15H0SAMPLE PROBLEM/6H TRUE=,1PE16.7/
- X 6H CALC=,1PE16.7/6H ERR =,1PE11.2)
- END
diff --git a/CEP/PyBDSM/src/port3/ex/qgsj.f b/CEP/PyBDSM/src/port3/ex/qgsj.f
deleted file mode 100644
index 9cd47f3e3c427e92a41fd6f279e72a718c0c5f05..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ex/qgsj.f
+++ /dev/null
@@ -1,33 +0,0 @@
-C$TEST QGSJ
-C TO RUN AS A MAIN PROGRAM REMOVE NEXT LINE
- SUBROUTINE QGSJ
-C***********************************************************************
-C
-C EXAMPLE OF USE OF THE PORT PROGRAM GQEX2
-C
-C***********************************************************************
- REAL X(5),W(5),FEX2,CALC,TRUE,PI,ERR
-C
- CALL GQEX2(5,X,W)
- IWRITE=I1MACH(2)
- WRITE(IWRITE,1)
- DO 10 J=1,5
- 10 WRITE(IWRITE,2) J, X(J),W(J)
- CALC=0.E0
- DO 20 J=1,5
- 20 CALC=CALC+W(J)*FEX2(X(J))
- PI=2.E0*ATAN2(1.E0,0.E0)
- TRUE=SQRT(PI)*EXP(-.25E0)
- ERR=TRUE - CALC
- WRITE(IWRITE,3) TRUE,CALC,ERR
- STOP
- 1 FORMAT(///15H TEST OF GQEX2//30H0ABSCISSAS AND WEIGHTS FOR N=5)
- 2 FORMAT(I4,0P2E16.7)
- 3 FORMAT(15H0SAMPLE PROBLEM/6H TRUE=,1PE16.7/
- X 6H CALC=,1PE16.7/6H ERR =,1PE11.2)
- END
- REAL FUNCTION FEX2(X)
- REAL X
- FEX2=COS(X)
- RETURN
- END
diff --git a/CEP/PyBDSM/src/port3/ex/qgsm.f b/CEP/PyBDSM/src/port3/ex/qgsm.f
deleted file mode 100644
index 1835a19a877e2e31e61721c080a2cf82c5a22070..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ex/qgsm.f
+++ /dev/null
@@ -1,33 +0,0 @@
-C$TEST QGSM
-C TO RUN AS A MAIN PROGRAM REMOVE NEXT LINE
- SUBROUTINE QGSM
-C***********************************************************************
-C
-C EXAMPLE OF USE OF THE PORT PROGRAM GQEXA
-C
-C***********************************************************************
- REAL X(5),W(5),FEXA,CALC,TRUE,PI,ERR
-C
- CALL GQEXA(5,-0.5E0,X,W)
- IWRITE=I1MACH(2)
- WRITE(IWRITE,1)
- DO 10 J=1,5
- 10 WRITE(IWRITE,2) J, X(J),W(J)
- CALC = 0.E0
- DO 20 J=1,5
- 20 CALC = CALC+W(J)*FEXA(X(J))
- PI = 2.E0*ATAN2(1.E0,0.E0)
- TRUE = 0.5E0*SQRT(PI)*(1.E0-1.E0/SQRT(3.E0))
- ERR = TRUE-CALC
- WRITE(IWRITE,3) TRUE,CALC,ERR
- STOP
- 1 FORMAT(///15H TEST OF GQEXA//30H0ABSCISSAS AND WEIGHTS FOR N=5)
- 2 FORMAT(I4,0P2E16.7)
- 3 FORMAT(15H0SAMPLE PROBLEM/6H TRUE=,1PE16.7/
- X 6H CALC=,1PE16.7/6H ERR =,1PE11.2)
- END
- REAL FUNCTION FEXA(X)
- REAL X
- FEXA=0.5E0*(1.E0-EXP(-2.E0*X))
- RETURN
- END
diff --git a/CEP/PyBDSM/src/port3/ex/qgsp.f b/CEP/PyBDSM/src/port3/ex/qgsp.f
deleted file mode 100644
index 4dd222f0feda7d275658d91a4c5fb16a436381b9..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ex/qgsp.f
+++ /dev/null
@@ -1,33 +0,0 @@
-C$TEST QGSP
-C TO RUN AS A MAIN PROGRAM REMOVE NEXT LINE
- SUBROUTINE QGSP
-C***********************************************************************
-C
-C EXAMPLE OF USE OF THE PORT PROGRAM GQLOG
-C
-C***********************************************************************
- REAL X(5),W(5),FLOG,CALC,TRUE,PI2,ERR
-C
- CALL GQLOG(5,X,W)
- IWRITE = I1MACH(2)
- WRITE(IWRITE,1)
- DO 10 J = 1,5
- 10 WRITE(IWRITE,2) J, X(J),W(J)
- CALC = 0.E0
- DO 20 J = 1,5
- 20 CALC = CALC+W(J)*FLOG(X(J))
- PI2 = ATAN2(1.E0,0.E0)
- TRUE = -(PI2**2/3.E0)
- ERR = TRUE - CALC
- WRITE(IWRITE,3) TRUE,CALC,ERR
- STOP
- 1 FORMAT(///15H TEST OF GQLOG//30H0ABSCISSAS AND WEIGHTS FOR N=5)
- 2 FORMAT(I4,0P2E16.7)
- 3 FORMAT(15H0SAMPLE PROBLEM/6H TRUE=,1PE16.7/
- X 6H CALC=,1PE16.7/6H ERR =,1PE11.2)
- END
- REAL FUNCTION FLOG(X)
- REAL X
- FLOG = -1.E0/(1.E0+X)
- RETURN
- END
diff --git a/CEP/PyBDSM/src/port3/ex/qgsr.f b/CEP/PyBDSM/src/port3/ex/qgsr.f
deleted file mode 100644
index 8e84b84567f09703163c1943ef22cf355f7da5a0..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ex/qgsr.f
+++ /dev/null
@@ -1,34 +0,0 @@
-C$TEST QGSR
-C TO RUN AS A MAIN PROGRAM REMOVE NEXT LINE
- SUBROUTINE QGSR
-C***********************************************************************
-C
-C EXAMPLE OF USE OF THE PORT PROGRAM GQXA
-C
-C***********************************************************************
- REAL X(5),W(5),FXA,CALC,TRUE,B(1),PI2,ERR
-C
- CALL GQXA(5,-0.5E0,X,W)
- IWRITE = I1MACH(2)
- WRITE(IWRITE,1)
- DO 10 J=1,5
- 10 WRITE(IWRITE,2) J, X(J),W(J)
- CALC = 0.E0
- DO 20 J=1,5
- 20 CALC = CALC+W(J)*FXA(X(J))
- CALL BESRJ(1.E0,1,B)
- PI2 = ATAN2(1.E0,0.E0)
- TRUE = PI2*B(1)
- ERR = TRUE-CALC
- WRITE(IWRITE,3) TRUE,CALC,ERR
- STOP
- 1 FORMAT(///14H TEST OF GQXA//30H0ABSCISSAS AND WEIGHTS FOR N=5)
- 2 FORMAT(I4,0P2E16.7)
- 3 FORMAT(15H0SAMPLE PROBLEM/6H TRUE=,1PE16.7/
- X 6H CALC=,1PE16.7/6H ERR =,1PE11.2)
- END
- REAL FUNCTION FXA(X)
- REAL X
- FXA=COS(1.E0-X)/SQRT(2.E0-X)
- RETURN
- END
diff --git a/CEP/PyBDSM/src/port3/ex/qgst.f b/CEP/PyBDSM/src/port3/ex/qgst.f
deleted file mode 100644
index b3c777fa74bcbd06268fbd0c14525b4a3045c46a..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ex/qgst.f
+++ /dev/null
@@ -1,33 +0,0 @@
-C$TEST QGST
-C TO RUN AS A MAIN PROGRAM REMOVE NEXT LINE
- SUBROUTINE QGST
-C***********************************************************************
-C
-C EXAMPLE OF USE OF THE PORT PROGRAM GQXAB
-C
-C***********************************************************************
- REAL X(5),W(5),FXAB,CALC,TRUE,PI,ERR
-C
- CALL GQXAB(5,-0.5E0,0.5E0,X,W)
- IWRITE=I1MACH(2)
- WRITE(IWRITE,1)
- DO 10 J=1,5
- 10 WRITE(IWRITE,2) J, X(J),W(J)
- CALC = 0.E0
- DO 20 J=1,5
- 20 CALC = CALC+W(J)*FXAB(X(J))
- PI = 2.E0*ATAN2(1.E0,0.E0)
- TRUE = PI*(1.E0-1.E0/SQRT(3.E0))
- ERR = TRUE - CALC
- WRITE(IWRITE,3) TRUE,CALC,ERR
- STOP
- 1 FORMAT(///15H TEST OF GQXAB//30H0ABSCISSAS AND WEIGHTS FOR N=5)
- 2 FORMAT(I4,0P2E16.7)
- 3 FORMAT(15H0SAMPLE PROBLEM/6H TRUE=,1PE16.7/
- X 6H CALC=,1PE16.7/6H ERR =,1PE11.2)
- END
- REAL FUNCTION FXAB(X)
- REAL X
- FXAB = 1.E0/(2.E0+X)
- RETURN
- END
diff --git a/CEP/PyBDSM/src/port3/ex/qodd.f b/CEP/PyBDSM/src/port3/ex/qodd.f
deleted file mode 100644
index 68ccdcaffc412f3ac1c985ab97e233e4a1b2ee92..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ex/qodd.f
+++ /dev/null
@@ -1,68 +0,0 @@
-C$TEST QODD
-C TO RUN AS A MAIN PROGRAM REMOVE NEXT LINE
- SUBROUTINE QODD
-C***********************************************************************
-C
-C EXAMPLE OF USE OF THE PORT PROGRAM DODEQ
-C
-C***********************************************************************
-C
- EXTERNAL F
-C
- INTEGER I1MACH,K,IWRITE
- DOUBLE PRECISION TWOPI,EM1,ANS(10),EPS
- DOUBLE PRECISION CHK1,CHK2,DK,DTEMP
- DOUBLE PRECISION DATAN, DEXP, DSIN, DCOSP
-C
-C INITIALIZE 2*PI AND EXP - 1
-C
- TWOPI = 8.0D0*DATAN(1.0D0)
- EM1 = DEXP(1.0D0) - 1.0D0
-C
-C SET OUTPUT WRITE UNIT
-C
- IWRITE = I1MACH(2)
-C
-C SET ACCURACY PARAMETER
-C
- EPS = 1.0D-10
-C
- WRITE(IWRITE,97) EPS
- 97 FORMAT(11H FOR EPS = ,1PD10.2,21H THE COEFFICIENTS ARE)
- WRITE(IWRITE,98)
- 98 FORMAT(/7X,1HK,11X,9HSIN COEFF,16X,9HCOS COEFF,10X,9HMAX ERROR)
-C
- CALL DODEQ(10,F,0.0D0,1.0D0,EPS,ANS)
-C
- DO 10 K=1,5
- DK=K
- DTEMP = 1.D0 + (TWOPI*DK)**2
- CHK1 = TWOPI*DK*(-EM1)/DTEMP - ANS(2*K-1)
- CHK2 = EM1/DTEMP - ANS(2*K)
-C
- DTEMP = DMAX1( DABS(CHK1), DABS(CHK2) )
-C
- 10 WRITE(IWRITE,99) K, ANS(2*K-1), ANS(2*K), DTEMP
- 99 FORMAT (1H0,2X,I5,2D25.14,1PD15.4)
- STOP
- END
- SUBROUTINE F(X,Y,N,FVAL)
-C
- INTEGER J, N
- DOUBLE PRECISION TWOPI,X,Y,EXPX,ANGL,FVAL(10)
-C
-C INITIALIZE 2*PI AND E**X
-C
- TWOPI = 8.0D0*DATAN(1.0D0)
- EXPX = DEXP(X)
-C
-C COMPUTE THE TWO INTEGRANDS, E**X * SIN AND E**X * COS,
-C
- DO 20 J=1,5
- ANGL = J
- ANGL = TWOPI*ANGL*X
- FVAL(2*J-1) = EXPX*DSIN(ANGL)
- 20 FVAL(2*J) = EXPX*DCOS(ANGL)
-C
- RETURN
- END
diff --git a/CEP/PyBDSM/src/port3/ex/qpra.f b/CEP/PyBDSM/src/port3/ex/qpra.f
deleted file mode 100644
index cff2bb1685095d36b8a27040425eec5799089068..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ex/qpra.f
+++ /dev/null
@@ -1,80 +0,0 @@
-C$TEST QPRA
-C TO RUN AS A MAIN PROGRAM REMOVE NEXT LINE
- SUBROUTINE QPRA
-C***********************************************************************
-C
-C EXAMPLE OF USE OF THE PORT PROGRAM IQP
-C
-C***********************************************************************
-C TEST PROGRAM FOR IQP
- REAL X(10), Q(10,10), A(10,10), BL(10), BU(10)
- REAL C(10), B(10)
- REAL SUM(10), FUNCT
- INTEGER N, I, J, IPRINT, MAXITR, IQ, M, IA
- INTEGER IEQ
- DOUBLE PRECISION DSTAK(2000)
- COMMON /CSTAK/DSTAK
-C
- IWRITE = I1MACH(2)
- CALL ISTKIN(2000,4)
- N = 4
- M = 3
-C SET UP INITIAL GUESS AND QUADRATIC FUNCTION
- DO 1 I=1,N
- X(I) = I + 1.
- C(I) = 8. - I
- DO 2 J=1,N
- Q(I,J) = FLOAT(IABS(I-J))
- 2 CONTINUE
- Q(I,I) = 1.69
-C SET UP GENERAL CONSTRAINTS
- DO 16 J=1,M
- A(J,I) = 0.
- 16 CONTINUE
- 1 CONTINUE
- DO 3 I=1,M
- B(I) = -1. - (I - 1.) * .05
- A(I,I) = -1.
- A(I,I+1) = 1.
- 3 CONTINUE
- IQ = 10
- IA = 10
- IEQ = 1
-C SET UP SIMPLE CONSTRAINTS
- DO 4 I=1,N
- BL(I) = -I - (I - 1.) * .1
- BU(I) = I
- 4 CONTINUE
-C GET MACHINE INFINITY FROM PORT
- BU(1) = R1MACH(2)
- IPRINT = 1
- MAXITR = 3*N
-C CALL THE QUADRATIC PROGRAMMING PACKAGE
- CALL IQP(N, X, Q, IQ, C, M, A, IA, B, BL, BU, IPRINT,
- 1 MAXITR, IEQ)
-C COMPUTE FINAL FUNCTION VALUE
- DO 6 J=1,N
- SUM(J) = X(J) * Q(J,J)
- 6 CONTINUE
- DO 7 I=2,N
- DO 9 J=1,I-1
- SUM(I) = SUM(I) + X(J)*Q(J,I)
- SUM(J) = SUM(J) + X(I)*Q(J,I)
- 9 CONTINUE
- 7 CONTINUE
- FUNCT = 0.
- DO 10 I=1,N
- FUNCT = SUM(I) * X(I)/2. + FUNCT + C(I) * X(I)
- 10 CONTINUE
- WRITE (IWRITE,1000)
- 1000 FORMAT (16H FINAL SOLUTION:)
- DO 11 I=1,N
- WRITE (IWRITE, 1001) I, X(I)
- 1001 FORMAT (I5,D14.4)
- 11 CONTINUE
- WRITE (IWRITE,1002)
- 1002 FORMAT (22H FINAL FUNCTION VALUE:)
- WRITE (IWRITE,1003) FUNCT
- 1003 FORMAT (D14.4)
- STOP
- END
diff --git a/CEP/PyBDSM/src/port3/ex/ranc.f b/CEP/PyBDSM/src/port3/ex/ranc.f
deleted file mode 100644
index e176bf886a44ab7ab70bd4a4a34e107511999aca..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ex/ranc.f
+++ /dev/null
@@ -1,38 +0,0 @@
-C$TEST RANC
-C TO RUN AS A MAIN PROGRAM REMOVE NEXT LINE
- SUBROUTINE RANC
-C***********************************************************************
-C
-C EXAMPLE OF USE OF THE PORT PROGRAM RANBYT
-C
-C***********************************************************************
- INTEGER IBYTE(4),IWRITE,I1MACH,K
- REAL R,RAND,UNI
-C
-C SET THE CORRECT OUTPUT UNIT
-C
- IWRITE = I1MACH(2)
-C
-C PRINT OUT THE FIRST FIVE UNIFORM RANDOM VARIATES
-C
- DO 1 K = 1,5
- RAND = UNI(0)
- 1 WRITE (IWRITE, 9997) RAND
- 9997 FORMAT(1H , E15.8)
-C
-C NOW RESET TO THE ORIGINAL SEEDS
-C AND SEE HOW THE VARIATES LOOK AS BIT PATTERNS
-C (WRITTEN IN OCTAL WITH INTEGER VALUES GIVEN UNDERNEATH)
-C
- CALL RANSET(12345,1073)
- DO 2 K = 1,5
- CALL RANBYT(R,IBYTE)
- WRITE (IWRITE, 9998) R, IBYTE
- 9998 FORMAT(1H0, E15.8, 4(3X, O3))
-C
- WRITE(IWRITE, 9999) IBYTE
- 9999 FORMAT(16X, 4(3X, I3))
- 2 CONTINUE
-C
- STOP
- END
diff --git a/CEP/PyBDSM/src/port3/ex/rnrm.f b/CEP/PyBDSM/src/port3/ex/rnrm.f
deleted file mode 100644
index 77f4047374d8cf045a52335ba3e152b9d5af658a..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ex/rnrm.f
+++ /dev/null
@@ -1,21 +0,0 @@
-C$TEST RNRM
-C TO RUN AS A MAIN PROGRAM REMOVE NEXT LINE
- SUBROUTINE RNRM
-C***********************************************************************
-C
-C EXAMPLE OF USE OF THE PORT PROGRAM RNORM
-C
-C***********************************************************************
-C RNORM - FIRST 10 RANDOM DEVIATES
-C
- REAL X
- IWRITE = I1MACH(2)
-C
- DO 10 K=1,10
- X = RNORM(0)
- WRITE (IWRITE,99) X
- 99 FORMAT(1H ,F11.8)
- 10 CONTINUE
-C
- STOP
- END
diff --git a/CEP/PyBDSM/src/port3/ex/rpad.f b/CEP/PyBDSM/src/port3/ex/rpad.f
deleted file mode 100644
index 2ac80dbb96d5b9605e0d0703a0498c7daf89c768..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ex/rpad.f
+++ /dev/null
@@ -1,25 +0,0 @@
-C$TEST RPAD
-C TO RUN AS A MAIN PROGRAM REMOVE NEXT LINE
- SUBROUTINE RPAD
-C***********************************************************************
-C
-C EXAMPLE OF USE OF THE PORT PROGRAM DRPOLY
-C
-C***********************************************************************
- INTEGER IWRITE,I1MACH,K
- DOUBLE PRECISION COEFF(6), ZR(5), ZI(5)
-C
- COEFF(1) = 8.D0
- COEFF(2) = -84.D0
- COEFF(3) = 9.D0
- COEFF(4) = - 589.D0
- COEFF(5) = 331.D0
- COEFF(6) = -2915.D0
-C
- CALL DRPOLY( 5, COEFF, ZR, ZI )
-C
- IWRITE = I1MACH(2)
- WRITE(IWRITE,99) (ZR(K),ZI(K),K = 1,5)
- 99 FORMAT(1H0,1P2E27.18)
- STOP
- END
diff --git a/CEP/PyBDSM/src/port3/ex/sdba.f b/CEP/PyBDSM/src/port3/ex/sdba.f
deleted file mode 100644
index 310c072d85350b80dbe0aa40e4440516c8b7252e..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ex/sdba.f
+++ /dev/null
@@ -1,56 +0,0 @@
-C$TEST SDBA
-C TO RUN AS A MAIN PROGRAM REMOVE NEXT LINE
- SUBROUTINE SDBA
-C***********************************************************************
-C
-C EXAMPLE OF USE OF THE PORT PROGRAM DL2SF
-C
-C***********************************************************************
- INTEGER I,I1MACH,IWRITE,K,N,NT
- REAL X(51),Y(51),T(100),A(100),
- 1 XCHECK(101),YCHECK(101,2),ERR(2)
-C
- K = 4
-C
-C MAKE THE ABSCISSAE FOR THE FIT.
-C
- CALL UMD(0.0E0,3.14E0,51,X)
-C
-C MAKE THE DATA.
-C
- DO 1000 I = 1, 51
- Y(I) = SIN(X(I))
- 1000 CONTINUE
-C
-C MAKE THE CHECK POINTS
-C
- CALL UMD(X(1),X(51),101,XCHECK)
-C
-C MAKE THE MESH.
-C
- N = 2
-C
- CALL MNPB(X,51,N,K,T,NT)
-C
-C DO THE FIT.
-C
- CALL DL2SF(X,Y,51,K,T,NT,A)
-C
-C EVALUATE THE ERROR IN THE FIT AND ITS DERIVATIVES
-C AT THE CHECK POINTS
-C
- CALL SPLND(K,T,NT,A,XCHECK,101,2,YCHECK)
-C
- CALL SETR(2,0.0E0,ERR)
- DO 1001 I = 1, 101
- ERR(1) = AMAX1(ERR(1),ABS(YCHECK(I,1)-SIN(XCHECK(I))))
- ERR(2) = AMAX1(ERR(2),ABS(YCHECK(I,2)-COS(XCHECK(I))))
- 1001 CONTINUE
-C
- IWRITE = I1MACH(2)
- WRITE(IWRITE,1006) ERR(1),ERR(2)
- 1006 FORMAT(9H ERROR = ,2E10.2)
-C
- STOP
-C
- END
diff --git a/CEP/PyBDSM/src/port3/ex/splf.f b/CEP/PyBDSM/src/port3/ex/splf.f
deleted file mode 100644
index bba3314e9da4983a80928bb448a17f901f99b29f..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ex/splf.f
+++ /dev/null
@@ -1,47 +0,0 @@
-C$TEST SPLF
-C TO RUN AS A MAIN PROGRAM REMOVE NEXT LINE
- SUBROUTINE SPLF
-C***********************************************************************
-C
-C EXAMPLE OF USE OF THE PORT PROGRAM SPLNI
-C
-C***********************************************************************
- INTEGER K,I,N,IWRITE,I1MACH,NT
- REAL X(51),Y(51),T(100),A(100),SINT,TINT
-C
- K = 4
-C
-C MAKE THE ABSCISSAE FOR THE FIT.
-C
- CALL UMD(0.0E0,3.14E0,51,X)
-C
-C MAKE THE DATA.
-C
- DO 1000 I = 1, 51
- Y(I) = SIN(X(I))
- 1000 CONTINUE
-C
-C MAKE THE MESH.
-C
- N = 2
-C
- CALL MNPB(X,51,N,K,T,NT)
-C
-C DO THE FIT.
-C
- CALL DL2SF(X,Y,51,K,T,NT,A)
-C
-C EVALUATE THE SPLINE INTEGRAL AND THE TRUE INTEGRAL.
-C
- CALL SPLNI(K,T,NT,A,T(NT),1,SINT)
-C
- TINT = 1.0E0-COS(3.14E0)
-C
- IWRITE = I1MACH(2)
- WRITE(IWRITE,1003) SINT,TINT
- 1003 FORMAT(18H SPLINE INTEGRAL =,E20.8//
- 1 18H TRUE INTEGRAL =,E20.8)
-C
- STOP
-C
- END
diff --git a/CEP/PyBDSM/src/port3/ex/ttg1.f b/CEP/PyBDSM/src/port3/ex/ttg1.f
deleted file mode 100644
index 416273802d5f533f334f18231c0a711587c18c76..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ex/ttg1.f
+++ /dev/null
@@ -1,194 +0,0 @@
-C$TEST TTG1
-C TO RUN AS A MAIN PROGRAM REMOVE NEXT LINE
- SUBROUTINE TTG1
-C***********************************************************************
-C
-C EXAMPLE OF USE OF PORT PROGRAM TTGR
-C
-C***********************************************************************
- COMMON /CSTAK/ DS
- DOUBLE PRECISION DS(350000)
- EXTERNAL HANDLE, BC, AF
- INTEGER NDX, NDY, ISTKGT, IUMB, IS(1000), IU
- INTEGER IX, IY, NU, KX, NX, KY
- INTEGER NY
- REAL ERRPAR(2), TSTART, DT, LX, LY, RX
- REAL RY, WS(1000), RS(1000), TSTOP
- LOGICAL LS(1000)
- COMPLEX CS(500)
- EQUIVALENCE (DS(1), CS(1), WS(1), RS(1), IS(1), LS(1))
-C TO SOLVE THE HEAT EQUATION WITH SOLUTION U == T*X*Y,
-C GRAD . ( U + UX + .1 * UY, U + UY + .1 * UX ) = UT + UX + UY +G(X,T)
-C THE PORT LIBRARY STACK AND ITS ALIASES.
-C INITIALIZE THE PORT LIBRARY STACK LENGTH.
- CALL ISTKIN(350000, 4)
- CALL ENTER(1)
- NU = 1
- LX = 0
- RX = 1
- LY = 0
- RY = 1
- KX = 2
- KY = 2
- NDX = 3
- NDY = 3
- TSTART = 0
- TSTOP = 1
- DT = 1
- ERRPAR(1) = 1E-2
- ERRPAR(2) = 1E-4
-C UNIFORM GRID.
- IX = IUMB(LX, RX, NDX, KX, NX)
-C UNIFORM GRID.
- IY = IUMB(LY, RY, NDY, KY, NY)
-C SPACE FOR THE SOLUTION.
- IU = ISTKGT(NU*(NX-KX)*(NY-KY), 3)
-C INITIAL CONDITIONS FOR U.
- CALL SETR(NU*(NX-KX)*(NY-KY), 0E0, WS(IU))
- CALL TTGR(WS(IU), NU, KX, WS(IX), NX, KY, WS(IY), NY, TSTART,
- 1 TSTOP, DT, AF, BC, ERRPAR, HANDLE)
- CALL LEAVE
- CALL WRAPUP
- STOP
- END
- SUBROUTINE AF(T, X, NX, Y, NY, NU, U, UT, UX, UY, UXT, UYT
- 1 , A, AU, AUT, AUX, AUY, AUXT, AUYT, F, FU, FUT, FUX, FUY, FUXT,
- 2 FUYT)
- INTEGER NU, NX, NY
- REAL T, X(NX), Y(NY), U(NX, NY, NU), UT(NX, NY, NU), UX(NX, NY,
- 1 NU)
- REAL UY(NX, NY, NU), UXT(NX, NY, NU), UYT(NX, NY, NU), A(NX, NY,
- 1 NU, 2), AU(NX, NY, NU, NU, 2), AUT(NX, NY, NU, NU, 2)
- REAL AUX(NX, NY, NU, NU, 2), AUY(NX, NY, NU, NU, 2), AUXT(NX, NY
- 1 , NU, NU, 2), AUYT(NX, NY, NU, NU, 2), F(NX, NY, NU), FU(NX,
- 2 NY, NU, NU)
- REAL FUT(NX, NY, NU, NU), FUX(NX, NY, NU, NU), FUY(NX, NY, NU, NU)
- 1 , FUXT(NX, NY, NU, NU), FUYT(NX, NY, NU, NU)
- INTEGER I, P, Q
- DO 3 I = 1, NU
- DO 2 Q = 1, NY
- DO 1 P = 1, NX
- A(P, Q, I, 1) = UX(P, Q, I)+.1*UY(P, Q, I)+U(P, Q, I)
- A(P, Q, I, 2) = UY(P, Q, I)+.1*UX(P, Q, I)+U(P, Q, I)
- AUX(P, Q, I, I, 1) = 1
- AUY(P, Q, I, I, 2) = 1
- AUY(P, Q, I, I, 1) = .1
- AUX(P, Q, I, I, 2) = .1
- AU(P, Q, I, I, 1) = 1
- AU(P, Q, I, I, 2) = 1
- F(P, Q, I) = UT(P, Q, I)+UX(P, Q, I)+UY(P, Q, I)
- FUT(P, Q, I, I) = 1
- FUX(P, Q, I, I) = 1
- FUY(P, Q, I, I) = 1
- F(P, Q, I) = F(P, Q, I)+.2*T-X(P)*Y(Q)
- 1 CONTINUE
- 2 CONTINUE
- 3 CONTINUE
- RETURN
- END
- SUBROUTINE BC(T, X, NX, Y, NY, LX, RX, LY, RY, U, UT, UX,
- 1 UY, UXT, UYT, NU, B, BU, BUT, BUX, BUY, BUXT, BUYT)
- INTEGER NU, NX, NY
- REAL T, X(NX), Y(NY), LX, RX, LY
- REAL RY, U(NX, NY, NU), UT(NX, NY, NU), UX(NX, NY, NU), UY(NX, NY,
- 1 NU), UXT(NX, NY, NU)
- REAL UYT(NX, NY, NU), B(NX, NY, NU), BU(NX, NY, NU, NU), BUT(NX,
- 1 NY, NU, NU), BUX(NX, NY, NU, NU), BUY(NX, NY, NU, NU)
- REAL BUXT(NX, NY, NU, NU), BUYT(NX, NY, NU, NU)
- INTEGER I, J
- DO 2 J = 1, NY
- DO 1 I = 1, NX
- BU(I, J, 1, 1) = 1
- B(I, J, 1) = U(I, J, 1)-T*X(I)*Y(J)
- 1 CONTINUE
- 2 CONTINUE
- RETURN
- END
- SUBROUTINE HANDLE(T0, U0, T, U, NV, DT, TSTOP)
- INTEGER NV
- REAL T0, U0(NV), T, U(NV), DT, TSTOP
- COMMON /A7TGRP/ ERRPAR, NU, MXQ, MYQ
- INTEGER NU, MXQ, MYQ
- REAL ERRPAR(2)
- COMMON /A7TGRM/ KX, IX, NX, KY, IY, NY
- INTEGER KX, IX, NX, KY, IY, NY
- IF (T0 .NE. T) GOTO 2
- WRITE (6, 1) T
- 1 FORMAT (16H RESTART FOR T =, 1PE10.2)
- RETURN
-C GET AND PRINT THE ERROR.
- 2 CALL GERR(KX, IX, NX, KY, IY, NY, U, NU, T)
- RETURN
- END
- SUBROUTINE GERR(KX, IX, NX, KY, IY, NY, U, NU, T)
- INTEGER KX, IX, NX, KY, IY, NY
- INTEGER NU
- REAL U(1), T
- COMMON /CSTAK/ DS
- DOUBLE PRECISION DS(500)
- INTEGER IFA, ITA(2), IXA(2), NTA(2), NXA(2), IXS
- INTEGER IYS, NXS, NYS, ISTKGT, I, IEWE
- INTEGER KA(2), MA(2), IS(1000), ILUMD, I1MACH
- REAL ABS, ERRU, AMAX1, RS(1000), WS(1000)
- LOGICAL LS(1000)
- COMPLEX CS(500)
- INTEGER TEMP, TEMP1, TEMP2
- EQUIVALENCE (DS(1), CS(1), WS(1), RS(1), IS(1), LS(1))
-C TO GET AND PRINT THE ERROR AT EACH TIME-STEP.
-C U(NX-KX,NY0KY,NU).
-C THE PORT LIBRARY STACK AND ITS ALIASES.
- CALL ENTER(1)
-C FIND THE ERROR IN THE SOLUTION AT 2*KX * 2*KY POINTS / MESH RECTANGLE.
-C X SEARCH GRID.
- IXS = ILUMD(WS(IX), NX, 2*KX, NXS)
-C Y SEARCH GRID.
- IYS = ILUMD(WS(IY), NY, 2*KY, NYS)
-C U SEARCH GRID VALUES.
- IEWE = ISTKGT(NXS*NYS, 3)
-C THE EXACT SOLUTION.
- CALL EWE(T, WS(IXS), NXS, WS(IYS), NYS, WS(IEWE), NU)
- KA(1) = KX
- KA(2) = KY
- ITA(1) = IX
- ITA(2) = IY
- NTA(1) = NX
- NTA(2) = NY
- IXA(1) = IXS
- IXA(2) = IYS
- NXA(1) = NXS
- NXA(2) = NYS
- MA(1) = 0
-C GET SOLUTION.
- MA(2) = 0
-C APPROXIMATE SOLUTION VALUES.
- IFA = ISTKGT(NXS*NYS, 3)
-C EVALUATE THEM.
- CALL TSD1(2, KA, WS, ITA, NTA, U, WS, IXA, NXA, MA, WS(IFA))
-C ERROR IN SOLUTION VALUES.
- ERRU = 0
- TEMP = NXS*NYS
- DO 1 I = 1, TEMP
- TEMP2 = IEWE+I
- TEMP1 = IFA+I
- ERRU = AMAX1(ERRU, ABS(WS(TEMP2-1)-WS(TEMP1-1)))
- 1 CONTINUE
- TEMP = I1MACH(2)
- WRITE (TEMP, 2) T, ERRU
- 2 FORMAT (14H ERROR IN U(.,, 1PE10.2, 3H) =, 1PE10.2)
- CALL LEAVE
- RETURN
- END
- SUBROUTINE EWE(T, X, NX, Y, NY, U, NU)
- INTEGER NU, NX, NY
- REAL T, X(NX), Y(NY), U(NX, NY, NU)
- INTEGER I, J, P
-C THE EXACT SOLUTION.
- DO 3 P = 1, NU
- DO 2 I = 1, NX
- DO 1 J = 1, NY
- U(I, J, P) = T*X(I)*Y(J)
- 1 CONTINUE
- 2 CONTINUE
- 3 CONTINUE
- RETURN
- END
diff --git a/CEP/PyBDSM/src/port3/ex/ttg2.f b/CEP/PyBDSM/src/port3/ex/ttg2.f
deleted file mode 100644
index aaee1bdcfff13c2f563ed6819a261896f9a8f781..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ex/ttg2.f
+++ /dev/null
@@ -1,198 +0,0 @@
-C$TEST TTG2
-C TO RUN AS A MAIN PROGRAM REMOVE NEXT LINE
- SUBROUTINE TTG2
-C***********************************************************************
-C
-C EXAMPLE OF USE OF PORT PROGRAM TTGR
-C
-C***********************************************************************
- COMMON /CSTAK/ DS
- DOUBLE PRECISION DS(350000)
- EXTERNAL HANDLE, BC, AF
- INTEGER NDX, NDY, ISTKGT, IUMB, IS(1000), IU
- INTEGER IX, IY, NU, KX, NX, KY
- INTEGER NY
- REAL ERRPAR(2), TSTART, DT, LX, LY, RX
- REAL RY, WS(1000), RS(1000), TSTOP
- LOGICAL LS(1000)
- COMPLEX CS(500)
- EQUIVALENCE (DS(1), CS(1), WS(1), RS(1), IS(1), LS(1))
-C TO SOLVE TWO COUPLED, NONLINEAR HEAT EQUATIONS.
-C U1 SUB T = DIV . ( U1X, U1Y ) - U1*U2 + G1
-C U2 SUB T = DIV . ( U2X, U2Y ) - U1*U2 + G2
-C THE PORT LIBRARY STACK AND ITS ALIASES.
-C INITIALIZE THE PORT LIBRARY STACK LENGTH.
- CALL ISTKIN(350000, 4)
- CALL ENTER(1)
- NU = 2
- LX = 0
- RX = 1
- LY = 0
- RY = 1
- KX = 4
- KY = 4
- NDX = 3
- NDY = 3
- TSTART = 0
- TSTOP = 1
- DT = 1E-2
- ERRPAR(1) = 1E-2
- ERRPAR(2) = 1E-4
-C UNIFORM GRID.
- IX = IUMB(LX, RX, NDX, KX, NX)
-C UNIFORM GRID.
- IY = IUMB(LY, RY, NDY, KY, NY)
-C SPACE FOR THE SOLUTION.
- IU = ISTKGT(NU*(NX-KX)*(NY-KY), 3)
- CALL SETR(NU*(NX-KX)*(NY-KY), 1E0, WS(IU))
- CALL TTGR(WS(IU), NU, KX, WS(IX), NX, KY, WS(IY), NY, TSTART,
- 1 TSTOP, DT, AF, BC, ERRPAR, HANDLE)
- CALL LEAVE
- CALL WRAPUP
- STOP
- END
- SUBROUTINE AF(T, X, NX, Y, NY, NU, U, UT, UX, UY, UXT, UYT
- 1 , A, AU, AUT, AUX, AUY, AUXT, AUYT, F, FU, FUT, FUX, FUY, FUXT,
- 2 FUYT)
- INTEGER NU, NX, NY
- REAL T, X(NX), Y(NY), U(NX, NY, NU), UT(NX, NY, NU), UX(NX, NY,
- 1 NU)
- REAL UY(NX, NY, NU), UXT(NX, NY, NU), UYT(NX, NY, NU), A(NX, NY,
- 1 NU, 2), AU(NX, NY, NU, NU, 2), AUT(NX, NY, NU, NU, 2)
- REAL AUX(NX, NY, NU, NU, 2), AUY(NX, NY, NU, NU, 2), AUXT(NX, NY
- 1 , NU, NU, 2), AUYT(NX, NY, NU, NU, 2), F(NX, NY, NU), FU(NX,
- 2 NY, NU, NU)
- REAL FUT(NX, NY, NU, NU), FUX(NX, NY, NU, NU), FUY(NX, NY, NU, NU)
- 1 , FUXT(NX, NY, NU, NU), FUYT(NX, NY, NU, NU)
- INTEGER P, Q
- REAL EXP
- DO 2 Q = 1, NY
- DO 1 P = 1, NX
- A(P, Q, 1, 1) = UX(P, Q, 1)
- AUX(P, Q, 1, 1, 1) = 1
- A(P, Q, 1, 2) = UY(P, Q, 1)
- AUY(P, Q, 1, 1, 2) = 1
- F(P, Q, 1) = UT(P, Q, 1)+U(P, Q, 1)*U(P, Q, 2)
- FU(P, Q, 1, 1) = U(P, Q, 2)
- FU(P, Q, 1, 2) = U(P, Q, 1)
- FUT(P, Q, 1, 1) = 1
- A(P, Q, 2, 1) = UX(P, Q, 2)
- AUX(P, Q, 2, 2, 1) = 1
- A(P, Q, 2, 2) = UY(P, Q, 2)
- AUY(P, Q, 2, 2, 2) = 1
- F(P, Q, 2) = UT(P, Q, 2)+U(P, Q, 1)*U(P, Q, 2)
- FU(P, Q, 2, 1) = U(P, Q, 2)
- FU(P, Q, 2, 2) = U(P, Q, 1)
- FUT(P, Q, 2, 2) = 1
- F(P, Q, 1) = F(P, Q, 1)-(EXP(T*(X(P)-Y(Q)))*(X(P)-Y(Q)-2.*T*
- 1 T)+1.)
- F(P, Q, 2) = F(P, Q, 2)-(EXP(T*(Y(Q)-X(P)))*(Y(Q)-X(P)-2.*T*
- 1 T)+1.)
- 1 CONTINUE
- 2 CONTINUE
- RETURN
- END
- SUBROUTINE BC(T, X, NX, Y, NY, LX, RX, LY, RY, U, UT, UX,
- 1 UY, UXT, UYT, NU, B, BU, BUT, BUX, BUY, BUXT, BUYT)
- INTEGER NU, NX, NY
- REAL T, X(NX), Y(NY), LX, RX, LY
- REAL RY, U(NX, NY, NU), UT(NX, NY, NU), UX(NX, NY, NU), UY(NX, NY,
- 1 NU), UXT(NX, NY, NU)
- REAL UYT(NX, NY, NU), B(NX, NY, NU), BU(NX, NY, NU, NU), BUT(NX,
- 1 NY, NU, NU), BUX(NX, NY, NU, NU), BUY(NX, NY, NU, NU)
- REAL BUXT(NX, NY, NU, NU), BUYT(NX, NY, NU, NU)
- INTEGER I, J
- REAL EXP
- DO 2 J = 1, NY
- DO 1 I = 1, NX
- BU(I, J, 1, 1) = 1
- B(I, J, 1) = U(I, J, 1)-EXP(T*(X(I)-Y(J)))
- BU(I, J, 2, 2) = 1
- B(I, J, 2) = U(I, J, 2)-EXP(T*(Y(J)-X(I)))
- 1 CONTINUE
- 2 CONTINUE
- RETURN
- END
- SUBROUTINE HANDLE(T0, U0, T, U, NV, DT, TSTOP)
- INTEGER NV
- REAL T0, U0(NV), T, U(NV), DT, TSTOP
- COMMON /CSTAK/ DS
- DOUBLE PRECISION DS(500)
- COMMON /A7TGRP/ ERRPAR, NU, MXQ, MYQ
- INTEGER NU, MXQ, MYQ
- REAL ERRPAR(2)
- COMMON /A7TGRM/ KX, IX, NX, KY, IY, NY
- INTEGER KX, IX, NX, KY, IY, NY
- INTEGER IFA, ITA(2), IXA(2), NTA(2), NXA(2), IXS
- INTEGER IYS, NXS, NYS, ISTKGT, I, J
- INTEGER IEWE, KA(2), MA(2), IS(1000), ILUMD, I1MACH
- REAL ABS, ERRU, AMAX1, RS(1000), WS(1000)
- LOGICAL LS(1000)
- COMPLEX CS(500)
- INTEGER TEMP, TEMP1, TEMP2
- EQUIVALENCE (DS(1), CS(1), WS(1), RS(1), IS(1), LS(1))
-C THE PORT LIBRARY STACK AND ITS ALIASES.
- IF (T0 .NE. T) GOTO 2
- WRITE (6, 1) T
- 1 FORMAT (16H RESTART FOR T =, 1PE10.2)
- RETURN
- 2 CALL ENTER(1)
-C FIND THE ERROR IN THE SOLUTION AT 2*KX * 2*KY POINTS / MESH RECTANGLE.
-C X SEARCH GRID.
- IXS = ILUMD(WS(IX), NX, 2*KX, NXS)
-C Y SEARCH GRID.
- IYS = ILUMD(WS(IY), NY, 2*KY, NYS)
-C U SEARCH GRID VALUES.
- IEWE = ISTKGT(NU*NXS*NYS, 3)
-C THE EXACT SOLUTION.
- CALL EWE(T, WS(IXS), NXS, WS(IYS), NYS, WS(IEWE), NU)
- KA(1) = KX
- KA(2) = KY
- ITA(1) = IX
- ITA(2) = IY
- NTA(1) = NX
- NTA(2) = NY
- IXA(1) = IXS
- IXA(2) = IYS
- NXA(1) = NXS
- NXA(2) = NYS
- MA(1) = 0
-C GET SOLUTION.
- MA(2) = 0
-C APPROXIMATE SOLUTION VALUES.
- IFA = ISTKGT(NXS*NYS, 3)
- DO 5 J = 1, NU
-C EVALUATE THEM.
- TEMP = (J-1)*(NX-KX)*(NY-KY)
- CALL TSD1(2, KA, WS, ITA, NTA, U(TEMP+1), WS, IXA, NXA, MA, WS(
- 1 IFA))
-C ERROR IN SOLUTION VALUES.
- ERRU = 0
- TEMP = NXS*NYS
- DO 3 I = 1, TEMP
- TEMP2 = IEWE+I-1+(J-1)*NXS*NYS
- TEMP1 = IFA+I
- ERRU = AMAX1(ERRU, ABS(WS(TEMP2)-WS(TEMP1-1)))
- 3 CONTINUE
- TEMP = I1MACH(2)
- WRITE (TEMP, 4) T, J, ERRU
- 4 FORMAT (14H ERROR IN U(.,, 1PE10.2, 1H,, I2, 3H) =, 1PE10.2)
- 5 CONTINUE
- CALL LEAVE
- RETURN
- END
- SUBROUTINE EWE(T, X, NX, Y, NY, U, NU)
- INTEGER NU, NX, NY
- REAL T, X(NX), Y(NY), U(NX, NY, NU)
- INTEGER I, J, P
- REAL EXP, FLOAT
-C THE EXACT SOLUTION.
- DO 3 P = 1, NU
- DO 2 I = 1, NX
- DO 1 J = 1, NY
- U(I, J, P) = EXP(FLOAT((-1)**(P+1))*T*(X(I)-Y(J)))
- 1 CONTINUE
- 2 CONTINUE
- 3 CONTINUE
- RETURN
- END
diff --git a/CEP/PyBDSM/src/port3/ex/ttg3.f b/CEP/PyBDSM/src/port3/ex/ttg3.f
deleted file mode 100644
index e11e38300b0866da59d02772c9796eeaa35a2bbf..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ex/ttg3.f
+++ /dev/null
@@ -1,232 +0,0 @@
-C$TEST TTG3
-C TO RUN AS A MAIN PROGRAM REMOVE NEXT LINE
- SUBROUTINE TTG3
-C***********************************************************************
-C
-C EXAMPLE OF USE OF PORT PROGRAM TTGR
-C
-C***********************************************************************
- COMMON /CSTAK/ DS
- DOUBLE PRECISION DS(350000)
- EXTERNAL HANDLE, BC, AF
- INTEGER NDX, NDY, ISTKGT, I, IUMB, IMMM
- INTEGER IS(1000), IU, IX, IY, NU, KX
- INTEGER NX, KY, NY, ILUMB
- REAL ERRPAR(2), TSTART, DT, YB(4), LX, RS(1000)
- REAL RX, WS(1000), TSTOP
- LOGICAL LS(1000)
- COMPLEX CS(500)
- EQUIVALENCE (DS(1), CS(1), WS(1), RS(1), IS(1), LS(1))
-C TO SOLVE THE LAYERED HEAT EQUATION, WITH KAPPA = 1, 1/2, 1/3,
-C DIV . ( KAPPA(X,Y) * GRAD U ) = UT + G
-C THE PORT LIBRARY STACK AND ITS ALIASES.
-C INITIALIZE THE PORT LIBRARY STACK LENGTH.
- CALL ISTKIN(350000, 4)
- CALL ENTER(1)
- NU = 1
- LX = 0
- RX = 1
- DO 1 I = 1, 4
- YB(I) = I-1
- 1 CONTINUE
- KX = 2
- KY = 2
- NDX = 3
- NDY = 3
- TSTART = 0
- TSTOP = 1
- DT = 1
- ERRPAR(1) = 1E-2
- ERRPAR(2) = 1E-4
-C UNIFORM GRID.
- IX = IUMB(LX, RX, NDX, KX, NX)
-C UNIFORM GRID.
- IY = ILUMB(YB, 4, NDY, KY, NY)
-C MAKE MULT = KY-1.
- IY = IMMM(IY, NY, YB(2), KY-1)
-C MAKE MULT = KY-1.
- IY = IMMM(IY, NY, YB(3), KY-1)
-C SPACE FOR THE SOLUTION.
- IU = ISTKGT(NU*(NX-KX)*(NY-KY), 3)
- CALL SETR(NU*(NX-KX)*(NY-KY), 0E0, WS(IU))
- CALL TTGR(WS(IU), NU, KX, WS(IX), NX, KY, WS(IY), NY, TSTART,
- 1 TSTOP, DT, AF, BC, ERRPAR, HANDLE)
- CALL LEAVE
- CALL WRAPUP
- STOP
- END
- SUBROUTINE AF(T, X, NX, Y, NY, NU, U, UT, UX, UY, UXT, UYT
- 1 , A, AU, AUT, AUX, AUY, AUXT, AUYT, F, FU, FUT, FUX, FUY, FUXT,
- 2 FUYT)
- INTEGER NU, NX, NY
- REAL T, X(NX), Y(NY), U(NX, NY, NU), UT(NX, NY, NU), UX(NX, NY,
- 1 NU)
- REAL UY(NX, NY, NU), UXT(NX, NY, NU), UYT(NX, NY, NU), A(NX, NY,
- 1 NU, 2), AU(NX, NY, NU, NU, 2), AUT(NX, NY, NU, NU, 2)
- REAL AUX(NX, NY, NU, NU, 2), AUY(NX, NY, NU, NU, 2), AUXT(NX, NY
- 1 , NU, NU, 2), AUYT(NX, NY, NU, NU, 2), F(NX, NY, NU), FU(NX,
- 2 NY, NU, NU)
- REAL FUT(NX, NY, NU, NU), FUX(NX, NY, NU, NU), FUY(NX, NY, NU, NU)
- 1 , FUXT(NX, NY, NU, NU), FUYT(NX, NY, NU, NU)
- INTEGER I, P, Q
- REAL KAPPA
- LOGICAL TEMP
- DO 7 I = 1, NU
- DO 6 Q = 1, NY
- DO 5 P = 1, NX
- IF (Y(Q) .GE. 1.) GOTO 1
- KAPPA = 1
- GOTO 4
- 1 IF (Y(Q) .GE. 2.) GOTO 2
- KAPPA = 0.5
- GOTO 3
- 2 KAPPA = 1./3E0
- 3 CONTINUE
- 4 A(P, Q, I, 1) = KAPPA*UX(P, Q, I)
- AUX(P, Q, I, I, 1) = KAPPA
- A(P, Q, I, 2) = KAPPA*UY(P, Q, I)
- AUY(P, Q, I, I, 2) = KAPPA
- F(P, Q, I) = UT(P, Q, I)
- FUT(P, Q, I, I) = 1
- F(P, Q, I) = F(P, Q, I)-Y(Q)/KAPPA
- TEMP = 1. .LT. Y(Q)
- IF (TEMP) TEMP = Y(Q) .LT. 2.
- IF (TEMP) F(P, Q, I) = F(P, Q, I)+1.
- TEMP = 2. .LT. Y(Q)
- IF (TEMP) TEMP = Y(Q) .LT. 3.
- IF (TEMP) F(P, Q, I) = F(P, Q, I)+3.
- 5 CONTINUE
- 6 CONTINUE
- 7 CONTINUE
- RETURN
- END
- SUBROUTINE BC(T, X, NX, Y, NY, LX, RX, LY, RY, U, UT, UX,
- 1 UY, UXT, UYT, NU, B, BU, BUT, BUX, BUY, BUXT, BUYT)
- INTEGER NU, NX, NY
- REAL T, X(NX), Y(NY), LX, RX, LY
- REAL RY, U(NX, NY, NU), UT(NX, NY, NU), UX(NX, NY, NU), UY(NX, NY,
- 1 NU), UXT(NX, NY, NU)
- REAL UYT(NX, NY, NU), B(NX, NY, NU), BU(NX, NY, NU, NU), BUT(NX,
- 1 NY, NU, NU), BUX(NX, NY, NU, NU), BUY(NX, NY, NU, NU)
- REAL BUXT(NX, NY, NU, NU), BUYT(NX, NY, NU, NU)
- INTEGER I, J
- LOGICAL TEMP
- DO 6 J = 1, NY
- DO 5 I = 1, NX
- TEMP = X(I) .EQ. LX
- IF (.NOT. TEMP) TEMP = X(I) .EQ. RX
- IF (.NOT. TEMP) GOTO 1
- BUX(I, J, 1, 1) = 1
-C LEFT OR RIGHT.
-C NEUMANN BCS.
- B(I, J, 1) = UX(I, J, 1)
- GOTO 4
- 1 IF (Y(J) .NE. LY) GOTO 2
- B(I, J, 1) = U(I, J, 1)
-C BOTTOM.
- BU(I, J, 1, 1) = 1
- GOTO 3
- 2 B(I, J, 1) = U(I, J, 1)-6.*T
-C TOP.
- BU(I, J, 1, 1) = 1
- 3 CONTINUE
- 4 CONTINUE
- 5 CONTINUE
- 6 CONTINUE
- RETURN
- END
- SUBROUTINE HANDLE(T0, U0, T, U, NV, DT, TSTOP)
- INTEGER NV
- REAL T0, U0(NV), T, U(NV), DT, TSTOP
- COMMON /A7TGRP/ ERRPAR, NU, MXQ, MYQ
- INTEGER NU, MXQ, MYQ
- REAL ERRPAR(2)
- COMMON /A7TGRM/ KX, IX, NX, KY, IY, NY
- INTEGER KX, IX, NX, KY, IY, NY
- IF (T0 .NE. T) GOTO 2
- WRITE (6, 1) T
- 1 FORMAT (16H RESTART FOR T =, 1PE10.2)
- RETURN
- 2 CALL GERR(KX, IX, NX, KY, IY, NY, U, NU, T)
- RETURN
- END
- SUBROUTINE GERR(KX, IX, NX, KY, IY, NY, U, NU, T)
- INTEGER KX, IX, NX, KY, IY, NY
- INTEGER NU
- REAL U(1), T
- COMMON /CSTAK/ DS
- DOUBLE PRECISION DS(500)
- INTEGER IFA, ITA(2), IXA(2), NTA(2), NXA(2), IXS
- INTEGER IYS, NXS, NYS, ISTKGT, I, IEWE
- INTEGER KA(2), MA(2), IS(1000), ILUMD, I1MACH
- REAL ABS, ERRU, AMAX1, RS(1000), WS(1000)
- LOGICAL LS(1000)
- COMPLEX CS(500)
- INTEGER TEMP, TEMP1, TEMP2
- EQUIVALENCE (DS(1), CS(1), WS(1), RS(1), IS(1), LS(1))
-C TO GET AND PRINT THE ERROR AT EACH TIME-STEP.
-C U(NX-KX,NY,KY,NU).
-C THE PORT LIBRARY STACK AND ITS ALIASES.
- CALL ENTER(1)
-C FIND THE ERROR IN THE SOLUTION AT 2*KX * 2*KY POINTS / MESH RECTANGLE.
-C X SEARCH GRID.
- IXS = ILUMD(WS(IX), NX, 2*KX, NXS)
-C Y SEARCH GRID.
- IYS = ILUMD(WS(IY), NY, 2*KY, NYS)
-C U SEARCH GRID VALUES.
- IEWE = ISTKGT(NXS*NYS, 3)
-C THE EXACT SOLUTION.
- CALL EWE(T, WS(IXS), NXS, WS(IYS), NYS, WS(IEWE), NU)
- KA(1) = KX
- KA(2) = KY
- ITA(1) = IX
- ITA(2) = IY
- NTA(1) = NX
- NTA(2) = NY
- IXA(1) = IXS
- IXA(2) = IYS
- NXA(1) = NXS
- NXA(2) = NYS
- MA(1) = 0
-C GET SOLUTION.
- MA(2) = 0
-C APPROXIMATE SOLUTION VALUES.
- IFA = ISTKGT(NXS*NYS, 3)
-C EVALUATE THEM.
- CALL TSD1(2, KA, WS, ITA, NTA, U, WS, IXA, NXA, MA, WS(IFA))
-C ERROR IN SOLUTION VALUES.
- ERRU = 0
- TEMP = NXS*NYS
- DO 1 I = 1, TEMP
- TEMP2 = IEWE+I
- TEMP1 = IFA+I
- ERRU = AMAX1(ERRU, ABS(WS(TEMP2-1)-WS(TEMP1-1)))
- 1 CONTINUE
- TEMP = I1MACH(2)
- WRITE (TEMP, 2) T, ERRU
- 2 FORMAT (14H ERROR IN U(.,, 1PE10.2, 3H) =, 1PE10.2)
- CALL LEAVE
- RETURN
- END
- SUBROUTINE EWE(T, X, NX, Y, NY, U, NU)
- INTEGER NU, NX, NY
- REAL T, X(NX), Y(NY), U(NX, NY, NU)
- INTEGER I, J, P
-C THE EXACT SOLUTION.
- DO 7 P = 1, NU
- DO 6 I = 1, NX
- DO 5 J = 1, NY
- IF (Y(J) .GE. 1.) GOTO 1
- U(I, J, P) = T*Y(J)
- GOTO 4
- 1 IF (Y(J) .GE. 2.) GOTO 2
- U(I, J, P) = 2.*T*Y(J)-T
- GOTO 3
- 2 U(I, J, P) = 3.*T*Y(J)-3.*T
- 3 CONTINUE
- 4 CONTINUE
- 5 CONTINUE
- 6 CONTINUE
- 7 CONTINUE
- RETURN
- END
diff --git a/CEP/PyBDSM/src/port3/ex/ttg4.f b/CEP/PyBDSM/src/port3/ex/ttg4.f
deleted file mode 100644
index 8bd89f77415734f9f0e588f02b4f62550bd55ad1..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ex/ttg4.f
+++ /dev/null
@@ -1,262 +0,0 @@
-C$TEST TTG4
-C TO RUN AS A MAIN PROGRAM REMOVE NEXT LINE
- SUBROUTINE TTG4
-C***********************************************************************
-C
-C EXAMPLE OF USE OF PORT PROGRAM TTGR
-C
-C***********************************************************************
- COMMON /CSTAK/ DS
- DOUBLE PRECISION DS(350000)
- EXTERNAL HANDLE, BC, AF
- INTEGER NDX, NDY, ISTKGT, IUMB, IS(1000), IU
- INTEGER IX, IY, NU, KX, NX, KY
- INTEGER NY
- REAL ERRPAR(2), TSTART, DT, LX, LY, RX
- REAL RY, WS(1000), RS(1000), TSTOP
- LOGICAL LS(1000)
- COMPLEX CS(500)
- EQUIVALENCE (DS(1), CS(1), WS(1), RS(1), IS(1), LS(1))
-C TO SOLVE THE LINEAR HEAT EQUATION
-C GRAD . ( UX - 0.1 * UY , 0.1*UX + UY ) = UT - X*Y
-C WITH SOLUTION U == T*X*Y ON [0,+1]**2, EXACT FOR K = 4,
-C WITH TILTED TOP AND BOTTOM, NORMAL BCS THERE.
-C THE PORT LIBRARY STACK AND ITS ALIASES.
-C INITIALIZE THE PORT LIBRARY STACK LENGTH.
- CALL ISTKIN(350000, 4)
- CALL ENTER(1)
- NU = 1
- LX = 0
- RX = 1
- LY = 0
- RY = 1
- KX = 4
- KY = 4
- NDX = 3
- NDY = 3
- TSTART = 0
- TSTOP = 1
- DT = 1
- ERRPAR(1) = 1E-2
- ERRPAR(2) = 1E-4
-C UNIFORM GRID.
- IX = IUMB(LX, RX, NDX, KX, NX)
-C UNIFORM GRID.
- IY = IUMB(LY, RY, NDY, KY, NY)
-C SPACE FOR THE SOLUTION.
- IU = ISTKGT(NU*(NX-KX)*(NY-KY), 3)
- CALL SETR(NU*(NX-KX)*(NY-KY), 0E0, WS(IU))
- CALL TTGR(WS(IU), NU, KX, WS(IX), NX, KY, WS(IY), NY, TSTART,
- 1 TSTOP, DT, AF, BC, ERRPAR, HANDLE)
- CALL LEAVE
- CALL WRAPUP
- STOP
- END
- SUBROUTINE AF(T, XI, NX, YI, NY, NU, U, UT, UX, UY, UXT,
- 1 UYT, A, AU, AUT, AUX, AUY, AUXT, AUYT, F, FU, FUT, FUX, FUY,
- 2 FUXT, FUYT)
- INTEGER NU, NX, NY
- REAL T, XI(NX), YI(NY), U(NX, NY, NU), UT(NX, NY, NU), UX(NX, NY
- 1 , NU)
- REAL UY(NX, NY, NU), UXT(NX, NY, NU), UYT(NX, NY, NU), A(NX, NY,
- 1 NU, 2), AU(NX, NY, NU, NU, 2), AUT(NX, NY, NU, NU, 2)
- REAL AUX(NX, NY, NU, NU, 2), AUY(NX, NY, NU, NU, 2), AUXT(NX, NY
- 1 , NU, NU, 2), AUYT(NX, NY, NU, NU, 2), F(NX, NY, NU), FU(NX,
- 2 NY, NU, NU)
- REAL FUT(NX, NY, NU, NU), FUX(NX, NY, NU, NU), FUY(NX, NY, NU, NU)
- 1 , FUXT(NX, NY, NU, NU), FUYT(NX, NY, NU, NU)
- EXTERNAL BT, LR
- INTEGER I, P, Q
- REAL D(600), X, Y, XX(100), YY(100)
- INTEGER TEMP
- IF (NX*NY .GT. 100) CALL SETERR(19HAF - NX*NY .GT. 100, 19, 1, 2)
- CALL BTMAP(T, XI, YI, NX, NY, LR, BT, XX, YY, D)
-C MAP INTO (X,Y).
- CALL TTGRU(NX, NY, D, UX, UY, UT, NU)
- DO 3 I = 1, NU
- DO 2 Q = 1, NY
- DO 1 P = 1, NX
- TEMP = P+(Q-1)*NX
- X = XX(TEMP)
- TEMP = P+(Q-1)*NX
- Y = YY(TEMP)
- A(P, Q, I, 1) = UX(P, Q, I)-.1*UY(P, Q, I)
- A(P, Q, I, 2) = UY(P, Q, I)+.1*UX(P, Q, I)
- AUX(P, Q, I, I, 1) = 1
- AUY(P, Q, I, I, 2) = 1
- AUY(P, Q, I, I, 1) = -.1
- AUX(P, Q, I, I, 2) = .1
- F(P, Q, 1) = UT(P, Q, 1)-X*Y
- FUT(P, Q, 1, 1) = 1
- 1 CONTINUE
- 2 CONTINUE
- 3 CONTINUE
-C MAP INTO (XI,ETA).
- CALL TTGRG(NX, NY, D, NU, A, AU, AUX, AUY, F, FU, FUX, FUY)
- RETURN
- END
- SUBROUTINE BC(T, XI, NX, YI, NY, LX, RX, LY, RY, U, UT, UX
- 1 , UY, UXT, UYT, NU, B, BU, BUT, BUX, BUY, BUXT, BUYT)
- INTEGER NU, NX, NY
- REAL T, XI(NX), YI(NY), LX, RX, LY
- REAL RY, U(NX, NY, NU), UT(NX, NY, NU), UX(NX, NY, NU), UY(NX, NY,
- 1 NU), UXT(NX, NY, NU)
- REAL UYT(NX, NY, NU), B(NX, NY, NU), BU(NX, NY, NU, NU), BUT(NX,
- 1 NY, NU, NU), BUX(NX, NY, NU, NU), BUY(NX, NY, NU, NU)
- REAL BUXT(NX, NY, NU, NU), BUYT(NX, NY, NU, NU)
- EXTERNAL BT, LR
- INTEGER I, J
- REAL D(600), X, Y, XX(100), YY(100)
- INTEGER TEMP1
- LOGICAL TEMP
- IF (NX*NY .GT. 100) CALL SETERR(19HBC - NX*NY .GT. 100, 19, 1, 2)
- CALL BTMAP(T, XI, YI, NX, NY, LR, BT, XX, YY, D)
-C MAP INTO (X,Y).
- CALL TTGRU(NX, NY, D, UX, UY, UT, NU)
- DO 6 J = 1, NY
- DO 5 I = 1, NX
- TEMP1 = I+(J-1)*NX
- X = XX(TEMP1)
- TEMP1 = I+(J-1)*NX
- Y = YY(TEMP1)
- TEMP = XI(I) .EQ. LX
- IF (.NOT. TEMP) TEMP = XI(I) .EQ. RX
- IF (.NOT. TEMP) GOTO 1
- BU(I, J, 1, 1) = 1
-C LEFT OR RIGHT.
- B(I, J, 1) = U(I, J, 1)-T*X*Y
- GOTO 4
- 1 IF (YI(J) .NE. LY) GOTO 2
- B(I, J, 1) = (UX(I, J, 1)-T*Y)-(UY(I, J, 1)-T*X)
-C BOTTOM.
- BUX(I, J, 1, 1) = 1
-C NORMAL IS (1,-1).
- BUY(I, J, 1, 1) = -1
- GOTO 3
- 2 B(I, J, 1) = (UY(I, J, 1)-T*X)-(UX(I, J, 1)-T*Y)
-C TOP.
- BUX(I, J, 1, 1) = -1
-C NORMAL IS (-1,1).
- BUY(I, J, 1, 1) = 1
- 3 CONTINUE
- 4 CONTINUE
- 5 CONTINUE
- 6 CONTINUE
-C MAP INTO (XI,ETA).
- CALL TTGRB(NX, NY, D, NU, BUX, BUY, BUT)
- RETURN
- END
- SUBROUTINE HANDLE(T0, U0, T, U, NV, DT, TSTOP)
- INTEGER NV
- REAL T0, U0(NV), T, U(NV), DT, TSTOP
- COMMON /A7TGRP/ ERRPAR, NU, MXQ, MYQ
- INTEGER NU, MXQ, MYQ
- REAL ERRPAR(2)
- COMMON /A7TGRM/ KX, IX, NX, KY, IY, NY
- INTEGER KX, IX, NX, KY, IY, NY
- IF (T0 .NE. T) GOTO 2
- WRITE (6, 1) T
- 1 FORMAT (16H RESTART FOR T =, 1PE10.2)
- RETURN
- 2 CALL GERR(KX, IX, NX, KY, IY, NY, U, NU, T)
- RETURN
- END
- SUBROUTINE GERR(KX, IX, NX, KY, IY, NY, U, NU, T)
- INTEGER KX, IX, NX, KY, IY, NY
- INTEGER NU
- REAL U(1), T
- COMMON /CSTAK/ DS
- DOUBLE PRECISION DS(500)
- INTEGER IFA, ITA(2), IXA(2), NTA(2), NXA(2), IXS
- INTEGER IYS, NXS, NYS, ISTKGT, I, IEWE
- INTEGER KA(2), MA(2), IS(1000), ILUMD, I1MACH
- REAL ABS, ERRU, AMAX1, RS(1000), WS(1000)
- LOGICAL LS(1000)
- COMPLEX CS(500)
- INTEGER TEMP, TEMP1, TEMP2
- EQUIVALENCE (DS(1), CS(1), WS(1), RS(1), IS(1), LS(1))
-C TO GET AND PRINT THE ERROR AT EACH TIME-STEP.
-C U(NX-KX,NY-KY,NU).
-C THE PORT LIBRARY STACK AND ITS ALIASES.
- CALL ENTER(1)
-C FIND THE ERROR IN THE SOLUTION AT 2*KX * 2*KY POINTS / MESH RECTANGLE.
-C X SEARCH GRID.
- IXS = ILUMD(WS(IX), NX, 2*KX, NXS)
-C Y SEARCH GRID.
- IYS = ILUMD(WS(IY), NY, 2*KY, NYS)
-C U SEARCH GRID VALUES.
- IEWE = ISTKGT(NXS*NYS, 3)
-C THE EXACT SOLUTION.
- CALL EWE(T, WS(IXS), NXS, WS(IYS), NYS, WS(IEWE), NU)
- KA(1) = KX
- KA(2) = KY
- ITA(1) = IX
- ITA(2) = IY
- NTA(1) = NX
- NTA(2) = NY
- IXA(1) = IXS
- IXA(2) = IYS
- NXA(1) = NXS
- NXA(2) = NYS
- MA(1) = 0
-C GET SOLUTION.
- MA(2) = 0
-C APPROXIMATE SOLUTION VALUES.
- IFA = ISTKGT(NXS*NYS, 3)
-C EVALUATE THEM.
- CALL TSD1(2, KA, WS, ITA, NTA, U, WS, IXA, NXA, MA, WS(IFA))
-C ERROR IN SOLUTION VALUES.
- ERRU = 0
- TEMP = NXS*NYS
- DO 1 I = 1, TEMP
- TEMP2 = IEWE+I
- TEMP1 = IFA+I
- ERRU = AMAX1(ERRU, ABS(WS(TEMP2-1)-WS(TEMP1-1)))
- 1 CONTINUE
- TEMP = I1MACH(2)
- WRITE (TEMP, 2) T, ERRU
- 2 FORMAT (14H ERROR IN U(.,, 1PE10.2, 3H) =, 1PE10.2)
- CALL LEAVE
- RETURN
- END
- SUBROUTINE EWE(T, XI, NX, YI, NY, U, NU)
- INTEGER NU, NX, NY
- REAL T, XI(NX), YI(NY), U(NX, NY, NU)
- EXTERNAL BT, LR
- INTEGER I, J, P
- REAL D(6000), X, Y, XX(1000), YY(1000)
-C THE EXACT SOLUTION.
- IF (NY .GT. 1000) CALL SETERR(18HEWE - NY .GT. 1000, 18, 1, 2)
- DO 3 P = 1, NU
- DO 2 I = 1, NX
- CALL BTMAP(T, XI(I), YI, 1, NY, LR, BT, XX, YY, D)
- DO 1 J = 1, NY
- X = XX(J)
- Y = YY(J)
- U(I, J, P) = T*X*Y
- 1 CONTINUE
- 2 CONTINUE
- 3 CONTINUE
- RETURN
- END
- SUBROUTINE LR(T, LX, RX, LXT, RXT)
- REAL T, LX, RX, LXT, RXT
-C TO GET THE L AND R END-POINTS OF THE MAPPING IN X.
- LX = 0
- RX = 1
- LXT = 0
- RXT = 0
- RETURN
- END
- SUBROUTINE BT(T, X, F, G, FX, GX, FT, GT)
- REAL T, X, F, G, FX, GX
- REAL FT, GT
-C TO GET THE BOTTOM AND TOP OF MAPPING IN Y.
- F = X-1.
- G = X
- FT = 0
- GT = 0
- FX = 1
- GX = 1
- RETURN
- END
diff --git a/CEP/PyBDSM/src/port3/ex/ttg5.f b/CEP/PyBDSM/src/port3/ex/ttg5.f
deleted file mode 100644
index 8e8d5e7376dec67ed2571a91cec2749239d2366b..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ex/ttg5.f
+++ /dev/null
@@ -1,235 +0,0 @@
-C$TEST TTG5
-C TO RUN AS A MAIN PROGRAM REMOVE NEXT LINE
- SUBROUTINE TTG5
-C***********************************************************************
-C
-C EXAMPLE OF USE OF PORT PROGRAM TTGR
-C
-C***********************************************************************
- COMMON /CSTAK/ DS
- DOUBLE PRECISION DS(350000)
- EXTERNAL HANDLE, BC, AF
- INTEGER NDX, NDY, ISTKGT, I, IS(1000), IU
- INTEGER IX, IY, NU, KX, NX, KY
- INTEGER NY
- REAL ERRPAR(2), TSTART, DT, LX, LY, RX
- REAL RY, WS(1000), RS(1000), FLOAT, TSTOP
- LOGICAL LS(1000)
- COMPLEX CS(500)
- INTEGER TEMP, TEMP1
- EQUIVALENCE (DS(1), CS(1), WS(1), RS(1), IS(1), LS(1))
-C TO SOLVE LAPLACES EQUATION WITH REAL ( Z*LOG(Z) ) AS SOLUTION.
-C THE PORT LIBRARY STACK AND ITS ALIASES.
-C INITIALIZE THE PORT LIBRARY STACK LENGTH.
- CALL ISTKIN(350000, 4)
- CALL ENTER(1)
- NU = 1
- LX = 0
- RX = 1
- LY = 0
- RY = 1
- KX = 4
- KY = 4
- NDX = 2
- NDY = 2
- TSTART = 0
- TSTOP = 1
- DT = 1
- ERRPAR(1) = 1E-2
- ERRPAR(2) = 1E-4
- NX = NDX+2*(KX-1)
-C SPACE FOR X MESH.
- IX = ISTKGT(NX, 3)
- DO 1 I = 1, KX
- TEMP = IX+I
- WS(TEMP-1) = 0
- TEMP = IX+NX-I
- WS(TEMP) = RX
- 1 CONTINUE
-C 0 AND RX MULT = KX.
- TEMP = NDX-1
- DO 2 I = 1, TEMP
- TEMP1 = IX+KX-2+I
- WS(TEMP1) = RX*(FLOAT(I-1)/(FLOAT(NDX)-1E0))**KX
- 2 CONTINUE
- NY = NDY+2*(KY-1)
-C SPACE FOR Y MESH.
- IY = ISTKGT(NY, 3)
- DO 3 I = 1, KY
- TEMP = IY+I
- WS(TEMP-1) = 0
- TEMP = IY+NY-I
- WS(TEMP) = RY
- 3 CONTINUE
-C 0 AND RY MULT = KY.
- TEMP = NDY-1
- DO 4 I = 1, TEMP
- TEMP1 = IY+KY-2+I
- WS(TEMP1) = RY*(FLOAT(I-1)/(FLOAT(NDY)-1E0))**KY
- 4 CONTINUE
-C SPACE FOR THE SOLUTION.
- IU = ISTKGT(NU*(NX-KX)*(NY-KY), 3)
- CALL SETR(NU*(NX-KX)*(NY-KY), 0E0, WS(IU))
- CALL TTGR(WS(IU), NU, KX, WS(IX), NX, KY, WS(IY), NY, TSTART,
- 1 TSTOP, DT, AF, BC, ERRPAR, HANDLE)
- CALL LEAVE
- CALL WRAPUP
- STOP
- END
- SUBROUTINE AF(T, XI, NX, YI, NY, NU, U, UT, UX, UY, UXT,
- 1 UYT, A, AU, AUT, AUX, AUY, AUXT, AUYT, F, FU, FUT, FUX, FUY,
- 2 FUXT, FUYT)
- INTEGER NU, NX, NY
- REAL T, XI(NX), YI(NY), U(NX, NY, NU), UT(NX, NY, NU), UX(NX, NY
- 1 , NU)
- REAL UY(NX, NY, NU), UXT(NX, NY, NU), UYT(NX, NY, NU), A(NX, NY,
- 1 NU, 2), AU(NX, NY, NU, NU, 2), AUT(NX, NY, NU, NU, 2)
- REAL AUX(NX, NY, NU, NU, 2), AUY(NX, NY, NU, NU, 2), AUXT(NX, NY
- 1 , NU, NU, 2), AUYT(NX, NY, NU, NU, 2), F(NX, NY, NU), FU(NX,
- 2 NY, NU, NU)
- REAL FUT(NX, NY, NU, NU), FUX(NX, NY, NU, NU), FUY(NX, NY, NU, NU)
- 1 , FUXT(NX, NY, NU, NU), FUYT(NX, NY, NU, NU)
- INTEGER I, P, Q
- DO 3 I = 1, NU
- DO 2 Q = 1, NY
- DO 1 P = 1, NX
- A(P, Q, I, 1) = UX(P, Q, I)
- A(P, Q, I, 2) = UY(P, Q, I)
- AUX(P, Q, I, I, 1) = 1
- AUY(P, Q, I, I, 2) = 1
- 1 CONTINUE
- 2 CONTINUE
- 3 CONTINUE
- RETURN
- END
- SUBROUTINE BC(T, X, NX, Y, NY, LX, RX, LY, RY, U, UT, UX,
- 1 UY, UXT, UYT, NU, B, BU, BUT, BUX, BUY, BUXT, BUYT)
- INTEGER NU, NX, NY
- REAL T, X(NX), Y(NY), LX, RX, LY
- REAL RY, U(NX, NY, NU), UT(NX, NY, NU), UX(NX, NY, NU), UY(NX, NY,
- 1 NU), UXT(NX, NY, NU)
- REAL UYT(NX, NY, NU), B(NX, NY, NU), BU(NX, NY, NU, NU), BUT(NX,
- 1 NY, NU, NU), BUX(NX, NY, NU, NU), BUY(NX, NY, NU, NU)
- REAL BUXT(NX, NY, NU, NU), BUYT(NX, NY, NU, NU)
- INTEGER I, J
- REAL COS, SIN, R, ALOG, ATAN, SQRT
- REAL THETA
- DO 6 J = 1, NY
- DO 5 I = 1, NX
- IF (Y(J) .NE. LY) GOTO 1
- B(I, J, 1) = UY(I, J, 1)
-C NEUMANN DATA ON BOTTOM.
- BUY(I, J, 1, 1) = 1
- GOTO 4
- 1 R = SQRT(X(I)**2+Y(J)**2)
-C DIRICHLET DATA.
- IF (X(I) .LE. 0.) GOTO 2
- THETA = ATAN(Y(J)/X(I))
- GOTO 3
- 2 THETA = 2.*ATAN(1E0)
- 3 B(I, J, 1) = U(I, J, 1)-R*(COS(THETA)*ALOG(R)-THETA*SIN(
- 1 THETA))
- BU(I, J, 1, 1) = 1
- 4 CONTINUE
- 5 CONTINUE
- 6 CONTINUE
- RETURN
- END
- SUBROUTINE HANDLE(T0, U0, T, U, NV, DT, TSTOP)
- INTEGER NV
- REAL T0, U0(NV), T, U(NV), DT, TSTOP
- COMMON /A7TGRP/ ERRPAR, NU, MXQ, MYQ
- INTEGER NU, MXQ, MYQ
- REAL ERRPAR(2)
- COMMON /A7TGRM/ KX, IX, NX, KY, IY, NY
- INTEGER KX, IX, NX, KY, IY, NY
- IF (T0 .NE. T) GOTO 2
- WRITE (6, 1) T
- 1 FORMAT (16H RESTART FOR T =, 1PE10.2)
- RETURN
- 2 CALL GERR(KX, IX, NX, KY, IY, NY, U, NU, T)
- RETURN
- END
- SUBROUTINE GERR(KX, IX, NX, KY, IY, NY, U, NU, T)
- INTEGER KX, IX, NX, KY, IY, NY
- INTEGER NU
- REAL U(1), T
- COMMON /CSTAK/ DS
- DOUBLE PRECISION DS(500)
- INTEGER IFA, ITA(2), IXA(2), NTA(2), NXA(2), IXS
- INTEGER IYS, NXS, NYS, ISTKGT, I, IEWE
- INTEGER KA(2), MA(2), IS(1000), ILUMD, I1MACH
- REAL ABS, ERRU, AMAX1, RS(1000), WS(1000)
- LOGICAL LS(1000)
- COMPLEX CS(500)
- INTEGER TEMP, TEMP1, TEMP2
- EQUIVALENCE (DS(1), CS(1), WS(1), RS(1), IS(1), LS(1))
-C TO GET AND PRINT THE ERROR AT EACH TIME-STEP.
-C U(NX-KX,NY-KY,NU).
-C THE PORT LIBRARY STACK AND ITS ALIASES.
- CALL ENTER(1)
-C FIND THE ERROR IN THE SOLUTION AT 2*KX * 2*KY POINTS / MESH RECTANGLE.
-C X SEARCH GRID.
- IXS = ILUMD(WS(IX), NX, 2*KX, NXS)
-C Y SEARCH GRID.
- IYS = ILUMD(WS(IY), NY, 2*KY, NYS)
-C U SEARCH GRID VALUES.
- IEWE = ISTKGT(NXS*NYS, 3)
-C THE EXACT SOLUTION.
- CALL EWE(T, WS(IXS), NXS, WS(IYS), NYS, WS(IEWE), NU)
- KA(1) = KX
- KA(2) = KY
- ITA(1) = IX
- ITA(2) = IY
- NTA(1) = NX
- NTA(2) = NY
- IXA(1) = IXS
- IXA(2) = IYS
- NXA(1) = NXS
- NXA(2) = NYS
- MA(1) = 0
-C GET SOLUTION.
- MA(2) = 0
-C APPROXIMATE SOLUTION VALUES.
- IFA = ISTKGT(NXS*NYS, 3)
-C EVALUATE THEM.
- CALL TSD1(2, KA, WS, ITA, NTA, U, WS, IXA, NXA, MA, WS(IFA))
-C ERROR IN SOLUTION VALUES.
- ERRU = 0
- TEMP = NXS*NYS
- DO 1 I = 1, TEMP
- TEMP2 = IEWE+I
- TEMP1 = IFA+I
- ERRU = AMAX1(ERRU, ABS(WS(TEMP2-1)-WS(TEMP1-1)))
- 1 CONTINUE
- TEMP = I1MACH(2)
- WRITE (TEMP, 2) T, ERRU
- 2 FORMAT (14H ERROR IN U(.,, 1PE10.2, 3H) =, 1PE10.2)
- CALL LEAVE
- RETURN
- END
- SUBROUTINE EWE(T, X, NX, Y, NY, U, NU)
- INTEGER NU, NX, NY
- REAL T, X(NX), Y(NY), U(NX, NY, NU)
- INTEGER I, J, P
- REAL COS, SIN, R, ALOG, ATAN, SQRT
- REAL THETA
-C THE EXACT SOLUTION.
- DO 7 P = 1, NU
- DO 6 I = 1, NX
- DO 5 J = 1, NY
- R = SQRT(X(I)**2+Y(J)**2)
- IF (X(I) .LE. 0.) GOTO 1
- THETA = ATAN(Y(J)/X(I))
- GOTO 2
- 1 THETA = 2.*ATAN(1E0)
- 2 IF (R .LE. 0.) GOTO 3
- U(I, J, P) = R*(COS(THETA)*ALOG(R)-THETA*SIN(THETA))
- GOTO 4
- 3 U(I, J, P) = 0
- 4 CONTINUE
- 5 CONTINUE
- 6 CONTINUE
- 7 CONTINUE
- RETURN
- END
diff --git a/CEP/PyBDSM/src/port3/ex/ttg6.f b/CEP/PyBDSM/src/port3/ex/ttg6.f
deleted file mode 100644
index 7a4aff077fb440d1aa474186fbeac75d88563352..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ex/ttg6.f
+++ /dev/null
@@ -1,380 +0,0 @@
-C$TEST TTG6
-C TO RUN AS A MAIN PROGRAM REMOVE NEXT LINE
- SUBROUTINE TTG6
-C***********************************************************************
-C
-C EXAMPLE OF USE OF PORT PROGRAM TTGR
-C
-C***********************************************************************
- COMMON /CSTAK/ DS
- DOUBLE PRECISION DS(350000)
- EXTERNAL HANDLE, BC, AF
- INTEGER IUE, NDX, NDY, IUR, IXR, IYR
- INTEGER NXR, NYR, ISTKGT, I, IS(1000), IU
- INTEGER IX, IY, NU, KX, NX, KY
- INTEGER NY, I1MACH
- REAL ABS, ERRPAR(2), TSTART, EERR, ERRE, ERRR
- REAL AMAX1, DT, LX, LY, RX, RY
- REAL WS(1000), RS(1000), FLOAT, TSTOP
- LOGICAL LS(1000)
- COMPLEX CS(500)
- INTEGER TEMP, TEMP1, TEMP2
- EQUIVALENCE (DS(1), CS(1), WS(1), RS(1), IS(1), LS(1))
-C TO GET ERROR ESTIMATES FOR LAPLACES EQUATION WITH REAL ( Z*LOG(Z) ) AS
-C SOLUTION.
-C THE PORT LIBRARY STACK AND ITS ALIASES.
-C INITIALIZE THE PORT LIBRARY STACK LENGTH.
- CALL ISTKIN(350000, 4)
- CALL ENTER(1)
- NU = 1
- LX = 0
- RX = 1
- LY = 0
- RY = 1
- KX = 4
- KY = 4
- NDX = 2
- NDY = 2
- TSTART = 0
- TSTOP = 1
- DT = 1
- ERRPAR(1) = 1E-2
- ERRPAR(2) = 1E-4
- NX = NDX+2*(KX-1)
-C SPACE FOR X MESH.
- IX = ISTKGT(NX, 3)
- DO 1 I = 1, KX
- TEMP = IX+I
- WS(TEMP-1) = 0
- TEMP = IX+NX-I
- WS(TEMP) = RX
- 1 CONTINUE
-C 0 AND RX MULT = KX.
- TEMP = NDX-1
- DO 2 I = 1, TEMP
- TEMP2 = IX+KX-2+I
- WS(TEMP2) = RX*(FLOAT(I-1)/(FLOAT(NDX)-1E0))**KX
- 2 CONTINUE
- NY = NDY+2*(KY-1)
-C SPACE FOR Y MESH.
- IY = ISTKGT(NY, 3)
- DO 3 I = 1, KY
- TEMP = IY+I
- WS(TEMP-1) = 0
- TEMP = IY+NY-I
- WS(TEMP) = RY
- 3 CONTINUE
-C 0 AND RY MULT = KY.
- TEMP = NDY-1
- DO 4 I = 1, TEMP
- TEMP2 = IY+KY-2+I
- WS(TEMP2) = RY*(FLOAT(I-1)/(FLOAT(NDY)-1E0))**KY
- 4 CONTINUE
-C SPACE FOR THE SOLUTION.
- IU = ISTKGT(NU*(NX-KX)*(NY-KY), 3)
- CALL SETR(NU*(NX-KX)*(NY-KY), 0E0, WS(IU))
- TEMP = I1MACH(2)
- WRITE (TEMP, 5)
- 5 FORMAT (23H SOLVING ON CRUDE MESH.)
- CALL TTGR(WS(IU), NU, KX, WS(IX), NX, KY, WS(IY), NY, TSTART,
- 1 TSTOP, DT, AF, BC, ERRPAR, HANDLE)
- DT = 1
- NDX = 2*NDX-1
-C REFINE MESH.
- NDY = 2*NDY-1
- NXR = NDX+2*(KX-1)
-C SPACE FOR X MESH.
- IXR = ISTKGT(NXR, 3)
- DO 6 I = 1, KX
- TEMP = IXR+I
- WS(TEMP-1) = 0
- TEMP = IXR+NXR-I
- WS(TEMP) = RX
- 6 CONTINUE
-C 0 AND RX MULT = KX.
- TEMP = NDX-1
- DO 7 I = 1, TEMP
- TEMP2 = IXR+KX-2+I
- WS(TEMP2) = RX*(FLOAT(I-1)/(FLOAT(NDX)-1E0))**KX
- 7 CONTINUE
- NYR = NDY+2*(KY-1)
-C SPACE FOR Y MESH.
- IYR = ISTKGT(NYR, 3)
- DO 8 I = 1, KY
- TEMP = IYR+I
- WS(TEMP-1) = 0
- TEMP = IYR+NYR-I
- WS(TEMP) = RY
- 8 CONTINUE
-C 0 AND RY MULT = KY.
- TEMP = NDY-1
- DO 9 I = 1, TEMP
- TEMP2 = IYR+KY-2+I
- WS(TEMP2) = RY*(FLOAT(I-1)/(FLOAT(NDY)-1E0))**KY
- 9 CONTINUE
-C SPACE FOR THE SOLUTION.
- IUR = ISTKGT(NU*(NXR-KX)*(NYR-KY), 3)
- CALL SETR(NU*(NXR-KX)*(NYR-KY), 0E0, WS(IUR))
- TEMP = I1MACH(2)
- WRITE (TEMP, 10)
- 10 FORMAT (25H SOLVING ON REFINED MESH.)
- CALL TTGR(WS(IUR), NU, KX, WS(IXR), NXR, KY, WS(IYR), NYR, TSTART,
- 1 TSTOP, DT, AF, BC, ERRPAR, HANDLE)
- DT = 1
- ERRPAR(1) = ERRPAR(1)/10.
- ERRPAR(2) = ERRPAR(2)/10.
-C SPACE FOR THE SOLUTION.
- IUE = ISTKGT(NU*(NX-KX)*(NY-KY), 3)
- CALL SETR(NU*(NX-KX)*(NY-KY), 0E0, WS(IUE))
- TEMP = I1MACH(2)
- WRITE (TEMP, 11)
- 11 FORMAT (24H SOLVING WITH ERRPAR/10.)
- CALL TTGR(WS(IUE), NU, KX, WS(IX), NX, KY, WS(IY), NY, TSTART,
- 1 TSTOP, DT, AF, BC, ERRPAR, HANDLE)
- ERRR = EERR(KX, IX, NX, KY, IY, NY, WS(IU), NU, IXR, NXR, IYR,
- 1 NYR, WS(IUR), TSTOP)
- ERRE = 0
- TEMP = NU*(NX-KX)*(NY-KY)
- DO 12 I = 1, TEMP
- TEMP2 = IU+I
- TEMP1 = IUE+I
- ERRE = AMAX1(ERRE, ABS(WS(TEMP2-1)-WS(TEMP1-1)))
- 12 CONTINUE
- TEMP = I1MACH(2)
- WRITE (TEMP, 13) ERRE
- 13 FORMAT (24H U ERROR FROM U AND UE =, 1PE10.2)
- TEMP = I1MACH(2)
- WRITE (TEMP, 14) ERRR
- 14 FORMAT (24H U ERROR FROM U AND UR =, 1PE10.2)
- CALL LEAVE
- CALL WRAPUP
- STOP
- END
- SUBROUTINE AF(T, XI, NX, YI, NY, NU, U, UT, UX, UY, UXT,
- 1 UYT, A, AU, AUT, AUX, AUY, AUXT, AUYT, F, FU, FUT, FUX, FUY,
- 2 FUXT, FUYT)
- INTEGER NU, NX, NY
- REAL T, XI(NX), YI(NY), U(NX, NY, NU), UT(NX, NY, NU), UX(NX, NY
- 1 , NU)
- REAL UY(NX, NY, NU), UXT(NX, NY, NU), UYT(NX, NY, NU), A(NX, NY,
- 1 NU, 2), AU(NX, NY, NU, NU, 2), AUT(NX, NY, NU, NU, 2)
- REAL AUX(NX, NY, NU, NU, 2), AUY(NX, NY, NU, NU, 2), AUXT(NX, NY
- 1 , NU, NU, 2), AUYT(NX, NY, NU, NU, 2), F(NX, NY, NU), FU(NX,
- 2 NY, NU, NU)
- REAL FUT(NX, NY, NU, NU), FUX(NX, NY, NU, NU), FUY(NX, NY, NU, NU)
- 1 , FUXT(NX, NY, NU, NU), FUYT(NX, NY, NU, NU)
- INTEGER I, P, Q
- DO 3 I = 1, NU
- DO 2 Q = 1, NY
- DO 1 P = 1, NX
- A(P, Q, I, 1) = UX(P, Q, I)
- A(P, Q, I, 2) = UY(P, Q, I)
- AUX(P, Q, I, I, 1) = 1
- AUY(P, Q, I, I, 2) = 1
- 1 CONTINUE
- 2 CONTINUE
- 3 CONTINUE
- RETURN
- END
- SUBROUTINE BC(T, X, NX, Y, NY, LX, RX, LY, RY, U, UT, UX,
- 1 UY, UXT, UYT, NU, B, BU, BUT, BUX, BUY, BUXT, BUYT)
- INTEGER NU, NX, NY
- REAL T, X(NX), Y(NY), LX, RX, LY
- REAL RY, U(NX, NY, NU), UT(NX, NY, NU), UX(NX, NY, NU), UY(NX, NY,
- 1 NU), UXT(NX, NY, NU)
- REAL UYT(NX, NY, NU), B(NX, NY, NU), BU(NX, NY, NU, NU), BUT(NX,
- 1 NY, NU, NU), BUX(NX, NY, NU, NU), BUY(NX, NY, NU, NU)
- REAL BUXT(NX, NY, NU, NU), BUYT(NX, NY, NU, NU)
- INTEGER I, J
- REAL COS, SIN, R, ALOG, ATAN, SQRT
- REAL THETA
- DO 6 J = 1, NY
- DO 5 I = 1, NX
- IF (Y(J) .NE. LY) GOTO 1
- B(I, J, 1) = UY(I, J, 1)
-C NEUMANN DATA ON BOTTOM.
- BUY(I, J, 1, 1) = 1
- GOTO 4
- 1 R = SQRT(X(I)**2+Y(J)**2)
-C DIRICHLET DATA.
- IF (X(I) .LE. 0.) GOTO 2
- THETA = ATAN(Y(J)/X(I))
- GOTO 3
- 2 THETA = 2.*ATAN(1E0)
- 3 B(I, J, 1) = U(I, J, 1)-R*(COS(THETA)*ALOG(R)-THETA*SIN(
- 1 THETA))
- BU(I, J, 1, 1) = 1
- 4 CONTINUE
- 5 CONTINUE
- 6 CONTINUE
- RETURN
- END
- SUBROUTINE HANDLE(T0, U0, T, U, NV, DT, TSTOP)
- INTEGER NV
- REAL T0, U0(NV), T, U(NV), DT, TSTOP
- COMMON /A7TGRP/ ERRPAR, NU, MXQ, MYQ
- INTEGER NU, MXQ, MYQ
- REAL ERRPAR(2)
- COMMON /A7TGRM/ KX, IX, NX, KY, IY, NY
- INTEGER KX, IX, NX, KY, IY, NY
- IF (T0 .NE. T) GOTO 2
- WRITE (6, 1) T
- 1 FORMAT (16H RESTART FOR T =, 1PE10.2)
- RETURN
- 2 CALL GERR(KX, IX, NX, KY, IY, NY, U, NU, T)
- RETURN
- END
- SUBROUTINE GERR(KX, IX, NX, KY, IY, NY, U, NU, T)
- INTEGER KX, IX, NX, KY, IY, NY
- INTEGER NU
- REAL U(1), T
- COMMON /CSTAK/ DS
- DOUBLE PRECISION DS(500)
- INTEGER IFA, ITA(2), IXA(2), NTA(2), NXA(2), IXS
- INTEGER IYS, NXS, NYS, ISTKGT, I, IEWE
- INTEGER KA(2), MA(2), IS(1000), ILUMD, I1MACH
- REAL ABS, ERRU, AMAX1, RS(1000), WS(1000)
- LOGICAL LS(1000)
- COMPLEX CS(500)
- INTEGER TEMP, TEMP1, TEMP2
- EQUIVALENCE (DS(1), CS(1), WS(1), RS(1), IS(1), LS(1))
-C TO GET AND PRINT THE ERROR AT EACH TIME-STEP.
-C U(NX-KX,NY-KY,NU).
-C THE PORT LIBRARY STACK AND ITS ALIASES.
- CALL ENTER(1)
-C FIND THE ERROR IN THE SOLUTION AT 2*KX * 2*KY POINTS / MESH RECTANGLE.
-C X SEARCH GRID.
- IXS = ILUMD(WS(IX), NX, 2*KX, NXS)
-C Y SEARCH GRID.
- IYS = ILUMD(WS(IY), NY, 2*KY, NYS)
-C U SEARCH GRID VALUES.
- IEWE = ISTKGT(NXS*NYS, 3)
-C THE EXACT SOLUTION.
- CALL EWE(T, WS(IXS), NXS, WS(IYS), NYS, WS(IEWE), NU)
- KA(1) = KX
- KA(2) = KY
- ITA(1) = IX
- ITA(2) = IY
- NTA(1) = NX
- NTA(2) = NY
- IXA(1) = IXS
- IXA(2) = IYS
- NXA(1) = NXS
- NXA(2) = NYS
- MA(1) = 0
-C GET SOLUTION.
- MA(2) = 0
-C APPROXIMATE SOLUTION VALUES.
- IFA = ISTKGT(NXS*NYS, 3)
-C EVALUATE THEM.
- CALL TSD1(2, KA, WS, ITA, NTA, U, WS, IXA, NXA, MA, WS(IFA))
-C ERROR IN SOLUTION VALUES.
- ERRU = 0
- TEMP = NXS*NYS
- DO 1 I = 1, TEMP
- TEMP2 = IEWE+I
- TEMP1 = IFA+I
- ERRU = AMAX1(ERRU, ABS(WS(TEMP2-1)-WS(TEMP1-1)))
- 1 CONTINUE
- TEMP = I1MACH(2)
- WRITE (TEMP, 2) T, ERRU
- 2 FORMAT (14H ERROR IN U(.,, 1PE10.2, 3H) =, 1PE10.2)
- CALL LEAVE
- RETURN
- END
- REAL FUNCTION EERR(KX, IX, NX, KY, IY, NY, U, NU, IXR, NXR
- 1 , IYR, NYR, UR, T)
- INTEGER KX, IX, NX, KY, IY, NY
- INTEGER NU, IXR, NXR, IYR, NYR
- REAL U(1), UR(1), T
- COMMON /CSTAK/ DS
- DOUBLE PRECISION DS(500)
- INTEGER IFA, ITA(2), IXA(2), NTA(2), NXA(2), IXS
- INTEGER IYS, NXS, NYS, ISTKGT, I, IFAR
- INTEGER KA(2), MA(2), IS(1000), ILUMD, I1MACH
- REAL ABS, ERRU, AMAX1, RS(1000), WS(1000)
- LOGICAL LS(1000)
- COMPLEX CS(500)
- INTEGER TEMP, TEMP1, TEMP2
- EQUIVALENCE (DS(1), CS(1), WS(1), RS(1), IS(1), LS(1))
-C TO GET AND PRINT THE ERROR ESTIMATE AT EACH TIME-STEP.
-C U(NX-KX,NY-KY,NU), UR(NXR-KX,NYR-KY,NU).
-C THE PORT LIBRARY STACK AND ITS ALIASES.
- CALL ENTER(1)
-C FIND THE ERROR IN THE SOLUTION AT 2*KX * 2*KY POINTS / FINE MESH RECTA
-CNGLE.
-C X SEARCH GRID.
- IXS = ILUMD(WS(IXR), NXR, 2*KX, NXS)
-C Y SEARCH GRID.
- IYS = ILUMD(WS(IYR), NYR, 2*KY, NYS)
- KA(1) = KX
- KA(2) = KY
- ITA(1) = IX
- ITA(2) = IY
- NTA(1) = NX
- NTA(2) = NY
- IXA(1) = IXS
- IXA(2) = IYS
- NXA(1) = NXS
- NXA(2) = NYS
- MA(1) = 0
-C GET SOLUTION.
- MA(2) = 0
-C APPROXIMATE SOLUTION VALUES.
- IFA = ISTKGT(NXS*NYS, 3)
-C EVALUATE THEM.
- CALL TSD1(2, KA, WS, ITA, NTA, U, WS, IXA, NXA, MA, WS(IFA))
- KA(1) = KX
- KA(2) = KY
- ITA(1) = IXR
- ITA(2) = IYR
- NTA(1) = NXR
- NTA(2) = NYR
- IXA(1) = IXS
- IXA(2) = IYS
- NXA(1) = NXS
- NXA(2) = NYS
- MA(1) = 0
-C GET SOLUTION.
- MA(2) = 0
-C APPROXIMATE SOLUTION VALUES.
- IFAR = ISTKGT(NXS*NYS, 3)
-C EVALUATE THEM.
- CALL TSD1(2, KA, WS, ITA, NTA, UR, WS, IXA, NXA, MA, WS(IFAR))
-C ERROR IN SOLUTION VALUES.
- ERRU = 0
- TEMP = NXS*NYS
- DO 1 I = 1, TEMP
- TEMP2 = IFAR+I
- TEMP1 = IFA+I
- ERRU = AMAX1(ERRU, ABS(WS(TEMP2-1)-WS(TEMP1-1)))
- 1 CONTINUE
- CALL LEAVE
- EERR = ERRU
- RETURN
- END
- SUBROUTINE EWE(T, X, NX, Y, NY, U, NU)
- INTEGER NU, NX, NY
- REAL T, X(NX), Y(NY), U(NX, NY, NU)
- INTEGER I, J, P
- REAL COS, SIN, R, ALOG, ATAN, SQRT
- REAL THETA
-C THE EXACT SOLUTION.
- DO 7 P = 1, NU
- DO 6 I = 1, NX
- DO 5 J = 1, NY
- R = SQRT(X(I)**2+Y(J)**2)
- IF (X(I) .LE. 0.) GOTO 1
- THETA = ATAN(Y(J)/X(I))
- GOTO 2
- 1 THETA = 2.*ATAN(1E0)
- 2 IF (R .LE. 0.) GOTO 3
- U(I, J, P) = R*(COS(THETA)*ALOG(R)-THETA*SIN(THETA))
- GOTO 4
- 3 U(I, J, P) = 0
- 4 CONTINUE
- 5 CONTINUE
- 6 CONTINUE
- 7 CONTINUE
- RETURN
- END
diff --git a/CEP/PyBDSM/src/port3/ex/ttgp.f b/CEP/PyBDSM/src/port3/ex/ttgp.f
deleted file mode 100644
index c572904c08fc16356fc2bc81315b2e13fbb00db4..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ex/ttgp.f
+++ /dev/null
@@ -1,183 +0,0 @@
-C$TEST TTGP
-C TO RUN AS A MAIN PROGRAM REMOVE NEXT LINE
- SUBROUTINE TTGP
-C***********************************************************************
-C
-C EXAMPLE OF USE OF PORT PROGRAM TTGR
-C
-C***********************************************************************
- COMMON /CSTAK/ DS
- DOUBLE PRECISION DS(350000)
- EXTERNAL HANDLE, BC, AF
- INTEGER NDX, NDY, ISTKGT, IUMB, IS(1000), IU
- INTEGER IX, IY, NU, KX, NX, KY
- INTEGER NY
- REAL ERRPAR(2), TSTART, DT, LX, LY, RX
- REAL RY, WS(1000), RS(1000), TSTOP
- LOGICAL LS(1000)
- COMPLEX CS(500)
- EQUIVALENCE (DS(1), CS(1), WS(1), RS(1), IS(1), LS(1))
-C TO SOLVE THE HEAT EQUATION WITH SOLUTION U == T*X*Y,
-C GRAD . ( U + UX + .1 * UY, U + UY + .1 * UX ) = UT + UX + UY +G(X,T)
-C THE PORT LIBRARY STACK AND ITS ALIASES.
-C INITIALIZE THE PORT LIBRARY STACK LENGTH.
- CALL ISTKIN(350000, 4)
- CALL ENTER(1)
- NU = 1
- LX = 0
- RX = 1
- LY = 0
- RY = 1
- KX = 2
- KY = 2
- NDX = 3
- NDY = 3
- TSTART = 0
- TSTOP = 1
- DT = 1
- ERRPAR(1) = 1E-2
- ERRPAR(2) = 1E-4
-C UNIFORM GRID.
- IX = IUMB(LX, RX, NDX, KX, NX)
-C UNIFORM GRID.
- IY = IUMB(LY, RY, NDY, KY, NY)
-C SPACE FOR THE SOLUTION.
- IU = ISTKGT(NU*(NX-KX)*(NY-KY), 3)
-C INITIAL CONDITIONS FOR U.
- CALL SETR(NU*(NX-KX)*(NY-KY), 0E0, WS(IU))
- CALL TTGR(WS(IU), NU, KX, WS(IX), NX, KY, WS(IY), NY, TSTART,
- 1 TSTOP, DT, AF, BC, ERRPAR, HANDLE)
- CALL LEAVE
- CALL WRAPUP
- STOP
- END
- SUBROUTINE AF(T, X, NX, Y, NY, NU, U, UT, UX, UY, UXT, UYT
- 1 , A, AU, AUT, AUX, AUY, AUXT, AUYT, F, FU, FUT, FUX, FUY, FUXT,
- 2 FUYT)
- INTEGER NU, NX, NY
- REAL T, X(NX), Y(NY), U(NX, NY, NU), UT(NX, NY, NU), UX(NX, NY,
- 1 NU)
- REAL UY(NX, NY, NU), UXT(NX, NY, NU), UYT(NX, NY, NU), A(NX, NY,
- 1 NU, 2), AU(NX, NY, NU, NU, 2), AUT(NX, NY, NU, NU, 2)
- REAL AUX(NX, NY, NU, NU, 2), AUY(NX, NY, NU, NU, 2), AUXT(NX, NY
- 1 , NU, NU, 2), AUYT(NX, NY, NU, NU, 2), F(NX, NY, NU), FU(NX,
- 2 NY, NU, NU)
- REAL FUT(NX, NY, NU, NU), FUX(NX, NY, NU, NU), FUY(NX, NY, NU, NU)
- 1 , FUXT(NX, NY, NU, NU), FUYT(NX, NY, NU, NU)
- INTEGER I, P, Q
- DO 3 I = 1, NU
- DO 2 Q = 1, NY
- DO 1 P = 1, NX
- A(P, Q, I, 1) = UX(P, Q, I)+.1*UY(P, Q, I)+U(P, Q, I)
- A(P, Q, I, 2) = UY(P, Q, I)+.1*UX(P, Q, I)+U(P, Q, I)
- AUX(P, Q, I, I, 1) = 1
- AUY(P, Q, I, I, 2) = 1
- AUY(P, Q, I, I, 1) = .1
- AUX(P, Q, I, I, 2) = .1
- AU(P, Q, I, I, 1) = 1
- AU(P, Q, I, I, 2) = 1
- F(P, Q, I) = UT(P, Q, I)+UX(P, Q, I)+UY(P, Q, I)
- FUT(P, Q, I, I) = 1
- FUX(P, Q, I, I) = 1
- FUY(P, Q, I, I) = 1
- F(P, Q, I) = F(P, Q, I)+.2*T-X(P)*Y(Q)
- 1 CONTINUE
- 2 CONTINUE
- 3 CONTINUE
- RETURN
- END
- SUBROUTINE BC(T, X, NX, Y, NY, LX, RX, LY, RY, U, UT, UX,
- 1 UY, UXT, UYT, NU, B, BU, BUT, BUX, BUY, BUXT, BUYT)
- INTEGER NU, NX, NY
- REAL T, X(NX), Y(NY), LX, RX, LY
- REAL RY, U(NX, NY, NU), UT(NX, NY, NU), UX(NX, NY, NU), UY(NX, NY,
- 1 NU), UXT(NX, NY, NU)
- REAL UYT(NX, NY, NU), B(NX, NY, NU), BU(NX, NY, NU, NU), BUT(NX,
- 1 NY, NU, NU), BUX(NX, NY, NU, NU), BUY(NX, NY, NU, NU)
- REAL BUXT(NX, NY, NU, NU), BUYT(NX, NY, NU, NU)
- INTEGER I, J
- DO 2 J = 1, NY
- DO 1 I = 1, NX
- BU(I, J, 1, 1) = 1
- B(I, J, 1) = U(I, J, 1)-T*X(I)*Y(J)
- 1 CONTINUE
- 2 CONTINUE
- RETURN
- END
- SUBROUTINE HANDLE(T0, U0, T, U, NV, DT, TSTOP)
- INTEGER NV
- REAL T0, U0(NV), T, U(NV), DT, TSTOP
- COMMON /A7TGRP/ ERRPAR, NU, MXQ, MYQ
- INTEGER NU, MXQ, MYQ
- REAL ERRPAR(2)
- COMMON /A7TGRM/ KX, IX, NX, KY, IY, NY
- INTEGER KX, IX, NX, KY, IY, NY
- IF (T0 .NE. T) GOTO 2
- WRITE (6, 1) T
- 1 FORMAT (16H RESTART FOR T =, 1PE10.2)
- RETURN
-C PRINT RESULTS.
- 2 CALL GERR(KX, IX, NX, KY, IY, NY, U, NU, T)
- RETURN
- END
- SUBROUTINE GERR(KX, IX, NX, KY, IY, NY, U, NU, T)
- INTEGER KX, IX, NX, KY, IY, NY
- INTEGER NU
- REAL U(1), T
- COMMON /CSTAK/ DS
- DOUBLE PRECISION DS(500)
- INTEGER IFA, ITA(2), IXA(2), NTA(2), NXA(2), IXS
- INTEGER IYS, NXS, NYS, ISTKGT, I, KA(2)
- INTEGER MA(2), IS(1000), ILUMD, I1MACH
- REAL RS(1000), WS(1000)
- LOGICAL LS(1000)
- COMPLEX CS(500)
- INTEGER TEMP, TEMP1
- EQUIVALENCE (DS(1), CS(1), WS(1), RS(1), IS(1), LS(1))
-C TO PRINT THE SOLUTION AT EACH TIME-STEP.
-C U(NX-KX,NY,KY,NU).
-C THE PORT LIBRARY STACK AND ITS ALIASES.
- CALL ENTER(1)
-C FIND THE SOLUTION AT 2 * 2 POINTS / MESH RECTANGLE.
-C X SEARCH GRID.
- IXS = ILUMD(WS(IX), NX, 2, NXS)
-C Y SEARCH GRID.
- IYS = ILUMD(WS(IY), NY, 2, NYS)
- KA(1) = KX
- KA(2) = KY
- ITA(1) = IX
- ITA(2) = IY
- NTA(1) = NX
- NTA(2) = NY
- IXA(1) = IXS
- IXA(2) = IYS
- NXA(1) = NXS
- NXA(2) = NYS
- MA(1) = 0
-C GET SOLUTION.
- MA(2) = 0
-C APPROXIMATE SOLUTION VALUES.
- IFA = ISTKGT(NXS*NYS, 3)
-C EVALUATE THEM.
- CALL TSD1(2, KA, WS, ITA, NTA, U, WS, IXA, NXA, MA, WS(IFA))
- TEMP1 = IFA+NXS*NYS-1
- TEMP = I1MACH(2)
- WRITE (TEMP, 1) T, (WS(I), I = IFA, TEMP1)
- 1 FORMAT (3H U(, 1PE10.2, 7H,.,.) =, (1P5E10.2/20X,1P4E10.2))
- CALL LEAVE
- RETURN
- END
- SUBROUTINE EWE(T, X, NX, Y, NY, U, NU)
- INTEGER NU, NX, NY
- REAL T, X(NX), Y(NY), U(NX, NY, NU)
- INTEGER I, J, P
-C THE EXACT SOLUTION.
- DO 3 P = 1, NU
- DO 2 I = 1, NX
- DO 1 J = 1, NY
- U(I, J, P) = T*X(I)*Y(J)
- 1 CONTINUE
- 2 CONTINUE
- 3 CONTINUE
- RETURN
- END
diff --git a/CEP/PyBDSM/src/port3/ex/ttgrx1.f b/CEP/PyBDSM/src/port3/ex/ttgrx1.f
deleted file mode 100644
index 416273802d5f533f334f18231c0a711587c18c76..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ex/ttgrx1.f
+++ /dev/null
@@ -1,194 +0,0 @@
-C$TEST TTG1
-C TO RUN AS A MAIN PROGRAM REMOVE NEXT LINE
- SUBROUTINE TTG1
-C***********************************************************************
-C
-C EXAMPLE OF USE OF PORT PROGRAM TTGR
-C
-C***********************************************************************
- COMMON /CSTAK/ DS
- DOUBLE PRECISION DS(350000)
- EXTERNAL HANDLE, BC, AF
- INTEGER NDX, NDY, ISTKGT, IUMB, IS(1000), IU
- INTEGER IX, IY, NU, KX, NX, KY
- INTEGER NY
- REAL ERRPAR(2), TSTART, DT, LX, LY, RX
- REAL RY, WS(1000), RS(1000), TSTOP
- LOGICAL LS(1000)
- COMPLEX CS(500)
- EQUIVALENCE (DS(1), CS(1), WS(1), RS(1), IS(1), LS(1))
-C TO SOLVE THE HEAT EQUATION WITH SOLUTION U == T*X*Y,
-C GRAD . ( U + UX + .1 * UY, U + UY + .1 * UX ) = UT + UX + UY +G(X,T)
-C THE PORT LIBRARY STACK AND ITS ALIASES.
-C INITIALIZE THE PORT LIBRARY STACK LENGTH.
- CALL ISTKIN(350000, 4)
- CALL ENTER(1)
- NU = 1
- LX = 0
- RX = 1
- LY = 0
- RY = 1
- KX = 2
- KY = 2
- NDX = 3
- NDY = 3
- TSTART = 0
- TSTOP = 1
- DT = 1
- ERRPAR(1) = 1E-2
- ERRPAR(2) = 1E-4
-C UNIFORM GRID.
- IX = IUMB(LX, RX, NDX, KX, NX)
-C UNIFORM GRID.
- IY = IUMB(LY, RY, NDY, KY, NY)
-C SPACE FOR THE SOLUTION.
- IU = ISTKGT(NU*(NX-KX)*(NY-KY), 3)
-C INITIAL CONDITIONS FOR U.
- CALL SETR(NU*(NX-KX)*(NY-KY), 0E0, WS(IU))
- CALL TTGR(WS(IU), NU, KX, WS(IX), NX, KY, WS(IY), NY, TSTART,
- 1 TSTOP, DT, AF, BC, ERRPAR, HANDLE)
- CALL LEAVE
- CALL WRAPUP
- STOP
- END
- SUBROUTINE AF(T, X, NX, Y, NY, NU, U, UT, UX, UY, UXT, UYT
- 1 , A, AU, AUT, AUX, AUY, AUXT, AUYT, F, FU, FUT, FUX, FUY, FUXT,
- 2 FUYT)
- INTEGER NU, NX, NY
- REAL T, X(NX), Y(NY), U(NX, NY, NU), UT(NX, NY, NU), UX(NX, NY,
- 1 NU)
- REAL UY(NX, NY, NU), UXT(NX, NY, NU), UYT(NX, NY, NU), A(NX, NY,
- 1 NU, 2), AU(NX, NY, NU, NU, 2), AUT(NX, NY, NU, NU, 2)
- REAL AUX(NX, NY, NU, NU, 2), AUY(NX, NY, NU, NU, 2), AUXT(NX, NY
- 1 , NU, NU, 2), AUYT(NX, NY, NU, NU, 2), F(NX, NY, NU), FU(NX,
- 2 NY, NU, NU)
- REAL FUT(NX, NY, NU, NU), FUX(NX, NY, NU, NU), FUY(NX, NY, NU, NU)
- 1 , FUXT(NX, NY, NU, NU), FUYT(NX, NY, NU, NU)
- INTEGER I, P, Q
- DO 3 I = 1, NU
- DO 2 Q = 1, NY
- DO 1 P = 1, NX
- A(P, Q, I, 1) = UX(P, Q, I)+.1*UY(P, Q, I)+U(P, Q, I)
- A(P, Q, I, 2) = UY(P, Q, I)+.1*UX(P, Q, I)+U(P, Q, I)
- AUX(P, Q, I, I, 1) = 1
- AUY(P, Q, I, I, 2) = 1
- AUY(P, Q, I, I, 1) = .1
- AUX(P, Q, I, I, 2) = .1
- AU(P, Q, I, I, 1) = 1
- AU(P, Q, I, I, 2) = 1
- F(P, Q, I) = UT(P, Q, I)+UX(P, Q, I)+UY(P, Q, I)
- FUT(P, Q, I, I) = 1
- FUX(P, Q, I, I) = 1
- FUY(P, Q, I, I) = 1
- F(P, Q, I) = F(P, Q, I)+.2*T-X(P)*Y(Q)
- 1 CONTINUE
- 2 CONTINUE
- 3 CONTINUE
- RETURN
- END
- SUBROUTINE BC(T, X, NX, Y, NY, LX, RX, LY, RY, U, UT, UX,
- 1 UY, UXT, UYT, NU, B, BU, BUT, BUX, BUY, BUXT, BUYT)
- INTEGER NU, NX, NY
- REAL T, X(NX), Y(NY), LX, RX, LY
- REAL RY, U(NX, NY, NU), UT(NX, NY, NU), UX(NX, NY, NU), UY(NX, NY,
- 1 NU), UXT(NX, NY, NU)
- REAL UYT(NX, NY, NU), B(NX, NY, NU), BU(NX, NY, NU, NU), BUT(NX,
- 1 NY, NU, NU), BUX(NX, NY, NU, NU), BUY(NX, NY, NU, NU)
- REAL BUXT(NX, NY, NU, NU), BUYT(NX, NY, NU, NU)
- INTEGER I, J
- DO 2 J = 1, NY
- DO 1 I = 1, NX
- BU(I, J, 1, 1) = 1
- B(I, J, 1) = U(I, J, 1)-T*X(I)*Y(J)
- 1 CONTINUE
- 2 CONTINUE
- RETURN
- END
- SUBROUTINE HANDLE(T0, U0, T, U, NV, DT, TSTOP)
- INTEGER NV
- REAL T0, U0(NV), T, U(NV), DT, TSTOP
- COMMON /A7TGRP/ ERRPAR, NU, MXQ, MYQ
- INTEGER NU, MXQ, MYQ
- REAL ERRPAR(2)
- COMMON /A7TGRM/ KX, IX, NX, KY, IY, NY
- INTEGER KX, IX, NX, KY, IY, NY
- IF (T0 .NE. T) GOTO 2
- WRITE (6, 1) T
- 1 FORMAT (16H RESTART FOR T =, 1PE10.2)
- RETURN
-C GET AND PRINT THE ERROR.
- 2 CALL GERR(KX, IX, NX, KY, IY, NY, U, NU, T)
- RETURN
- END
- SUBROUTINE GERR(KX, IX, NX, KY, IY, NY, U, NU, T)
- INTEGER KX, IX, NX, KY, IY, NY
- INTEGER NU
- REAL U(1), T
- COMMON /CSTAK/ DS
- DOUBLE PRECISION DS(500)
- INTEGER IFA, ITA(2), IXA(2), NTA(2), NXA(2), IXS
- INTEGER IYS, NXS, NYS, ISTKGT, I, IEWE
- INTEGER KA(2), MA(2), IS(1000), ILUMD, I1MACH
- REAL ABS, ERRU, AMAX1, RS(1000), WS(1000)
- LOGICAL LS(1000)
- COMPLEX CS(500)
- INTEGER TEMP, TEMP1, TEMP2
- EQUIVALENCE (DS(1), CS(1), WS(1), RS(1), IS(1), LS(1))
-C TO GET AND PRINT THE ERROR AT EACH TIME-STEP.
-C U(NX-KX,NY0KY,NU).
-C THE PORT LIBRARY STACK AND ITS ALIASES.
- CALL ENTER(1)
-C FIND THE ERROR IN THE SOLUTION AT 2*KX * 2*KY POINTS / MESH RECTANGLE.
-C X SEARCH GRID.
- IXS = ILUMD(WS(IX), NX, 2*KX, NXS)
-C Y SEARCH GRID.
- IYS = ILUMD(WS(IY), NY, 2*KY, NYS)
-C U SEARCH GRID VALUES.
- IEWE = ISTKGT(NXS*NYS, 3)
-C THE EXACT SOLUTION.
- CALL EWE(T, WS(IXS), NXS, WS(IYS), NYS, WS(IEWE), NU)
- KA(1) = KX
- KA(2) = KY
- ITA(1) = IX
- ITA(2) = IY
- NTA(1) = NX
- NTA(2) = NY
- IXA(1) = IXS
- IXA(2) = IYS
- NXA(1) = NXS
- NXA(2) = NYS
- MA(1) = 0
-C GET SOLUTION.
- MA(2) = 0
-C APPROXIMATE SOLUTION VALUES.
- IFA = ISTKGT(NXS*NYS, 3)
-C EVALUATE THEM.
- CALL TSD1(2, KA, WS, ITA, NTA, U, WS, IXA, NXA, MA, WS(IFA))
-C ERROR IN SOLUTION VALUES.
- ERRU = 0
- TEMP = NXS*NYS
- DO 1 I = 1, TEMP
- TEMP2 = IEWE+I
- TEMP1 = IFA+I
- ERRU = AMAX1(ERRU, ABS(WS(TEMP2-1)-WS(TEMP1-1)))
- 1 CONTINUE
- TEMP = I1MACH(2)
- WRITE (TEMP, 2) T, ERRU
- 2 FORMAT (14H ERROR IN U(.,, 1PE10.2, 3H) =, 1PE10.2)
- CALL LEAVE
- RETURN
- END
- SUBROUTINE EWE(T, X, NX, Y, NY, U, NU)
- INTEGER NU, NX, NY
- REAL T, X(NX), Y(NY), U(NX, NY, NU)
- INTEGER I, J, P
-C THE EXACT SOLUTION.
- DO 3 P = 1, NU
- DO 2 I = 1, NX
- DO 1 J = 1, NY
- U(I, J, P) = T*X(I)*Y(J)
- 1 CONTINUE
- 2 CONTINUE
- 3 CONTINUE
- RETURN
- END
diff --git a/CEP/PyBDSM/src/port3/ex/ttgrx1p.f b/CEP/PyBDSM/src/port3/ex/ttgrx1p.f
deleted file mode 100644
index c572904c08fc16356fc2bc81315b2e13fbb00db4..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ex/ttgrx1p.f
+++ /dev/null
@@ -1,183 +0,0 @@
-C$TEST TTGP
-C TO RUN AS A MAIN PROGRAM REMOVE NEXT LINE
- SUBROUTINE TTGP
-C***********************************************************************
-C
-C EXAMPLE OF USE OF PORT PROGRAM TTGR
-C
-C***********************************************************************
- COMMON /CSTAK/ DS
- DOUBLE PRECISION DS(350000)
- EXTERNAL HANDLE, BC, AF
- INTEGER NDX, NDY, ISTKGT, IUMB, IS(1000), IU
- INTEGER IX, IY, NU, KX, NX, KY
- INTEGER NY
- REAL ERRPAR(2), TSTART, DT, LX, LY, RX
- REAL RY, WS(1000), RS(1000), TSTOP
- LOGICAL LS(1000)
- COMPLEX CS(500)
- EQUIVALENCE (DS(1), CS(1), WS(1), RS(1), IS(1), LS(1))
-C TO SOLVE THE HEAT EQUATION WITH SOLUTION U == T*X*Y,
-C GRAD . ( U + UX + .1 * UY, U + UY + .1 * UX ) = UT + UX + UY +G(X,T)
-C THE PORT LIBRARY STACK AND ITS ALIASES.
-C INITIALIZE THE PORT LIBRARY STACK LENGTH.
- CALL ISTKIN(350000, 4)
- CALL ENTER(1)
- NU = 1
- LX = 0
- RX = 1
- LY = 0
- RY = 1
- KX = 2
- KY = 2
- NDX = 3
- NDY = 3
- TSTART = 0
- TSTOP = 1
- DT = 1
- ERRPAR(1) = 1E-2
- ERRPAR(2) = 1E-4
-C UNIFORM GRID.
- IX = IUMB(LX, RX, NDX, KX, NX)
-C UNIFORM GRID.
- IY = IUMB(LY, RY, NDY, KY, NY)
-C SPACE FOR THE SOLUTION.
- IU = ISTKGT(NU*(NX-KX)*(NY-KY), 3)
-C INITIAL CONDITIONS FOR U.
- CALL SETR(NU*(NX-KX)*(NY-KY), 0E0, WS(IU))
- CALL TTGR(WS(IU), NU, KX, WS(IX), NX, KY, WS(IY), NY, TSTART,
- 1 TSTOP, DT, AF, BC, ERRPAR, HANDLE)
- CALL LEAVE
- CALL WRAPUP
- STOP
- END
- SUBROUTINE AF(T, X, NX, Y, NY, NU, U, UT, UX, UY, UXT, UYT
- 1 , A, AU, AUT, AUX, AUY, AUXT, AUYT, F, FU, FUT, FUX, FUY, FUXT,
- 2 FUYT)
- INTEGER NU, NX, NY
- REAL T, X(NX), Y(NY), U(NX, NY, NU), UT(NX, NY, NU), UX(NX, NY,
- 1 NU)
- REAL UY(NX, NY, NU), UXT(NX, NY, NU), UYT(NX, NY, NU), A(NX, NY,
- 1 NU, 2), AU(NX, NY, NU, NU, 2), AUT(NX, NY, NU, NU, 2)
- REAL AUX(NX, NY, NU, NU, 2), AUY(NX, NY, NU, NU, 2), AUXT(NX, NY
- 1 , NU, NU, 2), AUYT(NX, NY, NU, NU, 2), F(NX, NY, NU), FU(NX,
- 2 NY, NU, NU)
- REAL FUT(NX, NY, NU, NU), FUX(NX, NY, NU, NU), FUY(NX, NY, NU, NU)
- 1 , FUXT(NX, NY, NU, NU), FUYT(NX, NY, NU, NU)
- INTEGER I, P, Q
- DO 3 I = 1, NU
- DO 2 Q = 1, NY
- DO 1 P = 1, NX
- A(P, Q, I, 1) = UX(P, Q, I)+.1*UY(P, Q, I)+U(P, Q, I)
- A(P, Q, I, 2) = UY(P, Q, I)+.1*UX(P, Q, I)+U(P, Q, I)
- AUX(P, Q, I, I, 1) = 1
- AUY(P, Q, I, I, 2) = 1
- AUY(P, Q, I, I, 1) = .1
- AUX(P, Q, I, I, 2) = .1
- AU(P, Q, I, I, 1) = 1
- AU(P, Q, I, I, 2) = 1
- F(P, Q, I) = UT(P, Q, I)+UX(P, Q, I)+UY(P, Q, I)
- FUT(P, Q, I, I) = 1
- FUX(P, Q, I, I) = 1
- FUY(P, Q, I, I) = 1
- F(P, Q, I) = F(P, Q, I)+.2*T-X(P)*Y(Q)
- 1 CONTINUE
- 2 CONTINUE
- 3 CONTINUE
- RETURN
- END
- SUBROUTINE BC(T, X, NX, Y, NY, LX, RX, LY, RY, U, UT, UX,
- 1 UY, UXT, UYT, NU, B, BU, BUT, BUX, BUY, BUXT, BUYT)
- INTEGER NU, NX, NY
- REAL T, X(NX), Y(NY), LX, RX, LY
- REAL RY, U(NX, NY, NU), UT(NX, NY, NU), UX(NX, NY, NU), UY(NX, NY,
- 1 NU), UXT(NX, NY, NU)
- REAL UYT(NX, NY, NU), B(NX, NY, NU), BU(NX, NY, NU, NU), BUT(NX,
- 1 NY, NU, NU), BUX(NX, NY, NU, NU), BUY(NX, NY, NU, NU)
- REAL BUXT(NX, NY, NU, NU), BUYT(NX, NY, NU, NU)
- INTEGER I, J
- DO 2 J = 1, NY
- DO 1 I = 1, NX
- BU(I, J, 1, 1) = 1
- B(I, J, 1) = U(I, J, 1)-T*X(I)*Y(J)
- 1 CONTINUE
- 2 CONTINUE
- RETURN
- END
- SUBROUTINE HANDLE(T0, U0, T, U, NV, DT, TSTOP)
- INTEGER NV
- REAL T0, U0(NV), T, U(NV), DT, TSTOP
- COMMON /A7TGRP/ ERRPAR, NU, MXQ, MYQ
- INTEGER NU, MXQ, MYQ
- REAL ERRPAR(2)
- COMMON /A7TGRM/ KX, IX, NX, KY, IY, NY
- INTEGER KX, IX, NX, KY, IY, NY
- IF (T0 .NE. T) GOTO 2
- WRITE (6, 1) T
- 1 FORMAT (16H RESTART FOR T =, 1PE10.2)
- RETURN
-C PRINT RESULTS.
- 2 CALL GERR(KX, IX, NX, KY, IY, NY, U, NU, T)
- RETURN
- END
- SUBROUTINE GERR(KX, IX, NX, KY, IY, NY, U, NU, T)
- INTEGER KX, IX, NX, KY, IY, NY
- INTEGER NU
- REAL U(1), T
- COMMON /CSTAK/ DS
- DOUBLE PRECISION DS(500)
- INTEGER IFA, ITA(2), IXA(2), NTA(2), NXA(2), IXS
- INTEGER IYS, NXS, NYS, ISTKGT, I, KA(2)
- INTEGER MA(2), IS(1000), ILUMD, I1MACH
- REAL RS(1000), WS(1000)
- LOGICAL LS(1000)
- COMPLEX CS(500)
- INTEGER TEMP, TEMP1
- EQUIVALENCE (DS(1), CS(1), WS(1), RS(1), IS(1), LS(1))
-C TO PRINT THE SOLUTION AT EACH TIME-STEP.
-C U(NX-KX,NY,KY,NU).
-C THE PORT LIBRARY STACK AND ITS ALIASES.
- CALL ENTER(1)
-C FIND THE SOLUTION AT 2 * 2 POINTS / MESH RECTANGLE.
-C X SEARCH GRID.
- IXS = ILUMD(WS(IX), NX, 2, NXS)
-C Y SEARCH GRID.
- IYS = ILUMD(WS(IY), NY, 2, NYS)
- KA(1) = KX
- KA(2) = KY
- ITA(1) = IX
- ITA(2) = IY
- NTA(1) = NX
- NTA(2) = NY
- IXA(1) = IXS
- IXA(2) = IYS
- NXA(1) = NXS
- NXA(2) = NYS
- MA(1) = 0
-C GET SOLUTION.
- MA(2) = 0
-C APPROXIMATE SOLUTION VALUES.
- IFA = ISTKGT(NXS*NYS, 3)
-C EVALUATE THEM.
- CALL TSD1(2, KA, WS, ITA, NTA, U, WS, IXA, NXA, MA, WS(IFA))
- TEMP1 = IFA+NXS*NYS-1
- TEMP = I1MACH(2)
- WRITE (TEMP, 1) T, (WS(I), I = IFA, TEMP1)
- 1 FORMAT (3H U(, 1PE10.2, 7H,.,.) =, (1P5E10.2/20X,1P4E10.2))
- CALL LEAVE
- RETURN
- END
- SUBROUTINE EWE(T, X, NX, Y, NY, U, NU)
- INTEGER NU, NX, NY
- REAL T, X(NX), Y(NY), U(NX, NY, NU)
- INTEGER I, J, P
-C THE EXACT SOLUTION.
- DO 3 P = 1, NU
- DO 2 I = 1, NX
- DO 1 J = 1, NY
- U(I, J, P) = T*X(I)*Y(J)
- 1 CONTINUE
- 2 CONTINUE
- 3 CONTINUE
- RETURN
- END
diff --git a/CEP/PyBDSM/src/port3/ex/ttgrx2.f b/CEP/PyBDSM/src/port3/ex/ttgrx2.f
deleted file mode 100644
index aaee1bdcfff13c2f563ed6819a261896f9a8f781..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ex/ttgrx2.f
+++ /dev/null
@@ -1,198 +0,0 @@
-C$TEST TTG2
-C TO RUN AS A MAIN PROGRAM REMOVE NEXT LINE
- SUBROUTINE TTG2
-C***********************************************************************
-C
-C EXAMPLE OF USE OF PORT PROGRAM TTGR
-C
-C***********************************************************************
- COMMON /CSTAK/ DS
- DOUBLE PRECISION DS(350000)
- EXTERNAL HANDLE, BC, AF
- INTEGER NDX, NDY, ISTKGT, IUMB, IS(1000), IU
- INTEGER IX, IY, NU, KX, NX, KY
- INTEGER NY
- REAL ERRPAR(2), TSTART, DT, LX, LY, RX
- REAL RY, WS(1000), RS(1000), TSTOP
- LOGICAL LS(1000)
- COMPLEX CS(500)
- EQUIVALENCE (DS(1), CS(1), WS(1), RS(1), IS(1), LS(1))
-C TO SOLVE TWO COUPLED, NONLINEAR HEAT EQUATIONS.
-C U1 SUB T = DIV . ( U1X, U1Y ) - U1*U2 + G1
-C U2 SUB T = DIV . ( U2X, U2Y ) - U1*U2 + G2
-C THE PORT LIBRARY STACK AND ITS ALIASES.
-C INITIALIZE THE PORT LIBRARY STACK LENGTH.
- CALL ISTKIN(350000, 4)
- CALL ENTER(1)
- NU = 2
- LX = 0
- RX = 1
- LY = 0
- RY = 1
- KX = 4
- KY = 4
- NDX = 3
- NDY = 3
- TSTART = 0
- TSTOP = 1
- DT = 1E-2
- ERRPAR(1) = 1E-2
- ERRPAR(2) = 1E-4
-C UNIFORM GRID.
- IX = IUMB(LX, RX, NDX, KX, NX)
-C UNIFORM GRID.
- IY = IUMB(LY, RY, NDY, KY, NY)
-C SPACE FOR THE SOLUTION.
- IU = ISTKGT(NU*(NX-KX)*(NY-KY), 3)
- CALL SETR(NU*(NX-KX)*(NY-KY), 1E0, WS(IU))
- CALL TTGR(WS(IU), NU, KX, WS(IX), NX, KY, WS(IY), NY, TSTART,
- 1 TSTOP, DT, AF, BC, ERRPAR, HANDLE)
- CALL LEAVE
- CALL WRAPUP
- STOP
- END
- SUBROUTINE AF(T, X, NX, Y, NY, NU, U, UT, UX, UY, UXT, UYT
- 1 , A, AU, AUT, AUX, AUY, AUXT, AUYT, F, FU, FUT, FUX, FUY, FUXT,
- 2 FUYT)
- INTEGER NU, NX, NY
- REAL T, X(NX), Y(NY), U(NX, NY, NU), UT(NX, NY, NU), UX(NX, NY,
- 1 NU)
- REAL UY(NX, NY, NU), UXT(NX, NY, NU), UYT(NX, NY, NU), A(NX, NY,
- 1 NU, 2), AU(NX, NY, NU, NU, 2), AUT(NX, NY, NU, NU, 2)
- REAL AUX(NX, NY, NU, NU, 2), AUY(NX, NY, NU, NU, 2), AUXT(NX, NY
- 1 , NU, NU, 2), AUYT(NX, NY, NU, NU, 2), F(NX, NY, NU), FU(NX,
- 2 NY, NU, NU)
- REAL FUT(NX, NY, NU, NU), FUX(NX, NY, NU, NU), FUY(NX, NY, NU, NU)
- 1 , FUXT(NX, NY, NU, NU), FUYT(NX, NY, NU, NU)
- INTEGER P, Q
- REAL EXP
- DO 2 Q = 1, NY
- DO 1 P = 1, NX
- A(P, Q, 1, 1) = UX(P, Q, 1)
- AUX(P, Q, 1, 1, 1) = 1
- A(P, Q, 1, 2) = UY(P, Q, 1)
- AUY(P, Q, 1, 1, 2) = 1
- F(P, Q, 1) = UT(P, Q, 1)+U(P, Q, 1)*U(P, Q, 2)
- FU(P, Q, 1, 1) = U(P, Q, 2)
- FU(P, Q, 1, 2) = U(P, Q, 1)
- FUT(P, Q, 1, 1) = 1
- A(P, Q, 2, 1) = UX(P, Q, 2)
- AUX(P, Q, 2, 2, 1) = 1
- A(P, Q, 2, 2) = UY(P, Q, 2)
- AUY(P, Q, 2, 2, 2) = 1
- F(P, Q, 2) = UT(P, Q, 2)+U(P, Q, 1)*U(P, Q, 2)
- FU(P, Q, 2, 1) = U(P, Q, 2)
- FU(P, Q, 2, 2) = U(P, Q, 1)
- FUT(P, Q, 2, 2) = 1
- F(P, Q, 1) = F(P, Q, 1)-(EXP(T*(X(P)-Y(Q)))*(X(P)-Y(Q)-2.*T*
- 1 T)+1.)
- F(P, Q, 2) = F(P, Q, 2)-(EXP(T*(Y(Q)-X(P)))*(Y(Q)-X(P)-2.*T*
- 1 T)+1.)
- 1 CONTINUE
- 2 CONTINUE
- RETURN
- END
- SUBROUTINE BC(T, X, NX, Y, NY, LX, RX, LY, RY, U, UT, UX,
- 1 UY, UXT, UYT, NU, B, BU, BUT, BUX, BUY, BUXT, BUYT)
- INTEGER NU, NX, NY
- REAL T, X(NX), Y(NY), LX, RX, LY
- REAL RY, U(NX, NY, NU), UT(NX, NY, NU), UX(NX, NY, NU), UY(NX, NY,
- 1 NU), UXT(NX, NY, NU)
- REAL UYT(NX, NY, NU), B(NX, NY, NU), BU(NX, NY, NU, NU), BUT(NX,
- 1 NY, NU, NU), BUX(NX, NY, NU, NU), BUY(NX, NY, NU, NU)
- REAL BUXT(NX, NY, NU, NU), BUYT(NX, NY, NU, NU)
- INTEGER I, J
- REAL EXP
- DO 2 J = 1, NY
- DO 1 I = 1, NX
- BU(I, J, 1, 1) = 1
- B(I, J, 1) = U(I, J, 1)-EXP(T*(X(I)-Y(J)))
- BU(I, J, 2, 2) = 1
- B(I, J, 2) = U(I, J, 2)-EXP(T*(Y(J)-X(I)))
- 1 CONTINUE
- 2 CONTINUE
- RETURN
- END
- SUBROUTINE HANDLE(T0, U0, T, U, NV, DT, TSTOP)
- INTEGER NV
- REAL T0, U0(NV), T, U(NV), DT, TSTOP
- COMMON /CSTAK/ DS
- DOUBLE PRECISION DS(500)
- COMMON /A7TGRP/ ERRPAR, NU, MXQ, MYQ
- INTEGER NU, MXQ, MYQ
- REAL ERRPAR(2)
- COMMON /A7TGRM/ KX, IX, NX, KY, IY, NY
- INTEGER KX, IX, NX, KY, IY, NY
- INTEGER IFA, ITA(2), IXA(2), NTA(2), NXA(2), IXS
- INTEGER IYS, NXS, NYS, ISTKGT, I, J
- INTEGER IEWE, KA(2), MA(2), IS(1000), ILUMD, I1MACH
- REAL ABS, ERRU, AMAX1, RS(1000), WS(1000)
- LOGICAL LS(1000)
- COMPLEX CS(500)
- INTEGER TEMP, TEMP1, TEMP2
- EQUIVALENCE (DS(1), CS(1), WS(1), RS(1), IS(1), LS(1))
-C THE PORT LIBRARY STACK AND ITS ALIASES.
- IF (T0 .NE. T) GOTO 2
- WRITE (6, 1) T
- 1 FORMAT (16H RESTART FOR T =, 1PE10.2)
- RETURN
- 2 CALL ENTER(1)
-C FIND THE ERROR IN THE SOLUTION AT 2*KX * 2*KY POINTS / MESH RECTANGLE.
-C X SEARCH GRID.
- IXS = ILUMD(WS(IX), NX, 2*KX, NXS)
-C Y SEARCH GRID.
- IYS = ILUMD(WS(IY), NY, 2*KY, NYS)
-C U SEARCH GRID VALUES.
- IEWE = ISTKGT(NU*NXS*NYS, 3)
-C THE EXACT SOLUTION.
- CALL EWE(T, WS(IXS), NXS, WS(IYS), NYS, WS(IEWE), NU)
- KA(1) = KX
- KA(2) = KY
- ITA(1) = IX
- ITA(2) = IY
- NTA(1) = NX
- NTA(2) = NY
- IXA(1) = IXS
- IXA(2) = IYS
- NXA(1) = NXS
- NXA(2) = NYS
- MA(1) = 0
-C GET SOLUTION.
- MA(2) = 0
-C APPROXIMATE SOLUTION VALUES.
- IFA = ISTKGT(NXS*NYS, 3)
- DO 5 J = 1, NU
-C EVALUATE THEM.
- TEMP = (J-1)*(NX-KX)*(NY-KY)
- CALL TSD1(2, KA, WS, ITA, NTA, U(TEMP+1), WS, IXA, NXA, MA, WS(
- 1 IFA))
-C ERROR IN SOLUTION VALUES.
- ERRU = 0
- TEMP = NXS*NYS
- DO 3 I = 1, TEMP
- TEMP2 = IEWE+I-1+(J-1)*NXS*NYS
- TEMP1 = IFA+I
- ERRU = AMAX1(ERRU, ABS(WS(TEMP2)-WS(TEMP1-1)))
- 3 CONTINUE
- TEMP = I1MACH(2)
- WRITE (TEMP, 4) T, J, ERRU
- 4 FORMAT (14H ERROR IN U(.,, 1PE10.2, 1H,, I2, 3H) =, 1PE10.2)
- 5 CONTINUE
- CALL LEAVE
- RETURN
- END
- SUBROUTINE EWE(T, X, NX, Y, NY, U, NU)
- INTEGER NU, NX, NY
- REAL T, X(NX), Y(NY), U(NX, NY, NU)
- INTEGER I, J, P
- REAL EXP, FLOAT
-C THE EXACT SOLUTION.
- DO 3 P = 1, NU
- DO 2 I = 1, NX
- DO 1 J = 1, NY
- U(I, J, P) = EXP(FLOAT((-1)**(P+1))*T*(X(I)-Y(J)))
- 1 CONTINUE
- 2 CONTINUE
- 3 CONTINUE
- RETURN
- END
diff --git a/CEP/PyBDSM/src/port3/ex/ttgrx3.f b/CEP/PyBDSM/src/port3/ex/ttgrx3.f
deleted file mode 100644
index e11e38300b0866da59d02772c9796eeaa35a2bbf..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ex/ttgrx3.f
+++ /dev/null
@@ -1,232 +0,0 @@
-C$TEST TTG3
-C TO RUN AS A MAIN PROGRAM REMOVE NEXT LINE
- SUBROUTINE TTG3
-C***********************************************************************
-C
-C EXAMPLE OF USE OF PORT PROGRAM TTGR
-C
-C***********************************************************************
- COMMON /CSTAK/ DS
- DOUBLE PRECISION DS(350000)
- EXTERNAL HANDLE, BC, AF
- INTEGER NDX, NDY, ISTKGT, I, IUMB, IMMM
- INTEGER IS(1000), IU, IX, IY, NU, KX
- INTEGER NX, KY, NY, ILUMB
- REAL ERRPAR(2), TSTART, DT, YB(4), LX, RS(1000)
- REAL RX, WS(1000), TSTOP
- LOGICAL LS(1000)
- COMPLEX CS(500)
- EQUIVALENCE (DS(1), CS(1), WS(1), RS(1), IS(1), LS(1))
-C TO SOLVE THE LAYERED HEAT EQUATION, WITH KAPPA = 1, 1/2, 1/3,
-C DIV . ( KAPPA(X,Y) * GRAD U ) = UT + G
-C THE PORT LIBRARY STACK AND ITS ALIASES.
-C INITIALIZE THE PORT LIBRARY STACK LENGTH.
- CALL ISTKIN(350000, 4)
- CALL ENTER(1)
- NU = 1
- LX = 0
- RX = 1
- DO 1 I = 1, 4
- YB(I) = I-1
- 1 CONTINUE
- KX = 2
- KY = 2
- NDX = 3
- NDY = 3
- TSTART = 0
- TSTOP = 1
- DT = 1
- ERRPAR(1) = 1E-2
- ERRPAR(2) = 1E-4
-C UNIFORM GRID.
- IX = IUMB(LX, RX, NDX, KX, NX)
-C UNIFORM GRID.
- IY = ILUMB(YB, 4, NDY, KY, NY)
-C MAKE MULT = KY-1.
- IY = IMMM(IY, NY, YB(2), KY-1)
-C MAKE MULT = KY-1.
- IY = IMMM(IY, NY, YB(3), KY-1)
-C SPACE FOR THE SOLUTION.
- IU = ISTKGT(NU*(NX-KX)*(NY-KY), 3)
- CALL SETR(NU*(NX-KX)*(NY-KY), 0E0, WS(IU))
- CALL TTGR(WS(IU), NU, KX, WS(IX), NX, KY, WS(IY), NY, TSTART,
- 1 TSTOP, DT, AF, BC, ERRPAR, HANDLE)
- CALL LEAVE
- CALL WRAPUP
- STOP
- END
- SUBROUTINE AF(T, X, NX, Y, NY, NU, U, UT, UX, UY, UXT, UYT
- 1 , A, AU, AUT, AUX, AUY, AUXT, AUYT, F, FU, FUT, FUX, FUY, FUXT,
- 2 FUYT)
- INTEGER NU, NX, NY
- REAL T, X(NX), Y(NY), U(NX, NY, NU), UT(NX, NY, NU), UX(NX, NY,
- 1 NU)
- REAL UY(NX, NY, NU), UXT(NX, NY, NU), UYT(NX, NY, NU), A(NX, NY,
- 1 NU, 2), AU(NX, NY, NU, NU, 2), AUT(NX, NY, NU, NU, 2)
- REAL AUX(NX, NY, NU, NU, 2), AUY(NX, NY, NU, NU, 2), AUXT(NX, NY
- 1 , NU, NU, 2), AUYT(NX, NY, NU, NU, 2), F(NX, NY, NU), FU(NX,
- 2 NY, NU, NU)
- REAL FUT(NX, NY, NU, NU), FUX(NX, NY, NU, NU), FUY(NX, NY, NU, NU)
- 1 , FUXT(NX, NY, NU, NU), FUYT(NX, NY, NU, NU)
- INTEGER I, P, Q
- REAL KAPPA
- LOGICAL TEMP
- DO 7 I = 1, NU
- DO 6 Q = 1, NY
- DO 5 P = 1, NX
- IF (Y(Q) .GE. 1.) GOTO 1
- KAPPA = 1
- GOTO 4
- 1 IF (Y(Q) .GE. 2.) GOTO 2
- KAPPA = 0.5
- GOTO 3
- 2 KAPPA = 1./3E0
- 3 CONTINUE
- 4 A(P, Q, I, 1) = KAPPA*UX(P, Q, I)
- AUX(P, Q, I, I, 1) = KAPPA
- A(P, Q, I, 2) = KAPPA*UY(P, Q, I)
- AUY(P, Q, I, I, 2) = KAPPA
- F(P, Q, I) = UT(P, Q, I)
- FUT(P, Q, I, I) = 1
- F(P, Q, I) = F(P, Q, I)-Y(Q)/KAPPA
- TEMP = 1. .LT. Y(Q)
- IF (TEMP) TEMP = Y(Q) .LT. 2.
- IF (TEMP) F(P, Q, I) = F(P, Q, I)+1.
- TEMP = 2. .LT. Y(Q)
- IF (TEMP) TEMP = Y(Q) .LT. 3.
- IF (TEMP) F(P, Q, I) = F(P, Q, I)+3.
- 5 CONTINUE
- 6 CONTINUE
- 7 CONTINUE
- RETURN
- END
- SUBROUTINE BC(T, X, NX, Y, NY, LX, RX, LY, RY, U, UT, UX,
- 1 UY, UXT, UYT, NU, B, BU, BUT, BUX, BUY, BUXT, BUYT)
- INTEGER NU, NX, NY
- REAL T, X(NX), Y(NY), LX, RX, LY
- REAL RY, U(NX, NY, NU), UT(NX, NY, NU), UX(NX, NY, NU), UY(NX, NY,
- 1 NU), UXT(NX, NY, NU)
- REAL UYT(NX, NY, NU), B(NX, NY, NU), BU(NX, NY, NU, NU), BUT(NX,
- 1 NY, NU, NU), BUX(NX, NY, NU, NU), BUY(NX, NY, NU, NU)
- REAL BUXT(NX, NY, NU, NU), BUYT(NX, NY, NU, NU)
- INTEGER I, J
- LOGICAL TEMP
- DO 6 J = 1, NY
- DO 5 I = 1, NX
- TEMP = X(I) .EQ. LX
- IF (.NOT. TEMP) TEMP = X(I) .EQ. RX
- IF (.NOT. TEMP) GOTO 1
- BUX(I, J, 1, 1) = 1
-C LEFT OR RIGHT.
-C NEUMANN BCS.
- B(I, J, 1) = UX(I, J, 1)
- GOTO 4
- 1 IF (Y(J) .NE. LY) GOTO 2
- B(I, J, 1) = U(I, J, 1)
-C BOTTOM.
- BU(I, J, 1, 1) = 1
- GOTO 3
- 2 B(I, J, 1) = U(I, J, 1)-6.*T
-C TOP.
- BU(I, J, 1, 1) = 1
- 3 CONTINUE
- 4 CONTINUE
- 5 CONTINUE
- 6 CONTINUE
- RETURN
- END
- SUBROUTINE HANDLE(T0, U0, T, U, NV, DT, TSTOP)
- INTEGER NV
- REAL T0, U0(NV), T, U(NV), DT, TSTOP
- COMMON /A7TGRP/ ERRPAR, NU, MXQ, MYQ
- INTEGER NU, MXQ, MYQ
- REAL ERRPAR(2)
- COMMON /A7TGRM/ KX, IX, NX, KY, IY, NY
- INTEGER KX, IX, NX, KY, IY, NY
- IF (T0 .NE. T) GOTO 2
- WRITE (6, 1) T
- 1 FORMAT (16H RESTART FOR T =, 1PE10.2)
- RETURN
- 2 CALL GERR(KX, IX, NX, KY, IY, NY, U, NU, T)
- RETURN
- END
- SUBROUTINE GERR(KX, IX, NX, KY, IY, NY, U, NU, T)
- INTEGER KX, IX, NX, KY, IY, NY
- INTEGER NU
- REAL U(1), T
- COMMON /CSTAK/ DS
- DOUBLE PRECISION DS(500)
- INTEGER IFA, ITA(2), IXA(2), NTA(2), NXA(2), IXS
- INTEGER IYS, NXS, NYS, ISTKGT, I, IEWE
- INTEGER KA(2), MA(2), IS(1000), ILUMD, I1MACH
- REAL ABS, ERRU, AMAX1, RS(1000), WS(1000)
- LOGICAL LS(1000)
- COMPLEX CS(500)
- INTEGER TEMP, TEMP1, TEMP2
- EQUIVALENCE (DS(1), CS(1), WS(1), RS(1), IS(1), LS(1))
-C TO GET AND PRINT THE ERROR AT EACH TIME-STEP.
-C U(NX-KX,NY,KY,NU).
-C THE PORT LIBRARY STACK AND ITS ALIASES.
- CALL ENTER(1)
-C FIND THE ERROR IN THE SOLUTION AT 2*KX * 2*KY POINTS / MESH RECTANGLE.
-C X SEARCH GRID.
- IXS = ILUMD(WS(IX), NX, 2*KX, NXS)
-C Y SEARCH GRID.
- IYS = ILUMD(WS(IY), NY, 2*KY, NYS)
-C U SEARCH GRID VALUES.
- IEWE = ISTKGT(NXS*NYS, 3)
-C THE EXACT SOLUTION.
- CALL EWE(T, WS(IXS), NXS, WS(IYS), NYS, WS(IEWE), NU)
- KA(1) = KX
- KA(2) = KY
- ITA(1) = IX
- ITA(2) = IY
- NTA(1) = NX
- NTA(2) = NY
- IXA(1) = IXS
- IXA(2) = IYS
- NXA(1) = NXS
- NXA(2) = NYS
- MA(1) = 0
-C GET SOLUTION.
- MA(2) = 0
-C APPROXIMATE SOLUTION VALUES.
- IFA = ISTKGT(NXS*NYS, 3)
-C EVALUATE THEM.
- CALL TSD1(2, KA, WS, ITA, NTA, U, WS, IXA, NXA, MA, WS(IFA))
-C ERROR IN SOLUTION VALUES.
- ERRU = 0
- TEMP = NXS*NYS
- DO 1 I = 1, TEMP
- TEMP2 = IEWE+I
- TEMP1 = IFA+I
- ERRU = AMAX1(ERRU, ABS(WS(TEMP2-1)-WS(TEMP1-1)))
- 1 CONTINUE
- TEMP = I1MACH(2)
- WRITE (TEMP, 2) T, ERRU
- 2 FORMAT (14H ERROR IN U(.,, 1PE10.2, 3H) =, 1PE10.2)
- CALL LEAVE
- RETURN
- END
- SUBROUTINE EWE(T, X, NX, Y, NY, U, NU)
- INTEGER NU, NX, NY
- REAL T, X(NX), Y(NY), U(NX, NY, NU)
- INTEGER I, J, P
-C THE EXACT SOLUTION.
- DO 7 P = 1, NU
- DO 6 I = 1, NX
- DO 5 J = 1, NY
- IF (Y(J) .GE. 1.) GOTO 1
- U(I, J, P) = T*Y(J)
- GOTO 4
- 1 IF (Y(J) .GE. 2.) GOTO 2
- U(I, J, P) = 2.*T*Y(J)-T
- GOTO 3
- 2 U(I, J, P) = 3.*T*Y(J)-3.*T
- 3 CONTINUE
- 4 CONTINUE
- 5 CONTINUE
- 6 CONTINUE
- 7 CONTINUE
- RETURN
- END
diff --git a/CEP/PyBDSM/src/port3/ex/ttgrx4.f b/CEP/PyBDSM/src/port3/ex/ttgrx4.f
deleted file mode 100644
index 8bd89f77415734f9f0e588f02b4f62550bd55ad1..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ex/ttgrx4.f
+++ /dev/null
@@ -1,262 +0,0 @@
-C$TEST TTG4
-C TO RUN AS A MAIN PROGRAM REMOVE NEXT LINE
- SUBROUTINE TTG4
-C***********************************************************************
-C
-C EXAMPLE OF USE OF PORT PROGRAM TTGR
-C
-C***********************************************************************
- COMMON /CSTAK/ DS
- DOUBLE PRECISION DS(350000)
- EXTERNAL HANDLE, BC, AF
- INTEGER NDX, NDY, ISTKGT, IUMB, IS(1000), IU
- INTEGER IX, IY, NU, KX, NX, KY
- INTEGER NY
- REAL ERRPAR(2), TSTART, DT, LX, LY, RX
- REAL RY, WS(1000), RS(1000), TSTOP
- LOGICAL LS(1000)
- COMPLEX CS(500)
- EQUIVALENCE (DS(1), CS(1), WS(1), RS(1), IS(1), LS(1))
-C TO SOLVE THE LINEAR HEAT EQUATION
-C GRAD . ( UX - 0.1 * UY , 0.1*UX + UY ) = UT - X*Y
-C WITH SOLUTION U == T*X*Y ON [0,+1]**2, EXACT FOR K = 4,
-C WITH TILTED TOP AND BOTTOM, NORMAL BCS THERE.
-C THE PORT LIBRARY STACK AND ITS ALIASES.
-C INITIALIZE THE PORT LIBRARY STACK LENGTH.
- CALL ISTKIN(350000, 4)
- CALL ENTER(1)
- NU = 1
- LX = 0
- RX = 1
- LY = 0
- RY = 1
- KX = 4
- KY = 4
- NDX = 3
- NDY = 3
- TSTART = 0
- TSTOP = 1
- DT = 1
- ERRPAR(1) = 1E-2
- ERRPAR(2) = 1E-4
-C UNIFORM GRID.
- IX = IUMB(LX, RX, NDX, KX, NX)
-C UNIFORM GRID.
- IY = IUMB(LY, RY, NDY, KY, NY)
-C SPACE FOR THE SOLUTION.
- IU = ISTKGT(NU*(NX-KX)*(NY-KY), 3)
- CALL SETR(NU*(NX-KX)*(NY-KY), 0E0, WS(IU))
- CALL TTGR(WS(IU), NU, KX, WS(IX), NX, KY, WS(IY), NY, TSTART,
- 1 TSTOP, DT, AF, BC, ERRPAR, HANDLE)
- CALL LEAVE
- CALL WRAPUP
- STOP
- END
- SUBROUTINE AF(T, XI, NX, YI, NY, NU, U, UT, UX, UY, UXT,
- 1 UYT, A, AU, AUT, AUX, AUY, AUXT, AUYT, F, FU, FUT, FUX, FUY,
- 2 FUXT, FUYT)
- INTEGER NU, NX, NY
- REAL T, XI(NX), YI(NY), U(NX, NY, NU), UT(NX, NY, NU), UX(NX, NY
- 1 , NU)
- REAL UY(NX, NY, NU), UXT(NX, NY, NU), UYT(NX, NY, NU), A(NX, NY,
- 1 NU, 2), AU(NX, NY, NU, NU, 2), AUT(NX, NY, NU, NU, 2)
- REAL AUX(NX, NY, NU, NU, 2), AUY(NX, NY, NU, NU, 2), AUXT(NX, NY
- 1 , NU, NU, 2), AUYT(NX, NY, NU, NU, 2), F(NX, NY, NU), FU(NX,
- 2 NY, NU, NU)
- REAL FUT(NX, NY, NU, NU), FUX(NX, NY, NU, NU), FUY(NX, NY, NU, NU)
- 1 , FUXT(NX, NY, NU, NU), FUYT(NX, NY, NU, NU)
- EXTERNAL BT, LR
- INTEGER I, P, Q
- REAL D(600), X, Y, XX(100), YY(100)
- INTEGER TEMP
- IF (NX*NY .GT. 100) CALL SETERR(19HAF - NX*NY .GT. 100, 19, 1, 2)
- CALL BTMAP(T, XI, YI, NX, NY, LR, BT, XX, YY, D)
-C MAP INTO (X,Y).
- CALL TTGRU(NX, NY, D, UX, UY, UT, NU)
- DO 3 I = 1, NU
- DO 2 Q = 1, NY
- DO 1 P = 1, NX
- TEMP = P+(Q-1)*NX
- X = XX(TEMP)
- TEMP = P+(Q-1)*NX
- Y = YY(TEMP)
- A(P, Q, I, 1) = UX(P, Q, I)-.1*UY(P, Q, I)
- A(P, Q, I, 2) = UY(P, Q, I)+.1*UX(P, Q, I)
- AUX(P, Q, I, I, 1) = 1
- AUY(P, Q, I, I, 2) = 1
- AUY(P, Q, I, I, 1) = -.1
- AUX(P, Q, I, I, 2) = .1
- F(P, Q, 1) = UT(P, Q, 1)-X*Y
- FUT(P, Q, 1, 1) = 1
- 1 CONTINUE
- 2 CONTINUE
- 3 CONTINUE
-C MAP INTO (XI,ETA).
- CALL TTGRG(NX, NY, D, NU, A, AU, AUX, AUY, F, FU, FUX, FUY)
- RETURN
- END
- SUBROUTINE BC(T, XI, NX, YI, NY, LX, RX, LY, RY, U, UT, UX
- 1 , UY, UXT, UYT, NU, B, BU, BUT, BUX, BUY, BUXT, BUYT)
- INTEGER NU, NX, NY
- REAL T, XI(NX), YI(NY), LX, RX, LY
- REAL RY, U(NX, NY, NU), UT(NX, NY, NU), UX(NX, NY, NU), UY(NX, NY,
- 1 NU), UXT(NX, NY, NU)
- REAL UYT(NX, NY, NU), B(NX, NY, NU), BU(NX, NY, NU, NU), BUT(NX,
- 1 NY, NU, NU), BUX(NX, NY, NU, NU), BUY(NX, NY, NU, NU)
- REAL BUXT(NX, NY, NU, NU), BUYT(NX, NY, NU, NU)
- EXTERNAL BT, LR
- INTEGER I, J
- REAL D(600), X, Y, XX(100), YY(100)
- INTEGER TEMP1
- LOGICAL TEMP
- IF (NX*NY .GT. 100) CALL SETERR(19HBC - NX*NY .GT. 100, 19, 1, 2)
- CALL BTMAP(T, XI, YI, NX, NY, LR, BT, XX, YY, D)
-C MAP INTO (X,Y).
- CALL TTGRU(NX, NY, D, UX, UY, UT, NU)
- DO 6 J = 1, NY
- DO 5 I = 1, NX
- TEMP1 = I+(J-1)*NX
- X = XX(TEMP1)
- TEMP1 = I+(J-1)*NX
- Y = YY(TEMP1)
- TEMP = XI(I) .EQ. LX
- IF (.NOT. TEMP) TEMP = XI(I) .EQ. RX
- IF (.NOT. TEMP) GOTO 1
- BU(I, J, 1, 1) = 1
-C LEFT OR RIGHT.
- B(I, J, 1) = U(I, J, 1)-T*X*Y
- GOTO 4
- 1 IF (YI(J) .NE. LY) GOTO 2
- B(I, J, 1) = (UX(I, J, 1)-T*Y)-(UY(I, J, 1)-T*X)
-C BOTTOM.
- BUX(I, J, 1, 1) = 1
-C NORMAL IS (1,-1).
- BUY(I, J, 1, 1) = -1
- GOTO 3
- 2 B(I, J, 1) = (UY(I, J, 1)-T*X)-(UX(I, J, 1)-T*Y)
-C TOP.
- BUX(I, J, 1, 1) = -1
-C NORMAL IS (-1,1).
- BUY(I, J, 1, 1) = 1
- 3 CONTINUE
- 4 CONTINUE
- 5 CONTINUE
- 6 CONTINUE
-C MAP INTO (XI,ETA).
- CALL TTGRB(NX, NY, D, NU, BUX, BUY, BUT)
- RETURN
- END
- SUBROUTINE HANDLE(T0, U0, T, U, NV, DT, TSTOP)
- INTEGER NV
- REAL T0, U0(NV), T, U(NV), DT, TSTOP
- COMMON /A7TGRP/ ERRPAR, NU, MXQ, MYQ
- INTEGER NU, MXQ, MYQ
- REAL ERRPAR(2)
- COMMON /A7TGRM/ KX, IX, NX, KY, IY, NY
- INTEGER KX, IX, NX, KY, IY, NY
- IF (T0 .NE. T) GOTO 2
- WRITE (6, 1) T
- 1 FORMAT (16H RESTART FOR T =, 1PE10.2)
- RETURN
- 2 CALL GERR(KX, IX, NX, KY, IY, NY, U, NU, T)
- RETURN
- END
- SUBROUTINE GERR(KX, IX, NX, KY, IY, NY, U, NU, T)
- INTEGER KX, IX, NX, KY, IY, NY
- INTEGER NU
- REAL U(1), T
- COMMON /CSTAK/ DS
- DOUBLE PRECISION DS(500)
- INTEGER IFA, ITA(2), IXA(2), NTA(2), NXA(2), IXS
- INTEGER IYS, NXS, NYS, ISTKGT, I, IEWE
- INTEGER KA(2), MA(2), IS(1000), ILUMD, I1MACH
- REAL ABS, ERRU, AMAX1, RS(1000), WS(1000)
- LOGICAL LS(1000)
- COMPLEX CS(500)
- INTEGER TEMP, TEMP1, TEMP2
- EQUIVALENCE (DS(1), CS(1), WS(1), RS(1), IS(1), LS(1))
-C TO GET AND PRINT THE ERROR AT EACH TIME-STEP.
-C U(NX-KX,NY-KY,NU).
-C THE PORT LIBRARY STACK AND ITS ALIASES.
- CALL ENTER(1)
-C FIND THE ERROR IN THE SOLUTION AT 2*KX * 2*KY POINTS / MESH RECTANGLE.
-C X SEARCH GRID.
- IXS = ILUMD(WS(IX), NX, 2*KX, NXS)
-C Y SEARCH GRID.
- IYS = ILUMD(WS(IY), NY, 2*KY, NYS)
-C U SEARCH GRID VALUES.
- IEWE = ISTKGT(NXS*NYS, 3)
-C THE EXACT SOLUTION.
- CALL EWE(T, WS(IXS), NXS, WS(IYS), NYS, WS(IEWE), NU)
- KA(1) = KX
- KA(2) = KY
- ITA(1) = IX
- ITA(2) = IY
- NTA(1) = NX
- NTA(2) = NY
- IXA(1) = IXS
- IXA(2) = IYS
- NXA(1) = NXS
- NXA(2) = NYS
- MA(1) = 0
-C GET SOLUTION.
- MA(2) = 0
-C APPROXIMATE SOLUTION VALUES.
- IFA = ISTKGT(NXS*NYS, 3)
-C EVALUATE THEM.
- CALL TSD1(2, KA, WS, ITA, NTA, U, WS, IXA, NXA, MA, WS(IFA))
-C ERROR IN SOLUTION VALUES.
- ERRU = 0
- TEMP = NXS*NYS
- DO 1 I = 1, TEMP
- TEMP2 = IEWE+I
- TEMP1 = IFA+I
- ERRU = AMAX1(ERRU, ABS(WS(TEMP2-1)-WS(TEMP1-1)))
- 1 CONTINUE
- TEMP = I1MACH(2)
- WRITE (TEMP, 2) T, ERRU
- 2 FORMAT (14H ERROR IN U(.,, 1PE10.2, 3H) =, 1PE10.2)
- CALL LEAVE
- RETURN
- END
- SUBROUTINE EWE(T, XI, NX, YI, NY, U, NU)
- INTEGER NU, NX, NY
- REAL T, XI(NX), YI(NY), U(NX, NY, NU)
- EXTERNAL BT, LR
- INTEGER I, J, P
- REAL D(6000), X, Y, XX(1000), YY(1000)
-C THE EXACT SOLUTION.
- IF (NY .GT. 1000) CALL SETERR(18HEWE - NY .GT. 1000, 18, 1, 2)
- DO 3 P = 1, NU
- DO 2 I = 1, NX
- CALL BTMAP(T, XI(I), YI, 1, NY, LR, BT, XX, YY, D)
- DO 1 J = 1, NY
- X = XX(J)
- Y = YY(J)
- U(I, J, P) = T*X*Y
- 1 CONTINUE
- 2 CONTINUE
- 3 CONTINUE
- RETURN
- END
- SUBROUTINE LR(T, LX, RX, LXT, RXT)
- REAL T, LX, RX, LXT, RXT
-C TO GET THE L AND R END-POINTS OF THE MAPPING IN X.
- LX = 0
- RX = 1
- LXT = 0
- RXT = 0
- RETURN
- END
- SUBROUTINE BT(T, X, F, G, FX, GX, FT, GT)
- REAL T, X, F, G, FX, GX
- REAL FT, GT
-C TO GET THE BOTTOM AND TOP OF MAPPING IN Y.
- F = X-1.
- G = X
- FT = 0
- GT = 0
- FX = 1
- GX = 1
- RETURN
- END
diff --git a/CEP/PyBDSM/src/port3/ex/ttgrx5.f b/CEP/PyBDSM/src/port3/ex/ttgrx5.f
deleted file mode 100644
index 8e8d5e7376dec67ed2571a91cec2749239d2366b..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ex/ttgrx5.f
+++ /dev/null
@@ -1,235 +0,0 @@
-C$TEST TTG5
-C TO RUN AS A MAIN PROGRAM REMOVE NEXT LINE
- SUBROUTINE TTG5
-C***********************************************************************
-C
-C EXAMPLE OF USE OF PORT PROGRAM TTGR
-C
-C***********************************************************************
- COMMON /CSTAK/ DS
- DOUBLE PRECISION DS(350000)
- EXTERNAL HANDLE, BC, AF
- INTEGER NDX, NDY, ISTKGT, I, IS(1000), IU
- INTEGER IX, IY, NU, KX, NX, KY
- INTEGER NY
- REAL ERRPAR(2), TSTART, DT, LX, LY, RX
- REAL RY, WS(1000), RS(1000), FLOAT, TSTOP
- LOGICAL LS(1000)
- COMPLEX CS(500)
- INTEGER TEMP, TEMP1
- EQUIVALENCE (DS(1), CS(1), WS(1), RS(1), IS(1), LS(1))
-C TO SOLVE LAPLACES EQUATION WITH REAL ( Z*LOG(Z) ) AS SOLUTION.
-C THE PORT LIBRARY STACK AND ITS ALIASES.
-C INITIALIZE THE PORT LIBRARY STACK LENGTH.
- CALL ISTKIN(350000, 4)
- CALL ENTER(1)
- NU = 1
- LX = 0
- RX = 1
- LY = 0
- RY = 1
- KX = 4
- KY = 4
- NDX = 2
- NDY = 2
- TSTART = 0
- TSTOP = 1
- DT = 1
- ERRPAR(1) = 1E-2
- ERRPAR(2) = 1E-4
- NX = NDX+2*(KX-1)
-C SPACE FOR X MESH.
- IX = ISTKGT(NX, 3)
- DO 1 I = 1, KX
- TEMP = IX+I
- WS(TEMP-1) = 0
- TEMP = IX+NX-I
- WS(TEMP) = RX
- 1 CONTINUE
-C 0 AND RX MULT = KX.
- TEMP = NDX-1
- DO 2 I = 1, TEMP
- TEMP1 = IX+KX-2+I
- WS(TEMP1) = RX*(FLOAT(I-1)/(FLOAT(NDX)-1E0))**KX
- 2 CONTINUE
- NY = NDY+2*(KY-1)
-C SPACE FOR Y MESH.
- IY = ISTKGT(NY, 3)
- DO 3 I = 1, KY
- TEMP = IY+I
- WS(TEMP-1) = 0
- TEMP = IY+NY-I
- WS(TEMP) = RY
- 3 CONTINUE
-C 0 AND RY MULT = KY.
- TEMP = NDY-1
- DO 4 I = 1, TEMP
- TEMP1 = IY+KY-2+I
- WS(TEMP1) = RY*(FLOAT(I-1)/(FLOAT(NDY)-1E0))**KY
- 4 CONTINUE
-C SPACE FOR THE SOLUTION.
- IU = ISTKGT(NU*(NX-KX)*(NY-KY), 3)
- CALL SETR(NU*(NX-KX)*(NY-KY), 0E0, WS(IU))
- CALL TTGR(WS(IU), NU, KX, WS(IX), NX, KY, WS(IY), NY, TSTART,
- 1 TSTOP, DT, AF, BC, ERRPAR, HANDLE)
- CALL LEAVE
- CALL WRAPUP
- STOP
- END
- SUBROUTINE AF(T, XI, NX, YI, NY, NU, U, UT, UX, UY, UXT,
- 1 UYT, A, AU, AUT, AUX, AUY, AUXT, AUYT, F, FU, FUT, FUX, FUY,
- 2 FUXT, FUYT)
- INTEGER NU, NX, NY
- REAL T, XI(NX), YI(NY), U(NX, NY, NU), UT(NX, NY, NU), UX(NX, NY
- 1 , NU)
- REAL UY(NX, NY, NU), UXT(NX, NY, NU), UYT(NX, NY, NU), A(NX, NY,
- 1 NU, 2), AU(NX, NY, NU, NU, 2), AUT(NX, NY, NU, NU, 2)
- REAL AUX(NX, NY, NU, NU, 2), AUY(NX, NY, NU, NU, 2), AUXT(NX, NY
- 1 , NU, NU, 2), AUYT(NX, NY, NU, NU, 2), F(NX, NY, NU), FU(NX,
- 2 NY, NU, NU)
- REAL FUT(NX, NY, NU, NU), FUX(NX, NY, NU, NU), FUY(NX, NY, NU, NU)
- 1 , FUXT(NX, NY, NU, NU), FUYT(NX, NY, NU, NU)
- INTEGER I, P, Q
- DO 3 I = 1, NU
- DO 2 Q = 1, NY
- DO 1 P = 1, NX
- A(P, Q, I, 1) = UX(P, Q, I)
- A(P, Q, I, 2) = UY(P, Q, I)
- AUX(P, Q, I, I, 1) = 1
- AUY(P, Q, I, I, 2) = 1
- 1 CONTINUE
- 2 CONTINUE
- 3 CONTINUE
- RETURN
- END
- SUBROUTINE BC(T, X, NX, Y, NY, LX, RX, LY, RY, U, UT, UX,
- 1 UY, UXT, UYT, NU, B, BU, BUT, BUX, BUY, BUXT, BUYT)
- INTEGER NU, NX, NY
- REAL T, X(NX), Y(NY), LX, RX, LY
- REAL RY, U(NX, NY, NU), UT(NX, NY, NU), UX(NX, NY, NU), UY(NX, NY,
- 1 NU), UXT(NX, NY, NU)
- REAL UYT(NX, NY, NU), B(NX, NY, NU), BU(NX, NY, NU, NU), BUT(NX,
- 1 NY, NU, NU), BUX(NX, NY, NU, NU), BUY(NX, NY, NU, NU)
- REAL BUXT(NX, NY, NU, NU), BUYT(NX, NY, NU, NU)
- INTEGER I, J
- REAL COS, SIN, R, ALOG, ATAN, SQRT
- REAL THETA
- DO 6 J = 1, NY
- DO 5 I = 1, NX
- IF (Y(J) .NE. LY) GOTO 1
- B(I, J, 1) = UY(I, J, 1)
-C NEUMANN DATA ON BOTTOM.
- BUY(I, J, 1, 1) = 1
- GOTO 4
- 1 R = SQRT(X(I)**2+Y(J)**2)
-C DIRICHLET DATA.
- IF (X(I) .LE. 0.) GOTO 2
- THETA = ATAN(Y(J)/X(I))
- GOTO 3
- 2 THETA = 2.*ATAN(1E0)
- 3 B(I, J, 1) = U(I, J, 1)-R*(COS(THETA)*ALOG(R)-THETA*SIN(
- 1 THETA))
- BU(I, J, 1, 1) = 1
- 4 CONTINUE
- 5 CONTINUE
- 6 CONTINUE
- RETURN
- END
- SUBROUTINE HANDLE(T0, U0, T, U, NV, DT, TSTOP)
- INTEGER NV
- REAL T0, U0(NV), T, U(NV), DT, TSTOP
- COMMON /A7TGRP/ ERRPAR, NU, MXQ, MYQ
- INTEGER NU, MXQ, MYQ
- REAL ERRPAR(2)
- COMMON /A7TGRM/ KX, IX, NX, KY, IY, NY
- INTEGER KX, IX, NX, KY, IY, NY
- IF (T0 .NE. T) GOTO 2
- WRITE (6, 1) T
- 1 FORMAT (16H RESTART FOR T =, 1PE10.2)
- RETURN
- 2 CALL GERR(KX, IX, NX, KY, IY, NY, U, NU, T)
- RETURN
- END
- SUBROUTINE GERR(KX, IX, NX, KY, IY, NY, U, NU, T)
- INTEGER KX, IX, NX, KY, IY, NY
- INTEGER NU
- REAL U(1), T
- COMMON /CSTAK/ DS
- DOUBLE PRECISION DS(500)
- INTEGER IFA, ITA(2), IXA(2), NTA(2), NXA(2), IXS
- INTEGER IYS, NXS, NYS, ISTKGT, I, IEWE
- INTEGER KA(2), MA(2), IS(1000), ILUMD, I1MACH
- REAL ABS, ERRU, AMAX1, RS(1000), WS(1000)
- LOGICAL LS(1000)
- COMPLEX CS(500)
- INTEGER TEMP, TEMP1, TEMP2
- EQUIVALENCE (DS(1), CS(1), WS(1), RS(1), IS(1), LS(1))
-C TO GET AND PRINT THE ERROR AT EACH TIME-STEP.
-C U(NX-KX,NY-KY,NU).
-C THE PORT LIBRARY STACK AND ITS ALIASES.
- CALL ENTER(1)
-C FIND THE ERROR IN THE SOLUTION AT 2*KX * 2*KY POINTS / MESH RECTANGLE.
-C X SEARCH GRID.
- IXS = ILUMD(WS(IX), NX, 2*KX, NXS)
-C Y SEARCH GRID.
- IYS = ILUMD(WS(IY), NY, 2*KY, NYS)
-C U SEARCH GRID VALUES.
- IEWE = ISTKGT(NXS*NYS, 3)
-C THE EXACT SOLUTION.
- CALL EWE(T, WS(IXS), NXS, WS(IYS), NYS, WS(IEWE), NU)
- KA(1) = KX
- KA(2) = KY
- ITA(1) = IX
- ITA(2) = IY
- NTA(1) = NX
- NTA(2) = NY
- IXA(1) = IXS
- IXA(2) = IYS
- NXA(1) = NXS
- NXA(2) = NYS
- MA(1) = 0
-C GET SOLUTION.
- MA(2) = 0
-C APPROXIMATE SOLUTION VALUES.
- IFA = ISTKGT(NXS*NYS, 3)
-C EVALUATE THEM.
- CALL TSD1(2, KA, WS, ITA, NTA, U, WS, IXA, NXA, MA, WS(IFA))
-C ERROR IN SOLUTION VALUES.
- ERRU = 0
- TEMP = NXS*NYS
- DO 1 I = 1, TEMP
- TEMP2 = IEWE+I
- TEMP1 = IFA+I
- ERRU = AMAX1(ERRU, ABS(WS(TEMP2-1)-WS(TEMP1-1)))
- 1 CONTINUE
- TEMP = I1MACH(2)
- WRITE (TEMP, 2) T, ERRU
- 2 FORMAT (14H ERROR IN U(.,, 1PE10.2, 3H) =, 1PE10.2)
- CALL LEAVE
- RETURN
- END
- SUBROUTINE EWE(T, X, NX, Y, NY, U, NU)
- INTEGER NU, NX, NY
- REAL T, X(NX), Y(NY), U(NX, NY, NU)
- INTEGER I, J, P
- REAL COS, SIN, R, ALOG, ATAN, SQRT
- REAL THETA
-C THE EXACT SOLUTION.
- DO 7 P = 1, NU
- DO 6 I = 1, NX
- DO 5 J = 1, NY
- R = SQRT(X(I)**2+Y(J)**2)
- IF (X(I) .LE. 0.) GOTO 1
- THETA = ATAN(Y(J)/X(I))
- GOTO 2
- 1 THETA = 2.*ATAN(1E0)
- 2 IF (R .LE. 0.) GOTO 3
- U(I, J, P) = R*(COS(THETA)*ALOG(R)-THETA*SIN(THETA))
- GOTO 4
- 3 U(I, J, P) = 0
- 4 CONTINUE
- 5 CONTINUE
- 6 CONTINUE
- 7 CONTINUE
- RETURN
- END
diff --git a/CEP/PyBDSM/src/port3/ex/ttgrx6.f b/CEP/PyBDSM/src/port3/ex/ttgrx6.f
deleted file mode 100644
index 7a4aff077fb440d1aa474186fbeac75d88563352..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ex/ttgrx6.f
+++ /dev/null
@@ -1,380 +0,0 @@
-C$TEST TTG6
-C TO RUN AS A MAIN PROGRAM REMOVE NEXT LINE
- SUBROUTINE TTG6
-C***********************************************************************
-C
-C EXAMPLE OF USE OF PORT PROGRAM TTGR
-C
-C***********************************************************************
- COMMON /CSTAK/ DS
- DOUBLE PRECISION DS(350000)
- EXTERNAL HANDLE, BC, AF
- INTEGER IUE, NDX, NDY, IUR, IXR, IYR
- INTEGER NXR, NYR, ISTKGT, I, IS(1000), IU
- INTEGER IX, IY, NU, KX, NX, KY
- INTEGER NY, I1MACH
- REAL ABS, ERRPAR(2), TSTART, EERR, ERRE, ERRR
- REAL AMAX1, DT, LX, LY, RX, RY
- REAL WS(1000), RS(1000), FLOAT, TSTOP
- LOGICAL LS(1000)
- COMPLEX CS(500)
- INTEGER TEMP, TEMP1, TEMP2
- EQUIVALENCE (DS(1), CS(1), WS(1), RS(1), IS(1), LS(1))
-C TO GET ERROR ESTIMATES FOR LAPLACES EQUATION WITH REAL ( Z*LOG(Z) ) AS
-C SOLUTION.
-C THE PORT LIBRARY STACK AND ITS ALIASES.
-C INITIALIZE THE PORT LIBRARY STACK LENGTH.
- CALL ISTKIN(350000, 4)
- CALL ENTER(1)
- NU = 1
- LX = 0
- RX = 1
- LY = 0
- RY = 1
- KX = 4
- KY = 4
- NDX = 2
- NDY = 2
- TSTART = 0
- TSTOP = 1
- DT = 1
- ERRPAR(1) = 1E-2
- ERRPAR(2) = 1E-4
- NX = NDX+2*(KX-1)
-C SPACE FOR X MESH.
- IX = ISTKGT(NX, 3)
- DO 1 I = 1, KX
- TEMP = IX+I
- WS(TEMP-1) = 0
- TEMP = IX+NX-I
- WS(TEMP) = RX
- 1 CONTINUE
-C 0 AND RX MULT = KX.
- TEMP = NDX-1
- DO 2 I = 1, TEMP
- TEMP2 = IX+KX-2+I
- WS(TEMP2) = RX*(FLOAT(I-1)/(FLOAT(NDX)-1E0))**KX
- 2 CONTINUE
- NY = NDY+2*(KY-1)
-C SPACE FOR Y MESH.
- IY = ISTKGT(NY, 3)
- DO 3 I = 1, KY
- TEMP = IY+I
- WS(TEMP-1) = 0
- TEMP = IY+NY-I
- WS(TEMP) = RY
- 3 CONTINUE
-C 0 AND RY MULT = KY.
- TEMP = NDY-1
- DO 4 I = 1, TEMP
- TEMP2 = IY+KY-2+I
- WS(TEMP2) = RY*(FLOAT(I-1)/(FLOAT(NDY)-1E0))**KY
- 4 CONTINUE
-C SPACE FOR THE SOLUTION.
- IU = ISTKGT(NU*(NX-KX)*(NY-KY), 3)
- CALL SETR(NU*(NX-KX)*(NY-KY), 0E0, WS(IU))
- TEMP = I1MACH(2)
- WRITE (TEMP, 5)
- 5 FORMAT (23H SOLVING ON CRUDE MESH.)
- CALL TTGR(WS(IU), NU, KX, WS(IX), NX, KY, WS(IY), NY, TSTART,
- 1 TSTOP, DT, AF, BC, ERRPAR, HANDLE)
- DT = 1
- NDX = 2*NDX-1
-C REFINE MESH.
- NDY = 2*NDY-1
- NXR = NDX+2*(KX-1)
-C SPACE FOR X MESH.
- IXR = ISTKGT(NXR, 3)
- DO 6 I = 1, KX
- TEMP = IXR+I
- WS(TEMP-1) = 0
- TEMP = IXR+NXR-I
- WS(TEMP) = RX
- 6 CONTINUE
-C 0 AND RX MULT = KX.
- TEMP = NDX-1
- DO 7 I = 1, TEMP
- TEMP2 = IXR+KX-2+I
- WS(TEMP2) = RX*(FLOAT(I-1)/(FLOAT(NDX)-1E0))**KX
- 7 CONTINUE
- NYR = NDY+2*(KY-1)
-C SPACE FOR Y MESH.
- IYR = ISTKGT(NYR, 3)
- DO 8 I = 1, KY
- TEMP = IYR+I
- WS(TEMP-1) = 0
- TEMP = IYR+NYR-I
- WS(TEMP) = RY
- 8 CONTINUE
-C 0 AND RY MULT = KY.
- TEMP = NDY-1
- DO 9 I = 1, TEMP
- TEMP2 = IYR+KY-2+I
- WS(TEMP2) = RY*(FLOAT(I-1)/(FLOAT(NDY)-1E0))**KY
- 9 CONTINUE
-C SPACE FOR THE SOLUTION.
- IUR = ISTKGT(NU*(NXR-KX)*(NYR-KY), 3)
- CALL SETR(NU*(NXR-KX)*(NYR-KY), 0E0, WS(IUR))
- TEMP = I1MACH(2)
- WRITE (TEMP, 10)
- 10 FORMAT (25H SOLVING ON REFINED MESH.)
- CALL TTGR(WS(IUR), NU, KX, WS(IXR), NXR, KY, WS(IYR), NYR, TSTART,
- 1 TSTOP, DT, AF, BC, ERRPAR, HANDLE)
- DT = 1
- ERRPAR(1) = ERRPAR(1)/10.
- ERRPAR(2) = ERRPAR(2)/10.
-C SPACE FOR THE SOLUTION.
- IUE = ISTKGT(NU*(NX-KX)*(NY-KY), 3)
- CALL SETR(NU*(NX-KX)*(NY-KY), 0E0, WS(IUE))
- TEMP = I1MACH(2)
- WRITE (TEMP, 11)
- 11 FORMAT (24H SOLVING WITH ERRPAR/10.)
- CALL TTGR(WS(IUE), NU, KX, WS(IX), NX, KY, WS(IY), NY, TSTART,
- 1 TSTOP, DT, AF, BC, ERRPAR, HANDLE)
- ERRR = EERR(KX, IX, NX, KY, IY, NY, WS(IU), NU, IXR, NXR, IYR,
- 1 NYR, WS(IUR), TSTOP)
- ERRE = 0
- TEMP = NU*(NX-KX)*(NY-KY)
- DO 12 I = 1, TEMP
- TEMP2 = IU+I
- TEMP1 = IUE+I
- ERRE = AMAX1(ERRE, ABS(WS(TEMP2-1)-WS(TEMP1-1)))
- 12 CONTINUE
- TEMP = I1MACH(2)
- WRITE (TEMP, 13) ERRE
- 13 FORMAT (24H U ERROR FROM U AND UE =, 1PE10.2)
- TEMP = I1MACH(2)
- WRITE (TEMP, 14) ERRR
- 14 FORMAT (24H U ERROR FROM U AND UR =, 1PE10.2)
- CALL LEAVE
- CALL WRAPUP
- STOP
- END
- SUBROUTINE AF(T, XI, NX, YI, NY, NU, U, UT, UX, UY, UXT,
- 1 UYT, A, AU, AUT, AUX, AUY, AUXT, AUYT, F, FU, FUT, FUX, FUY,
- 2 FUXT, FUYT)
- INTEGER NU, NX, NY
- REAL T, XI(NX), YI(NY), U(NX, NY, NU), UT(NX, NY, NU), UX(NX, NY
- 1 , NU)
- REAL UY(NX, NY, NU), UXT(NX, NY, NU), UYT(NX, NY, NU), A(NX, NY,
- 1 NU, 2), AU(NX, NY, NU, NU, 2), AUT(NX, NY, NU, NU, 2)
- REAL AUX(NX, NY, NU, NU, 2), AUY(NX, NY, NU, NU, 2), AUXT(NX, NY
- 1 , NU, NU, 2), AUYT(NX, NY, NU, NU, 2), F(NX, NY, NU), FU(NX,
- 2 NY, NU, NU)
- REAL FUT(NX, NY, NU, NU), FUX(NX, NY, NU, NU), FUY(NX, NY, NU, NU)
- 1 , FUXT(NX, NY, NU, NU), FUYT(NX, NY, NU, NU)
- INTEGER I, P, Q
- DO 3 I = 1, NU
- DO 2 Q = 1, NY
- DO 1 P = 1, NX
- A(P, Q, I, 1) = UX(P, Q, I)
- A(P, Q, I, 2) = UY(P, Q, I)
- AUX(P, Q, I, I, 1) = 1
- AUY(P, Q, I, I, 2) = 1
- 1 CONTINUE
- 2 CONTINUE
- 3 CONTINUE
- RETURN
- END
- SUBROUTINE BC(T, X, NX, Y, NY, LX, RX, LY, RY, U, UT, UX,
- 1 UY, UXT, UYT, NU, B, BU, BUT, BUX, BUY, BUXT, BUYT)
- INTEGER NU, NX, NY
- REAL T, X(NX), Y(NY), LX, RX, LY
- REAL RY, U(NX, NY, NU), UT(NX, NY, NU), UX(NX, NY, NU), UY(NX, NY,
- 1 NU), UXT(NX, NY, NU)
- REAL UYT(NX, NY, NU), B(NX, NY, NU), BU(NX, NY, NU, NU), BUT(NX,
- 1 NY, NU, NU), BUX(NX, NY, NU, NU), BUY(NX, NY, NU, NU)
- REAL BUXT(NX, NY, NU, NU), BUYT(NX, NY, NU, NU)
- INTEGER I, J
- REAL COS, SIN, R, ALOG, ATAN, SQRT
- REAL THETA
- DO 6 J = 1, NY
- DO 5 I = 1, NX
- IF (Y(J) .NE. LY) GOTO 1
- B(I, J, 1) = UY(I, J, 1)
-C NEUMANN DATA ON BOTTOM.
- BUY(I, J, 1, 1) = 1
- GOTO 4
- 1 R = SQRT(X(I)**2+Y(J)**2)
-C DIRICHLET DATA.
- IF (X(I) .LE. 0.) GOTO 2
- THETA = ATAN(Y(J)/X(I))
- GOTO 3
- 2 THETA = 2.*ATAN(1E0)
- 3 B(I, J, 1) = U(I, J, 1)-R*(COS(THETA)*ALOG(R)-THETA*SIN(
- 1 THETA))
- BU(I, J, 1, 1) = 1
- 4 CONTINUE
- 5 CONTINUE
- 6 CONTINUE
- RETURN
- END
- SUBROUTINE HANDLE(T0, U0, T, U, NV, DT, TSTOP)
- INTEGER NV
- REAL T0, U0(NV), T, U(NV), DT, TSTOP
- COMMON /A7TGRP/ ERRPAR, NU, MXQ, MYQ
- INTEGER NU, MXQ, MYQ
- REAL ERRPAR(2)
- COMMON /A7TGRM/ KX, IX, NX, KY, IY, NY
- INTEGER KX, IX, NX, KY, IY, NY
- IF (T0 .NE. T) GOTO 2
- WRITE (6, 1) T
- 1 FORMAT (16H RESTART FOR T =, 1PE10.2)
- RETURN
- 2 CALL GERR(KX, IX, NX, KY, IY, NY, U, NU, T)
- RETURN
- END
- SUBROUTINE GERR(KX, IX, NX, KY, IY, NY, U, NU, T)
- INTEGER KX, IX, NX, KY, IY, NY
- INTEGER NU
- REAL U(1), T
- COMMON /CSTAK/ DS
- DOUBLE PRECISION DS(500)
- INTEGER IFA, ITA(2), IXA(2), NTA(2), NXA(2), IXS
- INTEGER IYS, NXS, NYS, ISTKGT, I, IEWE
- INTEGER KA(2), MA(2), IS(1000), ILUMD, I1MACH
- REAL ABS, ERRU, AMAX1, RS(1000), WS(1000)
- LOGICAL LS(1000)
- COMPLEX CS(500)
- INTEGER TEMP, TEMP1, TEMP2
- EQUIVALENCE (DS(1), CS(1), WS(1), RS(1), IS(1), LS(1))
-C TO GET AND PRINT THE ERROR AT EACH TIME-STEP.
-C U(NX-KX,NY-KY,NU).
-C THE PORT LIBRARY STACK AND ITS ALIASES.
- CALL ENTER(1)
-C FIND THE ERROR IN THE SOLUTION AT 2*KX * 2*KY POINTS / MESH RECTANGLE.
-C X SEARCH GRID.
- IXS = ILUMD(WS(IX), NX, 2*KX, NXS)
-C Y SEARCH GRID.
- IYS = ILUMD(WS(IY), NY, 2*KY, NYS)
-C U SEARCH GRID VALUES.
- IEWE = ISTKGT(NXS*NYS, 3)
-C THE EXACT SOLUTION.
- CALL EWE(T, WS(IXS), NXS, WS(IYS), NYS, WS(IEWE), NU)
- KA(1) = KX
- KA(2) = KY
- ITA(1) = IX
- ITA(2) = IY
- NTA(1) = NX
- NTA(2) = NY
- IXA(1) = IXS
- IXA(2) = IYS
- NXA(1) = NXS
- NXA(2) = NYS
- MA(1) = 0
-C GET SOLUTION.
- MA(2) = 0
-C APPROXIMATE SOLUTION VALUES.
- IFA = ISTKGT(NXS*NYS, 3)
-C EVALUATE THEM.
- CALL TSD1(2, KA, WS, ITA, NTA, U, WS, IXA, NXA, MA, WS(IFA))
-C ERROR IN SOLUTION VALUES.
- ERRU = 0
- TEMP = NXS*NYS
- DO 1 I = 1, TEMP
- TEMP2 = IEWE+I
- TEMP1 = IFA+I
- ERRU = AMAX1(ERRU, ABS(WS(TEMP2-1)-WS(TEMP1-1)))
- 1 CONTINUE
- TEMP = I1MACH(2)
- WRITE (TEMP, 2) T, ERRU
- 2 FORMAT (14H ERROR IN U(.,, 1PE10.2, 3H) =, 1PE10.2)
- CALL LEAVE
- RETURN
- END
- REAL FUNCTION EERR(KX, IX, NX, KY, IY, NY, U, NU, IXR, NXR
- 1 , IYR, NYR, UR, T)
- INTEGER KX, IX, NX, KY, IY, NY
- INTEGER NU, IXR, NXR, IYR, NYR
- REAL U(1), UR(1), T
- COMMON /CSTAK/ DS
- DOUBLE PRECISION DS(500)
- INTEGER IFA, ITA(2), IXA(2), NTA(2), NXA(2), IXS
- INTEGER IYS, NXS, NYS, ISTKGT, I, IFAR
- INTEGER KA(2), MA(2), IS(1000), ILUMD, I1MACH
- REAL ABS, ERRU, AMAX1, RS(1000), WS(1000)
- LOGICAL LS(1000)
- COMPLEX CS(500)
- INTEGER TEMP, TEMP1, TEMP2
- EQUIVALENCE (DS(1), CS(1), WS(1), RS(1), IS(1), LS(1))
-C TO GET AND PRINT THE ERROR ESTIMATE AT EACH TIME-STEP.
-C U(NX-KX,NY-KY,NU), UR(NXR-KX,NYR-KY,NU).
-C THE PORT LIBRARY STACK AND ITS ALIASES.
- CALL ENTER(1)
-C FIND THE ERROR IN THE SOLUTION AT 2*KX * 2*KY POINTS / FINE MESH RECTA
-CNGLE.
-C X SEARCH GRID.
- IXS = ILUMD(WS(IXR), NXR, 2*KX, NXS)
-C Y SEARCH GRID.
- IYS = ILUMD(WS(IYR), NYR, 2*KY, NYS)
- KA(1) = KX
- KA(2) = KY
- ITA(1) = IX
- ITA(2) = IY
- NTA(1) = NX
- NTA(2) = NY
- IXA(1) = IXS
- IXA(2) = IYS
- NXA(1) = NXS
- NXA(2) = NYS
- MA(1) = 0
-C GET SOLUTION.
- MA(2) = 0
-C APPROXIMATE SOLUTION VALUES.
- IFA = ISTKGT(NXS*NYS, 3)
-C EVALUATE THEM.
- CALL TSD1(2, KA, WS, ITA, NTA, U, WS, IXA, NXA, MA, WS(IFA))
- KA(1) = KX
- KA(2) = KY
- ITA(1) = IXR
- ITA(2) = IYR
- NTA(1) = NXR
- NTA(2) = NYR
- IXA(1) = IXS
- IXA(2) = IYS
- NXA(1) = NXS
- NXA(2) = NYS
- MA(1) = 0
-C GET SOLUTION.
- MA(2) = 0
-C APPROXIMATE SOLUTION VALUES.
- IFAR = ISTKGT(NXS*NYS, 3)
-C EVALUATE THEM.
- CALL TSD1(2, KA, WS, ITA, NTA, UR, WS, IXA, NXA, MA, WS(IFAR))
-C ERROR IN SOLUTION VALUES.
- ERRU = 0
- TEMP = NXS*NYS
- DO 1 I = 1, TEMP
- TEMP2 = IFAR+I
- TEMP1 = IFA+I
- ERRU = AMAX1(ERRU, ABS(WS(TEMP2-1)-WS(TEMP1-1)))
- 1 CONTINUE
- CALL LEAVE
- EERR = ERRU
- RETURN
- END
- SUBROUTINE EWE(T, X, NX, Y, NY, U, NU)
- INTEGER NU, NX, NY
- REAL T, X(NX), Y(NY), U(NX, NY, NU)
- INTEGER I, J, P
- REAL COS, SIN, R, ALOG, ATAN, SQRT
- REAL THETA
-C THE EXACT SOLUTION.
- DO 7 P = 1, NU
- DO 6 I = 1, NX
- DO 5 J = 1, NY
- R = SQRT(X(I)**2+Y(J)**2)
- IF (X(I) .LE. 0.) GOTO 1
- THETA = ATAN(Y(J)/X(I))
- GOTO 2
- 1 THETA = 2.*ATAN(1E0)
- 2 IF (R .LE. 0.) GOTO 3
- U(I, J, P) = R*(COS(THETA)*ALOG(R)-THETA*SIN(THETA))
- GOTO 4
- 3 U(I, J, P) = 0
- 4 CONTINUE
- 5 CONTINUE
- 6 CONTINUE
- 7 CONTINUE
- RETURN
- END
diff --git a/CEP/PyBDSM/src/port3/ex/vdsa.f b/CEP/PyBDSM/src/port3/ex/vdsa.f
deleted file mode 100644
index e47575e7abdda7ce45ba9795f5e52a5bb8cdf10b..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ex/vdsa.f
+++ /dev/null
@@ -1,38 +0,0 @@
-C$TEST VDSA
-C TO RUN AS A MAIN PROGRAM REMOVE NEXT LINE
- SUBROUTINE VDSA
-C***********************************************************************
-C
-C EXAMPLE OF USE OF THE PORT PROGRAM VDSS1
-C
-C***********************************************************************
-C SIN(X) + X**2 + 3
-C
- REAL X, A(10), F, FPRIME, PT, H, SOL
- INTEGER IWRITE, N, I
- REAL U, L, DIST, DSOL
-C
- IWRITE = I1MACH(2)
- N = 10
- X = 1.3
- H = 1./ FLOAT(N-1)
- L = 1.0
- U = 5.0
- DIST = U - L
-C SET UP THE MESH AND DATA VALUES
- DO 100 I=1,N
- PT = L + DIST*FLOAT(I-1)*H
- A(I) = SIN(PT) + PT**2 + 3.0
- 100 CONTINUE
- CALL VDSS1 (X,N,U,L,A,F,FPRIME)
-C CHECK THE SOLUTION
- SOL = SIN(X) + X**2 + 3.0
- DSOL = COS(X) + 2.0*X
- WRITE (IWRITE,101)
- 101 FORMAT (45H ACTUAL COMPUTED//)
- WRITE (IWRITE,102) SOL,F
- 102 FORMAT (17H F(X) = ,2E16.8)
- WRITE (IWRITE,103) DSOL,FPRIME
- 103 FORMAT (17H DERIVATIVE = ,2E16.8)
- STOP
- END
diff --git a/CEP/PyBDSM/src/port3/ex/vdsb.f b/CEP/PyBDSM/src/port3/ex/vdsb.f
deleted file mode 100644
index 672718e0654b6af8870c00df201c0e9b80394416..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ex/vdsb.f
+++ /dev/null
@@ -1,51 +0,0 @@
-C$TEST VDSB
-C TO RUN AS A MAIN PROGRAM REMOVE NEXT LINE
- SUBROUTINE VDSB
-C***********************************************************************
-C
-C EXAMPLE OF USE OF THE PORT PROGRAM VDSS2
-C
-C***********************************************************************
-C SIN(X(1)) + X(2)**2 + 3
-C
- REAL X(2), A(10,10), F, FPRIME(2), PT1, PT2, H1, H2, SOL
- REAL DSOL1, DSOL2
- INTEGER IWRITE, N1, N2, NA1, I, J
- REAL U(2),L(2),DIST(2)
-C
- IWRITE = I1MACH(2)
- N1 = 10
- N2 = 10
- X(1) = 1.7
- X(2) = 1.7
- H1 = 1./ FLOAT(N1-1)
- H2 = 1./ FLOAT(N2-1)
- L(1) = 1.0
- U(1) = 5.0
- L(2) = 1.0
- U(2) = 5.0
- DIST(1) = U(1) - L(1)
- DIST(2) = U(2) - L(2)
-C SET UP THE MESH AND DATA VALUES
- DO 100 I=1,N1
- PT1 = L(1) + DIST(1)*FLOAT(I-1)*H1
- DO 100 J=1,N2
- PT2 = L(2) + DIST(2)*FLOAT(J-1)*H2
- A(I,J) = SIN(PT1) + PT2**2 + 3.0
- 100 CONTINUE
- NA1 = 10
- CALL VDSS2 (X,N1,N2,U,L,A,NA1,F,FPRIME)
-C CHECK THE SOLUTION
- SOL = SIN(X(1)) + X(2)**2 + 3.0
- DSOL1 = COS(X(1))
- DSOL2 = 2.0*X(2)
- WRITE (IWRITE,101)
- 101 FORMAT (45H ACTUAL COMPUTED//)
- WRITE (IWRITE,102) SOL,F
- 102 FORMAT (17H F(X) = ,2E16.8)
- WRITE (IWRITE,103) DSOL1,FPRIME(1)
- 103 FORMAT (17H PARTIAL X = ,2E16.8)
- WRITE (IWRITE,104) DSOL2,FPRIME(2)
- 104 FORMAT (17H PARTIAL Y = ,2E16.8)
- STOP
- END
diff --git a/CEP/PyBDSM/src/port3/ex/vdse.f b/CEP/PyBDSM/src/port3/ex/vdse.f
deleted file mode 100644
index 05d72af98ef5d4b5149457d526c95f83e28a7ce9..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ex/vdse.f
+++ /dev/null
@@ -1,65 +0,0 @@
-C$TEST VDSE
-C TO RUN AS A MAIN PROGRAM REMOVE NEXT LINE
- SUBROUTINE VDSE
-C***********************************************************************
-C
-C EXAMPLE OF USE OF THE PORT PROGRAM VDSS3
-C
-C***********************************************************************
-C X(1)*X(2) + EXP(X(2)) + X(3)**2
-C
- REAL X(3), A(10,10,10), F, FPRIME(3), PT1, PT2, PT3
- REAL H1, H2, H3, SOL
- REAL DSOL1, DSOL2, DSOL3
- INTEGER IWRITE, N1, N2, N3, NA1, NA2
- INTEGER I,J,K
- REAL U(3),L(3),DIST(3)
-C
- IWRITE = I1MACH(2)
- N1 = 10
- N2 = 10
- N3 = 10
- X(1) = 2.3
- X(2) = 2.3
- X(3) = 2.3
- H1 = 1./ FLOAT(N1-1)
- H2 = 1./ FLOAT(N2-1)
- H3 = 1./ FLOAT(N3-1)
- L(1) = 1.0
- U(1) = 3.0
- L(2) = 2.0
- U(2) = 4.0
- L(3) = 1.5
- U(3) = 3.5
- DIST(1) = U(1) - L(1)
- DIST(2) = U(2) - L(2)
- DIST(3) = U(3) - L(3)
-C SET UP THE MESH AND DATA VALUES
- DO 100 I=1,N1
- PT1 = L(1) + DIST(1)*FLOAT(I-1)*H1
- DO 100 J=1,N2
- PT2 = L(2) + DIST(2)*FLOAT(J-1)*H2
- DO 100 K=1,N3
- PT3 = L(3) + DIST(3)*FLOAT(K-1)*H3
- A(I,J,K) = PT1*PT2 + EXP(PT2) + PT3**2
- 100 CONTINUE
- NA1 = 10
- NA2 = 10
- CALL VDSS3 (X,N1,N2,N3,U,L,A,NA1,NA2,F,FPRIME)
-C CHECK THE SOLUTION
- SOL = X(1)*X(2) + EXP(X(2)) + X(3)**2
- DSOL1 = X(2)
- DSOL2 = X(1) + EXP(X(2))
- DSOL3 = 2.0*X(3)
- WRITE (IWRITE,101)
- 101 FORMAT (45H ACTUAL COMPUTED//)
- WRITE (IWRITE,102) SOL,F
- 102 FORMAT (17H F(X) = ,2E16.8)
- WRITE (IWRITE,103) DSOL1,FPRIME(1)
- 103 FORMAT (17H PARTIAL X = ,2E16.8)
- WRITE (IWRITE,104) DSOL2,FPRIME(2)
- 104 FORMAT (17H PARTIAL Y = ,2E16.8)
- WRITE (IWRITE,105) DSOL3,FPRIME(3)
- 105 FORMAT (17H PARTIAL Z = ,2E16.8)
- STOP
- END
diff --git a/CEP/PyBDSM/src/port3/ex/xkhd.f b/CEP/PyBDSM/src/port3/ex/xkhd.f
deleted file mode 100644
index 4c8ab804a10062283afaeecefa97b2258d297803..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ex/xkhd.f
+++ /dev/null
@@ -1,37 +0,0 @@
-C$TEST XKHD
-C TO RUN AS A MAIN PROGRAM REMOVE NEXT LINE
- SUBROUTINE XKHD
-C***********************************************************************
-C
-C EXAMPLE OF USE OF THE PORT PROGRAM DXKTH
-C
-C***********************************************************************
-C
- COMMON/CSTAK/DSTAK(500)
- INTEGER IWRITE, N, K
- DOUBLE PRECISION X(10), XK, DXKTH
- DOUBLE PRECISION DSTAK
-C
-C SET OUTPUT UNIT TO IWRITE .
- IWRITE = I1MACH(2)
-C
- N = 8
- X(1) = 3.
- X(2) = 2.
- X(3) = 9.
- X(4) = 7.
- X(5) = 8.
- X(6) = 8.
- X(7) = 5.
- X(8) = 8.
-C
- WRITE (IWRITE,98)
- 98 FORMAT(1H0,14H K XKTH//)
-C
- DO 10 K=1,8
- XK = DXKTH(N,K,X)
- WRITE (IWRITE,99) K, XK
- 99 FORMAT(1H ,I3,D25.14)
- 10 CONTINUE
- STOP
- END
diff --git a/CEP/PyBDSM/src/port3/ex/xkhi.f b/CEP/PyBDSM/src/port3/ex/xkhi.f
deleted file mode 100644
index 087ee044982b0590158135e2876dc2e190c05f4c..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ex/xkhi.f
+++ /dev/null
@@ -1,40 +0,0 @@
-C$TEST XKHI
-C TO RUN AS A MAIN PROGRAM REMOVE NEXT LINE
- SUBROUTINE XKHI
-C***********************************************************************
-C
-C EXAMPLE OF USE OF THE PORT PROGRAM IXKTH
-C
-C***********************************************************************
-C
- COMMON/CSTAK/DSTAK(500)
- INTEGER IWRITE, N, K
- INTEGER X(10), XK
- INTEGER ISTAK(1000)
- DOUBLE PRECISION DSTAK
-C
- EQUIVALENCE (DSTAK(1),ISTAK(1))
-C
-C SET OUTPUT UNIT TO IWRITE .
- IWRITE = I1MACH(2)
-C
- N = 8
- X(1) = 3.
- X(2) = 2.
- X(3) = 9.
- X(4) = 7.
- X(5) = 8.
- X(6) = 8.
- X(7) = 5.
- X(8) = 8.
-C
- WRITE (IWRITE,98)
- 98 FORMAT(1H0,15H K IXKTH,//)
-C
- DO 10 K=1,8
- XK = IXKTH(N,K,X)
- WRITE (IWRITE,99) K, XK
- 99 FORMAT(1H ,I3,I10)
- 10 CONTINUE
- STOP
- END
diff --git a/CEP/PyBDSM/src/port3/ex/xkt.f b/CEP/PyBDSM/src/port3/ex/xkt.f
deleted file mode 100644
index 18b232d1a51d4910d6c984aae43c1970e900173c..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ex/xkt.f
+++ /dev/null
@@ -1,40 +0,0 @@
-C$TEST XKTH
-C TO RUN AS A MAIN PROGRAM REMOVE NEXT LINE
- SUBROUTINE XKT
-C***********************************************************************
-C
-C EXAMPLE OF USE OF THE PORT PROGRAM XKTH
-C
-C***********************************************************************
-C
- COMMON/CSTAK/DSTAK(500)
- INTEGER IWRITE, I1MACH, N, K
- REAL X(10), XK, XKTH
- REAL RSTAK(1000)
- DOUBLE PRECISION DSTAK
-C
- EQUIVALENCE (DSTAK(1),RSTAK(1))
-C
-C SET OUTPUT UNIT TO IWRITE .
- IWRITE = I1MACH(2)
-C
- N = 8
- X(1) = 3.
- X(2) = 2.
- X(3) = 9.
- X(4) = 7.
- X(5) = 8.
- X(6) = 8.
- X(7) = 5.
- X(8) = 8.
-C
- WRITE (IWRITE,98)
- 98 FORMAT(1H0,14H K XKTH//)
-C
- DO 10 K=1,8
- XK = XKTH(N,K,X)
- WRITE (IWRITE,99) K, XK
- 99 FORMAT(1H ,I3,F10.1)
- 10 CONTINUE
- STOP
- END
diff --git a/CEP/PyBDSM/src/port3/ex/xkth b/CEP/PyBDSM/src/port3/ex/xkth
deleted file mode 100644
index 18b232d1a51d4910d6c984aae43c1970e900173c..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ex/xkth
+++ /dev/null
@@ -1,40 +0,0 @@
-C$TEST XKTH
-C TO RUN AS A MAIN PROGRAM REMOVE NEXT LINE
- SUBROUTINE XKT
-C***********************************************************************
-C
-C EXAMPLE OF USE OF THE PORT PROGRAM XKTH
-C
-C***********************************************************************
-C
- COMMON/CSTAK/DSTAK(500)
- INTEGER IWRITE, I1MACH, N, K
- REAL X(10), XK, XKTH
- REAL RSTAK(1000)
- DOUBLE PRECISION DSTAK
-C
- EQUIVALENCE (DSTAK(1),RSTAK(1))
-C
-C SET OUTPUT UNIT TO IWRITE .
- IWRITE = I1MACH(2)
-C
- N = 8
- X(1) = 3.
- X(2) = 2.
- X(3) = 9.
- X(4) = 7.
- X(5) = 8.
- X(6) = 8.
- X(7) = 5.
- X(8) = 8.
-C
- WRITE (IWRITE,98)
- 98 FORMAT(1H0,14H K XKTH//)
-C
- DO 10 K=1,8
- XK = XKTH(N,K,X)
- WRITE (IWRITE,99) K, XK
- 99 FORMAT(1H ,I3,F10.1)
- 10 CONTINUE
- STOP
- END
diff --git a/CEP/PyBDSM/src/port3/ex/zap.ed b/CEP/PyBDSM/src/port3/ex/zap.ed
deleted file mode 100644
index 3308c11547e83f4e9eed86bac7c1edb906a1bf1e..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ex/zap.ed
+++ /dev/null
@@ -1,8 +0,0 @@
-1s/ DTTGR/DTG/
-2d
-1r zap.head
-w
-4d
-.-1r zap.ex
-w
-q
diff --git a/CEP/PyBDSM/src/port3/ex/zap.ex b/CEP/PyBDSM/src/port3/ex/zap.ex
deleted file mode 100644
index 71040747e9a68333306aba568e370c7206376718..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ex/zap.ex
+++ /dev/null
@@ -1 +0,0 @@
-C EXAMPLE OF USE OF PORT PROGRAM DTTGR
diff --git a/CEP/PyBDSM/src/port3/ex/zap.head b/CEP/PyBDSM/src/port3/ex/zap.head
deleted file mode 100644
index 13ed360f4d4c3c2f5421466d154ad37355799f15..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ex/zap.head
+++ /dev/null
@@ -1,5 +0,0 @@
-C***********************************************************************
-C
-C EXAMPLE OF USE OF THE PORT PROGRAM POSTU
-C
-C***********************************************************************
diff --git a/CEP/PyBDSM/src/port3/ex/zap.t b/CEP/PyBDSM/src/port3/ex/zap.t
deleted file mode 100644
index 644a7045ebbcd9fe41ea1433cd67af05ab5f757c..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ex/zap.t
+++ /dev/null
@@ -1,14 +0,0 @@
-mv dttgr1.f dtg1.f
-mv dttgr1p.f dtgp.f
-mv dttgr2.f dtg2.f
-mv dttgr3.f dtg3.f
-mv dttgr4.f dtg4.f
-mv dttgr5.f dtg5.f
-mv dttgr6.f dtg6.f
-mv ttgr1.f ttg1.f
-mv ttgr1p.f ttgp.f
-mv ttgr2.f ttg2.f
-mv ttgr3.f ttg3.f
-mv ttgr4.f ttg4.f
-mv ttgr5.f ttg5.f
-mv ttgr6.f ttg6.f
diff --git a/CEP/PyBDSM/src/port3/ex/zera.f b/CEP/PyBDSM/src/port3/ex/zera.f
deleted file mode 100644
index 8e8a9228cba023b49d1be7015c3cee5f37b88144..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ex/zera.f
+++ /dev/null
@@ -1,29 +0,0 @@
-C$TEST ZERA
-C TO RUN AS A MAIN PROGRAM REMOVE NEXT LINE
- SUBROUTINE ZERA
-C***********************************************************************
-C
-C EXAMPLE OF USE OF THE PORT PROGRAM ZERO
-C
-C***********************************************************************
- EXTERNAL F
- INTEGER IWRITE,I1MACH
- REAL A,B,F,T,X,ZERO
-C
- IWRITE = I1MACH(2)
- A = 1.0
- B = 3.0
- T = 1.0E-7
- X=ZERO(F,A,B,T)
-C
- WRITE (IWRITE,9999) X
- 9999 FORMAT (17H THE ROOT IS X = ,1PE15.8)
-C
- STOP
- END
-C
- REAL FUNCTION F(X)
- REAL X
- F=X*X - 4.
- RETURN
- END
diff --git a/CEP/PyBDSM/src/port3/ex/zip.ed b/CEP/PyBDSM/src/port3/ex/zip.ed
deleted file mode 100644
index 7d78b497b6c880096c43ee104574262777ae82bd..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ex/zip.ed
+++ /dev/null
@@ -1,3 +0,0 @@
-4s/DTT/TT/p
-w
-q
diff --git a/CEP/PyBDSM/src/port3/ex/zona.f b/CEP/PyBDSM/src/port3/ex/zona.f
deleted file mode 100644
index d039f71ef34afc554b346b7d8296fa86fea72347..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ex/zona.f
+++ /dev/null
@@ -1,29 +0,0 @@
-C$TEST ZONA
-C TO RUN AS A MAIN PROGRAM REMOVE NEXT LINE
- SUBROUTINE ZONA
-C***********************************************************************
-C
-C EXAMPLE OF USE OF THE PORT PROGRAM ZONE
-C
-C***********************************************************************
- EXTERNAL ROSEN
- INTEGER IWRITE, I1MACH
- REAL X(2), FNORM
- IWRITE = I1MACH(2)
-C
- X(1) = -1.2
- X(2) = +1.0
-C
- CALL ZONE( ROSEN, 2, X, 1.E-2, 100, FNORM )
-C
- WRITE ( IWRITE, 9999 ) X(1), X(2), FNORM
- 9999 FORMAT ( 1P3E15.6 )
- STOP
- END
- SUBROUTINE ROSEN ( N, X, F )
- INTEGER N
- REAL X(2), F(2)
- F(1) = 10.0* ( X(2) - X(1)**2 )
- F(2) = 1.0 - X(1)
- RETURN
- END
diff --git a/CEP/PyBDSM/src/port3/ex/zonb.f b/CEP/PyBDSM/src/port3/ex/zonb.f
deleted file mode 100644
index 7f89b0b9c5873c03eb02bbe5c0d1567ebe941236..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ex/zonb.f
+++ /dev/null
@@ -1,43 +0,0 @@
-C$TEST ZONB
-C TO RUN AS A MAIN PROGRAM REMOVE NEXT LINE
- SUBROUTINE ZONB
-C***********************************************************************
-C
-C EXAMPLE OF USE OF THE PORT PROGRAM ZONEJ
-C
-C***********************************************************************
- EXTERNAL ROSEN,MYJAC
- INTEGER IWRITE,I1MACH
- REAL X(2), FNORM
- IWRITE = I1MACH(2)
-C
- X(1) = -1.2
- X(2) = +1.0
-C
- CALL ZONEJ( ROSEN, MYJAC, 2, X, 1.E-2, 100, FNORM )
-C
- WRITE ( IWRITE, 9999 ) X(1), X(2), FNORM
- 9999 FORMAT ( 1P3E15.6 )
- STOP
- END
- SUBROUTINE ROSEN ( N, X, F )
- INTEGER N
- REAL X(2), F(2)
- F(1) = 10.0 * ( X(2) - X(1)**2 )
- F(2) = 1.0 - X(1)
- RETURN
- END
- SUBROUTINE MYJAC(ROSEN, N, X, F, DFDX, JUSED)
- EXTERNAL ROSEN
- INTEGER N,JUSED
- REAL X(2), F(2), DFDX(2,2)
-C
-C JACOBIAN OF ROSEN AT X
-C
- DFDX(1,1) = -20.0*X(1)
- DFDX(1,2) = 10.0
- DFDX(2,1) = -1.0
- DFDX(2,2) = 0.0
- JUSED = 1
- RETURN
- END
diff --git a/CEP/PyBDSM/src/port3/f7dhb.f b/CEP/PyBDSM/src/port3/f7dhb.f
deleted file mode 100644
index e71c35a159c4af0c4e6ca028ed7401035aae73d1..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/f7dhb.f
+++ /dev/null
@@ -1,287 +0,0 @@
- SUBROUTINE F7DHB(B, D, G, IRT, IV, LIV, LV, P, V, X)
-C
-C *** COMPUTE FINITE-DIFFERENCE HESSIAN, STORE IT IN V STARTING
-C *** AT V(IV(FDH)) = V(-IV(H)). HONOR SIMPLE BOUNDS IN B.
-C
-C *** IF IV(COVREQ) .GE. 0 THEN F7DHB USES GRADIENT DIFFERENCES,
-C *** OTHERWISE FUNCTION DIFFERENCES. STORAGE IN V IS AS IN G7LIT.
-C
-C IRT VALUES...
-C 1 = COMPUTE FUNCTION VALUE, I.E., V(F).
-C 2 = COMPUTE G.
-C 3 = DONE.
-C
-C
-C *** PARAMETER DECLARATIONS ***
-C
- INTEGER IRT, LIV, LV, P
- INTEGER IV(LIV)
- REAL B(2,P), D(P), G(P), V(LV), X(P)
-C
-C *** LOCAL VARIABLES ***
-C
- LOGICAL OFFSID
- INTEGER GSAVE1, HES, HMI, HPI, HPM, I, K, KIND, L, M, MM1, MM1O2,
- 1 NEWM1, PP1O2, STPI, STPM, STP0
- REAL DEL, DEL0, T, XM, XM1
- REAL HALF, HLIM, ONE, TWO, ZERO
-C
-C *** EXTERNAL SUBROUTINES ***
-C
- EXTERNAL V7CPY, V7SCP
-C
-C V7CPY.... COPY ONE VECTOR TO ANOTHER.
-C V7SCP... COPY SCALAR TO ALL COMPONENTS OF A VECTOR.
-C
-C *** SUBSCRIPTS FOR IV AND V ***
-C
- INTEGER COVREQ, DELTA, DELTA0, DLTFDC, F, FDH, FX, H, KAGQT, MODE,
- 1 NFGCAL, SAVEI, SWITCH, TOOBIG, W, XMSAVE
-C
-C/6
-C DATA HALF/0.5E+0/, HLIM/0.1E+0/, ONE/1.E+0/, TWO/2.E+0/,
-C 1 ZERO/0.E+0/
-C/7
- PARAMETER (HALF=0.5E+0, HLIM=0.1E+0, ONE=1.E+0, TWO=2.E+0,
- 1 ZERO=0.E+0)
-C/
-C
-C/6
-C DATA COVREQ/15/, DELTA/52/, DELTA0/44/, DLTFDC/42/, F/10/,
-C 1 FDH/74/, FX/53/, H/56/, KAGQT/33/, MODE/35/, NFGCAL/7/,
-C 2 SAVEI/63/, SWITCH/12/, TOOBIG/2/, W/65/, XMSAVE/51/
-C/7
- PARAMETER (COVREQ=15, DELTA=52, DELTA0=44, DLTFDC=42, F=10,
- 1 FDH=74, FX=53, H=56, KAGQT=33, MODE=35, NFGCAL=7,
- 2 SAVEI=63, SWITCH=12, TOOBIG=2, W=65, XMSAVE=51)
-C/
-C
-C+++++++++++++++++++++++++++++++ BODY ++++++++++++++++++++++++++++++++
-C
- IRT = 4
- KIND = IV(COVREQ)
- M = IV(MODE)
- IF (M .GT. 0) GO TO 10
- HES = IABS(IV(H))
- IV(H) = -HES
- IV(FDH) = 0
- IV(KAGQT) = -1
- V(FX) = V(F)
-C *** SUPPLY ZEROS IN CASE B(1,I) = B(2,I) FOR SOME I ***
- CALL V7SCP(P*(P+1)/2, V(HES), ZERO)
- 10 IF (M .GT. P) GO TO 999
- IF (KIND .LT. 0) GO TO 120
-C
-C *** COMPUTE FINITE-DIFFERENCE HESSIAN USING BOTH FUNCTION AND
-C *** GRADIENT VALUES.
-C
- GSAVE1 = IV(W) + P
- IF (M .GT. 0) GO TO 20
-C *** FIRST CALL ON F7DHB. SET GSAVE = G, TAKE FIRST STEP ***
- CALL V7CPY(P, V(GSAVE1), G)
- IV(SWITCH) = IV(NFGCAL)
- GO TO 80
-C
- 20 DEL = V(DELTA)
- X(M) = V(XMSAVE)
- IF (IV(TOOBIG) .EQ. 0) GO TO 30
-C
-C *** HANDLE OVERSIZE V(DELTA) ***
-C
- DEL0 = V(DELTA0) * AMAX1(ONE/D(M), ABS(X(M)))
- DEL = HALF * DEL
- IF ( ABS(DEL/DEL0) .LE. HLIM) GO TO 140
-C
- 30 HES = -IV(H)
-C
-C *** SET G = (G - GSAVE)/DEL ***
-C
- DEL = ONE / DEL
- DO 40 I = 1, P
- G(I) = DEL * (G(I) - V(GSAVE1))
- GSAVE1 = GSAVE1 + 1
- 40 CONTINUE
-C
-C *** ADD G AS NEW COL. TO FINITE-DIFF. HESSIAN MATRIX ***
-C
- K = HES + M*(M-1)/2
- L = K + M - 2
- IF (M .EQ. 1) GO TO 60
-C
-C *** SET H(I,M) = 0.5 * (H(I,M) + G(I)) FOR I = 1 TO M-1 ***
-C
- MM1 = M - 1
- DO 50 I = 1, MM1
- IF (B(1,I) .LT. B(2,I)) V(K) = HALF * (V(K) + G(I))
- K = K + 1
- 50 CONTINUE
-C
-C *** ADD H(I,M) = G(I) FOR I = M TO P ***
-C
- 60 L = L + 1
- DO 70 I = M, P
- IF (B(1,I) .LT. B(2,I)) V(L) = G(I)
- L = L + I
- 70 CONTINUE
-C
- 80 M = M + 1
- IV(MODE) = M
- IF (M .GT. P) GO TO 340
- IF (B(1,M) .GE. B(2,M)) GO TO 80
-C
-C *** CHOOSE NEXT FINITE-DIFFERENCE STEP, RETURN TO GET G THERE ***
-C
- DEL = V(DELTA0) * AMAX1(ONE/D(M), ABS(X(M)))
- XM = X(M)
- IF (XM .LT. ZERO) GO TO 90
- XM1 = XM + DEL
- IF (XM1 .LE. B(2,M)) GO TO 110
- XM1 = XM - DEL
- IF (XM1 .GE. B(1,M)) GO TO 100
- GO TO 280
- 90 XM1 = XM - DEL
- IF (XM1 .GE. B(1,M)) GO TO 100
- XM1 = XM + DEL
- IF (XM1 .LE. B(2,M)) GO TO 110
- GO TO 280
-C
- 100 DEL = -DEL
- 110 V(XMSAVE) = XM
- X(M) = XM1
- V(DELTA) = DEL
- IRT = 2
- GO TO 999
-C
-C *** COMPUTE FINITE-DIFFERENCE HESSIAN USING FUNCTION VALUES ONLY.
-C
- 120 STP0 = IV(W) + P - 1
- MM1 = M - 1
- MM1O2 = M*MM1/2
- HES = -IV(H)
- IF (M .GT. 0) GO TO 130
-C *** FIRST CALL ON F7DHB. ***
- IV(SAVEI) = 0
- GO TO 240
-C
- 130 IF (IV(TOOBIG) .EQ. 0) GO TO 150
-C *** PUNT IN THE EVENT OF AN OVERSIZE STEP ***
- 140 IV(FDH) = -2
- GO TO 350
- 150 I = IV(SAVEI)
- IF (I .GT. 0) GO TO 190
-C
-C *** SAVE F(X + STP(M)*E(M)) IN H(P,M) ***
-C
- PP1O2 = P * (P-1) / 2
- HPM = HES + PP1O2 + MM1
- V(HPM) = V(F)
-C
-C *** START COMPUTING ROW M OF THE FINITE-DIFFERENCE HESSIAN H. ***
-C
- NEWM1 = 1
- GO TO 260
- 160 HMI = HES + MM1O2
- IF (MM1 .EQ. 0) GO TO 180
- HPI = HES + PP1O2
- DO 170 I = 1, MM1
- T = ZERO
- IF (B(1,I) .LT. B(2,I)) T = V(FX) - (V(F) + V(HPI))
- V(HMI) = T
- HMI = HMI + 1
- HPI = HPI + 1
- 170 CONTINUE
- 180 V(HMI) = V(F) - TWO*V(FX)
- IF (OFFSID) V(HMI) = V(FX) - TWO*V(F)
-C
-C *** COMPUTE FUNCTION VALUES NEEDED TO COMPLETE ROW M OF H. ***
-C
- I = 0
- GO TO 200
-C
- 190 X(I) = V(DELTA)
-C
-C *** FINISH COMPUTING H(M,I) ***
-C
- STPI = STP0 + I
- HMI = HES + MM1O2 + I - 1
- STPM = STP0 + M
- V(HMI) = (V(HMI) + V(F)) / (V(STPI)*V(STPM))
- 200 I = I + 1
- IF (I .GT. M) GO TO 230
- IF (B(1,I) .LT. B(2,I)) GO TO 210
- GO TO 200
-C
- 210 IV(SAVEI) = I
- STPI = STP0 + I
- V(DELTA) = X(I)
- X(I) = X(I) + V(STPI)
- IRT = 1
- IF (I .LT. M) GO TO 999
- NEWM1 = 2
- GO TO 260
- 220 X(M) = V(XMSAVE) - DEL
- IF (OFFSID) X(M) = V(XMSAVE) + TWO*DEL
- GO TO 999
-C
- 230 IV(SAVEI) = 0
- X(M) = V(XMSAVE)
-C
- 240 M = M + 1
- IV(MODE) = M
- IF (M .GT. P) GO TO 330
- IF (B(1,M) .LT. B(2,M)) GO TO 250
- GO TO 240
-C
-C *** PREPARE TO COMPUTE ROW M OF THE FINITE-DIFFERENCE HESSIAN H.
-C *** COMPUTE M-TH STEP SIZE STP(M), THEN RETURN TO OBTAIN
-C *** F(X + STP(M)*E(M)), WHERE E(M) = M-TH STD. UNIT VECTOR.
-C
- 250 V(XMSAVE) = X(M)
- NEWM1 = 3
- 260 XM = V(XMSAVE)
- DEL = V(DLTFDC) * AMAX1(ONE/D(M), ABS(XM))
- XM1 = XM + DEL
- OFFSID = .FALSE.
- IF (XM1 .LE. B(2,M)) GO TO 270
- OFFSID = .TRUE.
- XM1 = XM - DEL
- IF (XM - TWO*DEL .GE. B(1,M)) GO TO 300
- GO TO 280
- 270 IF (XM-DEL .GE. B(1,M)) GO TO 290
- OFFSID = .TRUE.
- IF (XM + TWO*DEL .LE. B(2,M)) GO TO 310
-C
- 280 IV(FDH) = -2
- GO TO 350
-C
- 290 IF (XM .GE. ZERO) GO TO 310
- XM1 = XM - DEL
- 300 DEL = -DEL
- 310 GO TO (160, 220, 320), NEWM1
- 320 X(M) = XM1
- STPM = STP0 + M
- V(STPM) = DEL
- IRT = 1
- GO TO 999
-C
-C *** HANDLE SPECIAL CASE OF B(1,P) = B(2,P) -- CLEAR SCRATCH VALUES
-C *** FROM LAST ROW OF FDH...
-C
- 330 IF (B(1,P) .LT. B(2,P)) GO TO 340
- I = HES + P*(P-1)/2
- CALL V7SCP(P, V(I), ZERO)
-C
-C *** RESTORE V(F), ETC. ***
-C
- 340 IV(FDH) = HES
- 350 V(F) = V(FX)
- IRT = 3
- IF (KIND .LT. 0) GO TO 999
- IV(NFGCAL) = IV(SWITCH)
- GSAVE1 = IV(W) + P
- CALL V7CPY(P, G, V(GSAVE1))
- GO TO 999
-C
- 999 RETURN
-C *** LAST LINE OF F7DHB FOLLOWS ***
- END
diff --git a/CEP/PyBDSM/src/port3/f7hes.f b/CEP/PyBDSM/src/port3/f7hes.f
deleted file mode 100644
index 7f79053cb36a75cda68678f3068c0debb6dc7ead..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/f7hes.f
+++ /dev/null
@@ -1,247 +0,0 @@
- SUBROUTINE F7HES(D, G, IRT, IV, LIV, LV, P, V, X)
-C
-C *** COMPUTE FINITE-DIFFERENCE HESSIAN, STORE IT IN V STARTING
-C *** AT V(IV(FDH)) = V(-IV(H)).
-C
-C *** IF IV(COVREQ) .GE. 0 THEN F7HES USES GRADIENT DIFFERENCES,
-C *** OTHERWISE FUNCTION DIFFERENCES. STORAGE IN V IS AS IN G7LIT.
-C
-C IRT VALUES...
-C 1 = COMPUTE FUNCTION VALUE, I.E., V(F).
-C 2 = COMPUTE G.
-C 3 = DONE.
-C
-C
-C *** PARAMETER DECLARATIONS ***
-C
- INTEGER IRT, LIV, LV, P
- INTEGER IV(LIV)
- REAL D(P), G(P), V(LV), X(P)
-C
-C *** LOCAL VARIABLES ***
-C
- INTEGER GSAVE1, HES, HMI, HPI, HPM, I, K, KIND, L, M, MM1, MM1O2,
- 1 PP1O2, STPI, STPM, STP0
- REAL DEL, HALF, NEGPT5, ONE, TWO, ZERO
-C
-C *** EXTERNAL SUBROUTINES ***
-C
- EXTERNAL V7CPY
-C
-C V7CPY.... COPY ONE VECTOR TO ANOTHER.
-C
-C *** SUBSCRIPTS FOR IV AND V ***
-C
- INTEGER COVREQ, DELTA, DELTA0, DLTFDC, F, FDH, FX, H, KAGQT, MODE,
- 1 NFGCAL, SAVEI, SWITCH, TOOBIG, W, XMSAVE
-C
-C/6
-C DATA HALF/0.5E+0/, NEGPT5/-0.5E+0/, ONE/1.E+0/, TWO/2.E+0/,
-C 1 ZERO/0.E+0/
-C/7
- PARAMETER (HALF=0.5E+0, NEGPT5=-0.5E+0, ONE=1.E+0, TWO=2.E+0,
- 1 ZERO=0.E+0)
-C/
-C
-C/6
-C DATA COVREQ/15/, DELTA/52/, DELTA0/44/, DLTFDC/42/, F/10/,
-C 1 FDH/74/, FX/53/, H/56/, KAGQT/33/, MODE/35/, NFGCAL/7/,
-C 2 SAVEI/63/, SWITCH/12/, TOOBIG/2/, W/65/, XMSAVE/51/
-C/7
- PARAMETER (COVREQ=15, DELTA=52, DELTA0=44, DLTFDC=42, F=10,
- 1 FDH=74, FX=53, H=56, KAGQT=33, MODE=35, NFGCAL=7,
- 2 SAVEI=63, SWITCH=12, TOOBIG=2, W=65, XMSAVE=51)
-C/
-C
-C+++++++++++++++++++++++++++++++ BODY ++++++++++++++++++++++++++++++++
-C
- IRT = 4
- KIND = IV(COVREQ)
- M = IV(MODE)
- IF (M .GT. 0) GO TO 10
- IV(H) = -IABS(IV(H))
- IV(FDH) = 0
- IV(KAGQT) = -1
- V(FX) = V(F)
- 10 IF (M .GT. P) GO TO 999
- IF (KIND .LT. 0) GO TO 110
-C
-C *** COMPUTE FINITE-DIFFERENCE HESSIAN USING BOTH FUNCTION AND
-C *** GRADIENT VALUES.
-C
- GSAVE1 = IV(W) + P
- IF (M .GT. 0) GO TO 20
-C *** FIRST CALL ON F7HES. SET GSAVE = G, TAKE FIRST STEP ***
- CALL V7CPY(P, V(GSAVE1), G)
- IV(SWITCH) = IV(NFGCAL)
- GO TO 90
-C
- 20 DEL = V(DELTA)
- X(M) = V(XMSAVE)
- IF (IV(TOOBIG) .EQ. 0) GO TO 40
-C
-C *** HANDLE OVERSIZE V(DELTA) ***
-C
- IF (DEL*X(M) .GT. ZERO) GO TO 30
-C *** WE ALREADY TRIED SHRINKING V(DELTA), SO QUIT ***
- IV(FDH) = -2
- GO TO 220
-C
-C *** TRY SHRINKING V(DELTA) ***
- 30 DEL = NEGPT5 * DEL
- GO TO 100
-C
- 40 HES = -IV(H)
-C
-C *** SET G = (G - GSAVE)/DEL ***
-C
- DO 50 I = 1, P
- G(I) = (G(I) - V(GSAVE1)) / DEL
- GSAVE1 = GSAVE1 + 1
- 50 CONTINUE
-C
-C *** ADD G AS NEW COL. TO FINITE-DIFF. HESSIAN MATRIX ***
-C
- K = HES + M*(M-1)/2
- L = K + M - 2
- IF (M .EQ. 1) GO TO 70
-C
-C *** SET H(I,M) = 0.5 * (H(I,M) + G(I)) FOR I = 1 TO M-1 ***
-C
- MM1 = M - 1
- DO 60 I = 1, MM1
- V(K) = HALF * (V(K) + G(I))
- K = K + 1
- 60 CONTINUE
-C
-C *** ADD H(I,M) = G(I) FOR I = M TO P ***
-C
- 70 L = L + 1
- DO 80 I = M, P
- V(L) = G(I)
- L = L + I
- 80 CONTINUE
-C
- 90 M = M + 1
- IV(MODE) = M
- IF (M .GT. P) GO TO 210
-C
-C *** CHOOSE NEXT FINITE-DIFFERENCE STEP, RETURN TO GET G THERE ***
-C
- DEL = V(DELTA0) * AMAX1(ONE/D(M), ABS(X(M)))
- IF (X(M) .LT. ZERO) DEL = -DEL
- V(XMSAVE) = X(M)
- 100 X(M) = X(M) + DEL
- V(DELTA) = DEL
- IRT = 2
- GO TO 999
-C
-C *** COMPUTE FINITE-DIFFERENCE HESSIAN USING FUNCTION VALUES ONLY.
-C
- 110 STP0 = IV(W) + P - 1
- MM1 = M - 1
- MM1O2 = M*MM1/2
- IF (M .GT. 0) GO TO 120
-C *** FIRST CALL ON F7HES. ***
- IV(SAVEI) = 0
- GO TO 200
-C
- 120 I = IV(SAVEI)
- HES = -IV(H)
- IF (I .GT. 0) GO TO 180
- IF (IV(TOOBIG) .EQ. 0) GO TO 140
-C
-C *** HANDLE OVERSIZE STEP ***
-C
- STPM = STP0 + M
- DEL = V(STPM)
- IF (DEL*X(XMSAVE) .GT. ZERO) GO TO 130
-C *** WE ALREADY TRIED SHRINKING THE STEP, SO QUIT ***
- IV(FDH) = -2
- GO TO 220
-C
-C *** TRY SHRINKING THE STEP ***
- 130 DEL = NEGPT5 * DEL
- X(M) = X(XMSAVE) + DEL
- V(STPM) = DEL
- IRT = 1
- GO TO 999
-C
-C *** SAVE F(X + STP(M)*E(M)) IN H(P,M) ***
-C
- 140 PP1O2 = P * (P-1) / 2
- HPM = HES + PP1O2 + MM1
- V(HPM) = V(F)
-C
-C *** START COMPUTING ROW M OF THE FINITE-DIFFERENCE HESSIAN H. ***
-C
- HMI = HES + MM1O2
- IF (MM1 .EQ. 0) GO TO 160
- HPI = HES + PP1O2
- DO 150 I = 1, MM1
- V(HMI) = V(FX) - (V(F) + V(HPI))
- HMI = HMI + 1
- HPI = HPI + 1
- 150 CONTINUE
- 160 V(HMI) = V(F) - TWO*V(FX)
-C
-C *** COMPUTE FUNCTION VALUES NEEDED TO COMPLETE ROW M OF H. ***
-C
- I = 1
-C
- 170 IV(SAVEI) = I
- STPI = STP0 + I
- V(DELTA) = X(I)
- X(I) = X(I) + V(STPI)
- IF (I .EQ. M) X(I) = V(XMSAVE) - V(STPI)
- IRT = 1
- GO TO 999
-C
- 180 X(I) = V(DELTA)
- IF (IV(TOOBIG) .EQ. 0) GO TO 190
-C *** PUNT IN THE EVENT OF AN OVERSIZE STEP ***
- IV(FDH) = -2
- GO TO 220
-C
-C *** FINISH COMPUTING H(M,I) ***
-C
- 190 STPI = STP0 + I
- HMI = HES + MM1O2 + I - 1
- STPM = STP0 + M
- V(HMI) = (V(HMI) + V(F)) / (V(STPI)*V(STPM))
- I = I + 1
- IF (I .LE. M) GO TO 170
- IV(SAVEI) = 0
- X(M) = V(XMSAVE)
-C
- 200 M = M + 1
- IV(MODE) = M
- IF (M .GT. P) GO TO 210
-C
-C *** PREPARE TO COMPUTE ROW M OF THE FINITE-DIFFERENCE HESSIAN H.
-C *** COMPUTE M-TH STEP SIZE STP(M), THEN RETURN TO OBTAIN
-C *** F(X + STP(M)*E(M)), WHERE E(M) = M-TH STD. UNIT VECTOR.
-C
- DEL = V(DLTFDC) * AMAX1(ONE/D(M), ABS(X(M)))
- IF (X(M) .LT. ZERO) DEL = -DEL
- V(XMSAVE) = X(M)
- X(M) = X(M) + DEL
- STPM = STP0 + M
- V(STPM) = DEL
- IRT = 1
- GO TO 999
-C
-C *** RESTORE V(F), ETC. ***
-C
- 210 IV(FDH) = HES
- 220 V(F) = V(FX)
- IRT = 3
- IF (KIND .LT. 0) GO TO 999
- IV(NFGCAL) = IV(SWITCH)
- GSAVE1 = IV(W) + P
- CALL V7CPY(P, G, V(GSAVE1))
- GO TO 999
-C
- 999 RETURN
-C *** LAST CARD OF F7HES FOLLOWS ***
- END
diff --git a/CEP/PyBDSM/src/port3/fdump.f b/CEP/PyBDSM/src/port3/fdump.f
deleted file mode 100644
index 373e0e2d132db778fab5ba00e8ab6014f2c87961..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/fdump.f
+++ /dev/null
@@ -1,6 +0,0 @@
- SUBROUTINE FDUMP
-C THIS IS A DUMMY ROUTINE TO BE SENT OUT ON
-C THE PORT SEDIT TAPE
-C
- RETURN
- END
diff --git a/CEP/PyBDSM/src/port3/frmatd.f b/CEP/PyBDSM/src/port3/frmatd.f
deleted file mode 100644
index aa6d2d40ced40c28ad2e9f04bc7c3aec6b843385..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/frmatd.f
+++ /dev/null
@@ -1,32 +0,0 @@
- SUBROUTINE FRMATD(WWIDTH, EWIDTH)
-C
-C THIS SUBROUTINE COMPUTES, FOR THE FORMAT SPECIFICATION, DW.E, THE
-C NUMBER OF DIGITS TO THE RIGHT OF THE DECIMAL POINT, E=EWIDTH, AND
-C THE FIELD WIDTH, W=WWIDTH.
-C
-C WWIDTH INCLUDES THE FIVE POSITIONS NEEDED FOR THE SIGN OF THE
-C MANTISSA, THE SIGN OF THE EXPONENT, THE 0, THE DECIMAL POINT AND THE
-C CHARACTER IN THE OUTPUT - +0.XXXXXXXXXD+YYYY
-C
-C THE FOLLOWING MACHINE-DEPENDENT VALUES ARE USED -
-C
-C I1MACH(10) - THE BASE, B
-C I1MACH(14) - THE NUMBER OF BASE-B DIGITS IN THE MANTISSA
-C I1MACH(15) - THE SMALLEST EXPONENT, EMIN
-C I1MACH(16) - THE LARGEST EXPONENT, EMAX
-C
- INTEGER I1MACH, ICEIL, IFLR, EWIDTH, WWIDTH
- INTEGER DEMIN, DEMAX, EXPWID
- REAL BASE
-C
- BASE = I1MACH(10)
-C
- EWIDTH = ICEIL( ALOG10(BASE)*FLOAT(I1MACH(14)) )
-C
- DEMIN = IFLR( ALOG10(BASE)*FLOAT(I1MACH(15)-1) ) + 1
- DEMAX = ICEIL( ALOG10(BASE)*FLOAT(I1MACH(16)) )
- EXPWID = IFLR( ALOG10(FLOAT(MAX0(IABS(DEMIN),IABS(DEMAX)))) ) + 1
- WWIDTH = EWIDTH + EXPWID + 5
-C
- RETURN
- END
diff --git a/CEP/PyBDSM/src/port3/frmati.f b/CEP/PyBDSM/src/port3/frmati.f
deleted file mode 100644
index 24fa024cb876b8282acba07466ecfa627c311005..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/frmati.f
+++ /dev/null
@@ -1,17 +0,0 @@
- SUBROUTINE FRMATI(IWIDTH)
-C
-C THIS SUBROUTINE COMPUTES THE WIDTH, W=IWIDTH, IN THE FORMAT
-C SPECIFICATION FOR INTEGER VARIABLES.
-C
-C FRMATI SETS IWIDTH TO THE NUMBER OF CHARACTER POSITIONS NEEDED
-C FOR WRITING OUT THE LARGEST INTEGER PLUS ONE POSITION FOR THE SIGN.
-C
-C I1MACH(7) IS THE BASE, A, FOR INTEGER REPRESENTATION IN THE MACHINE.
-C I1MACH(8) IS THE (MAXIMUM) NUMBER OF BASE A DIGITS.
-C
- INTEGER I1MACH, ICEIL, IWIDTH
-C
- IWIDTH = ICEIL( ALOG10(FLOAT(I1MACH(7)))*FLOAT(I1MACH(8)) ) + 1
-C
- RETURN
- END
diff --git a/CEP/PyBDSM/src/port3/frmatr.f b/CEP/PyBDSM/src/port3/frmatr.f
deleted file mode 100644
index f6a8284855ef24f61f96cad85d02e3a677bba857..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/frmatr.f
+++ /dev/null
@@ -1,32 +0,0 @@
- SUBROUTINE FRMATR(WWIDTH, EWIDTH)
-C
-C THIS SUBROUTINE COMPUTES, FOR THE FORMAT SPECIFICATION, EW.E, THE
-C NUMBER OF DIGITS TO THE RIGHT OF THE DECIMAL POINT, E=EWIDTH, AND
-C THE FIELD WIDTH, W=WWIDTH.
-C
-C WWIDTH INCLUDES THE FIVE POSITIONS NEEDED FOR THE SIGN OF THE
-C MANTISSA, THE SIGN OF THE EXPONENT, THE 0, THE DECIMAL POINT AND THE
-C CHARACTER IN THE OUTPUT - +0.XXXXXXXXXE+YYYY
-C
-C THE FOLLOWING MACHINE-DEPENDENT VALUES ARE USED -
-C
-C I1MACH(10) - THE BASE, B
-C I1MACH(11) - THE NUMBER OF BASE-B DIGITS IN THE MANTISSA
-C I1MACH(12) - THE SMALLEST EXPONENT, EMIN
-C I1MACH(13) - THE LARGEST EXPONENT, EMAX
-C
- INTEGER I1MACH, ICEIL, IFLR, EWIDTH, WWIDTH
- INTEGER DEMIN, DEMAX, EXPWID
- REAL BASE
-C
- BASE = I1MACH(10)
-C
- EWIDTH = ICEIL( ALOG10(BASE)*FLOAT(I1MACH(11)) )
-C
- DEMIN = IFLR( ALOG10(BASE)*FLOAT(I1MACH(12)-1) ) + 1
- DEMAX = ICEIL( ALOG10(BASE)*FLOAT(I1MACH(13)) )
- EXPWID = IFLR( ALOG10(FLOAT(MAX0(IABS(DEMIN),IABS(DEMAX)))) ) + 1
- WWIDTH = EWIDTH + EXPWID + 5
-C
- RETURN
- END
diff --git a/CEP/PyBDSM/src/port3/g7itb.f b/CEP/PyBDSM/src/port3/g7itb.f
deleted file mode 100644
index 4f80ca7d03e767fa0eabbcedbf454c9694d15041..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/g7itb.f
+++ /dev/null
@@ -1,859 +0,0 @@
- SUBROUTINE G7ITB(B, D, G, IV, LIV, LV, P, PS, V, X, Y)
-C
-C *** CARRY OUT NL2SOL-LIKE ITERATIONS FOR GENERALIZED LINEAR ***
-C *** REGRESSION PROBLEMS (AND OTHERS OF SIMILAR STRUCTURE) ***
-C *** HAVING SIMPLE BOUNDS ON THE PARAMETERS BEING ESTIMATED. ***
-C
-C *** PARAMETER DECLARATIONS ***
-C
- INTEGER LIV, LV, P, PS
- INTEGER IV(LIV)
- REAL B(2,P), D(P), G(P), V(LV), X(P), Y(P)
-C
-C-------------------------- PARAMETER USAGE --------------------------
-C
-C B.... VECTOR OF LOWER AND UPPER BOUNDS ON X.
-C D.... SCALE VECTOR.
-C IV... INTEGER VALUE ARRAY.
-C LIV.. LENGTH OF IV. MUST BE AT LEAST 80.
-C LH... LENGTH OF H = P*(P+1)/2.
-C LV... LENGTH OF V. MUST BE AT LEAST P*(3*P + 19)/2 + 7.
-C G.... GRADIENT AT X (WHEN IV(1) = 2).
-C HC... GAUSS-NEWTON HESSIAN AT X (WHEN IV(1) = 2).
-C P.... NUMBER OF PARAMETERS (COMPONENTS IN X).
-C PS... NUMBER OF NONZERO ROWS AND COLUMNS IN S.
-C V.... FLOATING-POINT VALUE ARRAY.
-C X.... PARAMETER VECTOR.
-C Y.... PART OF YIELD VECTOR (WHEN IV(1)= 2, SCRATCH OTHERWISE).
-C
-C *** DISCUSSION ***
-C
-C G7ITB IS SIMILAR TO G7LIT, EXCEPT FOR THE EXTRA PARAMETER B
-C -- G7ITB ENFORCES THE BOUNDS B(1,I) .LE. X(I) .LE. B(2,I),
-C I = 1(1)P.
-C G7ITB PERFORMS NL2SOL-LIKE ITERATIONS FOR A VARIETY OF
-C REGRESSION PROBLEMS THAT ARE SIMILAR TO NONLINEAR LEAST-SQUARES
-C IN THAT THE HESSIAN IS THE SUM OF TWO TERMS, A READILY-COMPUTED
-C FIRST-ORDER TERM AND A SECOND-ORDER TERM. THE CALLER SUPPLIES
-C THE FIRST-ORDER TERM OF THE HESSIAN IN HC (LOWER TRIANGLE, STORED
-C COMPACTLY BY ROWS), AND G7ITB BUILDS AN APPROXIMATION, S, TO THE
-C SECOND-ORDER TERM. THE CALLER ALSO PROVIDES THE FUNCTION VALUE,
-C GRADIENT, AND PART OF THE YIELD VECTOR USED IN UPDATING S.
-C G7ITB DECIDES DYNAMICALLY WHETHER OR NOT TO _USE_ S WHEN CHOOSING
-C THE NEXT STEP TO TRY... THE HESSIAN APPROXIMATION USED IS EITHER
-C HC ALONE (GAUSS-NEWTON MODEL) OR HC + S (AUGMENTED MODEL).
-C IF PS .LT. P, THEN ROWS AND COLUMNS PS+1...P OF S ARE KEPT
-C CONSTANT. THEY WILL BE ZERO UNLESS THE CALLER SETS IV(INITS) TO
-C 1 OR 2 AND SUPPLIES NONZERO VALUES FOR THEM, OR THE CALLER SETS
-C IV(INITS) TO 3 OR 4 AND THE FINITE-DIFFERENCE INITIAL S THEN
-C COMPUTED HAS NONZERO VALUES IN THESE ROWS.
-C
-C IF IV(INITS) IS 3 OR 4, THEN THE INITIAL S IS COMPUTED BY
-C FINITE DIFFERENCES. 3 MEANS _USE_ FUNCTION DIFFERENCES, 4 MEANS
-C _USE_ GRADIENT DIFFERENCES. FINITE DIFFERENCING IS DONE THE SAME
-C WAY AS IN COMPUTING A COVARIANCE MATRIX (WITH IV(COVREQ) = -1, -2,
-C 1, OR 2).
-C
-C FOR UPDATING S, G7ITB ASSUMES THAT THE GRADIENT HAS THE FORM
-C OF A SUM OVER I OF RHO(I,X)*GRAD(R(I,X)), WHERE GRAD DENOTES THE
-C GRADIENT WITH RESPECT TO X. THE TRUE SECOND-ORDER TERM THEN IS
-C THE SUM OVER I OF RHO(I,X)*HESSIAN(R(I,X)). IF X = X0 + STEP,
-C THEN WE WISH TO UPDATE S SO THAT S*STEP IS THE SUM OVER I OF
-C RHO(I,X)*(GRAD(R(I,X)) - GRAD(R(I,X0))). THE CALLER MUST SUPPLY
-C PART OF THIS IN Y, NAMELY THE SUM OVER I OF
-C RHO(I,X)*GRAD(R(I,X0)), WHEN CALLING G7ITB WITH IV(1) = 2 AND
-C IV(MODE) = 0 (WHERE MODE = 38). G THEN CONTANS THE OTHER PART,
-C SO THAT THE DESIRED YIELD VECTOR IS G - Y. IF PS .LT. P, THEN
-C THE ABOVE DISCUSSION APPLIES ONLY TO THE FIRST PS COMPONENTS OF
-C GRAD(R(I,X)), STEP, AND Y.
-C
-C PARAMETERS IV, P, V, AND X ARE THE SAME AS THE CORRESPONDING
-C ONES TO N2GB (AND NL2SOL), EXCEPT THAT V CAN BE SHORTER
-C (SINCE THE PART OF V THAT N2GB USES FOR STORING D, J, AND R IS
-C NOT NEEDED). MOREOVER, COMPARED WITH N2GB (AND NL2SOL), IV(1)
-C MAY HAVE THE TWO ADDITIONAL OUTPUT VALUES 1 AND 2, WHICH ARE
-C EXPLAINED BELOW, AS IS THE _USE_ OF IV(TOOBIG) AND IV(NFGCAL).
-C THE VALUES IV(D), IV(J), AND IV(R), WHICH ARE OUTPUT VALUES FROM
-C N2GB (AND N2FB), ARE NOT REFERENCED BY G7ITB OR THE
-C SUBROUTINES IT CALLS.
-C
-C WHEN G7ITB IS FIRST CALLED, I.E., WHEN G7ITB IS CALLED WITH
-C IV(1) = 0 OR 12, V(F), G, AND HC NEED NOT BE INITIALIZED. TO
-C OBTAIN THESE STARTING VALUES, G7ITB RETURNS FIRST WITH IV(1) = 1,
-C THEN WITH IV(1) = 2, WITH IV(MODE) = -1 IN BOTH CASES. ON
-C SUBSEQUENT RETURNS WITH IV(1) = 2, IV(MODE) = 0 IMPLIES THAT
-C Y MUST ALSO BE SUPPLIED. (NOTE THAT Y IS USED FOR SCRATCH -- ITS
-C INPUT CONTENTS ARE LOST. BY CONTRAST, HC IS NEVER CHANGED.)
-C ONCE CONVERGENCE HAS BEEN OBTAINED, IV(RDREQ) AND IV(COVREQ) MAY
-C IMPLY THAT A FINITE-DIFFERENCE HESSIAN SHOULD BE COMPUTED FOR USE
-C IN COMPUTING A COVARIANCE MATRIX. IN THIS CASE G7ITB WILL MAKE
-C A NUMBER OF RETURNS WITH IV(1) = 1 OR 2 AND IV(MODE) POSITIVE.
-C WHEN IV(MODE) IS POSITIVE, Y SHOULD NOT BE CHANGED.
-C
-C IV(1) = 1 MEANS THE CALLER SHOULD SET V(F) (I.E., V(10)) TO F(X), THE
-C FUNCTION VALUE AT X, AND CALL G7ITB AGAIN, HAVING CHANGED
-C NONE OF THE OTHER PARAMETERS. AN EXCEPTION OCCURS IF F(X)
-C CANNOT BE EVALUATED (E.G. IF OVERFLOW WOULD OCCUR), WHICH
-C MAY HAPPEN BECAUSE OF AN OVERSIZED STEP. IN THIS CASE
-C THE CALLER SHOULD SET IV(TOOBIG) = IV(2) TO 1, WHICH WILL
-C CAUSE G7ITB TO IGNORE V(F) AND TRY A SMALLER STEP. NOTE
-C THAT THE CURRENT FUNCTION EVALUATION COUNT IS AVAILABLE
-C IN IV(NFCALL) = IV(6). THIS MAY BE USED TO IDENTIFY
-C WHICH COPY OF SAVED INFORMATION SHOULD BE USED IN COM-
-C PUTING G, HC, AND Y THE NEXT TIME G7ITB RETURNS WITH
-C IV(1) = 2. SEE MLPIT FOR AN EXAMPLE OF THIS.
-C IV(1) = 2 MEANS THE CALLER SHOULD SET G TO G(X), THE GRADIENT OF F AT
-C X. THE CALLER SHOULD ALSO SET HC TO THE GAUSS-NEWTON
-C HESSIAN AT X. IF IV(MODE) = 0, THEN THE CALLER SHOULD
-C ALSO COMPUTE THE PART OF THE YIELD VECTOR DESCRIBED ABOVE.
-C THE CALLER SHOULD THEN CALL G7ITB AGAIN (WITH IV(1) = 2).
-C THE CALLER MAY ALSO CHANGE D AT THIS TIME, BUT SHOULD NOT
-C CHANGE X. NOTE THAT IV(NFGCAL) = IV(7) CONTAINS THE
-C VALUE THAT IV(NFCALL) HAD DURING THE RETURN WITH
-C IV(1) = 1 IN WHICH X HAD THE SAME VALUE AS IT NOW HAS.
-C IV(NFGCAL) IS EITHER IV(NFCALL) OR IV(NFCALL) - 1. MLPIT
-C IS AN EXAMPLE WHERE THIS INFORMATION IS USED. IF G OR HC
-C CANNOT BE EVALUATED AT X, THEN THE CALLER MAY SET
-C IV(NFGCAL) TO 0, IN WHICH CASE G7ITB WILL RETURN WITH
-C IV(1) = 15.
-C
-C *** GENERAL ***
-C
-C CODED BY DAVID M. GAY.
-C
-C (SEE NL2SOL FOR REFERENCES.)
-C
-C+++++++++++++++++++++++++++ DECLARATIONS ++++++++++++++++++++++++++++
-C
-C *** LOCAL VARIABLES ***
-C
- LOGICAL HAVQTR, HAVRM
- INTEGER DUMMY, DIG1, G01, H1, HC1, I, I1, IPI, IPIV0, IPIV1,
- 1 IPIV2, IPN, J, K, L, LMAT1, LSTGST, P1, P1LEN, PP1, PP1O2,
- 2 QTR1, RMAT1, RSTRST, STEP1, STPMOD, S1, TD1, TEMP1, TEMP2,
- 3 TG1, W1, WLM1, X01
- REAL E, GI, STTSST, T, T1, XI
-C
-C *** CONSTANTS ***
-C
- REAL HALF, NEGONE, ONE, ONEP2, ZERO
-C
-C *** EXTERNAL FUNCTIONS AND SUBROUTINES ***
-C
- LOGICAL STOPX
- REAL D7TPR, RLDST, V2NRM
- EXTERNAL A7SST, D7TPR, F7DHB, G7QSB,I7COPY, I7PNVR, I7SHFT,
- 1 ITSUM, L7MSB, L7SQR, L7TVM, L7VML, PARCK, Q7RSH,
- 2 RLDST, S7DMP, S7IPR, S7LUP, S7LVM, STOPX, V2NRM,
- 3 V2AXY, V7CPY, V7IPR, V7SCP, V7VMP
-C
-C A7SST.... ASSESSES CANDIDATE STEP.
-C D7TPR... RETURNS INNER PRODUCT OF TWO VECTORS.
-C F7DHB... COMPUTE FINITE-DIFFERENCE HESSIAN (FOR INIT. S MATRIX).
-C G7QSB... COMPUTES GOLDFELD-QUANDT-TROTTER STEP (AUGMENTED MODEL).
-C I7COPY.... COPIES ONE INTEGER VECTOR TO ANOTHER.
-C I7PNVR... INVERTS PERMUTATION ARRAY.
-C I7SHFT... SHIFTS AN INTEGER VECTOR.
-C ITSUM.... PRINTS ITERATION SUMMARY AND INFO ON INITIAL AND FINAL X.
-C L7MSB... COMPUTES LEVENBERG-MARQUARDT STEP (GAUSS-NEWTON MODEL).
-C L7SQR... COMPUTES L * L**T FROM LOWER TRIANGULAR MATRIX L.
-C L7TVM... COMPUTES L**T * V, V = VECTOR, L = LOWER TRIANGULAR MATRIX.
-C L7VML.... COMPUTES L * V, V = VECTOR, L = LOWER TRIANGULAR MATRIX.
-C PARCK.... CHECK VALIDITY OF IV AND V INPUT COMPONENTS.
-C Q7RSH... SHIFTS A QR FACTORIZATION.
-C RLDST... COMPUTES V(RELDX) = RELATIVE STEP SIZE.
-C S7DMP... MULTIPLIES A SYM. MATRIX FORE AND AFT BY A DIAG. MATRIX.
-C S7IPR... APPLIES PERMUTATION TO (LOWER TRIANG. OF) SYM. MATRIX.
-C S7LUP... PERFORMS QUASI-NEWTON UPDATE ON COMPACTLY STORED LOWER TRI-
-C ANGLE OF A SYMMETRIC MATRIX.
-C S7LVM... MULTIPLIES COMPACTLY STORED SYM. MATRIX TIMES VECTOR.
-C STOPX.... RETURNS .TRUE. IF THE BREAK KEY HAS BEEN PRESSED.
-C V2NRM... RETURNS THE 2-NORM OF A VECTOR.
-C V2AXY.... COMPUTES SCALAR TIMES ONE VECTOR PLUS ANOTHER.
-C V7CPY.... COPIES ONE VECTOR TO ANOTHER.
-C V7IPR... APPLIES A PERMUTATION TO A VECTOR.
-C V7SCP... SETS ALL ELEMENTS OF A VECTOR TO A SCALAR.
-C V7VMP... MULTIPLIES (DIVIDES) VECTORS COMPONENTWISE.
-C
-C *** SUBSCRIPTS FOR IV AND V ***
-C
- INTEGER CNVCOD, COSMIN, COVMAT, COVREQ, DGNORM, DIG,
- 1 DSTNRM, F, FDH, FDIF, FUZZ, F0, GTSTEP, H, HC, IERR,
- 2 INCFAC, INITS, IPIVOT, IRC, IVNEED, KAGQT, KALM, LMAT,
- 3 LMAX0, LMAXS, MODE, MODEL, MXFCAL, MXITER, NEXTIV, NEXTV,
- 4 NFCALL, NFGCAL, NFCOV, NGCOV, NGCALL, NITER, NVSAVE, P0,
- 5 PC, PERM, PHMXFC, PREDUC, QTR, RADFAC, RADINC, RADIUS,
- 6 RAD0, RDREQ, REGD, RELDX, RESTOR, RMAT, S, SIZE, STEP,
- 7 STGLIM, STPPAR, SUSED, SWITCH, TOOBIG, TUNER4, TUNER5,
- 8 VNEED, VSAVE, W, WSCALE, XIRC, X0
-C
-C *** IV SUBSCRIPT VALUES ***
-C
-C *** (NOTE THAT P0 AND PC ARE STORED IN IV(G0) AND IV(STLSTG) RESP.)
-C
-C/6
-C DATA CNVCOD/55/, COVMAT/26/, COVREQ/15/, DIG/37/, FDH/74/, H/56/,
-C 1 HC/71/, IERR/75/, INITS/25/, IPIVOT/76/, IRC/29/, IVNEED/3/,
-C 2 KAGQT/33/, KALM/34/, LMAT/42/, MODE/35/, MODEL/5/,
-C 3 MXFCAL/17/, MXITER/18/, NEXTIV/46/, NEXTV/47/, NFCALL/6/,
-C 4 NFGCAL/7/, NFCOV/52/, NGCOV/53/, NGCALL/30/, NITER/31/,
-C 5 P0/48/, PC/41/, PERM/58/, QTR/77/, RADINC/8/, RDREQ/57/,
-C 6 REGD/67/, RESTOR/9/, RMAT/78/, S/62/, STEP/40/, STGLIM/11/,
-C 7 SUSED/64/, SWITCH/12/, TOOBIG/2/, VNEED/4/, VSAVE/60/, W/65/,
-C 8 XIRC/13/, X0/43/
-C/7
- PARAMETER (CNVCOD=55, COVMAT=26, COVREQ=15, DIG=37, FDH=74, H=56,
- 1 HC=71, IERR=75, INITS=25, IPIVOT=76, IRC=29, IVNEED=3,
- 2 KAGQT=33, KALM=34, LMAT=42, MODE=35, MODEL=5,
- 3 MXFCAL=17, MXITER=18, NEXTIV=46, NEXTV=47, NFCALL=6,
- 4 NFGCAL=7, NFCOV=52, NGCOV=53, NGCALL=30, NITER=31,
- 5 P0=48, PC=41, PERM=58, QTR=77, RADINC=8, RDREQ=57,
- 6 REGD=67, RESTOR=9, RMAT=78, S=62, STEP=40, STGLIM=11,
- 7 SUSED=64, SWITCH=12, TOOBIG=2, VNEED=4, VSAVE=60, W=65,
- 8 XIRC=13, X0=43)
-C/
-C
-C *** V SUBSCRIPT VALUES ***
-C
-C/6
-C DATA COSMIN/47/, DGNORM/1/, DSTNRM/2/, F/10/, FDIF/11/, FUZZ/45/,
-C 1 F0/13/, GTSTEP/4/, INCFAC/23/, LMAX0/35/, LMAXS/36/,
-C 2 NVSAVE/9/, PHMXFC/21/, PREDUC/7/, RADFAC/16/, RADIUS/8/,
-C 3 RAD0/9/, RELDX/17/, SIZE/55/, STPPAR/5/, TUNER4/29/,
-C 4 TUNER5/30/, WSCALE/56/
-C/7
- PARAMETER (COSMIN=47, DGNORM=1, DSTNRM=2, F=10, FDIF=11, FUZZ=45,
- 1 F0=13, GTSTEP=4, INCFAC=23, LMAX0=35, LMAXS=36,
- 2 NVSAVE=9, PHMXFC=21, PREDUC=7, RADFAC=16, RADIUS=8,
- 3 RAD0=9, RELDX=17, SIZE=55, STPPAR=5, TUNER4=29,
- 4 TUNER5=30, WSCALE=56)
-C/
-C
-C
-C/6
-C DATA HALF/0.5E+0/, NEGONE/-1.E+0/, ONE/1.E+0/, ONEP2/1.2E+0/,
-C 1 ZERO/0.E+0/
-C/7
- PARAMETER (HALF=0.5E+0, NEGONE=-1.E+0, ONE=1.E+0, ONEP2=1.2E+0,
- 1 ZERO=0.E+0)
-C/
-C
-C+++++++++++++++++++++++++++++++ BODY ++++++++++++++++++++++++++++++++
-C
- I = IV(1)
- IF (I .EQ. 1) GO TO 50
- IF (I .EQ. 2) GO TO 60
-C
- IF (I .LT. 12) GO TO 10
- IF (I .GT. 13) GO TO 10
- IV(VNEED) = IV(VNEED) + P*(3*P + 25)/2 + 7
- IV(IVNEED) = IV(IVNEED) + 4*P
- 10 CALL PARCK(1, D, IV, LIV, LV, P, V)
- I = IV(1) - 2
- IF (I .GT. 12) GO TO 999
- GO TO (360, 360, 360, 360, 360, 360, 240, 190, 240, 20, 20, 30), I
-C
-C *** STORAGE ALLOCATION ***
-C
- 20 PP1O2 = P * (P + 1) / 2
- IV(S) = IV(LMAT) + PP1O2
- IV(X0) = IV(S) + PP1O2
- IV(STEP) = IV(X0) + 2*P
- IV(DIG) = IV(STEP) + 3*P
- IV(W) = IV(DIG) + 2*P
- IV(H) = IV(W) + 4*P + 7
- IV(NEXTV) = IV(H) + PP1O2
- IV(IPIVOT) = IV(PERM) + 3*P
- IV(NEXTIV) = IV(IPIVOT) + P
- IF (IV(1) .NE. 13) GO TO 30
- IV(1) = 14
- GO TO 999
-C
-C *** INITIALIZATION ***
-C
- 30 IV(NITER) = 0
- IV(NFCALL) = 1
- IV(NGCALL) = 1
- IV(NFGCAL) = 1
- IV(MODE) = -1
- IV(STGLIM) = 2
- IV(TOOBIG) = 0
- IV(CNVCOD) = 0
- IV(COVMAT) = 0
- IV(NFCOV) = 0
- IV(NGCOV) = 0
- IV(RADINC) = 0
- IV(PC) = P
- V(RAD0) = ZERO
- V(STPPAR) = ZERO
- V(RADIUS) = V(LMAX0) / (ONE + V(PHMXFC))
-C
-C *** CHECK CONSISTENCY OF B AND INITIALIZE IP ARRAY ***
-C
- IPI = IV(IPIVOT)
- DO 40 I = 1, P
- IV(IPI) = I
- IPI = IPI + 1
- IF (B(1,I) .GT. B(2,I)) GO TO 680
- 40 CONTINUE
-C
-C *** SET INITIAL MODEL AND S MATRIX ***
-C
- IV(MODEL) = 1
- IV(1) = 1
- IF (IV(S) .LT. 0) GO TO 710
- IF (IV(INITS) .GT. 1) IV(MODEL) = 2
- S1 = IV(S)
- IF (IV(INITS) .EQ. 0 .OR. IV(INITS) .GT. 2)
- 1 CALL V7SCP(P*(P+1)/2, V(S1), ZERO)
- GO TO 710
-C
-C *** NEW FUNCTION VALUE ***
-C
- 50 IF (IV(MODE) .EQ. 0) GO TO 360
- IF (IV(MODE) .GT. 0) GO TO 590
-C
- IF (IV(TOOBIG) .EQ. 0) GO TO 690
- IV(1) = 63
- GO TO 999
-C
-C *** MAKE SURE GRADIENT COULD BE COMPUTED ***
-C
- 60 IF (IV(TOOBIG) .EQ. 0) GO TO 70
- IV(1) = 65
- GO TO 999
-C
-C *** NEW GRADIENT ***
-C
- 70 IV(KALM) = -1
- IV(KAGQT) = -1
- IV(FDH) = 0
- IF (IV(MODE) .GT. 0) GO TO 590
- IF (IV(HC) .LE. 0 .AND. IV(RMAT) .LE. 0) GO TO 670
-C
-C *** CHOOSE INITIAL PERMUTATION ***
-C
- IPI = IV(IPIVOT)
- IPN = IPI + P - 1
- IPIV2 = IV(PERM) - 1
- K = IV(PC)
- P1 = P
- PP1 = P + 1
- RMAT1 = IV(RMAT)
- HAVRM = RMAT1 .GT. 0
- QTR1 = IV(QTR)
- HAVQTR = QTR1 .GT. 0
-C *** MAKE SURE V(QTR1) IS LEGAL (EVEN WHEN NOT REFERENCED) ***
- W1 = IV(W)
- IF (.NOT. HAVQTR) QTR1 = W1 + P
-C
- DO 100 I = 1, P
- I1 = IV(IPN)
- IPN = IPN - 1
- IF (B(1,I1) .GE. B(2,I1)) GO TO 80
- XI = X(I1)
- GI = G(I1)
- IF (XI .LE. B(1,I1) .AND. GI .GT. ZERO) GO TO 80
- IF (XI .GE. B(2,I1) .AND. GI .LT. ZERO) GO TO 80
-C *** DISALLOW CONVERGENCE IF X(I1) HAS JUST BEEN FREED ***
- J = IPIV2 + I1
- IF (IV(J) .GT. K) IV(CNVCOD) = 0
- GO TO 100
- 80 IF (I1 .GE. P1) GO TO 90
- I1 = PP1 - I
- CALL I7SHFT(P1, I1, IV(IPI))
- IF (HAVRM)
- 1 CALL Q7RSH(I1, P1, HAVQTR, V(QTR1), V(RMAT1), V(W1))
- 90 P1 = P1 - 1
- 100 CONTINUE
- IV(PC) = P1
-C
-C *** COMPUTE V(DGNORM) (AN OUTPUT VALUE IF WE STOP NOW) ***
-C
- V(DGNORM) = ZERO
- IF (P1 .LE. 0) GO TO 110
- DIG1 = IV(DIG)
- CALL V7VMP(P, V(DIG1), G, D, -1)
- CALL V7IPR(P, IV(IPI), V(DIG1))
- V(DGNORM) = V2NRM(P1, V(DIG1))
- 110 IF (IV(CNVCOD) .NE. 0) GO TO 580
- IF (IV(MODE) .EQ. 0) GO TO 510
- IV(MODE) = 0
- V(F0) = V(F)
- IF (IV(INITS) .LE. 2) GO TO 170
-C
-C *** ARRANGE FOR FINITE-DIFFERENCE INITIAL S ***
-C
- IV(XIRC) = IV(COVREQ)
- IV(COVREQ) = -1
- IF (IV(INITS) .GT. 3) IV(COVREQ) = 1
- IV(CNVCOD) = 70
- GO TO 600
-C
-C *** COME TO NEXT STMT AFTER COMPUTING F.D. HESSIAN FOR INIT. S ***
-C
- 120 H1 = IV(FDH)
- IF (H1 .LE. 0) GO TO 660
- IV(CNVCOD) = 0
- IV(MODE) = 0
- IV(NFCOV) = 0
- IV(NGCOV) = 0
- IV(COVREQ) = IV(XIRC)
- S1 = IV(S)
- PP1O2 = PS * (PS + 1) / 2
- HC1 = IV(HC)
- IF (HC1 .LE. 0) GO TO 130
- CALL V2AXY(PP1O2, V(S1), NEGONE, V(HC1), V(H1))
- GO TO 140
- 130 RMAT1 = IV(RMAT)
- LMAT1 = IV(LMAT)
- CALL L7SQR(P, V(LMAT1), V(RMAT1))
- IPI = IV(IPIVOT)
- IPIV1 = IV(PERM) + P
- CALL I7PNVR(P, IV(IPIV1), IV(IPI))
- CALL S7IPR(P, IV(IPIV1), V(LMAT1))
- CALL V2AXY(PP1O2, V(S1), NEGONE, V(LMAT1), V(H1))
-C
-C *** ZERO PORTION OF S CORRESPONDING TO FIXED X COMPONENTS ***
-C
- 140 DO 160 I = 1, P
- IF (B(1,I) .LT. B(2,I)) GO TO 160
- K = S1 + I*(I-1)/2
- CALL V7SCP(I, V(K), ZERO)
- IF (I .GE. P) GO TO 170
- K = K + 2*I - 1
- I1 = I + 1
- DO 150 J = I1, P
- V(K) = ZERO
- K = K + J
- 150 CONTINUE
- 160 CONTINUE
-C
- 170 IV(1) = 2
-C
-C
-C----------------------------- MAIN LOOP -----------------------------
-C
-C
-C *** PRINT ITERATION SUMMARY, CHECK ITERATION LIMIT ***
-C
- 180 CALL ITSUM(D, G, IV, LIV, LV, P, V, X)
- 190 K = IV(NITER)
- IF (K .LT. IV(MXITER)) GO TO 200
- IV(1) = 10
- GO TO 999
- 200 IV(NITER) = K + 1
-C
-C *** UPDATE RADIUS ***
-C
- IF (K .EQ. 0) GO TO 220
- STEP1 = IV(STEP)
- DO 210 I = 1, P
- V(STEP1) = D(I) * V(STEP1)
- STEP1 = STEP1 + 1
- 210 CONTINUE
- STEP1 = IV(STEP)
- T = V(RADFAC) * V2NRM(P, V(STEP1))
- IF (V(RADFAC) .LT. ONE .OR. T .GT. V(RADIUS)) V(RADIUS) = T
-C
-C *** INITIALIZE FOR START OF NEXT ITERATION ***
-C
- 220 X01 = IV(X0)
- V(F0) = V(F)
- IV(IRC) = 4
- IV(H) = -IABS(IV(H))
- IV(SUSED) = IV(MODEL)
-C
-C *** COPY X TO X0 ***
-C
- CALL V7CPY(P, V(X01), X)
-C
-C *** CHECK STOPX AND FUNCTION EVALUATION LIMIT ***
-C
- 230 IF (.NOT. STOPX(DUMMY)) GO TO 250
- IV(1) = 11
- GO TO 260
-C
-C *** COME HERE WHEN RESTARTING AFTER FUNC. EVAL. LIMIT OR STOPX.
-C
- 240 IF (V(F) .GE. V(F0)) GO TO 250
- V(RADFAC) = ONE
- K = IV(NITER)
- GO TO 200
-C
- 250 IF (IV(NFCALL) .LT. IV(MXFCAL) + IV(NFCOV)) GO TO 270
- IV(1) = 9
- 260 IF (V(F) .GE. V(F0)) GO TO 999
-C
-C *** IN CASE OF STOPX OR FUNCTION EVALUATION LIMIT WITH
-C *** IMPROVED V(F), EVALUATE THE GRADIENT AT X.
-C
- IV(CNVCOD) = IV(1)
- GO TO 500
-C
-C. . . . . . . . . . . . . COMPUTE CANDIDATE STEP . . . . . . . . . .
-C
- 270 STEP1 = IV(STEP)
- TG1 = IV(DIG)
- TD1 = TG1 + P
- X01 = IV(X0)
- W1 = IV(W)
- H1 = IV(H)
- P1 = IV(PC)
- IPI = IV(PERM)
- IPIV1 = IPI + P
- IPIV2 = IPIV1 + P
- IPIV0 = IV(IPIVOT)
- IF (IV(MODEL) .EQ. 2) GO TO 280
-C
-C *** COMPUTE LEVENBERG-MARQUARDT STEP IF POSSIBLE...
-C
- RMAT1 = IV(RMAT)
- IF (RMAT1 .LE. 0) GO TO 280
- QTR1 = IV(QTR)
- IF (QTR1 .LE. 0) GO TO 280
- LMAT1 = IV(LMAT)
- WLM1 = W1 + P
- CALL L7MSB(B, D, G, IV(IERR), IV(IPIV0), IV(IPIV1),
- 1 IV(IPIV2), IV(KALM), V(LMAT1), LV, P, IV(P0),
- 2 IV(PC), V(QTR1), V(RMAT1), V(STEP1), V(TD1),
- 3 V(TG1), V, V(W1), V(WLM1), X, V(X01))
-C *** H IS STORED IN THE END OF W AND HAS JUST BEEN OVERWRITTEN,
-C *** SO WE MARK IT INVALID...
- IV(H) = -IABS(H1)
-C *** EVEN IF H WERE STORED ELSEWHERE, IT WOULD BE NECESSARY TO
-C *** MARK INVALID THE INFORMATION G7QTS MAY HAVE STORED IN V...
- IV(KAGQT) = -1
- GO TO 330
-C
- 280 IF (H1 .GT. 0) GO TO 320
-C
-C *** SET H TO D**-1 * (HC + T1*S) * D**-1. ***
-C
- P1LEN = P1*(P1+1)/2
- H1 = -H1
- IV(H) = H1
- IV(FDH) = 0
- IF (P1 .LE. 0) GO TO 320
-C *** MAKE TEMPORARY PERMUTATION ARRAY ***
- CALL I7COPY(P, IV(IPI), IV(IPIV0))
- J = IV(HC)
- IF (J .GT. 0) GO TO 290
- J = H1
- RMAT1 = IV(RMAT)
- CALL L7SQR(P1, V(H1), V(RMAT1))
- GO TO 300
- 290 CALL V7CPY(P*(P+1)/2, V(H1), V(J))
- CALL S7IPR(P, IV(IPI), V(H1))
- 300 IF (IV(MODEL) .EQ. 1) GO TO 310
- LMAT1 = IV(LMAT)
- S1 = IV(S)
- CALL V7CPY(P*(P+1)/2, V(LMAT1), V(S1))
- CALL S7IPR(P, IV(IPI), V(LMAT1))
- CALL V2AXY(P1LEN, V(H1), ONE, V(LMAT1), V(H1))
- 310 CALL V7CPY(P, V(TD1), D)
- CALL V7IPR(P, IV(IPI), V(TD1))
- CALL S7DMP(P1, V(H1), V(H1), V(TD1), -1)
- IV(KAGQT) = -1
-C
-C *** COMPUTE ACTUAL GOLDFELD-QUANDT-TROTTER STEP ***
-C
- 320 LMAT1 = IV(LMAT)
- CALL G7QSB(B, D, V(H1), G, IV(IPI), IV(IPIV1), IV(IPIV2),
- 1 IV(KAGQT), V(LMAT1), LV, P, IV(P0), P1, V(STEP1),
- 2 V(TD1), V(TG1), V, V(W1), X, V(X01))
- IF (IV(KALM) .GT. 0) IV(KALM) = 0
-C
- 330 IF (IV(IRC) .NE. 6) GO TO 340
- IF (IV(RESTOR) .NE. 2) GO TO 360
- RSTRST = 2
- GO TO 370
-C
-C *** CHECK WHETHER EVALUATING F(X0 + STEP) LOOKS WORTHWHILE ***
-C
- 340 IV(TOOBIG) = 0
- IF (V(DSTNRM) .LE. ZERO) GO TO 360
- IF (IV(IRC) .NE. 5) GO TO 350
- IF (V(RADFAC) .LE. ONE) GO TO 350
- IF (V(PREDUC) .GT. ONEP2 * V(FDIF)) GO TO 350
- STEP1 = IV(STEP)
- X01 = IV(X0)
- CALL V2AXY(P, V(STEP1), NEGONE, V(X01), X)
- IF (IV(RESTOR) .NE. 2) GO TO 360
- RSTRST = 0
- GO TO 370
-C
-C *** COMPUTE F(X0 + STEP) ***
-C
- 350 X01 = IV(X0)
- STEP1 = IV(STEP)
- CALL V2AXY(P, X, ONE, V(STEP1), V(X01))
- IV(NFCALL) = IV(NFCALL) + 1
- IV(1) = 1
- GO TO 710
-C
-C. . . . . . . . . . . . . ASSESS CANDIDATE STEP . . . . . . . . . . .
-C
- 360 RSTRST = 3
- 370 X01 = IV(X0)
- V(RELDX) = RLDST(P, D, X, V(X01))
- CALL A7SST(IV, LIV, LV, V)
- STEP1 = IV(STEP)
- LSTGST = X01 + P
- I = IV(RESTOR) + 1
- GO TO (410, 380, 390, 400), I
- 380 CALL V7CPY(P, X, V(X01))
- GO TO 410
- 390 CALL V7CPY(P, V(LSTGST), V(STEP1))
- GO TO 410
- 400 CALL V7CPY(P, V(STEP1), V(LSTGST))
- CALL V2AXY(P, X, ONE, V(STEP1), V(X01))
- V(RELDX) = RLDST(P, D, X, V(X01))
- IV(RESTOR) = RSTRST
-C
-C *** IF NECESSARY, SWITCH MODELS ***
-C
- 410 IF (IV(SWITCH) .EQ. 0) GO TO 420
- IV(H) = -IABS(IV(H))
- IV(SUSED) = IV(SUSED) + 2
- L = IV(VSAVE)
- CALL V7CPY(NVSAVE, V, V(L))
- 420 L = IV(IRC) - 4
- STPMOD = IV(MODEL)
- IF (L .GT. 0) GO TO (440,450,460,460,460,460,460,460,570,510), L
-C
-C *** DECIDE WHETHER TO CHANGE MODELS ***
-C
- E = V(PREDUC) - V(FDIF)
- S1 = IV(S)
- CALL S7LVM(PS, Y, V(S1), V(STEP1))
- STTSST = HALF * D7TPR(PS, V(STEP1), Y)
- IF (IV(MODEL) .EQ. 1) STTSST = -STTSST
- IF ( ABS(E + STTSST) * V(FUZZ) .GE. ABS(E)) GO TO 430
-C
-C *** SWITCH MODELS ***
-C
- IV(MODEL) = 3 - IV(MODEL)
- IF (-2 .LT. L) GO TO 470
- IV(H) = -IABS(IV(H))
- IV(SUSED) = IV(SUSED) + 2
- L = IV(VSAVE)
- CALL V7CPY(NVSAVE, V(L), V)
- GO TO 230
-C
- 430 IF (-3 .LT. L) GO TO 470
-C
-C *** RECOMPUTE STEP WITH DIFFERENT RADIUS ***
-C
- 440 V(RADIUS) = V(RADFAC) * V(DSTNRM)
- GO TO 230
-C
-C *** COMPUTE STEP OF LENGTH V(LMAXS) FOR SINGULAR CONVERGENCE TEST
-C
- 450 V(RADIUS) = V(LMAXS)
- GO TO 270
-C
-C *** CONVERGENCE OR FALSE CONVERGENCE ***
-C
- 460 IV(CNVCOD) = L
- IF (V(F) .GE. V(F0)) GO TO 580
- IF (IV(XIRC) .EQ. 14) GO TO 580
- IV(XIRC) = 14
-C
-C. . . . . . . . . . . . PROCESS ACCEPTABLE STEP . . . . . . . . . . .
-C
- 470 IV(COVMAT) = 0
- IV(REGD) = 0
-C
-C *** SEE WHETHER TO SET V(RADFAC) BY GRADIENT TESTS ***
-C
- IF (IV(IRC) .NE. 3) GO TO 500
- STEP1 = IV(STEP)
- TEMP1 = STEP1 + P
- TEMP2 = IV(X0)
-C
-C *** SET TEMP1 = HESSIAN * STEP FOR _USE_ IN GRADIENT TESTS ***
-C
- HC1 = IV(HC)
- IF (HC1 .LE. 0) GO TO 480
- CALL S7LVM(P, V(TEMP1), V(HC1), V(STEP1))
- GO TO 490
- 480 RMAT1 = IV(RMAT)
- IPIV0 = IV(IPIVOT)
- CALL V7CPY(P, V(TEMP1), V(STEP1))
- CALL V7IPR(P, IV(IPIV0), V(TEMP1))
- CALL L7TVM(P, V(TEMP1), V(RMAT1), V(TEMP1))
- CALL L7VML(P, V(TEMP1), V(RMAT1), V(TEMP1))
- IPIV1 = IV(PERM) + P
- CALL I7PNVR(P, IV(IPIV1), IV(IPIV0))
- CALL V7IPR(P, IV(IPIV1), V(TEMP1))
-C
- 490 IF (STPMOD .EQ. 1) GO TO 500
- S1 = IV(S)
- CALL S7LVM(PS, V(TEMP2), V(S1), V(STEP1))
- CALL V2AXY(PS, V(TEMP1), ONE, V(TEMP2), V(TEMP1))
-C
-C *** SAVE OLD GRADIENT AND COMPUTE NEW ONE ***
-C
- 500 IV(NGCALL) = IV(NGCALL) + 1
- G01 = IV(W)
- CALL V7CPY(P, V(G01), G)
- GO TO 690
-C
-C *** INITIALIZATIONS -- G0 = G - G0, ETC. ***
-C
- 510 G01 = IV(W)
- CALL V2AXY(P, V(G01), NEGONE, V(G01), G)
- STEP1 = IV(STEP)
- TEMP1 = STEP1 + P
- TEMP2 = IV(X0)
- IF (IV(IRC) .NE. 3) GO TO 540
-C
-C *** SET V(RADFAC) BY GRADIENT TESTS ***
-C
-C *** SET TEMP1 = D**-1 * (HESSIAN * STEP + (G(X0) - G(X))) ***
-C
- K = TEMP1
- L = G01
- DO 520 I = 1, P
- V(K) = (V(K) - V(L)) / D(I)
- K = K + 1
- L = L + 1
- 520 CONTINUE
-C
-C *** DO GRADIENT TESTS ***
-C
- IF ( V2NRM(P, V(TEMP1)) .LE. V(DGNORM) * V(TUNER4)) GO TO 530
- IF ( D7TPR(P, G, V(STEP1))
- 1 .GE. V(GTSTEP) * V(TUNER5)) GO TO 540
- 530 V(RADFAC) = V(INCFAC)
-C
-C *** COMPUTE Y VECTOR NEEDED FOR UPDATING S ***
-C
- 540 CALL V2AXY(PS, Y, NEGONE, Y, G)
-C
-C *** DETERMINE SIZING FACTOR V(SIZE) ***
-C
-C *** SET TEMP1 = S * STEP ***
- S1 = IV(S)
- CALL S7LVM(PS, V(TEMP1), V(S1), V(STEP1))
-C
- T1 = ABS( D7TPR(PS, V(STEP1), V(TEMP1)))
- T = ABS( D7TPR(PS, V(STEP1), Y))
- V(SIZE) = ONE
- IF (T .LT. T1) V(SIZE) = T / T1
-C
-C *** SET G0 TO WCHMTD CHOICE OF FLETCHER AND AL-BAALI ***
-C
- HC1 = IV(HC)
- IF (HC1 .LE. 0) GO TO 550
- CALL S7LVM(PS, V(G01), V(HC1), V(STEP1))
- GO TO 560
-C
- 550 RMAT1 = IV(RMAT)
- IPIV0 = IV(IPIVOT)
- CALL V7CPY(P, V(G01), V(STEP1))
- I = G01 + PS
- IF (PS .LT. P) CALL V7SCP(P-PS, V(I), ZERO)
- CALL V7IPR(P, IV(IPIV0), V(G01))
- CALL L7TVM(P, V(G01), V(RMAT1), V(G01))
- CALL L7VML(P, V(G01), V(RMAT1), V(G01))
- IPIV1 = IV(PERM) + P
- CALL I7PNVR(P, IV(IPIV1), IV(IPIV0))
- CALL V7IPR(P, IV(IPIV1), V(G01))
-C
- 560 CALL V2AXY(PS, V(G01), ONE, Y, V(G01))
-C
-C *** UPDATE S ***
-C
- CALL S7LUP(V(S1), V(COSMIN), PS, V(SIZE), V(STEP1), V(TEMP1),
- 1 V(TEMP2), V(G01), V(WSCALE), Y)
- IV(1) = 2
- GO TO 180
-C
-C. . . . . . . . . . . . . . MISC. DETAILS . . . . . . . . . . . . . .
-C
-C *** BAD PARAMETERS TO ASSESS ***
-C
- 570 IV(1) = 64
- GO TO 999
-C
-C
-C *** CONVERGENCE OBTAINED -- SEE WHETHER TO COMPUTE COVARIANCE ***
-C
- 580 IF (IV(RDREQ) .EQ. 0) GO TO 660
- IF (IV(FDH) .NE. 0) GO TO 660
- IF (IV(CNVCOD) .GE. 7) GO TO 660
- IF (IV(REGD) .GT. 0) GO TO 660
- IF (IV(COVMAT) .GT. 0) GO TO 660
- IF (IABS(IV(COVREQ)) .GE. 3) GO TO 640
- IF (IV(RESTOR) .EQ. 0) IV(RESTOR) = 2
- GO TO 600
-C
-C *** COMPUTE FINITE-DIFFERENCE HESSIAN FOR COMPUTING COVARIANCE ***
-C
- 590 IV(RESTOR) = 0
- 600 CALL F7DHB(B, D, G, I, IV, LIV, LV, P, V, X)
- GO TO (610, 620, 630), I
- 610 IV(NFCOV) = IV(NFCOV) + 1
- IV(NFCALL) = IV(NFCALL) + 1
- IV(1) = 1
- GO TO 710
-C
- 620 IV(NGCOV) = IV(NGCOV) + 1
- IV(NGCALL) = IV(NGCALL) + 1
- IV(NFGCAL) = IV(NFCALL) + IV(NGCOV)
- GO TO 690
-C
- 630 IF (IV(CNVCOD) .EQ. 70) GO TO 120
- GO TO 660
-C
- 640 H1 = IABS(IV(H))
- IV(FDH) = H1
- IV(H) = -H1
- HC1 = IV(HC)
- IF (HC1 .LE. 0) GO TO 650
- CALL V7CPY(P*(P+1)/2, V(H1), V(HC1))
- GO TO 660
- 650 RMAT1 = IV(RMAT)
- CALL L7SQR(P, V(H1), V(RMAT1))
-C
- 660 IV(MODE) = 0
- IV(1) = IV(CNVCOD)
- IV(CNVCOD) = 0
- GO TO 999
-C
-C *** SPECIAL RETURN FOR MISSING HESSIAN INFORMATION -- BOTH
-C *** IV(HC) .LE. 0 AND IV(RMAT) .LE. 0
-C
- 670 IV(1) = 1400
- GO TO 999
-C
-C *** INCONSISTENT B ***
-C
- 680 IV(1) = 82
- GO TO 999
-C
-C *** SAVE, THEN INITIALIZE IPIVOT ARRAY BEFORE COMPUTING G ***
-C
- 690 IV(1) = 2
- J = IV(IPIVOT)
- IPI = IV(PERM)
- CALL I7PNVR(P, IV(IPI), IV(J))
- DO 700 I = 1, P
- IV(J) = I
- J = J + 1
- 700 CONTINUE
-C
-C *** PROJECT X INTO FEASIBLE REGION (PRIOR TO COMPUTING F OR G) ***
-C
- 710 DO 720 I = 1, P
- IF (X(I) .LT. B(1,I)) X(I) = B(1,I)
- IF (X(I) .GT. B(2,I)) X(I) = B(2,I)
- 720 CONTINUE
- IV(TOOBIG) = 0
-C
- 999 RETURN
-C
-C *** LAST LINE OF G7ITB FOLLOWS ***
- END
diff --git a/CEP/PyBDSM/src/port3/g7lit.f b/CEP/PyBDSM/src/port3/g7lit.f
deleted file mode 100644
index 37e1fa19bb541938a32f44d944c24c76f624f022..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/g7lit.f
+++ /dev/null
@@ -1,753 +0,0 @@
- SUBROUTINE G7LIT(D, G, IV, LIV, LV, P, PS, V, X, Y)
-C
-C *** CARRY OUT NL2SOL-LIKE ITERATIONS FOR GENERALIZED LINEAR ***
-C *** REGRESSION PROBLEMS (AND OTHERS OF SIMILAR STRUCTURE) ***
-C
-C *** PARAMETER DECLARATIONS ***
-C
- INTEGER LIV, LV, P, PS
- INTEGER IV(LIV)
- REAL D(P), G(P), V(LV), X(P), Y(P)
-C
-C-------------------------- PARAMETER USAGE --------------------------
-C
-C D.... SCALE VECTOR.
-C IV... INTEGER VALUE ARRAY.
-C LIV.. LENGTH OF IV. MUST BE AT LEAST 82.
-C LH... LENGTH OF H = P*(P+1)/2.
-C LV... LENGTH OF V. MUST BE AT LEAST P*(3*P + 19)/2 + 7.
-C G.... GRADIENT AT X (WHEN IV(1) = 2).
-C P.... NUMBER OF PARAMETERS (COMPONENTS IN X).
-C PS... NUMBER OF NONZERO ROWS AND COLUMNS IN S.
-C V.... FLOATING-POINT VALUE ARRAY.
-C X.... PARAMETER VECTOR.
-C Y.... PART OF YIELD VECTOR (WHEN IV(1)= 2, SCRATCH OTHERWISE).
-C
-C *** DISCUSSION ***
-C
-C G7LIT PERFORMS NL2SOL-LIKE ITERATIONS FOR A VARIETY OF
-C REGRESSION PROBLEMS THAT ARE SIMILAR TO NONLINEAR LEAST-SQUARES
-C IN THAT THE HESSIAN IS THE SUM OF TWO TERMS, A READILY-COMPUTED
-C FIRST-ORDER TERM AND A SECOND-ORDER TERM. THE CALLER SUPPLIES
-C THE FIRST-ORDER TERM OF THE HESSIAN IN HC (LOWER TRIANGLE, STORED
-C COMPACTLY BY ROWS IN V, STARTING AT IV(HC)), AND G7LIT BUILDS AN
-C APPROXIMATION, S, TO THE SECOND-ORDER TERM. THE CALLER ALSO
-C PROVIDES THE FUNCTION VALUE, GRADIENT, AND PART OF THE YIELD
-C VECTOR USED IN UPDATING S. G7LIT DECIDES DYNAMICALLY WHETHER OR
-C NOT TO _USE_ S WHEN CHOOSING THE NEXT STEP TO TRY... THE HESSIAN
-C APPROXIMATION USED IS EITHER HC ALONE (GAUSS-NEWTON MODEL) OR
-C HC + S (AUGMENTED MODEL).
-C
-C IF PS .LT. P, THEN ROWS AND COLUMNS PS+1...P OF S ARE KEPT
-C CONSTANT. THEY WILL BE ZERO UNLESS THE CALLER SETS IV(INITS) TO
-C 1 OR 2 AND SUPPLIES NONZERO VALUES FOR THEM, OR THE CALLER SETS
-C IV(INITS) TO 3 OR 4 AND THE FINITE-DIFFERENCE INITIAL S THEN
-C COMPUTED HAS NONZERO VALUES IN THESE ROWS.
-C
-C IF IV(INITS) IS 3 OR 4, THEN THE INITIAL S IS COMPUTED BY
-C FINITE DIFFERENCES. 3 MEANS _USE_ FUNCTION DIFFERENCES, 4 MEANS
-C _USE_ GRADIENT DIFFERENCES. FINITE DIFFERENCING IS DONE THE SAME
-C WAY AS IN COMPUTING A COVARIANCE MATRIX (WITH IV(COVREQ) = -1, -2,
-C 1, OR 2).
-C
-C FOR UPDATING S, G7LIT ASSUMES THAT THE GRADIENT HAS THE FORM
-C OF A SUM OVER I OF RHO(I,X)*GRAD(R(I,X)), WHERE GRAD DENOTES THE
-C GRADIENT WITH RESPECT TO X. THE TRUE SECOND-ORDER TERM THEN IS
-C THE SUM OVER I OF RHO(I,X)*HESSIAN(R(I,X)). IF X = X0 + STEP,
-C THEN WE WISH TO UPDATE S SO THAT S*STEP IS THE SUM OVER I OF
-C RHO(I,X)*(GRAD(R(I,X)) - GRAD(R(I,X0))). THE CALLER MUST SUPPLY
-C PART OF THIS IN Y, NAMELY THE SUM OVER I OF
-C RHO(I,X)*GRAD(R(I,X0)), WHEN CALLING G7LIT WITH IV(1) = 2 AND
-C IV(MODE) = 0 (WHERE MODE = 38). G THEN CONTANS THE OTHER PART,
-C SO THAT THE DESIRED YIELD VECTOR IS G - Y. IF PS .LT. P, THEN
-C THE ABOVE DISCUSSION APPLIES ONLY TO THE FIRST PS COMPONENTS OF
-C GRAD(R(I,X)), STEP, AND Y.
-C
-C PARAMETERS IV, P, V, AND X ARE THE SAME AS THE CORRESPONDING
-C ONES TO NL2SOL (WHICH SEE), EXCEPT THAT V CAN BE SHORTER
-C (SINCE THE PART OF V THAT NL2SOL USES FOR STORING D, J, AND R IS
-C NOT NEEDED). MOREOVER, COMPARED WITH NL2SOL, IV(1) MAY HAVE THE
-C TWO ADDITIONAL OUTPUT VALUES 1 AND 2, WHICH ARE EXPLAINED BELOW,
-C AS IS THE _USE_ OF IV(TOOBIG) AND IV(NFGCAL). THE VALUES IV(D),
-C IV(J), AND IV(R), WHICH ARE OUTPUT VALUES FROM NL2SOL (AND
-C NL2SNO), ARE NOT REFERENCED BY G7LIT OR THE SUBROUTINES IT CALLS.
-C
-C WHEN G7LIT IS FIRST CALLED, I.E., WHEN G7LIT IS CALLED WITH
-C IV(1) = 0 OR 12, V(F), G, AND HC NEED NOT BE INITIALIZED. TO
-C OBTAIN THESE STARTING VALUES, G7LIT RETURNS FIRST WITH IV(1) = 1,
-C THEN WITH IV(1) = 2, WITH IV(MODE) = -1 IN BOTH CASES. ON
-C SUBSEQUENT RETURNS WITH IV(1) = 2, IV(MODE) = 0 IMPLIES THAT
-C Y MUST ALSO BE SUPPLIED. (NOTE THAT Y IS USED FOR SCRATCH -- ITS
-C INPUT CONTENTS ARE LOST. BY CONTRAST, HC IS NEVER CHANGED.)
-C ONCE CONVERGENCE HAS BEEN OBTAINED, IV(RDREQ) AND IV(COVREQ) MAY
-C IMPLY THAT A FINITE-DIFFERENCE HESSIAN SHOULD BE COMPUTED FOR USE
-C IN COMPUTING A COVARIANCE MATRIX. IN THIS CASE G7LIT WILL MAKE A
-C NUMBER OF RETURNS WITH IV(1) = 1 OR 2 AND IV(MODE) POSITIVE.
-C WHEN IV(MODE) IS POSITIVE, Y SHOULD NOT BE CHANGED.
-C
-C IV(1) = 1 MEANS THE CALLER SHOULD SET V(F) (I.E., V(10)) TO F(X), THE
-C FUNCTION VALUE AT X, AND CALL G7LIT AGAIN, HAVING CHANGED
-C NONE OF THE OTHER PARAMETERS. AN EXCEPTION OCCURS IF F(X)
-C CANNOT BE EVALUATED (E.G. IF OVERFLOW WOULD OCCUR), WHICH
-C MAY HAPPEN BECAUSE OF AN OVERSIZED STEP. IN THIS CASE
-C THE CALLER SHOULD SET IV(TOOBIG) = IV(2) TO 1, WHICH WILL
-C CAUSE G7LIT TO IGNORE V(F) AND TRY A SMALLER STEP. NOTE
-C THAT THE CURRENT FUNCTION EVALUATION COUNT IS AVAILABLE
-C IN IV(NFCALL) = IV(6). THIS MAY BE USED TO IDENTIFY
-C WHICH COPY OF SAVED INFORMATION SHOULD BE USED IN COM-
-C PUTING G, HC, AND Y THE NEXT TIME G7LIT RETURNS WITH
-C IV(1) = 2. SEE MLPIT FOR AN EXAMPLE OF THIS.
-C IV(1) = 2 MEANS THE CALLER SHOULD SET G TO G(X), THE GRADIENT OF F AT
-C X. THE CALLER SHOULD ALSO SET HC TO THE GAUSS-NEWTON
-C HESSIAN AT X. IF IV(MODE) = 0, THEN THE CALLER SHOULD
-C ALSO COMPUTE THE PART OF THE YIELD VECTOR DESCRIBED ABOVE.
-C THE CALLER SHOULD THEN CALL G7LIT AGAIN (WITH IV(1) = 2).
-C THE CALLER MAY ALSO CHANGE D AT THIS TIME, BUT SHOULD NOT
-C CHANGE X. NOTE THAT IV(NFGCAL) = IV(7) CONTAINS THE
-C VALUE THAT IV(NFCALL) HAD DURING THE RETURN WITH
-C IV(1) = 1 IN WHICH X HAD THE SAME VALUE AS IT NOW HAS.
-C IV(NFGCAL) IS EITHER IV(NFCALL) OR IV(NFCALL) - 1. MLPIT
-C IS AN EXAMPLE WHERE THIS INFORMATION IS USED. IF G OR HC
-C CANNOT BE EVALUATED AT X, THEN THE CALLER MAY SET
-C IV(TOOBIG) TO 1, IN WHICH CASE G7LIT WILL RETURN WITH
-C IV(1) = 15.
-C
-C *** GENERAL ***
-C
-C CODED BY DAVID M. GAY.
-C THIS SUBROUTINE WAS WRITTEN IN CONNECTION WITH RESEARCH
-C SUPPORTED IN PART BY D.O.E. GRANT EX-76-A-01-2295 TO MIT/CCREMS.
-C
-C (SEE NL2SOL FOR REFERENCES.)
-C
-C+++++++++++++++++++++++++++ DECLARATIONS ++++++++++++++++++++++++++++
-C
-C *** LOCAL VARIABLES ***
-C
- INTEGER DUMMY, DIG1, G01, H1, HC1, I, IPIV1, J, K, L, LMAT1,
- 1 LSTGST, PP1O2, QTR1, RMAT1, RSTRST, STEP1, STPMOD, S1,
- 2 TEMP1, TEMP2, W1, X01
- REAL E, STTSST, T, T1
-C
-C *** CONSTANTS ***
-C
- REAL HALF, NEGONE, ONE, ONEP2, ZERO
-C
-C *** EXTERNAL FUNCTIONS AND SUBROUTINES ***
-C
- LOGICAL STOPX
- REAL D7TPR, L7SVX, L7SVN, RLDST, R7MDC, V2NRM
- EXTERNAL A7SST, D7TPR, F7HES, G7QTS, ITSUM, L7MST, L7SRT,
- 1 L7SQR, L7SVX, L7SVN, L7TVM, L7VML, PARCK, RLDST,
- 2 R7MDC, S7LUP, S7LVM, STOPX, V2AXY, V7CPY, V7SCP,
- 3 V2NRM
-C
-C A7SST.... ASSESSES CANDIDATE STEP.
-C D7TPR... RETURNS INNER PRODUCT OF TWO VECTORS.
-C F7HES.... COMPUTE FINITE-DIFFERENCE HESSIAN (FOR COVARIANCE).
-C G7QTS.... COMPUTES GOLDFELD-QUANDT-TROTTER STEP (AUGMENTED MODEL).
-C ITSUM.... PRINTS ITERATION SUMMARY AND INFO ON INITIAL AND FINAL X.
-C L7MST... COMPUTES LEVENBERG-MARQUARDT STEP (GAUSS-NEWTON MODEL).
-C L7SRT.... COMPUTES CHOLESKY FACTOR OF (LOWER TRIANG. OF) SYM. MATRIX.
-C L7SQR... COMPUTES L * L**T FROM LOWER TRIANGULAR MATRIX L.
-C L7TVM... COMPUTES L**T * V, V = VECTOR, L = LOWER TRIANGULAR MATRIX.
-C L7SVX... ESTIMATES LARGEST SING. VALUE OF LOWER TRIANG. MATRIX.
-C L7SVN... ESTIMATES SMALLEST SING. VALUE OF LOWER TRIANG. MATRIX.
-C L7VML.... COMPUTES L * V, V = VECTOR, L = LOWER TRIANGULAR MATRIX.
-C PARCK.... CHECK VALIDITY OF IV AND V INPUT COMPONENTS.
-C RLDST... COMPUTES V(RELDX) = RELATIVE STEP SIZE.
-C R7MDC... RETURNS MACHINE-DEPENDENT CONSTANTS.
-C S7LUP... PERFORMS QUASI-NEWTON UPDATE ON COMPACTLY STORED LOWER TRI-
-C ANGLE OF A SYMMETRIC MATRIX.
-C STOPX.... RETURNS .TRUE. IF THE BREAK KEY HAS BEEN PRESSED.
-C V2AXY.... COMPUTES SCALAR TIMES ONE VECTOR PLUS ANOTHER.
-C V7CPY.... COPIES ONE VECTOR TO ANOTHER.
-C V7SCP... SETS ALL ELEMENTS OF A VECTOR TO A SCALAR.
-C V2NRM... RETURNS THE 2-NORM OF A VECTOR.
-C
-C *** SUBSCRIPTS FOR IV AND V ***
-C
- INTEGER CNVCOD, COSMIN, COVMAT, COVREQ, DGNORM, DIG, DSTNRM, F,
- 1 FDH, FDIF, FUZZ, F0, GTSTEP, H, HC, IERR, INCFAC, INITS,
- 2 IPIVOT, IRC, KAGQT, KALM, LMAT, LMAX0, LMAXS, MODE, MODEL,
- 3 MXFCAL, MXITER, NEXTV, NFCALL, NFGCAL, NFCOV, NGCOV,
- 4 NGCALL, NITER, NVSAVE, PHMXFC, PREDUC, QTR, RADFAC,
- 5 RADINC, RADIUS, RAD0, RCOND, RDREQ, REGD, RELDX, RESTOR,
- 6 RMAT, S, SIZE, STEP, STGLIM, STLSTG, STPPAR, SUSED,
- 7 SWITCH, TOOBIG, TUNER4, TUNER5, VNEED, VSAVE, W, WSCALE,
- 8 XIRC, X0
-C
-C *** IV SUBSCRIPT VALUES ***
-C
-C/6
-C DATA CNVCOD/55/, COVMAT/26/, COVREQ/15/, DIG/37/, FDH/74/, H/56/,
-C 1 HC/71/, IERR/75/, INITS/25/, IPIVOT/76/, IRC/29/, KAGQT/33/,
-C 2 KALM/34/, LMAT/42/, MODE/35/, MODEL/5/, MXFCAL/17/,
-C 3 MXITER/18/, NEXTV/47/, NFCALL/6/, NFGCAL/7/, NFCOV/52/,
-C 4 NGCOV/53/, NGCALL/30/, NITER/31/, QTR/77/, RADINC/8/,
-C 5 RDREQ/57/, REGD/67/, RESTOR/9/, RMAT/78/, S/62/, STEP/40/,
-C 6 STGLIM/11/, STLSTG/41/, SUSED/64/, SWITCH/12/, TOOBIG/2/,
-C 7 VNEED/4/, VSAVE/60/, W/65/, XIRC/13/, X0/43/
-C/7
- PARAMETER (CNVCOD=55, COVMAT=26, COVREQ=15, DIG=37, FDH=74, H=56,
- 1 HC=71, IERR=75, INITS=25, IPIVOT=76, IRC=29, KAGQT=33,
- 2 KALM=34, LMAT=42, MODE=35, MODEL=5, MXFCAL=17,
- 3 MXITER=18, NEXTV=47, NFCALL=6, NFGCAL=7, NFCOV=52,
- 4 NGCOV=53, NGCALL=30, NITER=31, QTR=77, RADINC=8,
- 5 RDREQ=57, REGD=67, RESTOR=9, RMAT=78, S=62, STEP=40,
- 6 STGLIM=11, STLSTG=41, SUSED=64, SWITCH=12, TOOBIG=2,
- 7 VNEED=4, VSAVE=60, W=65, XIRC=13, X0=43)
-C/
-C
-C *** V SUBSCRIPT VALUES ***
-C
-C/6
-C DATA COSMIN/47/, DGNORM/1/, DSTNRM/2/, F/10/, FDIF/11/, FUZZ/45/,
-C 1 F0/13/, GTSTEP/4/, INCFAC/23/, LMAX0/35/, LMAXS/36/,
-C 2 NVSAVE/9/, PHMXFC/21/, PREDUC/7/, RADFAC/16/, RADIUS/8/,
-C 3 RAD0/9/, RCOND/53/, RELDX/17/, SIZE/55/, STPPAR/5/,
-C 4 TUNER4/29/, TUNER5/30/, WSCALE/56/
-C/7
- PARAMETER (COSMIN=47, DGNORM=1, DSTNRM=2, F=10, FDIF=11, FUZZ=45,
- 1 F0=13, GTSTEP=4, INCFAC=23, LMAX0=35, LMAXS=36,
- 2 NVSAVE=9, PHMXFC=21, PREDUC=7, RADFAC=16, RADIUS=8,
- 3 RAD0=9, RCOND=53, RELDX=17, SIZE=55, STPPAR=5,
- 4 TUNER4=29, TUNER5=30, WSCALE=56)
-C/
-C
-C
-C/6
-C DATA HALF/0.5E+0/, NEGONE/-1.E+0/, ONE/1.E+0/, ONEP2/1.2E+0/,
-C 1 ZERO/0.E+0/
-C/7
- PARAMETER (HALF=0.5E+0, NEGONE=-1.E+0, ONE=1.E+0, ONEP2=1.2E+0,
- 1 ZERO=0.E+0)
-C/
-C
-C+++++++++++++++++++++++++++++++ BODY ++++++++++++++++++++++++++++++++
-C
- I = IV(1)
- IF (I .EQ. 1) GO TO 40
- IF (I .EQ. 2) GO TO 50
-C
- IF (I .EQ. 12 .OR. I .EQ. 13)
- 1 IV(VNEED) = IV(VNEED) + P*(3*P + 19)/2 + 7
- CALL PARCK(1, D, IV, LIV, LV, P, V)
- I = IV(1) - 2
- IF (I .GT. 12) GO TO 999
- GO TO (290, 290, 290, 290, 290, 290, 170, 120, 170, 10, 10, 20), I
-C
-C *** STORAGE ALLOCATION ***
-C
- 10 PP1O2 = P * (P + 1) / 2
- IV(S) = IV(LMAT) + PP1O2
- IV(X0) = IV(S) + PP1O2
- IV(STEP) = IV(X0) + P
- IV(STLSTG) = IV(STEP) + P
- IV(DIG) = IV(STLSTG) + P
- IV(W) = IV(DIG) + P
- IV(H) = IV(W) + 4*P + 7
- IV(NEXTV) = IV(H) + PP1O2
- IF (IV(1) .NE. 13) GO TO 20
- IV(1) = 14
- GO TO 999
-C
-C *** INITIALIZATION ***
-C
- 20 IV(NITER) = 0
- IV(NFCALL) = 1
- IV(NGCALL) = 1
- IV(NFGCAL) = 1
- IV(MODE) = -1
- IV(STGLIM) = 2
- IV(TOOBIG) = 0
- IV(CNVCOD) = 0
- IV(COVMAT) = 0
- IV(NFCOV) = 0
- IV(NGCOV) = 0
- IV(RADINC) = 0
- IV(RESTOR) = 0
- IV(FDH) = 0
- V(RAD0) = ZERO
- V(STPPAR) = ZERO
- V(RADIUS) = V(LMAX0) / (ONE + V(PHMXFC))
-C
-C *** SET INITIAL MODEL AND S MATRIX ***
-C
- IV(MODEL) = 1
- IF (IV(S) .LT. 0) GO TO 999
- IF (IV(INITS) .GT. 1) IV(MODEL) = 2
- S1 = IV(S)
- IF (IV(INITS) .EQ. 0 .OR. IV(INITS) .GT. 2)
- 1 CALL V7SCP(P*(P+1)/2, V(S1), ZERO)
- IV(1) = 1
- J = IV(IPIVOT)
- IF (J .LE. 0) GO TO 999
- DO 30 I = 1, P
- IV(J) = I
- J = J + 1
- 30 CONTINUE
- GO TO 999
-C
-C *** NEW FUNCTION VALUE ***
-C
- 40 IF (IV(MODE) .EQ. 0) GO TO 290
- IF (IV(MODE) .GT. 0) GO TO 520
-C
- IV(1) = 2
- IF (IV(TOOBIG) .EQ. 0) GO TO 999
- IV(1) = 63
- GO TO 999
-C
-C *** NEW GRADIENT ***
-C
- 50 IV(KALM) = -1
- IV(KAGQT) = -1
- IV(FDH) = 0
- IF (IV(MODE) .GT. 0) GO TO 520
-C
-C *** MAKE SURE GRADIENT COULD BE COMPUTED ***
-C
- IF (IV(TOOBIG) .EQ. 0) GO TO 60
- IV(1) = 65
- GO TO 999
- 60 IF (IV(HC) .LE. 0 .AND. IV(RMAT) .LE. 0) GO TO 610
-C
-C *** COMPUTE D**-1 * GRADIENT ***
-C
- DIG1 = IV(DIG)
- K = DIG1
- DO 70 I = 1, P
- V(K) = G(I) / D(I)
- K = K + 1
- 70 CONTINUE
- V(DGNORM) = V2NRM(P, V(DIG1))
-C
- IF (IV(CNVCOD) .NE. 0) GO TO 510
- IF (IV(MODE) .EQ. 0) GO TO 440
- IV(MODE) = 0
- V(F0) = V(F)
- IF (IV(INITS) .LE. 2) GO TO 100
-C
-C *** ARRANGE FOR FINITE-DIFFERENCE INITIAL S ***
-C
- IV(XIRC) = IV(COVREQ)
- IV(COVREQ) = -1
- IF (IV(INITS) .GT. 3) IV(COVREQ) = 1
- IV(CNVCOD) = 70
- GO TO 530
-C
-C *** COME TO NEXT STMT AFTER COMPUTING F.D. HESSIAN FOR INIT. S ***
-C
- 80 IV(CNVCOD) = 0
- IV(MODE) = 0
- IV(NFCOV) = 0
- IV(NGCOV) = 0
- IV(COVREQ) = IV(XIRC)
- S1 = IV(S)
- PP1O2 = PS * (PS + 1) / 2
- HC1 = IV(HC)
- IF (HC1 .LE. 0) GO TO 90
- CALL V2AXY(PP1O2, V(S1), NEGONE, V(HC1), V(H1))
- GO TO 100
- 90 RMAT1 = IV(RMAT)
- CALL L7SQR(PS, V(S1), V(RMAT1))
- CALL V2AXY(PP1O2, V(S1), NEGONE, V(S1), V(H1))
- 100 IV(1) = 2
-C
-C
-C----------------------------- MAIN LOOP -----------------------------
-C
-C
-C *** PRINT ITERATION SUMMARY, CHECK ITERATION LIMIT ***
-C
- 110 CALL ITSUM(D, G, IV, LIV, LV, P, V, X)
- 120 K = IV(NITER)
- IF (K .LT. IV(MXITER)) GO TO 130
- IV(1) = 10
- GO TO 999
- 130 IV(NITER) = K + 1
-C
-C *** UPDATE RADIUS ***
-C
- IF (K .EQ. 0) GO TO 150
- STEP1 = IV(STEP)
- DO 140 I = 1, P
- V(STEP1) = D(I) * V(STEP1)
- STEP1 = STEP1 + 1
- 140 CONTINUE
- STEP1 = IV(STEP)
- T = V(RADFAC) * V2NRM(P, V(STEP1))
- IF (V(RADFAC) .LT. ONE .OR. T .GT. V(RADIUS)) V(RADIUS) = T
-C
-C *** INITIALIZE FOR START OF NEXT ITERATION ***
-C
- 150 X01 = IV(X0)
- V(F0) = V(F)
- IV(IRC) = 4
- IV(H) = -IABS(IV(H))
- IV(SUSED) = IV(MODEL)
-C
-C *** COPY X TO X0 ***
-C
- CALL V7CPY(P, V(X01), X)
-C
-C *** CHECK STOPX AND FUNCTION EVALUATION LIMIT ***
-C
- 160 IF (.NOT. STOPX(DUMMY)) GO TO 180
- IV(1) = 11
- GO TO 190
-C
-C *** COME HERE WHEN RESTARTING AFTER FUNC. EVAL. LIMIT OR STOPX.
-C
- 170 IF (V(F) .GE. V(F0)) GO TO 180
- V(RADFAC) = ONE
- K = IV(NITER)
- GO TO 130
-C
- 180 IF (IV(NFCALL) .LT. IV(MXFCAL) + IV(NFCOV)) GO TO 200
- IV(1) = 9
- 190 IF (V(F) .GE. V(F0)) GO TO 999
-C
-C *** IN CASE OF STOPX OR FUNCTION EVALUATION LIMIT WITH
-C *** IMPROVED V(F), EVALUATE THE GRADIENT AT X.
-C
- IV(CNVCOD) = IV(1)
- GO TO 430
-C
-C. . . . . . . . . . . . . COMPUTE CANDIDATE STEP . . . . . . . . . .
-C
- 200 STEP1 = IV(STEP)
- W1 = IV(W)
- H1 = IV(H)
- T1 = ONE
- IF (IV(MODEL) .EQ. 2) GO TO 210
- T1 = ZERO
-C
-C *** COMPUTE LEVENBERG-MARQUARDT STEP IF POSSIBLE...
-C
- RMAT1 = IV(RMAT)
- IF (RMAT1 .LE. 0) GO TO 210
- QTR1 = IV(QTR)
- IF (QTR1 .LE. 0) GO TO 210
- IPIV1 = IV(IPIVOT)
- CALL L7MST(D, G, IV(IERR), IV(IPIV1), IV(KALM), P, V(QTR1),
- 1 V(RMAT1), V(STEP1), V, V(W1))
-C *** H IS STORED IN THE END OF W AND HAS JUST BEEN OVERWRITTEN,
-C *** SO WE MARK IT INVALID...
- IV(H) = -IABS(H1)
-C *** EVEN IF H WERE STORED ELSEWHERE, IT WOULD BE NECESSARY TO
-C *** MARK INVALID THE INFORMATION G7QTS MAY HAVE STORED IN V...
- IV(KAGQT) = -1
- GO TO 260
-C
- 210 IF (H1 .GT. 0) GO TO 250
-C
-C *** SET H TO D**-1 * (HC + T1*S) * D**-1. ***
-C
- H1 = -H1
- IV(H) = H1
- IV(FDH) = 0
- J = IV(HC)
- IF (J .GT. 0) GO TO 220
- J = H1
- RMAT1 = IV(RMAT)
- CALL L7SQR(P, V(H1), V(RMAT1))
- 220 S1 = IV(S)
- DO 240 I = 1, P
- T = ONE / D(I)
- DO 230 K = 1, I
- V(H1) = T * (V(J) + T1*V(S1)) / D(K)
- J = J + 1
- H1 = H1 + 1
- S1 = S1 + 1
- 230 CONTINUE
- 240 CONTINUE
- H1 = IV(H)
- IV(KAGQT) = -1
-C
-C *** COMPUTE ACTUAL GOLDFELD-QUANDT-TROTTER STEP ***
-C
- 250 DIG1 = IV(DIG)
- LMAT1 = IV(LMAT)
- CALL G7QTS(D, V(DIG1), V(H1), IV(KAGQT), V(LMAT1), P, V(STEP1),
- 1 V, V(W1))
- IF (IV(KALM) .GT. 0) IV(KALM) = 0
-C
- 260 IF (IV(IRC) .NE. 6) GO TO 270
- IF (IV(RESTOR) .NE. 2) GO TO 290
- RSTRST = 2
- GO TO 300
-C
-C *** CHECK WHETHER EVALUATING F(X0 + STEP) LOOKS WORTHWHILE ***
-C
- 270 IV(TOOBIG) = 0
- IF (V(DSTNRM) .LE. ZERO) GO TO 290
- IF (IV(IRC) .NE. 5) GO TO 280
- IF (V(RADFAC) .LE. ONE) GO TO 280
- IF (V(PREDUC) .GT. ONEP2 * V(FDIF)) GO TO 280
- STEP1 = IV(STEP)
- X01 = IV(X0)
- CALL V2AXY(P, V(STEP1), NEGONE, V(X01), X)
- IF (IV(RESTOR) .NE. 2) GO TO 290
- RSTRST = 0
- GO TO 300
-C
-C *** COMPUTE F(X0 + STEP) ***
-C
- 280 X01 = IV(X0)
- STEP1 = IV(STEP)
- CALL V2AXY(P, X, ONE, V(STEP1), V(X01))
- IV(NFCALL) = IV(NFCALL) + 1
- IV(1) = 1
- GO TO 999
-C
-C. . . . . . . . . . . . . ASSESS CANDIDATE STEP . . . . . . . . . . .
-C
- 290 RSTRST = 3
- 300 X01 = IV(X0)
- V(RELDX) = RLDST(P, D, X, V(X01))
- CALL A7SST(IV, LIV, LV, V)
- STEP1 = IV(STEP)
- LSTGST = IV(STLSTG)
- I = IV(RESTOR) + 1
- GO TO (340, 310, 320, 330), I
- 310 CALL V7CPY(P, X, V(X01))
- GO TO 340
- 320 CALL V7CPY(P, V(LSTGST), V(STEP1))
- GO TO 340
- 330 CALL V7CPY(P, V(STEP1), V(LSTGST))
- CALL V2AXY(P, X, ONE, V(STEP1), V(X01))
- V(RELDX) = RLDST(P, D, X, V(X01))
- IV(RESTOR) = RSTRST
-C
-C *** IF NECESSARY, SWITCH MODELS ***
-C
- 340 IF (IV(SWITCH) .EQ. 0) GO TO 350
- IV(H) = -IABS(IV(H))
- IV(SUSED) = IV(SUSED) + 2
- L = IV(VSAVE)
- CALL V7CPY(NVSAVE, V, V(L))
- 350 L = IV(IRC) - 4
- STPMOD = IV(MODEL)
- IF (L .GT. 0) GO TO (370,380,390,390,390,390,390,390,500,440), L
-C
-C *** DECIDE WHETHER TO CHANGE MODELS ***
-C
- E = V(PREDUC) - V(FDIF)
- S1 = IV(S)
- CALL S7LVM(PS, Y, V(S1), V(STEP1))
- STTSST = HALF * D7TPR(PS, V(STEP1), Y)
- IF (IV(MODEL) .EQ. 1) STTSST = -STTSST
- IF ( ABS(E + STTSST) * V(FUZZ) .GE. ABS(E)) GO TO 360
-C
-C *** SWITCH MODELS ***
-C
- IV(MODEL) = 3 - IV(MODEL)
- IF (-2 .LT. L) GO TO 400
- IV(H) = -IABS(IV(H))
- IV(SUSED) = IV(SUSED) + 2
- L = IV(VSAVE)
- CALL V7CPY(NVSAVE, V(L), V)
- GO TO 160
-C
- 360 IF (-3 .LT. L) GO TO 400
-C
-C *** RECOMPUTE STEP WITH NEW RADIUS ***
-C
- 370 V(RADIUS) = V(RADFAC) * V(DSTNRM)
- GO TO 160
-C
-C *** COMPUTE STEP OF LENGTH V(LMAXS) FOR SINGULAR CONVERGENCE TEST
-C
- 380 V(RADIUS) = V(LMAXS)
- GO TO 200
-C
-C *** CONVERGENCE OR FALSE CONVERGENCE ***
-C
- 390 IV(CNVCOD) = L
- IF (V(F) .GE. V(F0)) GO TO 510
- IF (IV(XIRC) .EQ. 14) GO TO 510
- IV(XIRC) = 14
-C
-C. . . . . . . . . . . . PROCESS ACCEPTABLE STEP . . . . . . . . . . .
-C
- 400 IV(COVMAT) = 0
- IV(REGD) = 0
-C
-C *** SEE WHETHER TO SET V(RADFAC) BY GRADIENT TESTS ***
-C
- IF (IV(IRC) .NE. 3) GO TO 430
- STEP1 = IV(STEP)
- TEMP1 = IV(STLSTG)
- TEMP2 = IV(W)
-C
-C *** SET TEMP1 = HESSIAN * STEP FOR _USE_ IN GRADIENT TESTS ***
-C
- HC1 = IV(HC)
- IF (HC1 .LE. 0) GO TO 410
- CALL S7LVM(P, V(TEMP1), V(HC1), V(STEP1))
- GO TO 420
- 410 RMAT1 = IV(RMAT)
- CALL L7TVM(P, V(TEMP1), V(RMAT1), V(STEP1))
- CALL L7VML(P, V(TEMP1), V(RMAT1), V(TEMP1))
-C
- 420 IF (STPMOD .EQ. 1) GO TO 430
- S1 = IV(S)
- CALL S7LVM(PS, V(TEMP2), V(S1), V(STEP1))
- CALL V2AXY(PS, V(TEMP1), ONE, V(TEMP2), V(TEMP1))
-C
-C *** SAVE OLD GRADIENT AND COMPUTE NEW ONE ***
-C
- 430 IV(NGCALL) = IV(NGCALL) + 1
- G01 = IV(W)
- CALL V7CPY(P, V(G01), G)
- IV(1) = 2
- IV(TOOBIG) = 0
- GO TO 999
-C
-C *** INITIALIZATIONS -- G0 = G - G0, ETC. ***
-C
- 440 G01 = IV(W)
- CALL V2AXY(P, V(G01), NEGONE, V(G01), G)
- STEP1 = IV(STEP)
- TEMP1 = IV(STLSTG)
- TEMP2 = IV(W)
- IF (IV(IRC) .NE. 3) GO TO 470
-C
-C *** SET V(RADFAC) BY GRADIENT TESTS ***
-C
-C *** SET TEMP1 = D**-1 * (HESSIAN * STEP + (G(X0) - G(X))) ***
-C
- K = TEMP1
- L = G01
- DO 450 I = 1, P
- V(K) = (V(K) - V(L)) / D(I)
- K = K + 1
- L = L + 1
- 450 CONTINUE
-C
-C *** DO GRADIENT TESTS ***
-C
- IF ( V2NRM(P, V(TEMP1)) .LE. V(DGNORM) * V(TUNER4)) GO TO 460
- IF ( D7TPR(P, G, V(STEP1))
- 1 .GE. V(GTSTEP) * V(TUNER5)) GO TO 470
- 460 V(RADFAC) = V(INCFAC)
-C
-C *** COMPUTE Y VECTOR NEEDED FOR UPDATING S ***
-C
- 470 CALL V2AXY(PS, Y, NEGONE, Y, G)
-C
-C *** DETERMINE SIZING FACTOR V(SIZE) ***
-C
-C *** SET TEMP1 = S * STEP ***
- S1 = IV(S)
- CALL S7LVM(PS, V(TEMP1), V(S1), V(STEP1))
-C
- T1 = ABS( D7TPR(PS, V(STEP1), V(TEMP1)))
- T = ABS( D7TPR(PS, V(STEP1), Y))
- V(SIZE) = ONE
- IF (T .LT. T1) V(SIZE) = T / T1
-C
-C *** SET G0 TO WCHMTD CHOICE OF FLETCHER AND AL-BAALI ***
-C
- HC1 = IV(HC)
- IF (HC1 .LE. 0) GO TO 480
- CALL S7LVM(PS, V(G01), V(HC1), V(STEP1))
- GO TO 490
-C
- 480 RMAT1 = IV(RMAT)
- CALL L7TVM(PS, V(G01), V(RMAT1), V(STEP1))
- CALL L7VML(PS, V(G01), V(RMAT1), V(G01))
-C
- 490 CALL V2AXY(PS, V(G01), ONE, Y, V(G01))
-C
-C *** UPDATE S ***
-C
- CALL S7LUP(V(S1), V(COSMIN), PS, V(SIZE), V(STEP1), V(TEMP1),
- 1 V(TEMP2), V(G01), V(WSCALE), Y)
- IV(1) = 2
- GO TO 110
-C
-C. . . . . . . . . . . . . . MISC. DETAILS . . . . . . . . . . . . . .
-C
-C *** BAD PARAMETERS TO ASSESS ***
-C
- 500 IV(1) = 64
- GO TO 999
-C
-C
-C *** CONVERGENCE OBTAINED -- SEE WHETHER TO COMPUTE COVARIANCE ***
-C
- 510 IF (IV(RDREQ) .EQ. 0) GO TO 600
- IF (IV(FDH) .NE. 0) GO TO 600
- IF (IV(CNVCOD) .GE. 7) GO TO 600
- IF (IV(REGD) .GT. 0) GO TO 600
- IF (IV(COVMAT) .GT. 0) GO TO 600
- IF (IABS(IV(COVREQ)) .GE. 3) GO TO 560
- IF (IV(RESTOR) .EQ. 0) IV(RESTOR) = 2
- GO TO 530
-C
-C *** COMPUTE FINITE-DIFFERENCE HESSIAN FOR COMPUTING COVARIANCE ***
-C
- 520 IV(RESTOR) = 0
- 530 CALL F7HES(D, G, I, IV, LIV, LV, P, V, X)
- GO TO (540, 550, 580), I
- 540 IV(NFCOV) = IV(NFCOV) + 1
- IV(NFCALL) = IV(NFCALL) + 1
- IV(1) = 1
- GO TO 999
-C
- 550 IV(NGCOV) = IV(NGCOV) + 1
- IV(NGCALL) = IV(NGCALL) + 1
- IV(NFGCAL) = IV(NFCALL) + IV(NGCOV)
- IV(1) = 2
- GO TO 999
-C
- 560 H1 = IABS(IV(H))
- IV(H) = -H1
- PP1O2 = P * (P + 1) / 2
- RMAT1 = IV(RMAT)
- IF (RMAT1 .LE. 0) GO TO 570
- LMAT1 = IV(LMAT)
- CALL V7CPY(PP1O2, V(LMAT1), V(RMAT1))
- V(RCOND) = ZERO
- GO TO 590
- 570 HC1 = IV(HC)
- IV(FDH) = H1
- CALL V7CPY(P*(P+1)/2, V(H1), V(HC1))
-C
-C *** COMPUTE CHOLESKY FACTOR OF FINITE-DIFFERENCE HESSIAN
-C *** FOR _USE_ IN CALLER*S COVARIANCE CALCULATION...
-C
- 580 LMAT1 = IV(LMAT)
- H1 = IV(FDH)
- IF (H1 .LE. 0) GO TO 600
- IF (IV(CNVCOD) .EQ. 70) GO TO 80
- CALL L7SRT(1, P, V(LMAT1), V(H1), I)
- IV(FDH) = -1
- V(RCOND) = ZERO
- IF (I .NE. 0) GO TO 600
-C
- 590 IV(FDH) = -1
- STEP1 = IV(STEP)
- T = L7SVN(P, V(LMAT1), V(STEP1), V(STEP1))
- IF (T .LE. ZERO) GO TO 600
- T = T / L7SVX(P, V(LMAT1), V(STEP1), V(STEP1))
- IF (T .GT. R7MDC(4)) IV(FDH) = H1
- V(RCOND) = T
-C
- 600 IV(MODE) = 0
- IV(1) = IV(CNVCOD)
- IV(CNVCOD) = 0
- GO TO 999
-C
-C *** SPECIAL RETURN FOR MISSING HESSIAN INFORMATION -- BOTH
-C *** IV(HC) .LE. 0 AND IV(RMAT) .LE. 0
-C
- 610 IV(1) = 1400
-C
- 999 RETURN
-C
-C *** LAST LINE OF G7LIT FOLLOWS ***
- END
diff --git a/CEP/PyBDSM/src/port3/g7qsb.f b/CEP/PyBDSM/src/port3/g7qsb.f
deleted file mode 100644
index 24db0faa0fd58f1f4728706182de541fb0d2795f..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/g7qsb.f
+++ /dev/null
@@ -1,88 +0,0 @@
- SUBROUTINE G7QSB(B, D, DIHDI, G, IPIV, IPIV1, IPIV2, KA, L, LV,
- 1 P, P0, PC, STEP, TD, TG, V, W, X, X0)
-C
-C *** COMPUTE HEURISTIC BOUNDED NEWTON STEP ***
-C
- INTEGER KA, LV, P, P0, PC
- INTEGER IPIV(P), IPIV1(P), IPIV2(P)
- REAL B(2,P), D(P), DIHDI(1), G(P), L(1),
- 1 STEP(P,2), TD(P), TG(P), V(LV), W(P), X0(P), X(P)
-C DIMENSION DIHDI(P*(P+1)/2), L(P*(P+1)/2)
-C
- REAL D7TPR
- EXTERNAL D7TPR, G7QTS, S7BQN, S7IPR, V7CPY, V7IPR,
- 1 V7SCP, V7VMP
-C
-C *** LOCAL VARIABLES ***
-C
- INTEGER K, KB, KINIT, NS, P1, P10
- REAL DS0, NRED, PRED, RAD
- REAL ZERO
-C
-C *** V SUBSCRIPTS ***
-C
- INTEGER DST0, DSTNRM, GTSTEP, NREDUC, PREDUC, RADIUS
-C
-C/6
-C DATA DST0/3/, DSTNRM/2/, GTSTEP/4/, NREDUC/6/, PREDUC/7/,
-C 1 RADIUS/8/
-C/7
- PARAMETER (DST0=3, DSTNRM=2, GTSTEP=4, NREDUC=6, PREDUC=7,
- 1 RADIUS=8)
-C/
- DATA ZERO/0.E+0/
-C
-C+++++++++++++++++++++++++++++++ BODY ++++++++++++++++++++++++++++++++
-C
- P1 = PC
- IF (KA .LT. 0) GO TO 10
- NRED = V(NREDUC)
- DS0 = V(DST0)
- GO TO 20
- 10 P0 = 0
- KA = -1
-C
- 20 KINIT = -1
- IF (P0 .EQ. P1) KINIT = KA
- CALL V7CPY(P, X, X0)
- PRED = ZERO
- RAD = V(RADIUS)
- KB = -1
- V(DSTNRM) = ZERO
- IF (P1 .GT. 0) GO TO 30
- NRED = ZERO
- DS0 = ZERO
- CALL V7SCP(P, STEP, ZERO)
- GO TO 60
-C
- 30 CALL V7CPY(P, TD, D)
- CALL V7IPR(P, IPIV, TD)
- CALL V7VMP(P, TG, G, D, -1)
- CALL V7IPR(P, IPIV, TG)
- 40 K = KINIT
- KINIT = -1
- V(RADIUS) = RAD - V(DSTNRM)
- CALL G7QTS(TD, TG, DIHDI, K, L, P1, STEP, V, W)
- P0 = P1
- IF (KA .GE. 0) GO TO 50
- NRED = V(NREDUC)
- DS0 = V(DST0)
-C
- 50 KA = K
- V(RADIUS) = RAD
- P10 = P1
- CALL S7BQN(B, D, STEP(1,2), IPIV, IPIV1, IPIV2, KB, L, LV,
- 1 NS, P, P1, STEP, TD, TG, V, W, X, X0)
- IF (NS .GT. 0) CALL S7IPR(P10, IPIV1, DIHDI)
- PRED = PRED + V(PREDUC)
- IF (NS .NE. 0) P0 = 0
- IF (KB .LE. 0) GO TO 40
-C
- 60 V(DST0) = DS0
- V(NREDUC) = NRED
- V(PREDUC) = PRED
- V(GTSTEP) = D7TPR(P, G, STEP)
-C
- 999 RETURN
-C *** LAST LINE OF G7QSB FOLLOWS ***
- END
diff --git a/CEP/PyBDSM/src/port3/g7qts.f b/CEP/PyBDSM/src/port3/g7qts.f
deleted file mode 100644
index 410c204346631cd1263ae0960ede9be3275fb416..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/g7qts.f
+++ /dev/null
@@ -1,644 +0,0 @@
- SUBROUTINE G7QTS(D, DIG, DIHDI, KA, L, P, STEP, V, W)
-C
-C *** COMPUTE GOLDFELD-QUANDT-TROTTER STEP BY MORE-HEBDEN TECHNIQUE ***
-C *** (NL2SOL VERSION 2.2), MODIFIED A LA MORE AND SORENSEN ***
-C
-C *** PARAMETER DECLARATIONS ***
-C
- INTEGER KA, P
- REAL D(P), DIG(P), DIHDI(1), L(1), V(21), STEP(P),
- 1 W(1)
-C DIMENSION DIHDI(P*(P+1)/2), L(P*(P+1)/2), W(4*P+7)
-C
-C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
-C
-C *** PURPOSE ***
-C
-C GIVEN THE (COMPACTLY STORED) LOWER TRIANGLE OF A SCALED
-C HESSIAN (APPROXIMATION) AND A NONZERO SCALED GRADIENT VECTOR,
-C THIS SUBROUTINE COMPUTES A GOLDFELD-QUANDT-TROTTER STEP OF
-C APPROXIMATE LENGTH V(RADIUS) BY THE MORE-HEBDEN TECHNIQUE. IN
-C OTHER WORDS, STEP IS COMPUTED TO (APPROXIMATELY) MINIMIZE
-C PSI(STEP) = (G**T)*STEP + 0.5*(STEP**T)*H*STEP SUCH THAT THE
-C 2-NORM OF D*STEP IS AT MOST (APPROXIMATELY) V(RADIUS), WHERE
-C G IS THE GRADIENT, H IS THE HESSIAN, AND D IS A DIAGONAL
-C SCALE MATRIX WHOSE DIAGONAL IS STORED IN THE PARAMETER D.
-C (G7QTS ASSUMES DIG = D**-1 * G AND DIHDI = D**-1 * H * D**-1.)
-C
-C *** PARAMETER DESCRIPTION ***
-C
-C D (IN) = THE SCALE VECTOR, I.E. THE DIAGONAL OF THE SCALE
-C MATRIX D MENTIONED ABOVE UNDER PURPOSE.
-C DIG (IN) = THE SCALED GRADIENT VECTOR, D**-1 * G. IF G = 0, THEN
-C STEP = 0 AND V(STPPAR) = 0 ARE RETURNED.
-C DIHDI (IN) = LOWER TRIANGLE OF THE SCALED HESSIAN (APPROXIMATION),
-C I.E., D**-1 * H * D**-1, STORED COMPACTLY BY ROWS., I.E.,
-C IN THE ORDER (1,1), (2,1), (2,2), (3,1), (3,2), ETC.
-C KA (I/O) = THE NUMBER OF HEBDEN ITERATIONS (SO FAR) TAKEN TO DETER-
-C MINE STEP. KA .LT. 0 ON INPUT MEANS THIS IS THE FIRST
-C ATTEMPT TO DETERMINE STEP (FOR THE PRESENT DIG AND DIHDI)
-C -- KA IS INITIALIZED TO 0 IN THIS CASE. OUTPUT WITH
-C KA = 0 (OR V(STPPAR) = 0) MEANS STEP = -(H**-1)*G.
-C L (I/O) = WORKSPACE OF LENGTH P*(P+1)/2 FOR CHOLESKY FACTORS.
-C P (IN) = NUMBER OF PARAMETERS -- THE HESSIAN IS A P X P MATRIX.
-C STEP (I/O) = THE STEP COMPUTED.
-C V (I/O) CONTAINS VARIOUS CONSTANTS AND VARIABLES DESCRIBED BELOW.
-C W (I/O) = WORKSPACE OF LENGTH 4*P + 6.
-C
-C *** ENTRIES IN V ***
-C
-C V(DGNORM) (I/O) = 2-NORM OF (D**-1)*G.
-C V(DSTNRM) (OUTPUT) = 2-NORM OF D*STEP.
-C V(DST0) (I/O) = 2-NORM OF D*(H**-1)*G (FOR POS. DEF. H ONLY), OR
-C OVERESTIMATE OF SMALLEST EIGENVALUE OF (D**-1)*H*(D**-1).
-C V(EPSLON) (IN) = MAX. REL. ERROR ALLOWED FOR PSI(STEP). FOR THE
-C STEP RETURNED, PSI(STEP) WILL EXCEED ITS OPTIMAL VALUE
-C BY LESS THAN -V(EPSLON)*PSI(STEP). SUGGESTED VALUE = 0.1.
-C V(GTSTEP) (OUT) = INNER PRODUCT BETWEEN G AND STEP.
-C V(NREDUC) (OUT) = PSI(-(H**-1)*G) = PSI(NEWTON STEP) (FOR POS. DEF.
-C H ONLY -- V(NREDUC) IS SET TO ZERO OTHERWISE).
-C V(PHMNFC) (IN) = TOL. (TOGETHER WITH V(PHMXFC)) FOR ACCEPTING STEP
-C (MORE*S SIGMA). THE ERROR V(DSTNRM) - V(RADIUS) MUST LIE
-C BETWEEN V(PHMNFC)*V(RADIUS) AND V(PHMXFC)*V(RADIUS).
-C V(PHMXFC) (IN) (SEE V(PHMNFC).)
-C SUGGESTED VALUES -- V(PHMNFC) = -0.25, V(PHMXFC) = 0.5.
-C V(PREDUC) (OUT) = PSI(STEP) = PREDICTED OBJ. FUNC. REDUCTION FOR STEP.
-C V(RADIUS) (IN) = RADIUS OF CURRENT (SCALED) TRUST REGION.
-C V(RAD0) (I/O) = VALUE OF V(RADIUS) FROM PREVIOUS CALL.
-C V(STPPAR) (I/O) IS NORMALLY THE MARQUARDT PARAMETER, I.E. THE ALPHA
-C DESCRIBED BELOW UNDER ALGORITHM NOTES. IF H + ALPHA*D**2
-C (SEE ALGORITHM NOTES) IS (NEARLY) SINGULAR, HOWEVER,
-C THEN V(STPPAR) = -ALPHA.
-C
-C *** USAGE NOTES ***
-C
-C IF IT IS DESIRED TO RECOMPUTE STEP USING A DIFFERENT VALUE OF
-C V(RADIUS), THEN THIS ROUTINE MAY BE RESTARTED BY CALLING IT
-C WITH ALL PARAMETERS UNCHANGED EXCEPT V(RADIUS). (THIS EXPLAINS
-C WHY STEP AND W ARE LISTED AS I/O). ON AN INITIAL CALL (ONE WITH
-C KA .LT. 0), STEP AND W NEED NOT BE INITIALIZED AND ONLY COMPO-
-C NENTS V(EPSLON), V(STPPAR), V(PHMNFC), V(PHMXFC), V(RADIUS), AND
-C V(RAD0) OF V MUST BE INITIALIZED.
-C
-C *** ALGORITHM NOTES ***
-C
-C THE DESIRED G-Q-T STEP (REF. 2, 3, 4, 6) SATISFIES
-C (H + ALPHA*D**2)*STEP = -G FOR SOME NONNEGATIVE ALPHA SUCH THAT
-C H + ALPHA*D**2 IS POSITIVE SEMIDEFINITE. ALPHA AND STEP ARE
-C COMPUTED BY A SCHEME ANALOGOUS TO THE ONE DESCRIBED IN REF. 5.
-C ESTIMATES OF THE SMALLEST AND LARGEST EIGENVALUES OF THE HESSIAN
-C ARE OBTAINED FROM THE GERSCHGORIN CIRCLE THEOREM ENHANCED BY A
-C SIMPLE FORM OF THE SCALING DESCRIBED IN REF. 7. CASES IN WHICH
-C H + ALPHA*D**2 IS NEARLY (OR EXACTLY) SINGULAR ARE HANDLED BY
-C THE TECHNIQUE DISCUSSED IN REF. 2. IN THESE CASES, A STEP OF
-C (EXACT) LENGTH V(RADIUS) IS RETURNED FOR WHICH PSI(STEP) EXCEEDS
-C ITS OPTIMAL VALUE BY LESS THAN -V(EPSLON)*PSI(STEP). THE TEST
-C SUGGESTED IN REF. 6 FOR DETECTING THE SPECIAL CASE IS PERFORMED
-C ONCE TWO MATRIX FACTORIZATIONS HAVE BEEN DONE -- DOING SO SOONER
-C SEEMS TO DEGRADE THE PERFORMANCE OF OPTIMIZATION ROUTINES THAT
-C CALL THIS ROUTINE.
-C
-C *** FUNCTIONS AND SUBROUTINES CALLED ***
-C
-C D7TPR - RETURNS INNER PRODUCT OF TWO VECTORS.
-C L7ITV - APPLIES INVERSE-TRANSPOSE OF COMPACT LOWER TRIANG. MATRIX.
-C L7IVM - APPLIES INVERSE OF COMPACT LOWER TRIANG. MATRIX.
-C L7SRT - FINDS CHOLESKY FACTOR (OF COMPACTLY STORED LOWER TRIANG.).
-C L7SVN - RETURNS APPROX. TO MIN. SING. VALUE OF LOWER TRIANG. MATRIX.
-C R7MDC - RETURNS MACHINE-DEPENDENT CONSTANTS.
-C V2NRM - RETURNS 2-NORM OF A VECTOR.
-C
-C *** REFERENCES ***
-C
-C 1. DENNIS, J.E., GAY, D.M., AND WELSCH, R.E. (1981), AN ADAPTIVE
-C NONLINEAR LEAST-SQUARES ALGORITHM, ACM TRANS. MATH.
-C SOFTWARE, VOL. 7, NO. 3.
-C 2. GAY, D.M. (1981), COMPUTING OPTIMAL LOCALLY CONSTRAINED STEPS,
-C SIAM J. SCI. STATIST. COMPUTING, VOL. 2, NO. 2, PP.
-C 186-197.
-C 3. GOLDFELD, S.M., QUANDT, R.E., AND TROTTER, H.F. (1966),
-C MAXIMIZATION BY QUADRATIC HILL-CLIMBING, ECONOMETRICA 34,
-C PP. 541-551.
-C 4. HEBDEN, M.D. (1973), AN ALGORITHM FOR MINIMIZATION USING EXACT
-C SECOND DERIVATIVES, REPORT T.P. 515, THEORETICAL PHYSICS
-C DIV., A.E.R.E. HARWELL, OXON., ENGLAND.
-C 5. MORE, J.J. (1978), THE LEVENBERG-MARQUARDT ALGORITHM, IMPLEMEN-
-C TATION AND THEORY, PP.105-116 OF SPRINGER LECTURE NOTES
-C IN MATHEMATICS NO. 630, EDITED BY G.A. WATSON, SPRINGER-
-C VERLAG, BERLIN AND NEW YORK.
-C 6. MORE, J.J., AND SORENSEN, D.C. (1981), COMPUTING A TRUST REGION
-C STEP, TECHNICAL REPORT ANL-81-83, ARGONNE NATIONAL LAB.
-C 7. VARGA, R.S. (1965), MINIMAL GERSCHGORIN SETS, PACIFIC J. MATH. 15,
-C PP. 719-729.
-C
-C *** GENERAL ***
-C
-C CODED BY DAVID M. GAY.
-C THIS SUBROUTINE WAS WRITTEN IN CONNECTION WITH RESEARCH
-C SUPPORTED BY THE NATIONAL SCIENCE FOUNDATION UNDER GRANTS
-C MCS-7600324, DCR75-10143, 76-14311DSS, MCS76-11989, AND
-C MCS-7906671.
-C
-C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
-C
-C *** LOCAL VARIABLES ***
-C
- LOGICAL RESTRT
- INTEGER DGGDMX, DIAG, DIAG0, DSTSAV, EMAX, EMIN, I, IM1, INC, IRC,
- 1 J, K, KALIM, KAMIN, K1, LK0, PHIPIN, Q, Q0, UK0, X
- REAL ALPHAK, AKI, AKK, DELTA, DST, EPS, GTSTA, LK,
- 1 OLDPHI, PHI, PHIMAX, PHIMIN, PSIFAC, RAD, RADSQ,
- 2 ROOT, SI, SK, SW, T, TWOPSI, T1, T2, UK, WI
-C
-C *** CONSTANTS ***
- REAL BIG, DGXFAC, EPSFAC, FOUR, HALF, KAPPA, NEGONE,
- 1 ONE, P001, SIX, THREE, TWO, ZERO
-C
-C *** INTRINSIC FUNCTIONS ***
-C/+
- REAL SQRT
-C/
-C *** EXTERNAL FUNCTIONS AND SUBROUTINES ***
-C
- REAL D7TPR, L7SVN, R7MDC, V2NRM
- EXTERNAL D7TPR, L7ITV, L7IVM, L7SRT, L7SVN, R7MDC, V2NRM
-C
-C *** SUBSCRIPTS FOR V ***
-C
- INTEGER DGNORM, DSTNRM, DST0, EPSLON, GTSTEP, STPPAR, NREDUC,
- 1 PHMNFC, PHMXFC, PREDUC, RADIUS, RAD0
-C/6
-C DATA DGNORM/1/, DSTNRM/2/, DST0/3/, EPSLON/19/, GTSTEP/4/,
-C 1 NREDUC/6/, PHMNFC/20/, PHMXFC/21/, PREDUC/7/, RADIUS/8/,
-C 2 RAD0/9/, STPPAR/5/
-C/7
- PARAMETER (DGNORM=1, DSTNRM=2, DST0=3, EPSLON=19, GTSTEP=4,
- 1 NREDUC=6, PHMNFC=20, PHMXFC=21, PREDUC=7, RADIUS=8,
- 2 RAD0=9, STPPAR=5)
-C/
-C
-C/6
-C DATA EPSFAC/50.0E+0/, FOUR/4.0E+0/, HALF/0.5E+0/,
-C 1 KAPPA/2.0E+0/, NEGONE/-1.0E+0/, ONE/1.0E+0/, P001/1.0E-3/,
-C 2 SIX/6.0E+0/, THREE/3.0E+0/, TWO/2.0E+0/, ZERO/0.0E+0/
-C/7
- PARAMETER (EPSFAC=50.0E+0, FOUR=4.0E+0, HALF=0.5E+0,
- 1 KAPPA=2.0E+0, NEGONE=-1.0E+0, ONE=1.0E+0, P001=1.0E-3,
- 2 SIX=6.0E+0, THREE=3.0E+0, TWO=2.0E+0, ZERO=0.0E+0)
- SAVE DGXFAC
-C/
- DATA BIG/0.E+0/, DGXFAC/0.E+0/
-C
-C *** BODY ***
-C
- IF (BIG .LE. ZERO) BIG = R7MDC(6)
-C
-C *** STORE LARGEST ABS. ENTRY IN (D**-1)*H*(D**-1) AT W(DGGDMX).
- DGGDMX = P + 1
-C *** STORE GERSCHGORIN OVER- AND UNDERESTIMATES OF THE LARGEST
-C *** AND SMALLEST EIGENVALUES OF (D**-1)*H*(D**-1) AT W(EMAX)
-C *** AND W(EMIN) RESPECTIVELY.
- EMAX = DGGDMX + 1
- EMIN = EMAX + 1
-C *** FOR _USE_ IN RECOMPUTING STEP, THE FINAL VALUES OF LK, UK, DST,
-C *** AND THE INVERSE DERIVATIVE OF MORE*S PHI AT 0 (FOR POS. DEF.
-C *** H) ARE STORED IN W(LK0), W(UK0), W(DSTSAV), AND W(PHIPIN)
-C *** RESPECTIVELY.
- LK0 = EMIN + 1
- PHIPIN = LK0 + 1
- UK0 = PHIPIN + 1
- DSTSAV = UK0 + 1
-C *** STORE DIAG OF (D**-1)*H*(D**-1) IN W(DIAG),...,W(DIAG0+P).
- DIAG0 = DSTSAV
- DIAG = DIAG0 + 1
-C *** STORE -D*STEP IN W(Q),...,W(Q0+P).
- Q0 = DIAG0 + P
- Q = Q0 + 1
-C *** ALLOCATE STORAGE FOR SCRATCH VECTOR X ***
- X = Q + P
- RAD = V(RADIUS)
- RADSQ = RAD**2
-C *** PHITOL = MAX. ERROR ALLOWED IN DST = V(DSTNRM) = 2-NORM OF
-C *** D*STEP.
- PHIMAX = V(PHMXFC) * RAD
- PHIMIN = V(PHMNFC) * RAD
- PSIFAC = BIG
- T1 = TWO * V(EPSLON) / (THREE * (FOUR * (V(PHMNFC) + ONE) *
- 1 (KAPPA + ONE) + KAPPA + TWO) * RAD)
- IF (T1 .LT. BIG*AMIN1(RAD,ONE)) PSIFAC = T1 / RAD
-C *** OLDPHI IS USED TO DETECT LIMITS OF NUMERICAL ACCURACY. IF
-C *** WE RECOMPUTE STEP AND IT DOES NOT CHANGE, THEN WE ACCEPT IT.
- OLDPHI = ZERO
- EPS = V(EPSLON)
- IRC = 0
- RESTRT = .FALSE.
- KALIM = KA + 50
-C
-C *** START OR RESTART, DEPENDING ON KA ***
-C
- IF (KA .GE. 0) GO TO 290
-C
-C *** FRESH START ***
-C
- K = 0
- UK = NEGONE
- KA = 0
- KALIM = 50
- V(DGNORM) = V2NRM(P, DIG)
- V(NREDUC) = ZERO
- V(DST0) = ZERO
- KAMIN = 3
- IF (V(DGNORM) .EQ. ZERO) KAMIN = 0
-C
-C *** STORE DIAG(DIHDI) IN W(DIAG0+1),...,W(DIAG0+P) ***
-C
- J = 0
- DO 10 I = 1, P
- J = J + I
- K1 = DIAG0 + I
- W(K1) = DIHDI(J)
- 10 CONTINUE
-C
-C *** DETERMINE W(DGGDMX), THE LARGEST ELEMENT OF DIHDI ***
-C
- T1 = ZERO
- J = P * (P + 1) / 2
- DO 20 I = 1, J
- T = ABS(DIHDI(I))
- IF (T1 .LT. T) T1 = T
- 20 CONTINUE
- W(DGGDMX) = T1
-C
-C *** TRY ALPHA = 0 ***
-C
- 30 CALL L7SRT(1, P, L, DIHDI, IRC)
- IF (IRC .EQ. 0) GO TO 50
-C *** INDEF. H -- UNDERESTIMATE SMALLEST EIGENVALUE, _USE_ THIS
-C *** ESTIMATE TO INITIALIZE LOWER BOUND LK ON ALPHA.
- J = IRC*(IRC+1)/2
- T = L(J)
- L(J) = ONE
- DO 40 I = 1, IRC
- 40 W(I) = ZERO
- W(IRC) = ONE
- CALL L7ITV(IRC, W, L, W)
- T1 = V2NRM(IRC, W)
- LK = -T / T1 / T1
- V(DST0) = -LK
- IF (RESTRT) GO TO 210
- GO TO 70
-C
-C *** POSITIVE DEFINITE H -- COMPUTE UNMODIFIED NEWTON STEP. ***
- 50 LK = ZERO
- T = L7SVN(P, L, W(Q), W(Q))
- IF (T .GE. ONE) GO TO 60
- IF (V(DGNORM) .GE. T*T*BIG) GO TO 70
- 60 CALL L7IVM(P, W(Q), L, DIG)
- GTSTA = D7TPR(P, W(Q), W(Q))
- V(NREDUC) = HALF * GTSTA
- CALL L7ITV(P, W(Q), L, W(Q))
- DST = V2NRM(P, W(Q))
- V(DST0) = DST
- PHI = DST - RAD
- IF (PHI .LE. PHIMAX) GO TO 260
- IF (RESTRT) GO TO 210
-C
-C *** PREPARE TO COMPUTE GERSCHGORIN ESTIMATES OF LARGEST (AND
-C *** SMALLEST) EIGENVALUES. ***
-C
- 70 K = 0
- DO 100 I = 1, P
- WI = ZERO
- IF (I .EQ. 1) GO TO 90
- IM1 = I - 1
- DO 80 J = 1, IM1
- K = K + 1
- T = ABS(DIHDI(K))
- WI = WI + T
- W(J) = W(J) + T
- 80 CONTINUE
- 90 W(I) = WI
- K = K + 1
- 100 CONTINUE
-C
-C *** (UNDER-)ESTIMATE SMALLEST EIGENVALUE OF (D**-1)*H*(D**-1) ***
-C
- K = 1
- T1 = W(DIAG) - W(1)
- IF (P .LE. 1) GO TO 120
- DO 110 I = 2, P
- J = DIAG0 + I
- T = W(J) - W(I)
- IF (T .GE. T1) GO TO 110
- T1 = T
- K = I
- 110 CONTINUE
-C
- 120 SK = W(K)
- J = DIAG0 + K
- AKK = W(J)
- K1 = K*(K-1)/2 + 1
- INC = 1
- T = ZERO
- DO 150 I = 1, P
- IF (I .EQ. K) GO TO 130
- AKI = ABS(DIHDI(K1))
- SI = W(I)
- J = DIAG0 + I
- T1 = HALF * (AKK - W(J) + SI - AKI)
- T1 = T1 + SQRT(T1*T1 + SK*AKI)
- IF (T .LT. T1) T = T1
- IF (I .LT. K) GO TO 140
- 130 INC = I
- 140 K1 = K1 + INC
- 150 CONTINUE
-C
- W(EMIN) = AKK - T
- UK = V(DGNORM)/RAD - W(EMIN)
- IF (V(DGNORM) .EQ. ZERO) UK = UK + P001 + P001*UK
- IF (UK .LE. ZERO) UK = P001
-C
-C *** COMPUTE GERSCHGORIN (OVER-)ESTIMATE OF LARGEST EIGENVALUE ***
-C
- K = 1
- T1 = W(DIAG) + W(1)
- IF (P .LE. 1) GO TO 170
- DO 160 I = 2, P
- J = DIAG0 + I
- T = W(J) + W(I)
- IF (T .LE. T1) GO TO 160
- T1 = T
- K = I
- 160 CONTINUE
-C
- 170 SK = W(K)
- J = DIAG0 + K
- AKK = W(J)
- K1 = K*(K-1)/2 + 1
- INC = 1
- T = ZERO
- DO 200 I = 1, P
- IF (I .EQ. K) GO TO 180
- AKI = ABS(DIHDI(K1))
- SI = W(I)
- J = DIAG0 + I
- T1 = HALF * (W(J) + SI - AKI - AKK)
- T1 = T1 + SQRT(T1*T1 + SK*AKI)
- IF (T .LT. T1) T = T1
- IF (I .LT. K) GO TO 190
- 180 INC = I
- 190 K1 = K1 + INC
- 200 CONTINUE
-C
- W(EMAX) = AKK + T
- LK = AMAX1(LK, V(DGNORM)/RAD - W(EMAX))
-C
-C *** ALPHAK = CURRENT VALUE OF ALPHA (SEE ALG. NOTES ABOVE). WE
-C *** _USE_ MORE*S SCHEME FOR INITIALIZING IT.
- ALPHAK = ABS(V(STPPAR)) * V(RAD0)/RAD
- ALPHAK = AMIN1(UK, AMAX1(ALPHAK, LK))
-C
- IF (IRC .NE. 0) GO TO 210
-C
-C *** COMPUTE L0 FOR POSITIVE DEFINITE H ***
-C
- CALL L7IVM(P, W, L, W(Q))
- T = V2NRM(P, W)
- W(PHIPIN) = RAD / T / T
- LK = AMAX1(LK, PHI*W(PHIPIN))
-C
-C *** SAFEGUARD ALPHAK AND ADD ALPHAK*I TO (D**-1)*H*(D**-1) ***
-C
- 210 KA = KA + 1
- IF (-V(DST0) .GE. ALPHAK .OR. ALPHAK .LT. LK .OR. ALPHAK .GE. UK)
- 1 ALPHAK = UK * AMAX1(P001, SQRT(LK/UK))
- IF (ALPHAK .LE. ZERO) ALPHAK = HALF * UK
- IF (ALPHAK .LE. ZERO) ALPHAK = UK
- K = 0
- DO 220 I = 1, P
- K = K + I
- J = DIAG0 + I
- DIHDI(K) = W(J) + ALPHAK
- 220 CONTINUE
-C
-C *** TRY COMPUTING CHOLESKY DECOMPOSITION ***
-C
- CALL L7SRT(1, P, L, DIHDI, IRC)
- IF (IRC .EQ. 0) GO TO 240
-C
-C *** (D**-1)*H*(D**-1) + ALPHAK*I IS INDEFINITE -- OVERESTIMATE
-C *** SMALLEST EIGENVALUE FOR _USE_ IN UPDATING LK ***
-C
- J = (IRC*(IRC+1))/2
- T = L(J)
- L(J) = ONE
- DO 230 I = 1, IRC
- 230 W(I) = ZERO
- W(IRC) = ONE
- CALL L7ITV(IRC, W, L, W)
- T1 = V2NRM(IRC, W)
- LK = ALPHAK - T/T1/T1
- V(DST0) = -LK
- IF (UK .LT. LK) UK = LK
- IF (ALPHAK .LT. LK) GO TO 210
-C
-C *** NASTY CASE -- EXACT GERSCHGORIN BOUNDS. FUDGE LK, UK...
-C
- T = P001 * ALPHAK
- IF (T .LE. ZERO) T = P001
- LK = ALPHAK + T
- IF (UK .LE. LK) UK = LK + T
- GO TO 210
-C
-C *** ALPHAK MAKES (D**-1)*H*(D**-1) POSITIVE DEFINITE.
-C *** COMPUTE Q = -D*STEP, CHECK FOR CONVERGENCE. ***
-C
- 240 CALL L7IVM(P, W(Q), L, DIG)
- GTSTA = D7TPR(P, W(Q), W(Q))
- CALL L7ITV(P, W(Q), L, W(Q))
- DST = V2NRM(P, W(Q))
- PHI = DST - RAD
- IF (PHI .LE. PHIMAX .AND. PHI .GE. PHIMIN) GO TO 270
- IF (PHI .EQ. OLDPHI) GO TO 270
- OLDPHI = PHI
- IF (PHI .LT. ZERO) GO TO 330
-C
-C *** UNACCEPTABLE ALPHAK -- UPDATE LK, UK, ALPHAK ***
-C
- 250 IF (KA .GE. KALIM) GO TO 270
-C *** THE FOLLOWING AMIN1 IS NECESSARY BECAUSE OF RESTARTS ***
- IF (PHI .LT. ZERO) UK = AMIN1(UK, ALPHAK)
-C *** KAMIN = 0 ONLY IFF THE GRADIENT VANISHES ***
- IF (KAMIN .EQ. 0) GO TO 210
- CALL L7IVM(P, W, L, W(Q))
-C *** THE FOLLOWING, COMMENTED CALCULATION OF ALPHAK IS SOMETIMES
-C *** SAFER BUT WORSE IN PERFORMANCE...
-C T1 = DST / V2NRM(P, W)
-C ALPHAK = ALPHAK + T1 * (PHI/RAD) * T1
- T1 = V2NRM(P, W)
- ALPHAK = ALPHAK + (PHI/T1) * (DST/T1) * (DST/RAD)
- LK = AMAX1(LK, ALPHAK)
- ALPHAK = LK
- GO TO 210
-C
-C *** ACCEPTABLE STEP ON FIRST TRY ***
-C
- 260 ALPHAK = ZERO
-C
-C *** SUCCESSFUL STEP IN GENERAL. COMPUTE STEP = -(D**-1)*Q ***
-C
- 270 DO 280 I = 1, P
- J = Q0 + I
- STEP(I) = -W(J)/D(I)
- 280 CONTINUE
- V(GTSTEP) = -GTSTA
- V(PREDUC) = HALF * ( ABS(ALPHAK)*DST*DST + GTSTA)
- GO TO 410
-C
-C
-C *** RESTART WITH NEW RADIUS ***
-C
- 290 IF (V(DST0) .LE. ZERO .OR. V(DST0) - RAD .GT. PHIMAX) GO TO 310
-C
-C *** PREPARE TO RETURN NEWTON STEP ***
-C
- RESTRT = .TRUE.
- KA = KA + 1
- K = 0
- DO 300 I = 1, P
- K = K + I
- J = DIAG0 + I
- DIHDI(K) = W(J)
- 300 CONTINUE
- UK = NEGONE
- GO TO 30
-C
- 310 KAMIN = KA + 3
- IF (V(DGNORM) .EQ. ZERO) KAMIN = 0
- IF (KA .EQ. 0) GO TO 50
-C
- DST = W(DSTSAV)
- ALPHAK = ABS(V(STPPAR))
- PHI = DST - RAD
- T = V(DGNORM)/RAD
- UK = T - W(EMIN)
- IF (V(DGNORM) .EQ. ZERO) UK = UK + P001 + P001*UK
- IF (UK .LE. ZERO) UK = P001
- IF (RAD .GT. V(RAD0)) GO TO 320
-C
-C *** SMALLER RADIUS ***
- LK = ZERO
- IF (ALPHAK .GT. ZERO) LK = W(LK0)
- LK = AMAX1(LK, T - W(EMAX))
- IF (V(DST0) .GT. ZERO) LK = AMAX1(LK, (V(DST0)-RAD)*W(PHIPIN))
- GO TO 250
-C
-C *** BIGGER RADIUS ***
- 320 IF (ALPHAK .GT. ZERO) UK = AMIN1(UK, W(UK0))
- LK = AMAX1(ZERO, -V(DST0), T - W(EMAX))
- IF (V(DST0) .GT. ZERO) LK = AMAX1(LK, (V(DST0)-RAD)*W(PHIPIN))
- GO TO 250
-C
-C *** DECIDE WHETHER TO CHECK FOR SPECIAL CASE... IN PRACTICE (FROM
-C *** THE STANDPOINT OF THE CALLING OPTIMIZATION CODE) IT SEEMS BEST
-C *** NOT TO CHECK UNTIL A FEW ITERATIONS HAVE FAILED -- HENCE THE
-C *** TEST ON KAMIN BELOW.
-C
- 330 DELTA = ALPHAK + AMIN1(ZERO, V(DST0))
- TWOPSI = ALPHAK*DST*DST + GTSTA
- IF (KA .GE. KAMIN) GO TO 340
-C *** IF THE TEST IN REF. 2 IS SATISFIED, FALL THROUGH TO HANDLE
-C *** THE SPECIAL CASE (AS SOON AS THE MORE-SORENSEN TEST DETECTS
-C *** IT).
- IF (PSIFAC .GE. BIG) GO TO 340
- IF (DELTA .GE. PSIFAC*TWOPSI) GO TO 370
-C
-C *** CHECK FOR THE SPECIAL CASE OF H + ALPHA*D**2 (NEARLY)
-C *** SINGULAR. _USE_ ONE STEP OF INVERSE POWER METHOD WITH START
-C *** FROM L7SVN TO OBTAIN APPROXIMATE EIGENVECTOR CORRESPONDING
-C *** TO SMALLEST EIGENVALUE OF (D**-1)*H*(D**-1). L7SVN RETURNS
-C *** X AND W WITH L*W = X.
-C
- 340 T = L7SVN(P, L, W(X), W)
-C
-C *** NORMALIZE W ***
- DO 350 I = 1, P
- 350 W(I) = T*W(I)
-C *** COMPLETE CURRENT INV. POWER ITER. -- REPLACE W BY (L**-T)*W.
- CALL L7ITV(P, W, L, W)
- T2 = ONE/ V2NRM(P, W)
- DO 360 I = 1, P
- 360 W(I) = T2*W(I)
- T = T2 * T
-C
-C *** NOW W IS THE DESIRED APPROXIMATE (UNIT) EIGENVECTOR AND
-C *** T*X = ((D**-1)*H*(D**-1) + ALPHAK*I)*W.
-C
- SW = D7TPR(P, W(Q), W)
- T1 = (RAD + DST) * (RAD - DST)
- ROOT = SQRT(SW*SW + T1)
- IF (SW .LT. ZERO) ROOT = -ROOT
- SI = T1 / (SW + ROOT)
-C
-C *** THE ACTUAL TEST FOR THE SPECIAL CASE...
-C
- IF ((T2*SI)**2 .LE. EPS*(DST**2 + ALPHAK*RADSQ)) GO TO 380
-C
-C *** UPDATE UPPER BOUND ON SMALLEST EIGENVALUE (WHEN NOT POSITIVE)
-C *** (AS RECOMMENDED BY MORE AND SORENSEN) AND CONTINUE...
-C
- IF (V(DST0) .LE. ZERO) V(DST0) = AMIN1(V(DST0), T2**2 - ALPHAK)
- LK = AMAX1(LK, -V(DST0))
-C
-C *** CHECK WHETHER WE CAN HOPE TO DETECT THE SPECIAL CASE IN
-C *** THE AVAILABLE ARITHMETIC. ACCEPT STEP AS IT IS IF NOT.
-C
-C *** IF NOT YET AVAILABLE, OBTAIN MACHINE DEPENDENT VALUE DGXFAC.
- 370 IF (DGXFAC .EQ. ZERO) DGXFAC = EPSFAC * R7MDC(3)
-C
- IF (DELTA .GT. DGXFAC*W(DGGDMX)) GO TO 250
- GO TO 270
-C
-C *** SPECIAL CASE DETECTED... NEGATE ALPHAK TO INDICATE SPECIAL CASE
-C
- 380 ALPHAK = -ALPHAK
- V(PREDUC) = HALF * TWOPSI
-C
-C *** ACCEPT CURRENT STEP IF ADDING SI*W WOULD LEAD TO A
-C *** FURTHER RELATIVE REDUCTION IN PSI OF LESS THAN V(EPSLON)/3.
-C
- T1 = ZERO
- T = SI*(ALPHAK*SW - HALF*SI*(ALPHAK + T* D7TPR(P,W(X),W)))
- IF (T .LT. EPS*TWOPSI/SIX) GO TO 390
- V(PREDUC) = V(PREDUC) + T
- DST = RAD
- T1 = -SI
- 390 DO 400 I = 1, P
- J = Q0 + I
- W(J) = T1*W(I) - W(J)
- STEP(I) = W(J) / D(I)
- 400 CONTINUE
- V(GTSTEP) = D7TPR(P, DIG, W(Q))
-C
-C *** SAVE VALUES FOR _USE_ IN A POSSIBLE RESTART ***
-C
- 410 V(DSTNRM) = DST
- V(STPPAR) = ALPHAK
- W(LK0) = LK
- W(UK0) = UK
- V(RAD0) = RAD
- W(DSTSAV) = DST
-C
-C *** RESTORE DIAGONAL OF DIHDI ***
-C
- J = 0
- DO 420 I = 1, P
- J = J + I
- K = DIAG0 + I
- DIHDI(J) = W(K)
- 420 CONTINUE
-C
- 999 RETURN
-C
-C *** LAST CARD OF G7QTS FOLLOWS ***
- END
diff --git a/CEP/PyBDSM/src/port3/h2rfa.f b/CEP/PyBDSM/src/port3/h2rfa.f
deleted file mode 100644
index 6b750121058fcfe43ab96abb036d7d380beea389..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/h2rfa.f
+++ /dev/null
@@ -1,17 +0,0 @@
- SUBROUTINE H2RFA(N, A, B, X, Y, Z)
-C
-C *** APPLY 2X2 HOUSEHOLDER REFLECTION DETERMINED BY X, Y, Z TO
-C *** N-VECTORS A, B ***
-C
- INTEGER N
- REAL A(N), B(N), X, Y, Z
- INTEGER I
- REAL T
- DO 10 I = 1, N
- T = A(I)*X + B(I)*Y
- A(I) = A(I) + T
- B(I) = B(I) + T*Z
- 10 CONTINUE
- 999 RETURN
-C *** LAST LINE OF H2RFA FOLLOWS ***
- END
diff --git a/CEP/PyBDSM/src/port3/h2rfg.f b/CEP/PyBDSM/src/port3/h2rfg.f
deleted file mode 100644
index 0031fa871d66ec7c1c88fb1b9683e234e281fbc5..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/h2rfg.f
+++ /dev/null
@@ -1,37 +0,0 @@
- REAL FUNCTION H2RFG(A, B, X, Y, Z)
-C
-C *** DETERMINE X, Y, Z SO I + (1,Z)**T * (X,Y) IS A 2X2
-C *** HOUSEHOLDER REFLECTION SENDING (A,B)**T INTO (C,0)**T,
-C *** WHERE C = -SIGN(A)*SQRT(A**2 + B**2) IS THE VALUE H2RFG
-C *** RETURNS.
-C
- REAL A, B, X, Y, Z
-C
- REAL A1, B1, C, T
-C/+
- REAL SQRT
-C/
- REAL ZERO
- DATA ZERO/0.E+0/
-C
-C *** BODY ***
-C
- IF (B .NE. ZERO) GO TO 10
- X = ZERO
- Y = ZERO
- Z = ZERO
- H2RFG = A
- GO TO 999
- 10 T = ABS(A) + ABS(B)
- A1 = A / T
- B1 = B / T
- C = SQRT(A1**2 + B1**2)
- IF (A1 .GT. ZERO) C = -C
- A1 = A1 - C
- Z = B1 / A1
- X = A1 / C
- Y = B1 / C
- H2RFG = T * C
- 999 RETURN
-C *** LAST LINE OF H2RFG FOLLOWS ***
- END
diff --git a/CEP/PyBDSM/src/port3/hqr2.f b/CEP/PyBDSM/src/port3/hqr2.f
deleted file mode 100644
index e6e93d892ab490c12a7141b7c63925ff3176ef49..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/hqr2.f
+++ /dev/null
@@ -1,452 +0,0 @@
- SUBROUTINE HQR2(NM,N,LOW,IGH,H,WR,WI,Z,IERR)
-C
- INTEGER I,J,K,L,M,N,EN,II,JJ,LL,MM,NA,NM,NN,
- X IGH,ITN,ITS,LOW,MP2,ENM2,IERR
- REAL H(NM,N),WR(N),WI(N),Z(NM,N)
- REAL P,Q,R,S,T,W,X,Y,RA,SA,VI,VR,ZZ,NORM,TST1,TST2
- COMPLEX Z3
- LOGICAL NOTLAS
-C
-C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE HQR2,
-C NUM. MATH. 16, 181-204(1970) BY PETERS AND WILKINSON.
-C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 372-395(1971).
-C
-C THIS SUBROUTINE FINDS THE EIGENVALUES AND EIGENVECTORS
-C OF A REAL UPPER HESSENBERG MATRIX BY THE QR METHOD. THE
-C EIGENVECTORS OF A REAL GENERAL MATRIX CAN ALSO BE FOUND
-C IF ELMHES AND ELTRAN OR ORTHES AND ORTRAN HAVE
-C BEEN USED TO REDUCE THIS GENERAL MATRIX TO HESSENBERG FORM
-C AND TO ACCUMULATE THE SIMILARITY TRANSFORMATIONS.
-C
-C ON INPUT
-C
-C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
-C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
-C DIMENSION STATEMENT.
-C
-C N IS THE ORDER OF THE MATRIX.
-C
-C LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING
-C SUBROUTINE BALANC. IF BALANC HAS NOT BEEN USED,
-C SET LOW=1, IGH=N.
-C
-C H CONTAINS THE UPPER HESSENBERG MATRIX.
-C
-C Z CONTAINS THE TRANSFORMATION MATRIX PRODUCED BY ELTRAN
-C AFTER THE REDUCTION BY ELMHES, OR BY ORTRAN AFTER THE
-C REDUCTION BY ORTHES, IF PERFORMED. IF THE EIGENVECTORS
-C OF THE HESSENBERG MATRIX ARE DESIRED, Z MUST CONTAIN THE
-C IDENTITY MATRIX.
-C
-C ON OUTPUT
-C
-C H HAS BEEN DESTROYED.
-C
-C WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS,
-C RESPECTIVELY, OF THE EIGENVALUES. THE EIGENVALUES
-C ARE UNORDERED EXCEPT THAT COMPLEX CONJUGATE PAIRS
-C OF VALUES APPEAR CONSECUTIVELY WITH THE EIGENVALUE
-C HAVING THE POSITIVE IMAGINARY PART FIRST. IF AN
-C ERROR EXIT IS MADE, THE EIGENVALUES SHOULD BE CORRECT
-C FOR INDICES IERR+1,...,N.
-C
-C Z CONTAINS THE REAL AND IMAGINARY PARTS OF THE EIGENVECTORS.
-C IF THE I-TH EIGENVALUE IS REAL, THE I-TH COLUMN OF Z
-C CONTAINS ITS EIGENVECTOR. IF THE I-TH EIGENVALUE IS COMPLEX
-C WITH POSITIVE IMAGINARY PART, THE I-TH AND (I+1)-TH
-C COLUMNS OF Z CONTAIN THE REAL AND IMAGINARY PARTS OF ITS
-C EIGENVECTOR. THE EIGENVECTORS ARE UNNORMALIZED. IF AN
-C ERROR EXIT IS MADE, NONE OF THE EIGENVECTORS HAS BEEN FOUND.
-C
-C IERR IS SET TO
-C ZERO FOR NORMAL RETURN,
-C J IF THE LIMIT OF 30*N ITERATIONS IS EXHAUSTED
-C WHILE THE J-TH EIGENVALUE IS BEING SOUGHT.
-C
-C THIS ROUTINE IS FROM EISPACK (VERSION DATED AUGUST 1983), WITH
-C CALLS ON CDIV REPLACED BY COMPLEX DIVISION.
-C
-C ------------------------------------------------------------------
-C
- IERR = 0
- NORM = 0.0E0
- K = 1
-C .......... STORE ROOTS ISOLATED BY BALANC
-C AND COMPUTE MATRIX NORM ..........
- DO 50 I = 1, N
-C
- DO 40 J = K, N
- 40 NORM = NORM + ABS(H(I,J))
-C
- K = I
- IF (I .GE. LOW .AND. I .LE. IGH) GO TO 50
- WR(I) = H(I,I)
- WI(I) = 0.0E0
- 50 CONTINUE
-C
- EN = IGH
- T = 0.0E0
- ITN = 30*N
-C .......... SEARCH FOR NEXT EIGENVALUES ..........
- 60 IF (EN .LT. LOW) GO TO 340
- ITS = 0
- NA = EN - 1
- ENM2 = NA - 1
-C .......... LOOK FOR SINGLE SMALL SUB-DIAGONAL ELEMENT
-C FOR L=EN STEP -1 UNTIL LOW DO -- ..........
- 70 DO 80 LL = LOW, EN
- L = EN + LOW - LL
- IF (L .EQ. LOW) GO TO 100
- S = ABS(H(L-1,L-1)) + ABS(H(L,L))
- IF (S .EQ. 0.0E0) S = NORM
- TST1 = S
- TST2 = TST1 + ABS(H(L,L-1))
- IF (TST2 .EQ. TST1) GO TO 100
- 80 CONTINUE
-C .......... FORM SHIFT ..........
- 100 X = H(EN,EN)
- IF (L .EQ. EN) GO TO 270
- Y = H(NA,NA)
- W = H(EN,NA) * H(NA,EN)
- IF (L .EQ. NA) GO TO 280
- IF (ITN .EQ. 0) GO TO 1000
- IF (ITS .NE. 10 .AND. ITS .NE. 20) GO TO 130
-C .......... FORM EXCEPTIONAL SHIFT ..........
- T = T + X
-C
- DO 120 I = LOW, EN
- 120 H(I,I) = H(I,I) - X
-C
- S = ABS(H(EN,NA)) + ABS(H(NA,ENM2))
- X = 0.75E0 * S
- Y = X
- W = -0.4375E0 * S * S
- 130 ITS = ITS + 1
- ITN = ITN - 1
-C .......... LOOK FOR TWO CONSECUTIVE SMALL
-C SUB-DIAGONAL ELEMENTS.
-C FOR M=EN-2 STEP -1 UNTIL L DO -- ..........
- DO 140 MM = L, ENM2
- M = ENM2 + L - MM
- ZZ = H(M,M)
- R = X - ZZ
- S = Y - ZZ
- P = (R * S - W) / H(M+1,M) + H(M,M+1)
- Q = H(M+1,M+1) - ZZ - R - S
- R = H(M+2,M+1)
- S = ABS(P) + ABS(Q) + ABS(R)
- P = P / S
- Q = Q / S
- R = R / S
- IF (M .EQ. L) GO TO 150
- TST1 = ABS(P)*(ABS(H(M-1,M-1)) + ABS(ZZ) + ABS(H(M+1,M+1)))
- TST2 = TST1 + ABS(H(M,M-1))*(ABS(Q) + ABS(R))
- IF (TST2 .EQ. TST1) GO TO 150
- 140 CONTINUE
-C
- 150 MP2 = M + 2
-C
- DO 160 I = MP2, EN
- H(I,I-2) = 0.0E0
- IF (I .EQ. MP2) GO TO 160
- H(I,I-3) = 0.0E0
- 160 CONTINUE
-C .......... DOUBLE QR STEP INVOLVING ROWS L TO EN AND
-C COLUMNS M TO EN ..........
- DO 260 K = M, NA
- NOTLAS = K .NE. NA
- IF (K .EQ. M) GO TO 170
- P = H(K,K-1)
- Q = H(K+1,K-1)
- R = 0.0E0
- IF (NOTLAS) R = H(K+2,K-1)
- X = ABS(P) + ABS(Q) + ABS(R)
- IF (X .EQ. 0.0E0) GO TO 260
- P = P / X
- Q = Q / X
- R = R / X
- 170 S = SIGN(SQRT(P*P+Q*Q+R*R),P)
- IF (K .EQ. M) GO TO 180
- H(K,K-1) = -S * X
- GO TO 190
- 180 IF (L .NE. M) H(K,K-1) = -H(K,K-1)
- 190 P = P + S
- X = P / S
- Y = Q / S
- ZZ = R / S
- Q = Q / P
- R = R / P
- IF (NOTLAS) GO TO 225
-C .......... ROW MODIFICATION ..........
- DO 200 J = K, N
- P = H(K,J) + Q * H(K+1,J)
- H(K,J) = H(K,J) - P * X
- H(K+1,J) = H(K+1,J) - P * Y
- 200 CONTINUE
-C
- J = MIN0(EN,K+3)
-C .......... COLUMN MODIFICATION ..........
- DO 210 I = 1, J
- P = X * H(I,K) + Y * H(I,K+1)
- H(I,K) = H(I,K) - P
- H(I,K+1) = H(I,K+1) - P * Q
- 210 CONTINUE
-C .......... ACCUMULATE TRANSFORMATIONS ..........
- DO 220 I = LOW, IGH
- P = X * Z(I,K) + Y * Z(I,K+1)
- Z(I,K) = Z(I,K) - P
- Z(I,K+1) = Z(I,K+1) - P * Q
- 220 CONTINUE
- GO TO 255
- 225 CONTINUE
-C .......... ROW MODIFICATION ..........
- DO 230 J = K, N
- P = H(K,J) + Q * H(K+1,J) + R * H(K+2,J)
- H(K,J) = H(K,J) - P * X
- H(K+1,J) = H(K+1,J) - P * Y
- H(K+2,J) = H(K+2,J) - P * ZZ
- 230 CONTINUE
-C
- J = MIN0(EN,K+3)
-C .......... COLUMN MODIFICATION ..........
- DO 240 I = 1, J
- P = X * H(I,K) + Y * H(I,K+1) + ZZ * H(I,K+2)
- H(I,K) = H(I,K) - P
- H(I,K+1) = H(I,K+1) - P * Q
- H(I,K+2) = H(I,K+2) - P * R
- 240 CONTINUE
-C .......... ACCUMULATE TRANSFORMATIONS ..........
- DO 250 I = LOW, IGH
- P = X * Z(I,K) + Y * Z(I,K+1) + ZZ * Z(I,K+2)
- Z(I,K) = Z(I,K) - P
- Z(I,K+1) = Z(I,K+1) - P * Q
- Z(I,K+2) = Z(I,K+2) - P * R
- 250 CONTINUE
- 255 CONTINUE
-C
- 260 CONTINUE
-C
- GO TO 70
-C .......... ONE ROOT FOUND ..........
- 270 H(EN,EN) = X + T
- WR(EN) = H(EN,EN)
- WI(EN) = 0.0E0
- EN = NA
- GO TO 60
-C .......... TWO ROOTS FOUND ..........
- 280 P = (Y - X) / 2.0E0
- Q = P * P + W
- ZZ = SQRT(ABS(Q))
- H(EN,EN) = X + T
- X = H(EN,EN)
- H(NA,NA) = Y + T
- IF (Q .LT. 0.0E0) GO TO 320
-C .......... REAL PAIR ..........
- ZZ = P + SIGN(ZZ,P)
- WR(NA) = X + ZZ
- WR(EN) = WR(NA)
- IF (ZZ .NE. 0.0E0) WR(EN) = X - W / ZZ
- WI(NA) = 0.0E0
- WI(EN) = 0.0E0
- X = H(EN,NA)
- S = ABS(X) + ABS(ZZ)
- P = X / S
- Q = ZZ / S
- R = SQRT(P*P+Q*Q)
- P = P / R
- Q = Q / R
-C .......... ROW MODIFICATION ..........
- DO 290 J = NA, N
- ZZ = H(NA,J)
- H(NA,J) = Q * ZZ + P * H(EN,J)
- H(EN,J) = Q * H(EN,J) - P * ZZ
- 290 CONTINUE
-C .......... COLUMN MODIFICATION ..........
- DO 300 I = 1, EN
- ZZ = H(I,NA)
- H(I,NA) = Q * ZZ + P * H(I,EN)
- H(I,EN) = Q * H(I,EN) - P * ZZ
- 300 CONTINUE
-C .......... ACCUMULATE TRANSFORMATIONS ..........
- DO 310 I = LOW, IGH
- ZZ = Z(I,NA)
- Z(I,NA) = Q * ZZ + P * Z(I,EN)
- Z(I,EN) = Q * Z(I,EN) - P * ZZ
- 310 CONTINUE
-C
- GO TO 330
-C .......... COMPLEX PAIR ..........
- 320 WR(NA) = X + P
- WR(EN) = X + P
- WI(NA) = ZZ
- WI(EN) = -ZZ
- 330 EN = ENM2
- GO TO 60
-C .......... ALL ROOTS FOUND. BACKSUBSTITUTE TO FIND
-C VECTORS OF UPPER TRIANGULAR FORM ..........
- 340 IF (NORM .EQ. 0.0E0) GO TO 1001
-C .......... FOR EN=N STEP -1 UNTIL 1 DO -- ..........
- DO 800 NN = 1, N
- EN = N + 1 - NN
- P = WR(EN)
- Q = WI(EN)
- NA = EN - 1
- IF (Q) 710, 600, 800
-C .......... REAL VECTOR ..........
- 600 M = EN
- H(EN,EN) = 1.0E0
- IF (NA .EQ. 0) GO TO 800
-C .......... FOR I=EN-1 STEP -1 UNTIL 1 DO -- ..........
- DO 700 II = 1, NA
- I = EN - II
- W = H(I,I) - P
- R = 0.0E0
-C
- DO 610 J = M, EN
- 610 R = R + H(I,J) * H(J,EN)
-C
- IF (WI(I) .GE. 0.0E0) GO TO 630
- ZZ = W
- S = R
- GO TO 700
- 630 M = I
- IF (WI(I) .NE. 0.0E0) GO TO 640
- T = W
- IF (T .NE. 0.0E0) GO TO 635
- TST1 = NORM
- T = TST1
- 632 T = 0.01E0 * T
- TST2 = NORM + T
- IF (TST2 .GT. TST1) GO TO 632
- 635 H(I,EN) = -R / T
- GO TO 680
-C .......... SOLVE REAL EQUATIONS ..........
- 640 X = H(I,I+1)
- Y = H(I+1,I)
- Q = (WR(I) - P) * (WR(I) - P) + WI(I) * WI(I)
- T = (X * S - ZZ * R) / Q
- H(I,EN) = T
- IF (ABS(X) .LE. ABS(ZZ)) GO TO 650
- H(I+1,EN) = (-R - W * T) / X
- GO TO 680
- 650 H(I+1,EN) = (-S - Y * T) / ZZ
-C
-C .......... OVERFLOW CONTROL ..........
- 680 T = ABS(H(I,EN))
- IF (T .EQ. 0.0E0) GO TO 700
- TST1 = T
- TST2 = TST1 + 1.0E0/TST1
- IF (TST2 .GT. TST1) GO TO 700
- DO 690 J = I, EN
- H(J,EN) = H(J,EN)/T
- 690 CONTINUE
-C
- 700 CONTINUE
-C .......... END REAL VECTOR ..........
- GO TO 800
-C .......... COMPLEX VECTOR ..........
- 710 M = NA
-C .......... LAST VECTOR COMPONENT CHOSEN IMAGINARY SO THAT
-C EIGENVECTOR MATRIX IS TRIANGULAR ..........
- IF (ABS(H(EN,NA)) .LE. ABS(H(NA,EN))) GO TO 720
- H(NA,NA) = Q / H(EN,NA)
- H(NA,EN) = -(H(EN,EN) - P) / H(EN,NA)
- GO TO 730
- 720 Z3 = CMPLX(0.0,-H(NA,EN)) / CMPLX(H(NA,NA)-P,Q)
- H(NA,NA) = REAL(Z3)
- H(NA,EN) = AIMAG(Z3)
- 730 H(EN,NA) = 0.0E0
- H(EN,EN) = 1.0E0
- ENM2 = NA - 1
- IF (ENM2 .EQ. 0) GO TO 800
-C .......... FOR I=EN-2 STEP -1 UNTIL 1 DO -- ..........
- DO 795 II = 1, ENM2
- I = NA - II
- W = H(I,I) - P
- RA = 0.0E0
- SA = 0.0E0
-C
- DO 760 J = M, EN
- RA = RA + H(I,J) * H(J,NA)
- SA = SA + H(I,J) * H(J,EN)
- 760 CONTINUE
-C
- IF (WI(I) .GE. 0.0E0) GO TO 770
- ZZ = W
- R = RA
- S = SA
- GO TO 795
- 770 M = I
- IF (WI(I) .NE. 0.0E0) GO TO 780
- Z3 = CMPLX(-RA,-SA) / CMPLX(W,Q)
- H(I,NA) = REAL(Z3)
- H(I,EN) = AIMAG(Z3)
- GO TO 790
-C .......... SOLVE COMPLEX EQUATIONS ..........
- 780 X = H(I,I+1)
- Y = H(I+1,I)
- VR = (WR(I) - P) * (WR(I) - P) + WI(I) * WI(I) - Q * Q
- VI = (WR(I) - P) * 2.0E0 * Q
- IF (VR .NE. 0.0E0 .OR. VI .NE. 0.0E0) GO TO 784
- TST1 = NORM * (ABS(W) + ABS(Q) + ABS(X)
- X + ABS(Y) + ABS(ZZ))
- VR = TST1
- 783 VR = 0.01E0 * VR
- TST2 = TST1 + VR
- IF (TST2 .GT. TST1) GO TO 783
- 784 Z3 = CMPLX(X*R-ZZ*RA+Q*SA,X*S-ZZ*SA-Q*RA) / CMPLX(VR,VI)
- H(I,NA) = REAL(Z3)
- H(I,EN) = AIMAG(Z3)
- IF (ABS(X) .LE. ABS(ZZ) + ABS(Q)) GO TO 785
- H(I+1,NA) = (-RA - W * H(I,NA) + Q * H(I,EN)) / X
- H(I+1,EN) = (-SA - W * H(I,EN) - Q * H(I,NA)) / X
- GO TO 790
- 785 Z3 = CMPLX(-R-Y*H(I,NA),-S-Y*H(I,EN)) / CMPLX(ZZ,Q)
- H(I+1,NA) = REAL(Z3)
- H(I+1,EN) = AIMAG(Z3)
-C
-C .......... OVERFLOW CONTROL ..........
- 790 T = AMAX1(ABS(H(I,NA)), ABS(H(I,EN)))
- IF (T .EQ. 0.0E0) GO TO 795
- TST1 = T
- TST2 = TST1 + 1.0E0/TST1
- IF (TST2 .GT. TST1) GO TO 795
- DO 792 J = I, EN
- H(J,NA) = H(J,NA)/T
- H(J,EN) = H(J,EN)/T
- 792 CONTINUE
-C
- 795 CONTINUE
-C .......... END COMPLEX VECTOR ..........
- 800 CONTINUE
-C .......... END BACK SUBSTITUTION.
-C VECTORS OF ISOLATED ROOTS ..........
- DO 840 I = 1, N
- IF (I .GE. LOW .AND. I .LE. IGH) GO TO 840
-C
- DO 820 J = I, N
- 820 Z(I,J) = H(I,J)
-C
- 840 CONTINUE
-C .......... MULTIPLY BY TRANSFORMATION MATRIX TO GIVE
-C VECTORS OF ORIGINAL FULL MATRIX.
-C FOR J=N STEP -1 UNTIL LOW DO -- ..........
- DO 880 JJ = LOW, N
- J = N + LOW - JJ
- M = MIN0(J,IGH)
-C
- DO 880 I = LOW, IGH
- ZZ = 0.0E0
-C
- DO 860 K = LOW, M
- 860 ZZ = ZZ + Z(I,K) * H(K,J)
-C
- Z(I,J) = ZZ
- 880 CONTINUE
-C
- GO TO 1001
-C .......... SET ERROR -- ALL EIGENVALUES HAVE NOT
-C CONVERGED AFTER 30*N ITERATIONS ..........
- 1000 IERR = EN
- 1001 RETURN
- END
diff --git a/CEP/PyBDSM/src/port3/i0tk00.f b/CEP/PyBDSM/src/port3/i0tk00.f
deleted file mode 100644
index df9d16e355ad9ff1f7c58d2a9d2e6259597633ce..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/i0tk00.f
+++ /dev/null
@@ -1,52 +0,0 @@
- SUBROUTINE I0TK00(LARG,NITEMS,ITYPE)
-C
-C INITIALIZES THE STACK TO NITEMS OF TYPE ITYPE
-C
- COMMON /CSTAK/DSTAK
-C
- DOUBLE PRECISION DSTAK(500)
- INTEGER ISTAK(1000)
- LOGICAL LARG,INIT
- INTEGER ISIZE(5)
-C
- EQUIVALENCE (DSTAK(1),ISTAK(1))
- EQUIVALENCE (ISTAK(1),LOUT)
- EQUIVALENCE (ISTAK(2),LNOW)
- EQUIVALENCE (ISTAK(3),LUSED)
- EQUIVALENCE (ISTAK(4),LMAX)
- EQUIVALENCE (ISTAK(5),LBOOK)
- EQUIVALENCE (ISTAK(6),ISIZE(1))
-C
- DATA INIT/.FALSE./
-C
- LARG = .FALSE.
- IF (INIT) RETURN
-C
-C HERE TO INITIALIZE
-C
- INIT = .TRUE.
-C
-C SET DATA SIZES APPROPRIATE FOR A STANDARD CONFORMING
-C FORTRAN SYSTEM USING THE FORTRAN STORAGE UNIT AS THE
-C MEASURE OF SIZE.
-C
-C LOGICAL
- ISIZE(1) = 1
-C INTEGER
- ISIZE(2) = 1
-C REAL
- ISIZE(3) = 1
-C DOUBLE PRECISION
- ISIZE(4) = 2
-C COMPLEX
- ISIZE(5) = 2
-C
- LBOOK = 10
- LNOW = LBOOK
- LUSED = LBOOK
- LMAX = MAX0( (NITEMS*ISIZE(ITYPE))/ISIZE(2), 12 )
- LOUT = 0
-C
- RETURN
-C
- END
diff --git a/CEP/PyBDSM/src/port3/i0tk01.f b/CEP/PyBDSM/src/port3/i0tk01.f
deleted file mode 100644
index cc4268340165ac847f5bf9441d935f3340e1b14a..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/i0tk01.f
+++ /dev/null
@@ -1,62 +0,0 @@
- SUBROUTINE I0TK01
-C
- LOGICAL DONE
-C
- DATA DONE /.FALSE./
-C
- IF(DONE) RETURN
- DONE = .TRUE.
- IUNIT = I1MACH(4)
-C
- WRITE( IUNIT, 100)
- WRITE( IUNIT, 200)
- WRITE( IUNIT, 300)
-C
- RETURN
-C
- 100 FORMAT (1H1,
- *62H YOU HAVE USED, DIRECTLY OR INDIRECTLY, ONE OF THE STORAGE AL-/
- *62H LOCATION PROGRAMS IALLOC, DALLOC, STINIT, NIRALL, MTSTAK OR/
- *62H SRECAP. THESE ARE BASED ON THE ASSUMPTION THAT ONE -UNIT- OF/
- *62H STORAGE IS ALLOCATED TO DATA OF TYPE LOGICAL, INTEGER AND/
- *62H REAL AND THAT TWO -UNITS- OF STORAGE ARE ALLOCATED TO DATA OF/
- *62H TYPE DOUBLE PRECISION AND COMPLEX. THIS ASSUMPTION PREVENTS/
- *62H MOVING PORT TO MANY MINI-COMPUTERS. /
- *62H /
- *62H TO OVERCOME THIS DIFFICULTY, THE PACKAGE HAS BEEN REWRITTEN/
- *62H WITH NEW NAMES AND SIMILAR CALLING SEQUENCES. CALLS TO THE/
- *62H OLD SUBPROGRAMS SHOULD BE REPLACED BY CALLS TO THE NEW/
- *62H PACKAGE WHEN CONVENIENT. TO AVOID OBSOLETING OLD PROGRAMS/
- *62H THE OLD CALLING SEQUENCES WILL CONTINUE TO BE SUPPORTED. /
- *62H /
- *)
-C
- 200 FORMAT(
- *62H THE OLD AND NEW CALLING SEQUENCES ARE AS FOLLOWS- /
- *62H /
- *62H FUNCTION OLD NEW /
- *62H /
- *62H GET IX = IALLOC(NDATA,ISIZE) IX = ISTKGT(NDATA,ITYPE)/
- *62H RELEASE CALL DALLOC(NFRAMES) CALL ISTKRL(NFRAMES) /
- *62H INITIALIZE CALL STINIT(NDATA,ISIZE) CALL ISTKIN(NDATA,ITYPE)/
- *62H MODIFY IX = MTSTAK(NDATA) IX = ISTKMD(NDATA) /
- *62H STATISTICS CALL SRECAP(IUNIT) - NO EQUIVALENT - /
- *62H QUERY N = NIRALL(ISIZE) N = ISTKQU(ITYPE) /
- *62H /
- *)
-C
- 300 FORMAT(
- *62H IN THE ABOVE ITYPE IS AS FOLLOWS- /
- *62H /
- *62H 1 LOGICAL /
- *62H 2 INTEGER /
- *62H 3 REAL /
- *62H 4 DOUBLE PRECISION /
- *62H 5 COMPLEX /
- *62H /
- *62H NOTE ALSO THAT ALLOCATIONS SHOULD NOT BE SPLIT INTO SUBAL-/
- *62H LOCATIONS OF DIFFERENT TYPE AS THIS ALSO COMPROMISES POR-/
- *62H TABILITY. /
- *)
-C
- END
diff --git a/CEP/PyBDSM/src/port3/i10wid.f b/CEP/PyBDSM/src/port3/i10wid.f
deleted file mode 100644
index 1d97b82fa6b1e89d87d15d34869c555ac5ddb01b..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/i10wid.f
+++ /dev/null
@@ -1,14 +0,0 @@
- INTEGER FUNCTION I10WID(IX)
- INTEGER IX
- INTEGER IABS, IY, DIGITS
-C THIS FUNCTION RETURNS THE NUMBER OF DECIMAL
-C DIGITS REQUIRED TO REPRESENT THE INTEGER, IX.
- DIGITS = 0
- IY = IABS(IX)
- 1 IF (IY .LT. 1) GOTO 2
- DIGITS = DIGITS+1
- IY = IY/10
- GOTO 1
- 2 I10WID = DIGITS
- RETURN
- END
diff --git a/CEP/PyBDSM/src/port3/i1mach.f b/CEP/PyBDSM/src/port3/i1mach.f
deleted file mode 100644
index 1d6f7fc6bb5428cbfdc55c1d34321331e0baf7e1..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/i1mach.f
+++ /dev/null
@@ -1,291 +0,0 @@
- INTEGER FUNCTION I1MACH(I)
- INTEGER I
-C
-C I1MACH( 1) = THE STANDARD INPUT UNIT.
-C I1MACH( 2) = THE STANDARD OUTPUT UNIT.
-C I1MACH( 3) = THE STANDARD PUNCH UNIT.
-C I1MACH( 4) = THE STANDARD ERROR MESSAGE UNIT.
-C I1MACH( 5) = THE NUMBER OF BITS PER INTEGER STORAGE UNIT.
-C I1MACH( 6) = THE NUMBER OF CHARACTERS PER CHARACTER STORAGE UNIT.
-C INTEGERS HAVE FORM SIGN ( X(S-1)*A**(S-1) + ... + X(1)*A + X(0) )
-C I1MACH( 7) = A, THE BASE.
-C I1MACH( 8) = S, THE NUMBER OF BASE-A DIGITS.
-C I1MACH( 9) = A**S - 1, THE LARGEST MAGNITUDE.
-C FLOATS HAVE FORM SIGN (B**E)*( (X(1)/B) + ... + (X(T)/B**T) )
-C WHERE EMIN .LE. E .LE. EMAX.
-C I1MACH(10) = B, THE BASE.
-C SINGLE-PRECISION
-C I1MACH(11) = T, THE NUMBER OF BASE-B DIGITS.
-C I1MACH(12) = EMIN, THE SMALLEST EXPONENT E.
-C I1MACH(13) = EMAX, THE LARGEST EXPONENT E.
-C DOUBLE-PRECISION
-C I1MACH(14) = T, THE NUMBER OF BASE-B DIGITS.
-C I1MACH(15) = EMIN, THE SMALLEST EXPONENT E.
-C I1MACH(16) = EMAX, THE LARGEST EXPONENT E.
-C
- INTEGER IMACH(16), OUTPUT, SC, SMALL(2)
- SAVE IMACH, SC
- REAL RMACH
- EQUIVALENCE (IMACH(4),OUTPUT), (RMACH,SMALL(1))
- INTEGER I3, J, K, T3E(3)
- DATA T3E(1) / 9777664 /
- DATA T3E(2) / 5323660 /
- DATA T3E(3) / 46980 /
-C THIS VERSION ADAPTS AUTOMATICALLY TO MOST CURRENT MACHINES,
-C INCLUDING AUTO-DOUBLE COMPILERS.
-C TO COMPILE ON OLDER MACHINES, ADD A C IN COLUMN 1
-C ON THE NEXT LINE
- DATA SC/0/
-C AND REMOVE THE C FROM COLUMN 1 IN ONE OF THE SECTIONS BELOW.
-C CONSTANTS FOR EVEN OLDER MACHINES CAN BE OBTAINED BY
-C mail netlib@research.bell-labs.com
-C send old1mach from blas
-C PLEASE SEND CORRECTIONS TO dmg OR ehg@bell-labs.com.
-C
-C MACHINE CONSTANTS FOR THE HONEYWELL DPS 8/70 SERIES.
-C
-C DATA IMACH( 1) / 5 /
-C DATA IMACH( 2) / 6 /
-C DATA IMACH( 3) / 43 /
-C DATA IMACH( 4) / 6 /
-C DATA IMACH( 5) / 36 /
-C DATA IMACH( 6) / 4 /
-C DATA IMACH( 7) / 2 /
-C DATA IMACH( 8) / 35 /
-C DATA IMACH( 9) / O377777777777 /
-C DATA IMACH(10) / 2 /
-C DATA IMACH(11) / 27 /
-C DATA IMACH(12) / -127 /
-C DATA IMACH(13) / 127 /
-C DATA IMACH(14) / 63 /
-C DATA IMACH(15) / -127 /
-C DATA IMACH(16) / 127 /, SC/987/
-C
-C MACHINE CONSTANTS FOR PDP-11 FORTRANS SUPPORTING
-C 32-BIT INTEGER ARITHMETIC.
-C
-C DATA IMACH( 1) / 5 /
-C DATA IMACH( 2) / 6 /
-C DATA IMACH( 3) / 7 /
-C DATA IMACH( 4) / 6 /
-C DATA IMACH( 5) / 32 /
-C DATA IMACH( 6) / 4 /
-C DATA IMACH( 7) / 2 /
-C DATA IMACH( 8) / 31 /
-C DATA IMACH( 9) / 2147483647 /
-C DATA IMACH(10) / 2 /
-C DATA IMACH(11) / 24 /
-C DATA IMACH(12) / -127 /
-C DATA IMACH(13) / 127 /
-C DATA IMACH(14) / 56 /
-C DATA IMACH(15) / -127 /
-C DATA IMACH(16) / 127 /, SC/987/
-C
-C MACHINE CONSTANTS FOR THE UNIVAC 1100 SERIES.
-C
-C NOTE THAT THE PUNCH UNIT, I1MACH(3), HAS BEEN SET TO 7
-C WHICH IS APPROPRIATE FOR THE UNIVAC-FOR SYSTEM.
-C IF YOU HAVE THE UNIVAC-FTN SYSTEM, SET IT TO 1.
-C
-C DATA IMACH( 1) / 5 /
-C DATA IMACH( 2) / 6 /
-C DATA IMACH( 3) / 7 /
-C DATA IMACH( 4) / 6 /
-C DATA IMACH( 5) / 36 /
-C DATA IMACH( 6) / 6 /
-C DATA IMACH( 7) / 2 /
-C DATA IMACH( 8) / 35 /
-C DATA IMACH( 9) / O377777777777 /
-C DATA IMACH(10) / 2 /
-C DATA IMACH(11) / 27 /
-C DATA IMACH(12) / -128 /
-C DATA IMACH(13) / 127 /
-C DATA IMACH(14) / 60 /
-C DATA IMACH(15) /-1024 /
-C DATA IMACH(16) / 1023 /, SC/987/
-C
- IF (SC .NE. 987) THEN
-* *** CHECK FOR AUTODOUBLE ***
- SMALL(2) = 0
- RMACH = 1E13
- IF (SMALL(2) .NE. 0) THEN
-* *** AUTODOUBLED ***
- IF ( (SMALL(1) .EQ. 1117925532
- * .AND. SMALL(2) .EQ. -448790528)
- * .OR. (SMALL(2) .EQ. 1117925532
- * .AND. SMALL(1) .EQ. -448790528)) THEN
-* *** IEEE ***
- IMACH(10) = 2
- IMACH(14) = 53
- IMACH(15) = -1021
- IMACH(16) = 1024
- ELSE IF ( SMALL(1) .EQ. -2065213935
- * .AND. SMALL(2) .EQ. 10752) THEN
-* *** VAX WITH D_FLOATING ***
- IMACH(10) = 2
- IMACH(14) = 56
- IMACH(15) = -127
- IMACH(16) = 127
- ELSE IF ( SMALL(1) .EQ. 1267827943
- * .AND. SMALL(2) .EQ. 704643072) THEN
-* *** IBM MAINFRAME ***
- IMACH(10) = 16
- IMACH(14) = 14
- IMACH(15) = -64
- IMACH(16) = 63
- ELSE
- WRITE(*,9010)
- STOP 777
- END IF
- IMACH(11) = IMACH(14)
- IMACH(12) = IMACH(15)
- IMACH(13) = IMACH(16)
- ELSE
- RMACH = 1234567.
- IF (SMALL(1) .EQ. 1234613304) THEN
-* *** IEEE ***
- IMACH(10) = 2
- IMACH(11) = 24
- IMACH(12) = -125
- IMACH(13) = 128
- IMACH(14) = 53
- IMACH(15) = -1021
- IMACH(16) = 1024
- SC = 987
- ELSE IF (SMALL(1) .EQ. -1271379306) THEN
-* *** VAX ***
- IMACH(10) = 2
- IMACH(11) = 24
- IMACH(12) = -127
- IMACH(13) = 127
- IMACH(14) = 56
- IMACH(15) = -127
- IMACH(16) = 127
- SC = 987
- ELSE IF (SMALL(1) .EQ. 1175639687) THEN
-* *** IBM MAINFRAME ***
- IMACH(10) = 16
- IMACH(11) = 6
- IMACH(12) = -64
- IMACH(13) = 63
- IMACH(14) = 14
- IMACH(15) = -64
- IMACH(16) = 63
- SC = 987
- ELSE IF (SMALL(1) .EQ. 1251390520) THEN
-* *** CONVEX C-1 ***
- IMACH(10) = 2
- IMACH(11) = 24
- IMACH(12) = -128
- IMACH(13) = 127
- IMACH(14) = 53
- IMACH(15) = -1024
- IMACH(16) = 1023
- ELSE
- DO 10 I3 = 1, 3
- J = SMALL(1) / 10000000
- K = SMALL(1) - 10000000*J
- IF (K .NE. T3E(I3)) GO TO 20
- SMALL(1) = J
- 10 CONTINUE
-* *** CRAY T3E ***
- IMACH( 1) = 5
- IMACH( 2) = 6
- IMACH( 3) = 0
- IMACH( 4) = 0
- IMACH( 5) = 64
- IMACH( 6) = 8
- IMACH( 7) = 2
- IMACH( 8) = 63
- CALL I1MCR1(IMACH(9), K, 32767, 16777215, 16777215)
- IMACH(10) = 2
- IMACH(11) = 53
- IMACH(12) = -1021
- IMACH(13) = 1024
- IMACH(14) = 53
- IMACH(15) = -1021
- IMACH(16) = 1024
- GO TO 35
- 20 CALL I1MCR1(J, K, 16405, 9876536, 0)
- IF (SMALL(1) .NE. J) THEN
- WRITE(*,9020)
- STOP 777
- END IF
-* *** CRAY 1, XMP, 2, AND 3 ***
- IMACH(1) = 5
- IMACH(2) = 6
- IMACH(3) = 102
- IMACH(4) = 6
- IMACH(5) = 46
- IMACH(6) = 8
- IMACH(7) = 2
- IMACH(8) = 45
- CALL I1MCR1(IMACH(9), K, 0, 4194303, 16777215)
- IMACH(10) = 2
- IMACH(11) = 47
- IMACH(12) = -8188
- IMACH(13) = 8189
- IMACH(14) = 94
- IMACH(15) = -8141
- IMACH(16) = 8189
- GO TO 35
- END IF
- END IF
- IMACH( 1) = 5
- IMACH( 2) = 6
- IMACH( 3) = 7
- IMACH( 4) = 6
- IMACH( 5) = 32
- IMACH( 6) = 4
- IMACH( 7) = 2
- IMACH( 8) = 31
- IMACH( 9) = 2147483647
- 35 SC = 987
- END IF
- 9010 FORMAT(/' Adjust autodoubled I1MACH by uncommenting data'/
- * ' statements appropriate for your machine and setting'/
- * ' IMACH(I) = IMACH(I+3) for I = 11, 12, and 13.')
- 9020 FORMAT(/' Adjust I1MACH by uncommenting data statements'/
- * ' appropriate for your machine.')
- IF (I .LT. 1 .OR. I .GT. 16) GO TO 40
- I1MACH = IMACH(I)
- RETURN
- 40 WRITE(*,*) 'I1MACH(I): I =',I,' is out of bounds.'
- STOP
-* /* C source for I1MACH -- remove the * in column 1 */
-* /* Note that some values may need changing. */
-*#include <stdio.h>
-*#include <float.h>
-*#include <limits.h>
-*#include <math.h>
-*
-*long i1mach_(long *i)
-*{
-* switch(*i){
-* case 1: return 5; /* standard input */
-* case 2: return 6; /* standard output */
-* case 3: return 7; /* standard punch */
-* case 4: return 0; /* standard error */
-* case 5: return 32; /* bits per integer */
-* case 6: return sizeof(int);
-* case 7: return 2; /* base for integers */
-* case 8: return 31; /* digits of integer base */
-* case 9: return LONG_MAX;
-* case 10: return FLT_RADIX;
-* case 11: return FLT_MANT_DIG;
-* case 12: return FLT_MIN_EXP;
-* case 13: return FLT_MAX_EXP;
-* case 14: return DBL_MANT_DIG;
-* case 15: return DBL_MIN_EXP;
-* case 16: return DBL_MAX_EXP;
-* }
-* fprintf(stderr, "invalid argument: i1mach(%ld)\n", *i);
-* exit(1);return 0; /* some compilers demand return values */
-*}
- END
- SUBROUTINE I1MCR1(A, A1, B, C, D)
-**** SPECIAL COMPUTATION FOR OLD CRAY MACHINES ****
- INTEGER A, A1, B, C, D
- A1 = 16777216*B + C
- A = 16777216*A1 + D
- END
diff --git a/CEP/PyBDSM/src/port3/i7copy.f b/CEP/PyBDSM/src/port3/i7copy.f
deleted file mode 100644
index c421fe03bdb04c39238f69d427b19cf842415e7d..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/i7copy.f
+++ /dev/null
@@ -1,13 +0,0 @@
- SUBROUTINE I7COPY(P, Y, X)
-C
-C *** SET Y = X, WHERE X AND Y ARE INTEGER P-VECTORS ***
-C
- INTEGER P
- INTEGER X(P), Y(P)
-C
- INTEGER I
-C
- DO 10 I = 1, P
- 10 Y(I) = X(I)
- 999 RETURN
- END
diff --git a/CEP/PyBDSM/src/port3/i7do.f b/CEP/PyBDSM/src/port3/i7do.f
deleted file mode 100644
index 5dde294c4b4661a3416fe14b527a845a26f8a537..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/i7do.f
+++ /dev/null
@@ -1,273 +0,0 @@
- SUBROUTINE I7DO(M,N,INDROW,JPNTR,INDCOL,IPNTR,NDEG,LIST,
- * MAXCLQ,IWA1,IWA2,IWA3,IWA4,BWA)
- INTEGER M,N,MAXCLQ
- INTEGER INDROW(1),JPNTR(1),INDCOL(1),IPNTR(1),NDEG(N),LIST(N),
- * IWA1(N),IWA2(N),IWA3(N),IWA4(N)
- LOGICAL BWA(N)
-C **********
-C
-C SUBROUTINE I7DO
-C
-C GIVEN THE SPARSITY PATTERN OF AN M BY N MATRIX A, THIS
-C SUBROUTINE DETERMINES AN INCIDENCE-DEGREE ORDERING OF THE
-C COLUMNS OF A.
-C
-C THE INCIDENCE-DEGREE ORDERING IS DEFINED FOR THE LOOPLESS
-C GRAPH G WITH VERTICES A(J), J = 1,2,...,N WHERE A(J) IS THE
-C J-TH COLUMN OF A AND WITH EDGE (A(I),A(J)) IF AND ONLY IF
-C COLUMNS I AND J HAVE A NON-ZERO IN THE SAME ROW POSITION.
-C
-C AT EACH STAGE OF I7DO, A COLUMN OF MAXIMAL INCIDENCE IS
-C CHOSEN AND ORDERED. IF JCOL IS AN UN-ORDERED COLUMN, THEN
-C THE INCIDENCE OF JCOL IS THE NUMBER OF ORDERED COLUMNS
-C ADJACENT TO JCOL IN THE GRAPH G. AMONG ALL THE COLUMNS OF
-C MAXIMAL INCIDENCE,I7DO CHOOSES A COLUMN OF MAXIMAL DEGREE.
-C
-C THE SUBROUTINE STATEMENT IS
-C
-C SUBROUTINE I7DO(M,N,INDROW,JPNTR,INDCOL,IPNTR,NDEG,LIST,
-C MAXCLQ,IWA1,IWA2,IWA3,IWA4,BWA)
-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 INDROW IS AN INTEGER INPUT ARRAY WHICH CONTAINS THE ROW
-C INDICES FOR THE NON-ZEROES IN THE MATRIX A.
-C
-C JPNTR IS AN INTEGER INPUT ARRAY OF LENGTH N + 1 WHICH
-C SPECIFIES THE LOCATIONS OF THE ROW INDICES IN INDROW.
-C THE ROW INDICES FOR COLUMN J ARE
-C
-C INDROW(K), K = JPNTR(J),...,JPNTR(J+1)-1.
-C
-C NOTE THAT JPNTR(N+1)-1 IS THEN THE NUMBER OF NON-ZERO
-C ELEMENTS OF THE MATRIX A.
-C
-C INDCOL IS AN INTEGER INPUT ARRAY WHICH CONTAINS THE
-C COLUMN INDICES FOR THE NON-ZEROES IN THE MATRIX A.
-C
-C IPNTR IS AN INTEGER INPUT ARRAY OF LENGTH M + 1 WHICH
-C SPECIFIES THE LOCATIONS OF THE COLUMN INDICES IN INDCOL.
-C THE COLUMN INDICES FOR ROW I ARE
-C
-C INDCOL(K), K = IPNTR(I),...,IPNTR(I+1)-1.
-C
-C NOTE THAT IPNTR(M+1)-1 IS THEN THE NUMBER OF NON-ZERO
-C ELEMENTS OF THE MATRIX A.
-C
-C NDEG IS AN INTEGER INPUT ARRAY OF LENGTH N WHICH SPECIFIES
-C THE DEGREE SEQUENCE. THE DEGREE OF THE J-TH COLUMN
-C OF A IS NDEG(J).
-C
-C LIST IS AN INTEGER OUTPUT ARRAY OF LENGTH N WHICH SPECIFIES
-C THE INCIDENCE-DEGREE ORDERING OF THE COLUMNS OF A. THE J-TH
-C COLUMN IN THIS ORDER IS LIST(J).
-C
-C MAXCLQ IS AN INTEGER OUTPUT VARIABLE SET TO THE SIZE
-C OF THE LARGEST CLIQUE FOUND DURING THE ORDERING.
-C
-C IWA1,IWA2,IWA3, AND IWA4 ARE INTEGER WORK ARRAYS OF LENGTH N.
-C
-C BWA IS A LOGICAL WORK ARRAY OF LENGTH N.
-C
-C SUBPROGRAMS CALLED
-C
-C MINPACK-SUPPLIED ... N7MSRT
-C
-C FORTRAN-SUPPLIED ... MAX0
-C
-C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. JUNE 1982.
-C THOMAS F. COLEMAN, BURTON S. GARBOW, JORGE J. MORE
-C
-C **********
- INTEGER DEG,HEAD,IC,IP,IPL,IPU,IR,JCOL,JP,JPL,JPU,L,MAXINC,
- * MAXLST,NCOMP,NUMINC,NUMLST,NUMORD,NUMWGT
-C
-C SORT THE DEGREE SEQUENCE.
-C
- CALL N7MSRT(N,N-1,NDEG,-1,IWA4,IWA1,IWA3)
-C
-C INITIALIZATION BLOCK.
-C
-C CREATE A DOUBLY-LINKED LIST TO ACCESS THE INCIDENCES OF THE
-C COLUMNS. THE POINTERS FOR THE LINKED LIST ARE AS FOLLOWS.
-C
-C EACH UN-ORDERED COLUMN JCOL IS IN A LIST (THE INCIDENCE LIST)
-C OF COLUMNS WITH THE SAME INCIDENCE.
-C
-C IWA1(NUMINC+1) IS THE FIRST COLUMN IN THE NUMINC LIST
-C UNLESS IWA1(NUMINC+1) = 0. IN THIS CASE THERE ARE
-C NO COLUMNS IN THE NUMINC LIST.
-C
-C IWA2(JCOL) IS THE COLUMN BEFORE JCOL IN THE INCIDENCE LIST
-C UNLESS IWA2(JCOL) = 0. IN THIS CASE JCOL IS THE FIRST
-C COLUMN IN THIS INCIDENCE LIST.
-C
-C IWA3(JCOL) IS THE COLUMN AFTER JCOL IN THE INCIDENCE LIST
-C UNLESS IWA3(JCOL) = 0. IN THIS CASE JCOL IS THE LAST
-C COLUMN IN THIS INCIDENCE LIST.
-C
-C IF JCOL IS AN UN-ORDERED COLUMN, THEN LIST(JCOL) IS THE
-C INCIDENCE OF JCOL IN THE GRAPH. IF JCOL IS AN ORDERED COLUMN,
-C THEN LIST(JCOL) IS THE INCIDENCE-DEGREE ORDER OF COLUMN JCOL.
-C
- MAXINC = 0
- DO 10 JP = 1, N
- LIST(JP) = 0
- BWA(JP) = .FALSE.
- IWA1(JP) = 0
- L = IWA4(JP)
- IF (JP .NE. 1) IWA2(L) = IWA4(JP-1)
- IF (JP .NE. N) IWA3(L) = IWA4(JP+1)
- 10 CONTINUE
- IWA1(1) = IWA4(1)
- L = IWA4(1)
- IWA2(L) = 0
- L = IWA4(N)
- IWA3(L) = 0
-C
-C DETERMINE THE MAXIMAL SEARCH LENGTH FOR THE LIST
-C OF COLUMNS OF MAXIMAL INCIDENCE.
-C
- MAXLST = 0
- DO 20 IR = 1, M
- MAXLST = MAXLST + (IPNTR(IR+1) - IPNTR(IR))**2
- 20 CONTINUE
- MAXLST = MAXLST/N
- MAXCLQ = 1
-C
-C BEGINNING OF ITERATION LOOP.
-C
- DO 140 NUMORD = 1, N
-C
-C CHOOSE A COLUMN JCOL OF MAXIMAL DEGREE AMONG THE
-C COLUMNS OF MAXIMAL INCIDENCE.
-C
- JP = IWA1(MAXINC+1)
- NUMLST = 1
- NUMWGT = -1
- 30 CONTINUE
- IF (NDEG(JP) .LE. NUMWGT) GO TO 40
- NUMWGT = NDEG(JP)
- JCOL = JP
- 40 CONTINUE
- JP = IWA3(JP)
- NUMLST = NUMLST + 1
- IF (JP .GT. 0 .AND. NUMLST .LE. MAXLST) GO TO 30
- LIST(JCOL) = NUMORD
-C
-C DELETE COLUMN JCOL FROM THE LIST OF COLUMNS OF
-C MAXIMAL INCIDENCE.
-C
- L = IWA2(JCOL)
- IF (L .EQ. 0) IWA1(MAXINC+1) = IWA3(JCOL)
- IF (L .GT. 0) IWA3(L) = IWA3(JCOL)
- L = IWA3(JCOL)
- IF (L .GT. 0) IWA2(L) = IWA2(JCOL)
-C
-C UPDATE THE SIZE OF THE LARGEST CLIQUE
-C FOUND DURING THE ORDERING.
-C
- IF (MAXINC .EQ. 0) NCOMP = 0
- NCOMP = NCOMP + 1
- IF (MAXINC + 1 .EQ. NCOMP) MAXCLQ = MAX0(MAXCLQ,NCOMP)
-C
-C UPDATE THE MAXIMAL INCIDENCE COUNT.
-C
- 50 CONTINUE
- IF (IWA1(MAXINC+1) .GT. 0) GO TO 60
- MAXINC = MAXINC - 1
- IF (MAXINC .GE. 0) GO TO 50
- 60 CONTINUE
-C
-C FIND ALL COLUMNS ADJACENT TO COLUMN JCOL.
-C
- BWA(JCOL) = .TRUE.
- DEG = 0
-C
-C DETERMINE ALL POSITIONS (IR,JCOL) WHICH CORRESPOND
-C TO NON-ZEROES IN THE MATRIX.
-C
- JPL = JPNTR(JCOL)
- JPU = JPNTR(JCOL+1) - 1
- IF (JPU .LT. JPL) GO TO 100
- DO 90 JP = JPL, JPU
- IR = INDROW(JP)
-C
-C FOR EACH ROW IR, DETERMINE ALL POSITIONS (IR,IC)
-C WHICH CORRESPOND TO NON-ZEROES IN THE MATRIX.
-C
- IPL = IPNTR(IR)
- IPU = IPNTR(IR+1) - 1
- DO 80 IP = IPL, IPU
- IC = INDCOL(IP)
-C
-C ARRAY BWA MARKS COLUMNS WHICH ARE ADJACENT TO
-C COLUMN JCOL. ARRAY IWA4 RECORDS THE MARKED COLUMNS.
-C
- IF (BWA(IC)) GO TO 70
- BWA(IC) = .TRUE.
- DEG = DEG + 1
- IWA4(DEG) = IC
- 70 CONTINUE
- 80 CONTINUE
- 90 CONTINUE
- 100 CONTINUE
-C
-C UPDATE THE POINTERS TO THE INCIDENCE LISTS.
-C
- IF (DEG .LT. 1) GO TO 130
- DO 120 JP = 1, DEG
- IC = IWA4(JP)
- IF (LIST(IC) .GT. 0) GO TO 110
- NUMINC = -LIST(IC) + 1
- LIST(IC) = -NUMINC
- MAXINC = MAX0(MAXINC,NUMINC)
-C
-C DELETE COLUMN IC FROM THE NUMINC-1 LIST.
-C
- L = IWA2(IC)
- IF (L .EQ. 0) IWA1(NUMINC) = IWA3(IC)
- IF (L .GT. 0) IWA3(L) = IWA3(IC)
- L = IWA3(IC)
- IF (L .GT. 0) IWA2(L) = IWA2(IC)
-C
-C ADD COLUMN IC TO THE NUMINC LIST.
-C
- HEAD = IWA1(NUMINC+1)
- IWA1(NUMINC+1) = IC
- IWA2(IC) = 0
- IWA3(IC) = HEAD
- IF (HEAD .GT. 0) IWA2(HEAD) = IC
- 110 CONTINUE
-C
-C UN-MARK COLUMN IC IN THE ARRAY BWA.
-C
- BWA(IC) = .FALSE.
- 120 CONTINUE
- 130 CONTINUE
- BWA(JCOL) = .FALSE.
-C
-C END OF ITERATION LOOP.
-C
- 140 CONTINUE
-C
-C INVERT THE ARRAY LIST.
-C
- DO 150 JCOL = 1, N
- NUMORD = LIST(JCOL)
- IWA1(NUMORD) = JCOL
- 150 CONTINUE
- DO 160 JP = 1, N
- LIST(JP) = IWA1(JP)
- 160 CONTINUE
- RETURN
-C
-C LAST CARD OF SUBROUTINE I7DO.
-C
- END
diff --git a/CEP/PyBDSM/src/port3/i7mdcn.f b/CEP/PyBDSM/src/port3/i7mdcn.f
deleted file mode 100644
index ea2fb8b71fb6934c18f006bb8c1a8485fa398f7a..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/i7mdcn.f
+++ /dev/null
@@ -1,28 +0,0 @@
- INTEGER FUNCTION I7MDCN(K)
-C
- INTEGER K
-C
-C *** RETURN INTEGER MACHINE-DEPENDENT CONSTANTS ***
-C
-C *** K = 1 MEANS RETURN STANDARD OUTPUT UNIT NUMBER. ***
-C *** K = 2 MEANS RETURN ALTERNATE OUTPUT UNIT NUMBER. ***
-C *** K = 3 MEANS RETURN INPUT UNIT NUMBER. ***
-C (NOTE -- K = 2, 3 ARE USED ONLY BY TEST PROGRAMS.)
-C
-C +++ PORT VERSION FOLLOWS...
- INTEGER I1MACH
- EXTERNAL I1MACH
- INTEGER MDPERM(3)
- DATA MDPERM(1)/2/, MDPERM(2)/4/, MDPERM(3)/1/
- I7MDCN = I1MACH(MDPERM(K))
-C +++ END OF PORT VERSION +++
-C
-C +++ NON-PORT VERSION FOLLOWS...
-C INTEGER MDCON(3)
-C DATA MDCON(1)/6/, MDCON(2)/8/, MDCON(3)/5/
-C I7MDCN = MDCON(K)
-C +++ END OF NON-PORT VERSION +++
-C
- 999 RETURN
-C *** LAST CARD OF I7MDCN FOLLOWS ***
- END
diff --git a/CEP/PyBDSM/src/port3/i7pnvr.f b/CEP/PyBDSM/src/port3/i7pnvr.f
deleted file mode 100644
index c041afa15077a2ce306ca7a93df84ef8f5b1ae98..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/i7pnvr.f
+++ /dev/null
@@ -1,16 +0,0 @@
- SUBROUTINE I7PNVR(N, X, Y)
-C
-C *** SET PERMUTATION VECTOR X TO INVERSE OF Y ***
-C
- INTEGER N
- INTEGER X(N), Y(N)
-C
- INTEGER I, J
- DO 10 I = 1, N
- J = Y(I)
- X(J) = I
- 10 CONTINUE
-C
- 999 RETURN
-C *** LAST LINE OF I7PNVR FOLLOWS ***
- END
diff --git a/CEP/PyBDSM/src/port3/i7shft.f b/CEP/PyBDSM/src/port3/i7shft.f
deleted file mode 100644
index 364041432f2007f15dc530d9c4ce72a4e388780d..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/i7shft.f
+++ /dev/null
@@ -1,31 +0,0 @@
- SUBROUTINE I7SHFT(N, K, X)
-C
-C *** SHIFT X(K),...,X(N) LEFT CIRCULARLY ONE POSITION IF K .GT. 0.
-C *** SHIFT X(-K),...,X(N) RIGHT CIRCULARLY ONE POSITION IF K .LT. 0.
-C
- INTEGER N, K
- INTEGER X(N)
-C
- INTEGER I, II, K1, NM1, T
-C
- IF (K .LT. 0) GO TO 20
- IF (K .GE. N) GO TO 999
- NM1 = N - 1
- T = X(K)
- DO 10 I = K, NM1
- 10 X(I) = X(I+1)
- X(N) = T
- GO TO 999
-C
- 20 K1 = -K
- IF (K1 .GE. N) GO TO 999
- T = X(N)
- NM1 = N - K1
- DO 30 II = 1, NM1
- I = N - II
- X(I+1) = X(I)
- 30 CONTINUE
- X(K1) = T
- 999 RETURN
-C *** LAST LINE OF I7SHFT FOLLOWS ***
- END
diff --git a/CEP/PyBDSM/src/port3/i8save.f b/CEP/PyBDSM/src/port3/i8save.f
deleted file mode 100644
index 63ab4dbdddffbfb5efb26d8235cca6c1acda6a08..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/i8save.f
+++ /dev/null
@@ -1,23 +0,0 @@
- INTEGER FUNCTION I8SAVE(ISW,IVALUE,SET)
-C
-C IF (ISW = 1) I8SAVE RETURNS THE CURRENT ERROR NUMBER AND
-C SETS IT TO IVALUE IF SET = .TRUE. .
-C
-C IF (ISW = 2) I8SAVE RETURNS THE CURRENT RECOVERY SWITCH AND
-C SETS IT TO IVALUE IF SET = .TRUE. .
-C
- LOGICAL SET
-C
- INTEGER IPARAM(2)
- EQUIVALENCE (IPARAM(1),LERROR) , (IPARAM(2),LRECOV)
-C
-C START EXECUTION ERROR FREE AND WITH RECOVERY TURNED OFF.
-C
- DATA LERROR/0/ , LRECOV/2/
-C
- I8SAVE=IPARAM(ISW)
- IF (SET) IPARAM(ISW)=IVALUE
-C
- RETURN
-C
- END
diff --git a/CEP/PyBDSM/src/port3/i8tsel.f b/CEP/PyBDSM/src/port3/i8tsel.f
deleted file mode 100644
index 687d2a7b303ef9d316e864e048d8106122a0444a..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/i8tsel.f
+++ /dev/null
@@ -1,15 +0,0 @@
- INTEGER FUNCTION I8TSEL(INOW)
-C
-C TO RETURN I8TSEL = THE POINTER TO THE CURRENT ENTER-BLOCK AND
-C SET THE CURRENT POINTER TO INOW.
-C
-C START WITH NO BACK-POINTER.
-C
- DATA IENTER/0/
-C
- I8TSEL=IENTER
- IF (INOW.GE.0) IENTER=INOW
-C
- RETURN
-C
- END
diff --git a/CEP/PyBDSM/src/port3/ialloc.f b/CEP/PyBDSM/src/port3/ialloc.f
deleted file mode 100644
index c3d4d48b14388a372711321c7f5e53ebacc21191..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ialloc.f
+++ /dev/null
@@ -1,8 +0,0 @@
- INTEGER FUNCTION IALLOC(NITEMS,ISIZE)
-C
- CALL I0TK01
- IALLOC = ISTKGT(NITEMS,ISIZE+2)
-C
- RETURN
-C
- END
diff --git a/CEP/PyBDSM/src/port3/iceil.f b/CEP/PyBDSM/src/port3/iceil.f
deleted file mode 100644
index 6e680f7b2fd8bbc8fd9df00a94505a6a58c4d93d..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/iceil.f
+++ /dev/null
@@ -1,10 +0,0 @@
- INTEGER FUNCTION ICEIL(X)
-C
-C ICEIL RETURNS CEIL(X)
-C
- ICEIL = INT(X)
- IF (X .LE. 0.0) RETURN
- IF (FLOAT(ICEIL) .NE. X) ICEIL = ICEIL + 1
-C
- RETURN
- END
diff --git a/CEP/PyBDSM/src/port3/iflr.f b/CEP/PyBDSM/src/port3/iflr.f
deleted file mode 100644
index d731e66620dab19e43343ed582c3c509086e5253..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/iflr.f
+++ /dev/null
@@ -1,10 +0,0 @@
- INTEGER FUNCTION IFLR(X)
-C
-C IFLR RETURNS FLR(X)
-C
- IFLR = INT(X)
- IF (X .GE. 0.0) RETURN
- IF (FLOAT(IFLR) .NE. X) IFLR = IFLR - 1
-C
- RETURN
- END
diff --git a/CEP/PyBDSM/src/port3/index.html b/CEP/PyBDSM/src/port3/index.html
deleted file mode 100644
index 212d94cd659d46667b8151417987615e8216cfa5..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/index.html
+++ /dev/null
@@ -1,766 +0,0 @@
-<head>
-<title>port</title>
-<meta name="waisindex" value="nse">
-</head>
-<h1>port</h1>
-<p>
-Click <A HREF="http://www.netlib.org/master_counts2.html#port">here</A> to see the number of accesses to this library.
-<p><hr>
-<pre>
-file <a href="readme">readme</a>
-for important notes on the PORT library
-, Note that dxxxxx.f is the double-precision version of xxxxx.f.
-, To get routine xxx.f and all the PORT library routines it calls,
-, send the E-mail message
-, send xxx from port
-, to netlib@netlib.bell-labs.com
-, Also: points to "Usage Summary for Selected Optimization Routines"
-, sometimes known as PORT OPTIMIZATION DOCUMENTATION in
-, http://netlib.bell-labs.com/cm/cs/cstr/153.ps.gz
-, or http://netlib.bell-labs.com/cm/cs/cstr/153.pdf
-
-file <a href="a0xtrp.f">a0xtrp.f</a>
-
-file <a href="a7sst.f">a7sst.f</a>
-
-file <a href="a9rntc.f">a9rntc.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/a9rntc.f">a9rntc.f plus dependencies</a>
-
-file <a href="a9rntd.f">a9rntd.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/a9rntd.f">a9rntd.f plus dependencies</a>
-
-file <a href="a9rnti.f">a9rnti.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/a9rnti.f">a9rnti.f plus dependencies</a>
-
-file <a href="a9rntl.f">a9rntl.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/a9rntl.f">a9rntl.f plus dependencies</a>
-
-file <a href="a9rntr.f">a9rntr.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/a9rntr.f">a9rntr.f plus dependencies</a>
-
-file <a href="aprntc.f">aprntc.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/aprntc.f">aprntc.f plus dependencies</a>
-for complex array print
-
-file <a href="aprntd.f">aprntd.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/aprntd.f">aprntd.f plus dependencies</a>
-for double precision array print
-
-file <a href="aprnti.f">aprnti.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/aprnti.f">aprnti.f plus dependencies</a>
-for integer array print
-
-file <a href="aprntl.f">aprntl.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/aprntl.f">aprntl.f plus dependencies</a>
-for logical array print
-
-file <a href="aprntr.f">aprntr.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/aprntr.f">aprntr.f plus dependencies</a>
-for single precision array print
-
-file <a href="c7vfn.f">c7vfn.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/c7vfn.f">c7vfn.f plus dependencies</a>
-
-file <a href="call.f">call.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/call.f">call.f plus dependencies</a>
-
-file <a href="cddiv.f">cddiv.f</a>
-
-file <a href="changes">changes</a>
-for errata
-
-file <a href="d0xtrp.f">d0xtrp.f</a>
-
-file <a href="d1mach.f">d1mach.f</a>
-for double-precision machine constants
-
-file <a href="d4sqr.f">d4sqr.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/d4sqr.f">d4sqr.f plus dependencies</a>
-
-file <a href="d7dgb.f">d7dgb.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/d7dgb.f">d7dgb.f plus dependencies</a>
-
-file <a href="d7dog.f">d7dog.f</a>
-
-file <a href="d7dup.f">d7dup.f</a>
-
-file <a href="d7egr.f">d7egr.f</a>
-
-file <a href="d7mlp.f">d7mlp.f</a>
-
-file <a href="d7tpr.f">d7tpr.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/d7tpr.f">d7tpr.f plus dependencies</a>
-
-file <a href="d7upd.f">d7upd.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/d7upd.f">d7upd.f plus dependencies</a>
-
-file <a href="da7sst.f">da7sst.f</a>
-
-file <a href="dalloc.f">dalloc.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/dalloc.f">dalloc.f plus dependencies</a>
-
-file <a href="dc7vfn.f">dc7vfn.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/dc7vfn.f">dc7vfn.f plus dependencies</a>
-
-file <a href="dd4sqr.f">dd4sqr.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/dd4sqr.f">dd4sqr.f plus dependencies</a>
-
-file <a href="dd7dgb.f">dd7dgb.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/dd7dgb.f">dd7dgb.f plus dependencies</a>
-
-file <a href="dd7dog.f">dd7dog.f</a>
-
-file <a href="dd7dup.f">dd7dup.f</a>
-
-file <a href="dd7mlp.f">dd7mlp.f</a>
-
-file <a href="dd7tpr.f">dd7tpr.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/dd7tpr.f">dd7tpr.f plus dependencies</a>
-
-file <a href="dd7upd.f">dd7upd.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/dd7upd.f">dd7upd.f plus dependencies</a>
-
-file <a href="deigen.f">deigen.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/deigen.f">deigen.f plus dependencies</a>
-
-file <a href="df7dhb.f">df7dhb.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/df7dhb.f">df7dhb.f plus dependencies</a>
-
-file <a href="df7hes.f">df7hes.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/df7hes.f">df7hes.f plus dependencies</a>
-
-file <a href="dg7itb.f">dg7itb.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/dg7itb.f">dg7itb.f plus dependencies</a>
-
-file <a href="dg7lit.f">dg7lit.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/dg7lit.f">dg7lit.f plus dependencies</a>
-
-file <a href="dg7qsb.f">dg7qsb.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/dg7qsb.f">dg7qsb.f plus dependencies</a>
-
-file <a href="dg7qts.f">dg7qts.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/dg7qts.f">dg7qts.f plus dependencies</a>
-
-file <a href="dh2rfa.f">dh2rfa.f</a>
-
-file <a href="dh2rfg.f">dh2rfg.f</a>
-
-file <a href="dhqr2.f">dhqr2.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/dhqr2.f">dhqr2.f plus dependencies</a>
-
-file <a href="ditsum.f">ditsum.f</a>
-
-file <a href="divset.f">divset.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/divset.f">divset.f plus dependencies</a>
-
-file <a href="dl7itv.f">dl7itv.f</a>
-
-file <a href="dl7ivm.f">dl7ivm.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/dl7ivm.f">dl7ivm.f plus dependencies</a>
-
-file <a href="dl7msb.f">dl7msb.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/dl7msb.f">dl7msb.f plus dependencies</a>
-
-file <a href="dl7mst.f">dl7mst.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/dl7mst.f">dl7mst.f plus dependencies</a>
-
-file <a href="dl7nvr.f">dl7nvr.f</a>
-
-file <a href="dl7sqr.f">dl7sqr.f</a>
-
-file <a href="dl7srt.f">dl7srt.f</a>
-
-file <a href="dl7svn.f">dl7svn.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/dl7svn.f">dl7svn.f plus dependencies</a>
-
-file <a href="dl7svx.f">dl7svx.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/dl7svx.f">dl7svx.f plus dependencies</a>
-
-file <a href="dl7tsq.f">dl7tsq.f</a>
-
-file <a href="dl7tvm.f">dl7tvm.f</a>
-
-file <a href="dl7upd.f">dl7upd.f</a>
-
-file <a href="dl7vml.f">dl7vml.f</a>
-
-file <a href="dmnf.f">dmnf.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/dmnf.f">dmnf.f plus dependencies</a>
-
-file <a href="dmnfb.f">dmnfb.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/dmnfb.f">dmnfb.f plus dependencies</a>
-
-file <a href="dmng.f">dmng.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/dmng.f">dmng.f plus dependencies</a>
-
-file <a href="dmngb.f">dmngb.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/dmngb.f">dmngb.f plus dependencies</a>
-
-file <a href="dmnh.f">dmnh.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/dmnh.f">dmnh.f plus dependencies</a>
-
-file <a href="dmnhb.f">dmnhb.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/dmnhb.f">dmnhb.f plus dependencies</a>
-
-file <a href="dn2cvp.f">dn2cvp.f</a>
-
-file <a href="dn2f.f">dn2f.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/dn2f.f">dn2f.f plus dependencies</a>
-
-file <a href="dn2fb.f">dn2fb.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/dn2fb.f">dn2fb.f plus dependencies</a>
-
-file <a href="dn2g.f">dn2g.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/dn2g.f">dn2g.f plus dependencies</a>
-
-file <a href="dn2gb.f">dn2gb.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/dn2gb.f">dn2gb.f plus dependencies</a>
-
-file <a href="dn2lrd.f">dn2lrd.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/dn2lrd.f">dn2lrd.f plus dependencies</a>
-
-file <a href="dn2p.f">dn2p.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/dn2p.f">dn2p.f plus dependencies</a>
-
-file <a href="dn2pb.f">dn2pb.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/dn2pb.f">dn2pb.f plus dependencies</a>
-
-file <a href="dn2rdp.f">dn2rdp.f</a>
-
-file <a href="dnsf.f">dnsf.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/dnsf.f">dnsf.f plus dependencies</a>
-
-file <a href="dnsfb.f">dnsfb.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/dnsfb.f">dnsfb.f plus dependencies</a>
-
-file <a href="dnsg.f">dnsg.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/dnsg.f">dnsg.f plus dependencies</a>
-
-file <a href="dnsgb.f">dnsgb.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/dnsgb.f">dnsgb.f plus dependencies</a>
-
-file <a href="do7prd.f">do7prd.f</a>
-
-file <a href="dorthe.f">dorthe.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/dorthe.f">dorthe.f plus dependencies</a>
-
-file <a href="dortra.f">dortra.f</a>
-
-file <a href="dparck.f">dparck.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/dparck.f">dparck.f plus dependencies</a>
-
-file <a href="dpostx1.f">dpostx1.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/dpostx1.f">dpostx1.f plus dependencies</a>
-
-file <a href="dpostx10.f">dpostx10.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/dpostx10.f">dpostx10.f plus dependencies</a>
-
-file <a href="dpostx2.f">dpostx2.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/dpostx2.f">dpostx2.f plus dependencies</a>
-
-file <a href="dpostx3.f">dpostx3.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/dpostx3.f">dpostx3.f plus dependencies</a>
-
-file <a href="dpostx4.f">dpostx4.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/dpostx4.f">dpostx4.f plus dependencies</a>
-
-file <a href="dpostx5.f">dpostx5.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/dpostx5.f">dpostx5.f plus dependencies</a>
-
-file <a href="dpostx6.f">dpostx6.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/dpostx6.f">dpostx6.f plus dependencies</a>
-
-file <a href="dpostx7.f">dpostx7.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/dpostx7.f">dpostx7.f plus dependencies</a>
-
-file <a href="dpostx8.f">dpostx8.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/dpostx8.f">dpostx8.f plus dependencies</a>
-
-file <a href="dpostx9.f">dpostx9.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/dpostx9.f">dpostx9.f plus dependencies</a>
-
-file <a href="dq7apl.f">dq7apl.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/dq7apl.f">dq7apl.f plus dependencies</a>
-
-file <a href="dq7rad.f">dq7rad.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/dq7rad.f">dq7rad.f plus dependencies</a>
-
-file <a href="dq7rfh.f">dq7rfh.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/dq7rfh.f">dq7rfh.f plus dependencies</a>
-
-file <a href="dq7rsh.f">dq7rsh.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/dq7rsh.f">dq7rsh.f plus dependencies</a>
-
-file <a href="dr7mdc.f">dr7mdc.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/dr7mdc.f">dr7mdc.f plus dependencies</a>
-
-file <a href="dr7tvm.f">dr7tvm.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/dr7tvm.f">dr7tvm.f plus dependencies</a>
-
-file <a href="drldst.f">drldst.f</a>
-
-file <a href="drmnf.f">drmnf.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/drmnf.f">drmnf.f plus dependencies</a>
-
-file <a href="drmnfb.f">drmnfb.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/drmnfb.f">drmnfb.f plus dependencies</a>
-
-file <a href="drmng.f">drmng.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/drmng.f">drmng.f plus dependencies</a>
-
-file <a href="drmngb.f">drmngb.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/drmngb.f">drmngb.f plus dependencies</a>
-
-file <a href="drmnh.f">drmnh.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/drmnh.f">drmnh.f plus dependencies</a>
-
-file <a href="drmnhb.f">drmnhb.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/drmnhb.f">drmnhb.f plus dependencies</a>
-
-file <a href="drn2g.f">drn2g.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/drn2g.f">drn2g.f plus dependencies</a>
-
-file <a href="drn2gb.f">drn2gb.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/drn2gb.f">drn2gb.f plus dependencies</a>
-
-file <a href="drnsg.f">drnsg.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/drnsg.f">drnsg.f plus dependencies</a>
-
-file <a href="drnsgb.f">drnsgb.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/drnsgb.f">drnsgb.f plus dependencies</a>
-
-file <a href="ds3grd.f">ds3grd.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/ds3grd.f">ds3grd.f plus dependencies</a>
-
-file <a href="ds7bqn.f">ds7bqn.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/ds7bqn.f">ds7bqn.f plus dependencies</a>
-
-file <a href="ds7cpr.f">ds7cpr.f</a>
-
-file <a href="ds7dmp.f">ds7dmp.f</a>
-
-file <a href="ds7grd.f">ds7grd.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/ds7grd.f">ds7grd.f plus dependencies</a>
-
-file <a href="ds7ipr.f">ds7ipr.f</a>
-
-file <a href="ds7lup.f">ds7lup.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/ds7lup.f">ds7lup.f plus dependencies</a>
-
-file <a href="ds7lvm.f">ds7lvm.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/ds7lvm.f">ds7lvm.f plus dependencies</a>
-
-file <a href="dsm.f">dsm.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/dsm.f">dsm.f plus dependencies</a>
-
-file <a href="dttgrx1.f">dttgrx1.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/dttgrx1.f">dttgrx1.f plus dependencies</a>
-
-file <a href="dttgrx1p.f">dttgrx1p.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/dttgrx1p.f">dttgrx1p.f plus dependencies</a>
-
-file <a href="dttgrx2.f">dttgrx2.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/dttgrx2.f">dttgrx2.f plus dependencies</a>
-
-file <a href="dttgrx3.f">dttgrx3.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/dttgrx3.f">dttgrx3.f plus dependencies</a>
-
-file <a href="dttgrx4.f">dttgrx4.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/dttgrx4.f">dttgrx4.f plus dependencies</a>
-
-file <a href="dttgrx5.f">dttgrx5.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/dttgrx5.f">dttgrx5.f plus dependencies</a>
-
-file <a href="dttgrx6.f">dttgrx6.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/dttgrx6.f">dttgrx6.f plus dependencies</a>
-
-file <a href="dttgux1.f">dttgux1.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/dttgux1.f">dttgux1.f plus dependencies</a>
-
-file <a href="dttgux1p.f">dttgux1p.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/dttgux1p.f">dttgux1p.f plus dependencies</a>
-
-file <a href="dttgux2.f">dttgux2.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/dttgux2.f">dttgux2.f plus dependencies</a>
-
-file <a href="dttgux3.f">dttgux3.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/dttgux3.f">dttgux3.f plus dependencies</a>
-
-file <a href="dttgux4.f">dttgux4.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/dttgux4.f">dttgux4.f plus dependencies</a>
-
-file <a href="dttgux5.f">dttgux5.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/dttgux5.f">dttgux5.f plus dependencies</a>
-
-file <a href="dv2axy.f">dv2axy.f</a>
-
-file <a href="dv2nrm.f">dv2nrm.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/dv2nrm.f">dv2nrm.f plus dependencies</a>
-
-file <a href="dv7cpy.f">dv7cpy.f</a>
-
-file <a href="dv7dfl.f">dv7dfl.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/dv7dfl.f">dv7dfl.f plus dependencies</a>
-
-file <a href="dv7ipr.f">dv7ipr.f</a>
-
-file <a href="dv7prm.f">dv7prm.f</a>
-
-file <a href="dv7scl.f">dv7scl.f</a>
-
-file <a href="dv7scp.f">dv7scp.f</a>
-
-file <a href="dv7shf.f">dv7shf.f</a>
-
-file <a href="dv7swp.f">dv7swp.f</a>
-
-file <a href="dv7vmp.f">dv7vmp.f</a>
-
-file <a href="dw7zbf.f">dw7zbf.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/dw7zbf.f">dw7zbf.f plus dependencies</a>
-
-file <a href="dxtrap.f">dxtrap.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/dxtrap.f">dxtrap.f plus dependencies</a>
-
-file <a href="dzero.f">dzero.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/dzero.f">dzero.f plus dependencies</a>
-
-file <a href="e9rint.f">e9rint.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/e9rint.f">e9rint.f plus dependencies</a>
-
-file <a href="eigen.f">eigen.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/eigen.f">eigen.f plus dependencies</a>
-for eigenvalues and eigenvectors of a general real matrix
-
-file <a href="enter.f">enter.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/enter.f">enter.f plus dependencies</a>
-for save current error recovery mode and storage allocation status
-
-file <a href="entsrc.f">entsrc.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/entsrc.f">entsrc.f plus dependencies</a>
-for test and set recovery mode (entry)
-
-file <a href="eprint.f">eprint.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/eprint.f">eprint.f plus dependencies</a>
-for print error message
-
-file <a href="erroff.f">erroff.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/erroff.f">erroff.f plus dependencies</a>
-for cancel error state
-
-file <a href="f7dhb.f">f7dhb.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/f7dhb.f">f7dhb.f plus dependencies</a>
-
-file <a href="f7hes.f">f7hes.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/f7hes.f">f7hes.f plus dependencies</a>
-
-file <a href="fdump.f">fdump.f</a>
-
-file <a href="frmatd.f">frmatd.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/frmatd.f">frmatd.f plus dependencies</a>
-
-file <a href="frmati.f">frmati.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/frmati.f">frmati.f plus dependencies</a>
-
-file <a href="frmatr.f">frmatr.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/frmatr.f">frmatr.f plus dependencies</a>
-
-file <a href="g7itb.f">g7itb.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/g7itb.f">g7itb.f plus dependencies</a>
-
-file <a href="g7lit.f">g7lit.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/g7lit.f">g7lit.f plus dependencies</a>
-
-file <a href="g7qsb.f">g7qsb.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/g7qsb.f">g7qsb.f plus dependencies</a>
-
-file <a href="g7qts.f">g7qts.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/g7qts.f">g7qts.f plus dependencies</a>
-
-file <a href="h2rfa.f">h2rfa.f</a>
-
-file <a href="h2rfg.f">h2rfg.f</a>
-
-file <a href="hqr2.f">hqr2.f</a>
-
-file <a href="i0tk00.f">i0tk00.f</a>
-
-file <a href="i0tk01.f">i0tk01.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/i0tk01.f">i0tk01.f plus dependencies</a>
-
-file <a href="i10wid.f">i10wid.f</a>
-
-file <a href="i1mach.f">i1mach.f</a>
-for integer machine constants
-
-file <a href="i7copy.f">i7copy.f</a>
-
-file <a href="i7do.f">i7do.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/i7do.f">i7do.f plus dependencies</a>
-
-file <a href="i7mdcn.f">i7mdcn.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/i7mdcn.f">i7mdcn.f plus dependencies</a>
-
-file <a href="i7pnvr.f">i7pnvr.f</a>
-
-file <a href="i7shft.f">i7shft.f</a>
-
-file <a href="i8save.f">i8save.f</a>
-
-file <a href="i8tsel.f">i8tsel.f</a>
-
-file <a href="ialloc.f">ialloc.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/ialloc.f">ialloc.f plus dependencies</a>
-
-file <a href="iceil.f">iceil.f</a>
-
-file <a href="iflr.f">iflr.f</a>
-
-file <a href="istkgt.f">istkgt.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/istkgt.f">istkgt.f plus dependencies</a>
-for get storage from stack
-
-file <a href="istkin.f">istkin.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/istkin.f">istkin.f plus dependencies</a>
-for initialize stack
-
-file <a href="istkmd.f">istkmd.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/istkmd.f">istkmd.f plus dependencies</a>
-for modify length of last stack allocation
-
-file <a href="istkqu.f">istkqu.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/istkqu.f">istkqu.f plus dependencies</a>
-for query the amount of space left in the stack
-
-file <a href="istkrl.f">istkrl.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/istkrl.f">istkrl.f plus dependencies</a>
-for release stack storage
-
-file <a href="istkst.f">istkst.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/istkst.f">istkst.f plus dependencies</a>
-for obtain stack statistics
-
-file <a href="itsum.f">itsum.f</a>
-
-file <a href="ivset.f">ivset.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/ivset.f">ivset.f plus dependencies</a>
-
-file <a href="l5stp.f">l5stp.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/l5stp.f">l5stp.f plus dependencies</a>
-
-file <a href="l7itv.f">l7itv.f</a>
-
-file <a href="l7ivm.f">l7ivm.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/l7ivm.f">l7ivm.f plus dependencies</a>
-
-file <a href="l7msb.f">l7msb.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/l7msb.f">l7msb.f plus dependencies</a>
-
-file <a href="l7mst.f">l7mst.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/l7mst.f">l7mst.f plus dependencies</a>
-
-file <a href="l7nvr.f">l7nvr.f</a>
-
-file <a href="l7sqr.f">l7sqr.f</a>
-
-file <a href="l7srt.f">l7srt.f</a>
-
-file <a href="l7svn.f">l7svn.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/l7svn.f">l7svn.f plus dependencies</a>
-
-file <a href="l7svx.f">l7svx.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/l7svx.f">l7svx.f plus dependencies</a>
-
-file <a href="l7tsq.f">l7tsq.f</a>
-
-file <a href="l7tvm.f">l7tvm.f</a>
-
-file <a href="l7upd.f">l7upd.f</a>
-
-file <a href="l7vml.f">l7vml.f</a>
-
-file <a href="leave.f">leave.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/leave.f">leave.f plus dependencies</a>
-for restore prior error recovery mode and reset stack
-
-file <a href="m7seq.f">m7seq.f</a>
-
-file <a href="m7slo.f">m7slo.f</a>
-
-file <a href="mnf.f">mnf.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/mnf.f">mnf.f plus dependencies</a>
-for general optimization
-
-file <a href="mnfb.f">mnfb.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/mnfb.f">mnfb.f plus dependencies</a>
-for general optimization, simple bounds
-
-file <a href="mng.f">mng.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/mng.f">mng.f plus dependencies</a>
-for general optimization, needs gradient
-
-file <a href="mngb.f">mngb.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/mngb.f">mngb.f plus dependencies</a>
-for general optimization, needs gradient, simple bounds
-
-file <a href="mnh.f">mnh.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/mnh.f">mnh.f plus dependencies</a>
-for general optimization, needs gradient and Hessian
-
-file <a href="mnhb.f">mnhb.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/mnhb.f">mnhb.f plus dependencies</a>
-for general optimization, needs gradient and Hessian, simple bounds
-
-file <a href="movebc.f">movebc.f</a>
-
-file <a href="movebd.f">movebd.f</a>
-
-file <a href="movebi.f">movebi.f</a>
-
-file <a href="movebl.f">movebl.f</a>
-
-file <a href="movebr.f">movebr.f</a>
-
-file <a href="movefc.f">movefc.f</a>
-
-file <a href="movefd.f">movefd.f</a>
-
-file <a href="movefi.f">movefi.f</a>
-
-file <a href="movefl.f">movefl.f</a>
-
-file <a href="movefr.f">movefr.f</a>
-
-file <a href="mtstak.f">mtstak.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/mtstak.f">mtstak.f plus dependencies</a>
-
-file <a href="n2cvp.f">n2cvp.f</a>
-
-file <a href="n2f.f">n2f.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/n2f.f">n2f.f plus dependencies</a>
-
-file <a href="n2fb.f">n2fb.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/n2fb.f">n2fb.f plus dependencies</a>
-
-file <a href="n2g.f">n2g.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/n2g.f">n2g.f plus dependencies</a>
-
-file <a href="n2gb.f">n2gb.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/n2gb.f">n2gb.f plus dependencies</a>
-
-file <a href="n2lrd.f">n2lrd.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/n2lrd.f">n2lrd.f plus dependencies</a>
-
-file <a href="n2p.f">n2p.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/n2p.f">n2p.f plus dependencies</a>
-
-file <a href="n2pb.f">n2pb.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/n2pb.f">n2pb.f plus dependencies</a>
-
-file <a href="n2rdp.f">n2rdp.f</a>
-
-file <a href="n7msrt.f">n7msrt.f</a>
-
-file <a href="nerror.f">nerror.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/nerror.f">nerror.f plus dependencies</a>
-for get error number
-
-file <a href="nirall.f">nirall.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/nirall.f">nirall.f plus dependencies</a>
-
-file <a href="nsf.f">nsf.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/nsf.f">nsf.f plus dependencies</a>
-for nonlinear separable least squares (update of nl2sno)
-keywords optimization
-
-file <a href="nsfb.f">nsfb.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/nsfb.f">nsfb.f plus dependencies</a>
-for nonlinear separable least squares, simple bounds
-keywords optimization
-
-file <a href="nsg.f">nsg.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/nsg.f">nsg.f plus dependencies</a>
-for nonlinear separable least squares, needs Jacobian (update of nl2sol)
-keywords optimization
-
-file <a href="nsgb.f">nsgb.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/nsgb.f">nsgb.f plus dependencies</a>
-for nonlinear separable least squares, needs Jacobian, simple bounds
-keywords optimization
-
-file <a href="o7prd.f">o7prd.f</a>
-
-file <a href="orthe.f">orthe.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/orthe.f">orthe.f plus dependencies</a>
-
-file <a href="ortra.f">ortra.f</a>
-
-file <a href="parck.f">parck.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/parck.f">parck.f plus dependencies</a>
-
-file <a href="postx1.f">postx1.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/postx1.f">postx1.f plus dependencies</a>
-
-file <a href="postx10.f">postx10.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/postx10.f">postx10.f plus dependencies</a>
-
-file <a href="postx2.f">postx2.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/postx2.f">postx2.f plus dependencies</a>
-
-file <a href="postx3.f">postx3.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/postx3.f">postx3.f plus dependencies</a>
-
-file <a href="postx4.f">postx4.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/postx4.f">postx4.f plus dependencies</a>
-
-file <a href="postx5.f">postx5.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/postx5.f">postx5.f plus dependencies</a>
-
-file <a href="postx6.f">postx6.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/postx6.f">postx6.f plus dependencies</a>
-
-file <a href="postx7.f">postx7.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/postx7.f">postx7.f plus dependencies</a>
-
-file <a href="postx8.f">postx8.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/postx8.f">postx8.f plus dependencies</a>
-
-file <a href="postx9.f">postx9.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/postx9.f">postx9.f plus dependencies</a>
-
-file <a href="q7apl.f">q7apl.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/q7apl.f">q7apl.f plus dependencies</a>
-
-file <a href="q7rad.f">q7rad.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/q7rad.f">q7rad.f plus dependencies</a>
-
-file <a href="q7rfh.f">q7rfh.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/q7rfh.f">q7rfh.f plus dependencies</a>
-
-file <a href="q7rsh.f">q7rsh.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/q7rsh.f">q7rsh.f plus dependencies</a>
-
-file <a href="r1mach.f">r1mach.f</a>
-for real (single-precision) machine constants
-
-file <a href="r7mdc.f">r7mdc.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/r7mdc.f">r7mdc.f plus dependencies</a>
-
-file <a href="r7tvm.f">r7tvm.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/r7tvm.f">r7tvm.f plus dependencies</a>
-
-file <a href="retsrc.f">retsrc.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/retsrc.f">retsrc.f plus dependencies</a>
-for test and reset recovery mode (return)
-
-file <a href="rldst.f">rldst.f</a>
-
-for storage economizing FFT for real data
-
-file <a href="rmnf.f">rmnf.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/rmnf.f">rmnf.f plus dependencies</a>
-for reverse communication version of MNF
-keywords optimization
-
-file <a href="rmnfb.f">rmnfb.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/rmnfb.f">rmnfb.f plus dependencies</a>
-for reverse communication version of MNFB
-keywords optimization
-
-file <a href="rmng.f">rmng.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/rmng.f">rmng.f plus dependencies</a>
-for reverse communication version of MNG
-keywords optimization
-
-file <a href="rmngb.f">rmngb.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/rmngb.f">rmngb.f plus dependencies</a>
-for reverse communication version of MNGB
-keywords optimization
-
-file <a href="rmnh.f">rmnh.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/rmnh.f">rmnh.f plus dependencies</a>
-for reverse communication version of MNH
-keywords optimization
-
-file <a href="rmnhb.f">rmnhb.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/rmnhb.f">rmnhb.f plus dependencies</a>
-for reverse communication version of MNHB
-keywords optimization
-
-file <a href="rn2g.f">rn2g.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/rn2g.f">rn2g.f plus dependencies</a>
-for reverse communication version of N2G
-keywords optimization
-
-file <a href="rn2gb.f">rn2gb.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/rn2gb.f">rn2gb.f plus dependencies</a>
-for reverse communication version of N2GB
-keywords optimization
-
-file <a href="rnsg.f">rnsg.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/rnsg.f">rnsg.f plus dependencies</a>
-for reverse communication version of NSG
-keywords optimization
-
-file <a href="rnsgb.f">rnsgb.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/rnsgb.f">rnsgb.f plus dependencies</a>
-for reverse communication version of NSGB
-keywords optimization
-
-for zeros of real polynomials
-
-file <a href="s1mach.f">s1mach.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/s1mach.f">s1mach.f plus dependencies</a>
-
-file <a href="s2mach.f">s2mach.f</a>
-
-file <a href="s3grd.f">s3grd.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/s3grd.f">s3grd.f plus dependencies</a>
-
-file <a href="s3mach.f">s3mach.f</a>
-
-file <a href="s7bqn.f">s7bqn.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/s7bqn.f">s7bqn.f plus dependencies</a>
-
-file <a href="s7cpr.f">s7cpr.f</a>
-
-file <a href="s7dmp.f">s7dmp.f</a>
-
-file <a href="s7etr.f">s7etr.f</a>
-
-file <a href="s7grd.f">s7grd.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/s7grd.f">s7grd.f plus dependencies</a>
-
-file <a href="s7ipr.f">s7ipr.f</a>
-
-file <a href="s7lup.f">s7lup.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/s7lup.f">s7lup.f plus dependencies</a>
-
-file <a href="s7lvm.f">s7lvm.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/s7lvm.f">s7lvm.f plus dependencies</a>
-
-file <a href="s7rtdt.f">s7rtdt.f</a>
-
-file <a href="s88fmt.f">s88fmt.f</a>
-
-file <a href="sdump.f">sdump.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/sdump.f">sdump.f plus dependencies</a>
-
-file <a href="setc.f">setc.f</a>
-
-file <a href="setd.f">setd.f</a>
-
-file <a href="seterr.f">seterr.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/seterr.f">seterr.f plus dependencies</a>
-for error handling
-
-file <a href="seti.f">seti.f</a>
-
-file <a href="setl.f">setl.f</a>
-
-file <a href="setr.f">setr.f</a>
-
-file <a href="srecap.f">srecap.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/srecap.f">srecap.f plus dependencies</a>
-
-for apply a plane rotation to a vector
-
-for construct Givens plane rotation
-
-file <a href="stinit.f">stinit.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/stinit.f">stinit.f plus dependencies</a>
-
-file <a href="stkdmp.f">stkdmp.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/stkdmp.f">stkdmp.f plus dependencies</a>
-for stack dump
-
-file <a href="stopx.f">stopx.f</a>
-
-file <a href="ttgrx1.f">ttgrx1.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/ttgrx1.f">ttgrx1.f plus dependencies</a>
-
-file <a href="ttgrx1p.f">ttgrx1p.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/ttgrx1p.f">ttgrx1p.f plus dependencies</a>
-
-file <a href="ttgrx2.f">ttgrx2.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/ttgrx2.f">ttgrx2.f plus dependencies</a>
-
-file <a href="ttgrx3.f">ttgrx3.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/ttgrx3.f">ttgrx3.f plus dependencies</a>
-
-file <a href="ttgrx4.f">ttgrx4.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/ttgrx4.f">ttgrx4.f plus dependencies</a>
-
-file <a href="ttgrx5.f">ttgrx5.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/ttgrx5.f">ttgrx5.f plus dependencies</a>
-
-file <a href="ttgrx6.f">ttgrx6.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/ttgrx6.f">ttgrx6.f plus dependencies</a>
-
-file <a href="ttgux1.f">ttgux1.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/ttgux1.f">ttgux1.f plus dependencies</a>
-
-file <a href="ttgux1p.f">ttgux1p.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/ttgux1p.f">ttgux1p.f plus dependencies</a>
-
-file <a href="ttgux2.f">ttgux2.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/ttgux2.f">ttgux2.f plus dependencies</a>
-
-file <a href="ttgux3.f">ttgux3.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/ttgux3.f">ttgux3.f plus dependencies</a>
-
-file <a href="ttgux4.f">ttgux4.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/ttgux4.f">ttgux4.f plus dependencies</a>
-
-file <a href="ttgux5.f">ttgux5.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/ttgux5.f">ttgux5.f plus dependencies</a>
-
-file <a href="u9dmp.f">u9dmp.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/u9dmp.f">u9dmp.f plus dependencies</a>
-
-file <a href="v2axy.f">v2axy.f</a>
-
-file <a href="v2nrm.f">v2nrm.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/v2nrm.f">v2nrm.f plus dependencies</a>
-
-file <a href="v7cpy.f">v7cpy.f</a>
-
-file <a href="v7dfl.f">v7dfl.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/v7dfl.f">v7dfl.f plus dependencies</a>
-
-file <a href="v7ipr.f">v7ipr.f</a>
-
-file <a href="v7prm.f">v7prm.f</a>
-
-file <a href="v7scl.f">v7scl.f</a>
-
-file <a href="v7scp.f">v7scp.f</a>
-
-file <a href="v7shf.f">v7shf.f</a>
-
-file <a href="v7swp.f">v7swp.f</a>
-
-file <a href="v7vmp.f">v7vmp.f</a>
-
-file <a href="w7zbf.f">w7zbf.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/w7zbf.f">w7zbf.f plus dependencies</a>
-
-file <a href="xtrap.f">xtrap.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/xtrap.f">xtrap.f plus dependencies</a>
-
-file <a href="zero.f">zero.f</a> <a href="/cgi-bin/netlibfiles.pl?filename=/port/zero.f">zero.f plus dependencies</a>
-for single real root
-
-lib <a href="Mach/">Mach</a>
-for obsolete versions of machine constants
-
-lib <a href="chk/">chk</a>
-for drivers to verify proper installation of port
-
-lib <a href="ex/">ex</a>
-for example drivers
-
-lib <a href="prop.upd/">prop.upd</a>
-for updated versions of some routines in the proprietary portion of
-, the PORT3 subroutine library -- for the convenience of people who
-, got the whole PORT3 library before these routines were updated.
-
-file <a href="c6lcf.f">c6lcf.f</a>
-
-file <a href="dc6lcf.f">dc6lcf.f</a>
-
-file <a href="c6lcf.f">c6lcf.f</a>
-
-file <a href="dc6lcf.f">dc6lcf.f</a>
-
-file <a href="smnfb.f">smnfb.f</a>
-
-file <a href="dsmnfb.f">dsmnfb.f</a>
-
-</pre>
-</body>
-</html>
diff --git a/CEP/PyBDSM/src/port3/istkgt.f b/CEP/PyBDSM/src/port3/istkgt.f
deleted file mode 100644
index c2dd15c01f3a9f678d2e7e520bec7d2e5855f55d..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/istkgt.f
+++ /dev/null
@@ -1,128 +0,0 @@
- INTEGER FUNCTION ISTKGT(NITEMS,ITYPE)
-C
-C ALLOCATES SPACE OUT OF THE INTEGER ARRAY ISTAK (IN COMMON
-C BLOCK CSTAK) FOR AN ARRAY OF LENGTH NITEMS AND OF TYPE
-C DETERMINED BY ITYPE AS FOLLOWS
-C
-C 1 - LOGICAL
-C 2 - INTEGER
-C 3 - REAL
-C 4 - DOUBLE PRECISION
-C 5 - COMPLEX
-C
-C ON RETURN, THE ARRAY WILL OCCUPY
-C
-C STAK(ISTKGT), STAK(ISTKGT+1), ..., STAK(ISTKGT-NITEMS+1)
-C
-C WHERE STAK IS AN ARRAY OF TYPE ITYPE EQUIVALENCED TO ISTAK.
-C
-C (FOR THOSE WANTING TO MAKE MACHINE DEPENDENT MODIFICATIONS
-C TO SUPPORT OTHER TYPES, CODES 6,7,8,9,10,11 AND 12 HAVE
-C BEEN RESERVED FOR 1/4 LOGICAL, 1/2 LOGICAL, 1/4 INTEGER,
-C 1/2 INTEGER, QUAD PRECISION, DOUBLE COMPLEX AND QUAD
-C COMPLEX, RESPECTIVELY.)
-C
-C THE ALLOCATOR RESERVES THE FIRST TEN INTEGER WORDS OF THE STACK
-C FOR ITS OWN INTERNAL BOOK-KEEPING. THESE ARE INITIALIZED BY
-C THE INITIALIZING SUBPROGRAM I0TK00 UPON THE FIRST CALL
-C TO A SUBPROGRAM IN THE ALLOCATION PACKAGE.
-C
-C THE _USE_ OF THE FIRST FIVE WORDS IS DESCRIBED BELOW.
-C
-C ISTAK( 1) - LOUT, THE NUMBER OF CURRENT ALLOCATIONS.
-C ISTAK( 2) - LNOW, THE CURRENT ACTIVE LENGTH OF THE STACK.
-C ISTAK( 3) - LUSED, THE MAXIMUM VALUE OF ISTAK(2) ACHIEVED.
-C ISTAK( 4) - LMAX, THE MAXIMUM LENGTH THE STACK.
-C ISTAK( 5) - LBOOK, THE NUMBER OF WORDS USED FOR BOOKEEPING.
-C
-C THE NEXT FIVE WORDS CONTAIN INTEGERS DESCRIBING THE AMOUNT
-C OF STORAGE ALLOCATED BY THE FORTRAN SYSTEM TO THE VARIOUS
-C DATA TYPES. THE UNIT OF MEASUREMENT IS ARBITRARY AND MAY
-C BE WORDS, BYTES OR BITS OR WHATEVER IS CONVENIENT. THE
-C VALUES CURRENTLY ASSUMED CORRESPOND TO AN ANS FORTRAN
-C ENVIRONMENT. FOR SOME MINI-COMPUTER SYSTEMS THE VALUES MAY
-C HAVE TO BE CHANGED (SEE I0TK00).
-C
-C ISTAK( 6) - THE NUMBER OF UNITS ALLOCATED TO LOGICAL
-C ISTAK( 7) - THE NUMBER OF UNITS ALLOCATED TO INTEGER
-C ISTAK( 8) - THE NUMBER OF UNITS ALLOCATED TO REAL
-C ISTAK( 9) - THE NUMBER OF UNITS ALLOCATED TO DOUBLE PRECISION
-C ISTAK(10) - THE NUMBER OF UNITS ALLOCATED TO COMPLEX
-C
-C ERROR STATES -
-C
-C 1 - NITEMS .LT. 0
-C 2 - ITYPE .LE. 0 .OR. ITYPE .GE. 6
-C 3 - LNOW, LUSED, LMAX OR LBOOK OVERWRITTEN
-C 4 - STACK OVERFLOW
-C
- COMMON /CSTAK/DSTAK
-C
- DOUBLE PRECISION DSTAK(500)
- INTEGER ISTAK(1000)
- INTEGER ISIZE(5)
-C
- LOGICAL INIT
-C
- EQUIVALENCE (DSTAK(1),ISTAK(1))
- EQUIVALENCE (ISTAK(1),LOUT)
- EQUIVALENCE (ISTAK(2),LNOW)
- EQUIVALENCE (ISTAK(3),LUSED)
- EQUIVALENCE (ISTAK(4),LMAX)
- EQUIVALENCE (ISTAK(5),LBOOK)
- EQUIVALENCE (ISTAK(6),ISIZE(1))
-C
- DATA INIT/.TRUE./
-C
- IF (INIT) CALL I0TK00(INIT,500,4)
-C
-C/6S
-C IF (NITEMS.LT.0) CALL SETERR(20HISTKGT - NITEMS.LT.0,20,1,2)
-C/7S
- IF (NITEMS.LT.0) CALL SETERR('ISTKGT - NITEMS.LT.0',20,1,2)
-C/
-C
-C/6S
-C IF (ITYPE.LE.0 .OR. ITYPE.GE.6) CALL SETERR
-C 1 (33HISTKGT - ITYPE.LE.0.OR.ITYPE.GE.6,33,2,2)
-C/7S
- IF (ITYPE.LE.0 .OR. ITYPE.GE.6) CALL SETERR
- 1 ('ISTKGT - ITYPE.LE.0.OR.ITYPE.GE.6',33,2,2)
-C/
-C
-C/6S
-C IF (LNOW.LT.LBOOK.OR.LNOW.GT.LUSED.OR.LUSED.GT.LMAX) CALL SETERR
-C 1 (47HISTKGT - LNOW, LUSED, LMAX OR LBOOK OVERWRITTEN,
-C 2 47,3,2)
-C/7S
- IF (LNOW.LT.LBOOK.OR.LNOW.GT.LUSED.OR.LUSED.GT.LMAX) CALL SETERR
- 1 ('ISTKGT - LNOW, LUSED, LMAX OR LBOOK OVERWRITTEN',
- 2 47,3,2)
-C/
-C
- ISTKGT = (LNOW*ISIZE(2)-1)/ISIZE(ITYPE) + 2
- I = ( (ISTKGT-1+NITEMS)*ISIZE(ITYPE) - 1 )/ISIZE(2) + 3
-C
-C STACK OVERFLOW IS AN UNRECOVERABLE ERROR.
-C
-C/6S
-C IF (I.GT.LMAX) CALL SETERR(69HISTKGT - STACK TOO SHORT. ENLARGE IT
-C 1 AND CALL ISTKIN IN MAIN PROGRAM.,69,4,2)
-C/7S
- IF (I.GT.LMAX) CALL SETERR('ISTKGT - STACK TOO SHORT. ENLARGE IT A
- *ND CALL ISTKIN IN MAIN PROGRAM.',69,4,2)
-C/
-C
-C ISTAK(I-1) CONTAINS THE TYPE FOR THIS ALLOCATION.
-C ISTAK(I ) CONTAINS A POINTER TO THE END OF THE PREVIOUS
-C ALLOCATION.
-C
- ISTAK(I-1) = ITYPE
- ISTAK(I ) = LNOW
- LOUT = LOUT+1
- LNOW = I
- LUSED = MAX0(LUSED,LNOW)
-C
- RETURN
-C
- END
diff --git a/CEP/PyBDSM/src/port3/istkin.f b/CEP/PyBDSM/src/port3/istkin.f
deleted file mode 100644
index 517e91966fa8570fd5660462c4325519e3e1e1c3..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/istkin.f
+++ /dev/null
@@ -1,32 +0,0 @@
- SUBROUTINE ISTKIN(NITEMS,ITYPE)
-C
-C INITIALIZES THE STACK ALLOCATOR, SETTING THE LENGTH OF THE STACK.
-C
-C ERROR STATES -
-C
-C 1 - NITEMS .LE. 0
-C 2 - ITYPE .LE. 0 .OR. ITYPE .GE. 6
-C
- LOGICAL INIT
-C
- DATA INIT/.TRUE./
-C
-C/6S
-C IF (NITEMS.LE.0) CALL SETERR(20HISTKIN - NITEMS.LE.0,20,1,2)
-C/7S
- IF (NITEMS.LE.0) CALL SETERR('ISTKIN - NITEMS.LE.0',20,1,2)
-C/
-C
-C/6S
-C IF (ITYPE.LE.0.OR.ITYPE.GE.6) CALL SETERR
-C 1 (33HISTKIN - ITYPE.LE.0.OR.ITYPE.GE.6,33,2,2)
-C/7S
- IF (ITYPE.LE.0.OR.ITYPE.GE.6) CALL SETERR
- 1 ('ISTKIN - ITYPE.LE.0.OR.ITYPE.GE.6',33,2,2)
-C/
-C
- IF (INIT) CALL I0TK00(INIT,NITEMS,ITYPE)
-C
- RETURN
-C
- END
diff --git a/CEP/PyBDSM/src/port3/istkmd.f b/CEP/PyBDSM/src/port3/istkmd.f
deleted file mode 100644
index b570cf31c1ec1dc6e191f9967b5b3663f75511fa..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/istkmd.f
+++ /dev/null
@@ -1,36 +0,0 @@
- INTEGER FUNCTION ISTKMD(NITEMS)
-C
-C CHANGES THE LENGTH OF THE FRAME AT THE TOP OF THE STACK
-C TO NITEMS.
-C
-C ERROR STATES -
-C
-C 1 - LNOW OVERWRITTEN
-C 2 - ISTAK(LNOWO-1) OVERWRITTEN
-C
- COMMON /CSTAK/DSTAK
-C
- DOUBLE PRECISION DSTAK(500)
- INTEGER ISTAK(1000)
-C
- EQUIVALENCE (DSTAK(1),ISTAK(1))
- EQUIVALENCE (ISTAK(2),LNOW)
-C
- LNOWO = LNOW
- CALL ISTKRL(1)
-C
- ITYPE = ISTAK(LNOWO-1)
-C
-C/6S
-C IF (ITYPE.LE.0.OR.ITYPE.GE.6) CALL SETERR
-C 1 (35HISTKMD - ISTAK(LNOWO-1) OVERWRITTEN,35,1,2)
-C/7S
- IF (ITYPE.LE.0.OR.ITYPE.GE.6) CALL SETERR
- 1 ('ISTKMD - ISTAK(LNOWO-1) OVERWRITTEN',35,1,2)
-C/
-C
- ISTKMD = ISTKGT(NITEMS,ITYPE)
-C
- RETURN
-C
- END
diff --git a/CEP/PyBDSM/src/port3/istkqu.f b/CEP/PyBDSM/src/port3/istkqu.f
deleted file mode 100644
index 034ad6ea9659337a1d568f7378383b0e2bef57e5..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/istkqu.f
+++ /dev/null
@@ -1,54 +0,0 @@
- INTEGER FUNCTION ISTKQU(ITYPE)
-C
-C RETURNS THE NUMBER OF ITEMS OF TYPE ITYPE THAT REMAIN
-C TO BE ALLOCATED IN ONE REQUEST.
-C
-C ERROR STATES -
-C
-C 1 - LNOW, LUSED, LMAX OR LBOOK OVERWRITTEN
-C 2 - ITYPE .LE. 0 .OR. ITYPE .GE. 6
-C
- COMMON /CSTAK/DSTAK
-C
- DOUBLE PRECISION DSTAK(500)
- INTEGER ISTAK(1000)
- INTEGER ISIZE(5)
-C
- LOGICAL INIT
-C
- EQUIVALENCE (DSTAK(1),ISTAK(1))
- EQUIVALENCE (ISTAK(2),LNOW)
- EQUIVALENCE (ISTAK(3),LUSED)
- EQUIVALENCE (ISTAK(4),LMAX)
- EQUIVALENCE (ISTAK(5),LBOOK)
- EQUIVALENCE (ISTAK(6),ISIZE(1))
-C
- DATA INIT/.TRUE./
-C
- IF (INIT) CALL I0TK00(INIT,500,4)
-C
-C/6S
-C IF (LNOW.LT.LBOOK.OR.LNOW.GT.LUSED.OR.LUSED.GT.LMAX) CALL SETERR
-C 1 (47HISTKQU - LNOW, LUSED, LMAX OR LBOOK OVERWRITTEN,
-C 2 47,1,2)
-C/7S
- IF (LNOW.LT.LBOOK.OR.LNOW.GT.LUSED.OR.LUSED.GT.LMAX) CALL SETERR
- 1 ('ISTKQU - LNOW, LUSED, LMAX OR LBOOK OVERWRITTEN',
- 2 47,1,2)
-C/
-C
-C/6S
-C IF (ITYPE.LE.0.OR.ITYPE.GE.6) CALL SETERR
-C 1 (33HISTKQU - ITYPE.LE.0.OR.ITYPE.GE.6,33,2,2)
-C/7S
- IF (ITYPE.LE.0.OR.ITYPE.GE.6) CALL SETERR
- 1 ('ISTKQU - ITYPE.LE.0.OR.ITYPE.GE.6',33,2,2)
-C/
-C
- ISTKQU = MAX0( ((LMAX-2)*ISIZE(2))/ISIZE(ITYPE)
- 1 - (LNOW*ISIZE(2)-1)/ISIZE(ITYPE)
- 2 - 1, 0 )
-C
- RETURN
-C
- END
diff --git a/CEP/PyBDSM/src/port3/istkrl.f b/CEP/PyBDSM/src/port3/istkrl.f
deleted file mode 100644
index a809dd67cce0c1d7c888ad43c5c60dd4c88b35a7..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/istkrl.f
+++ /dev/null
@@ -1,76 +0,0 @@
- SUBROUTINE ISTKRL(NUMBER)
-C
-C DE-ALLOCATES THE LAST (NUMBER) ALLOCATIONS MADE IN THE STACK
-C BY ISTKGT.
-C
-C ERROR STATES -
-C
-C 1 - NUMBER .LT. 0
-C 2 - LNOW, LUSED, LMAX OR LBOOK OVERWRITTEN
-C 3 - ATTEMPT TO DE-ALLOCATE NON-EXISTENT ALLOCATION
-C 4 - THE POINTER AT ISTAK(LNOW) OVERWRITTEN
-C
- COMMON /CSTAK/DSTAK
-C
- DOUBLE PRECISION DSTAK(500)
- INTEGER ISTAK(1000)
- LOGICAL INIT
-C
- EQUIVALENCE (DSTAK(1),ISTAK(1))
- EQUIVALENCE (ISTAK(1),LOUT)
- EQUIVALENCE (ISTAK(2),LNOW)
- EQUIVALENCE (ISTAK(3),LUSED)
- EQUIVALENCE (ISTAK(4),LMAX)
- EQUIVALENCE (ISTAK(5),LBOOK)
-C
- DATA INIT/.TRUE./
-C
- IF (INIT) CALL I0TK00(INIT,500,4)
-C
-C/6S
-C IF (NUMBER.LT.0) CALL SETERR(20HISTKRL - NUMBER.LT.0,20,1,2)
-C/7S
- IF (NUMBER.LT.0) CALL SETERR('ISTKRL - NUMBER.LT.0',20,1,2)
-C/
-C
-C/6S
-C IF (LNOW.LT.LBOOK.OR.LNOW.GT.LUSED.OR.LUSED.GT.LMAX) CALL SETERR
-C 1 (47HISTKRL - LNOW, LUSED, LMAX OR LBOOK OVERWRITTEN,
-C 2 47,2,2)
-C/7S
- IF (LNOW.LT.LBOOK.OR.LNOW.GT.LUSED.OR.LUSED.GT.LMAX) CALL SETERR
- 1 ('ISTKRL - LNOW, LUSED, LMAX OR LBOOK OVERWRITTEN',
- 2 47,2,2)
-C/
-C
- IN = NUMBER
- 10 IF (IN.EQ.0) RETURN
-C
-C/6S
-C IF (LNOW.LE.LBOOK) CALL SETERR
-C 1 (55HISTKRL - ATTEMPT TO DE-ALLOCATE NON-EXISTENT ALLOCATION,
-C 2 55,3,2)
-C/7S
- IF (LNOW.LE.LBOOK) CALL SETERR
- 1 ('ISTKRL - ATTEMPT TO DE-ALLOCATE NON-EXISTENT ALLOCATION',
- 2 55,3,2)
-C/
-C
-C CHECK TO MAKE SURE THE BACK POINTERS ARE MONOTONE.
-C
-C/6S
-C IF (ISTAK(LNOW).LT.LBOOK.OR.ISTAK(LNOW).GE.LNOW-1) CALL SETERR
-C 1 (47HISTKRL - THE POINTER AT ISTAK(LNOW) OVERWRITTEN,
-C 2 47,4,2)
-C/7S
- IF (ISTAK(LNOW).LT.LBOOK.OR.ISTAK(LNOW).GE.LNOW-1) CALL SETERR
- 1 ('ISTKRL - THE POINTER AT ISTAK(LNOW) OVERWRITTEN',
- 2 47,4,2)
-C/
-C
- LOUT = LOUT-1
- LNOW = ISTAK(LNOW)
- IN = IN-1
- GO TO 10
-C
- END
diff --git a/CEP/PyBDSM/src/port3/istkst.f b/CEP/PyBDSM/src/port3/istkst.f
deleted file mode 100644
index 66c4dccd20d0a15b52c9d58c8f6114558685fe37..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/istkst.f
+++ /dev/null
@@ -1,38 +0,0 @@
- INTEGER FUNCTION ISTKST(NFACT)
-C
-C RETURNS CONTROL INFORMATION AS FOLLOWS
-C
-C NFACT ITEM RETURNED
-C
-C 1 LOUT, THE NUMBER OF CURRENT ALLOCATIONS
-C 2 LNOW, THE CURRENT ACTIVE LENGTH
-C 3 LUSED, THE MAXIMUM USED
-C 4 LMAX, THE MAXIMUM ALLOWED
-C
- COMMON /CSTAK/DSTAK
-C
- DOUBLE PRECISION DSTAK(500)
- INTEGER ISTAK(1000)
- INTEGER ISTATS(4)
- LOGICAL INIT
-C
- EQUIVALENCE (DSTAK(1),ISTAK(1))
- EQUIVALENCE (ISTAK(1),ISTATS(1))
-C
- DATA INIT/.TRUE./
-C
- IF (INIT) CALL I0TK00(INIT,500,4)
-C
-C/6S
-C IF (NFACT.LE.0.OR.NFACT.GE.5) CALL SETERR
-C 1 (33HISTKST - NFACT.LE.0.OR.NFACT.GE.5,33,1,2)
-C/7S
- IF (NFACT.LE.0.OR.NFACT.GE.5) CALL SETERR
- 1 ('ISTKST - NFACT.LE.0.OR.NFACT.GE.5',33,1,2)
-C/
-C
- ISTKST = ISTATS(NFACT)
-C
- RETURN
-C
- END
diff --git a/CEP/PyBDSM/src/port3/itsum.f b/CEP/PyBDSM/src/port3/itsum.f
deleted file mode 100644
index 4147945722a330497b2032e17f7a2c7718887754..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/itsum.f
+++ /dev/null
@@ -1,251 +0,0 @@
- SUBROUTINE ITSUM(D, G, IV, LIV, LV, P, V, X)
-C
-C *** PRINT ITERATION SUMMARY FOR ***SOL (VERSION 2.3) ***
-C
-C *** PARAMETER DECLARATIONS ***
-C
- INTEGER LIV, LV, P
- INTEGER IV(LIV)
- REAL D(P), G(P), V(LV), X(P)
-C
-C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
-C
-C *** LOCAL VARIABLES ***
-C
- INTEGER ALG, I, IV1, M, NF, NG, OL, PU
-C/6S
-C REAL MODEL1(6), MODEL2(6)
-C/7S
- CHARACTER*4 MODEL1(6), MODEL2(6)
-C/
- REAL NRELDF, OLDF, PRELDF, RELDF, ZERO
-C
-C *** NO EXTERNAL FUNCTIONS OR SUBROUTINES ***
-C
-C *** SUBSCRIPTS FOR IV AND V ***
-C
- INTEGER ALGSAV, DSTNRM, F, FDIF, F0, NEEDHD, NFCALL, NFCOV, NGCOV,
- 1 NGCALL, NITER, NREDUC, OUTLEV, PREDUC, PRNTIT, PRUNIT,
- 2 RELDX, SOLPRT, STATPR, STPPAR, SUSED, X0PRT
-C
-C *** IV SUBSCRIPT VALUES ***
-C
-C/6
-C DATA ALGSAV/51/, NEEDHD/36/, NFCALL/6/, NFCOV/52/, NGCALL/30/,
-C 1 NGCOV/53/, NITER/31/, OUTLEV/19/, PRNTIT/39/, PRUNIT/21/,
-C 2 SOLPRT/22/, STATPR/23/, SUSED/64/, X0PRT/24/
-C/7
- PARAMETER (ALGSAV=51, NEEDHD=36, NFCALL=6, NFCOV=52, NGCALL=30,
- 1 NGCOV=53, NITER=31, OUTLEV=19, PRNTIT=39, PRUNIT=21,
- 2 SOLPRT=22, STATPR=23, SUSED=64, X0PRT=24)
-C/
-C
-C *** V SUBSCRIPT VALUES ***
-C
-C/6
-C DATA DSTNRM/2/, F/10/, F0/13/, FDIF/11/, NREDUC/6/, PREDUC/7/,
-C 1 RELDX/17/, STPPAR/5/
-C/7
- PARAMETER (DSTNRM=2, F=10, F0=13, FDIF=11, NREDUC=6, PREDUC=7,
- 1 RELDX=17, STPPAR=5)
-C/
-C
-C/6
-C DATA ZERO/0.E+0/
-C/7
- PARAMETER (ZERO=0.E+0)
-C/
-C/6S
-C DATA MODEL1(1)/4H /, MODEL1(2)/4H /, MODEL1(3)/4H /,
-C 1 MODEL1(4)/4H /, MODEL1(5)/4H G /, MODEL1(6)/4H S /,
-C 2 MODEL2(1)/4H G /, MODEL2(2)/4H S /, MODEL2(3)/4HG-S /,
-C 3 MODEL2(4)/4HS-G /, MODEL2(5)/4H-S-G/, MODEL2(6)/4H-G-S/
-C/7S
- DATA MODEL1/' ',' ',' ',' ',' G ',' S '/,
- 1 MODEL2/' G ',' S ','G-S ','S-G ','-S-G','-G-S'/
-C/
-C
-C------------------------------- BODY --------------------------------
-C
- PU = IV(PRUNIT)
- IF (PU .EQ. 0) GO TO 999
- IV1 = IV(1)
- IF (IV1 .GT. 62) IV1 = IV1 - 51
- OL = IV(OUTLEV)
- ALG = MOD(IV(ALGSAV)-1,2) + 1
- IF (IV1 .LT. 2 .OR. IV1 .GT. 15) GO TO 370
- IF (IV1 .GE. 12) GO TO 120
- IF (IV1 .EQ. 2 .AND. IV(NITER) .EQ. 0) GO TO 390
- IF (OL .EQ. 0) GO TO 120
- IF (IV1 .GE. 10 .AND. IV(PRNTIT) .EQ. 0) GO TO 120
- IF (IV1 .GT. 2) GO TO 10
- IV(PRNTIT) = IV(PRNTIT) + 1
- IF (IV(PRNTIT) .LT. IABS(OL)) GO TO 999
- 10 NF = IV(NFCALL) - IABS(IV(NFCOV))
- IV(PRNTIT) = 0
- RELDF = ZERO
- PRELDF = ZERO
- OLDF = AMAX1( ABS(V(F0)), ABS(V(F)))
- IF (OLDF .LE. ZERO) GO TO 20
- RELDF = V(FDIF) / OLDF
- PRELDF = V(PREDUC) / OLDF
- 20 IF (OL .GT. 0) GO TO 60
-C
-C *** PRINT SHORT SUMMARY LINE ***
-C
- IF (IV(NEEDHD) .EQ. 1 .AND. ALG .EQ. 1) WRITE(PU,30)
- 30 FORMAT(/10H IT NF,6X,1HF,7X,5HRELDF,3X,6HPRELDF,3X,5HRELDX,
- 1 2X,13HMODEL STPPAR)
- IF (IV(NEEDHD) .EQ. 1 .AND. ALG .EQ. 2) WRITE(PU,40)
- 40 FORMAT(/11H IT NF,7X,1HF,8X,5HRELDF,4X,6HPRELDF,4X,5HRELDX,
- 1 3X,6HSTPPAR)
- IV(NEEDHD) = 0
- IF (ALG .EQ. 2) GO TO 50
- M = IV(SUSED)
- WRITE(PU,100) IV(NITER), NF, V(F), RELDF, PRELDF, V(RELDX),
- 1 MODEL1(M), MODEL2(M), V(STPPAR)
- GO TO 120
-C
- 50 WRITE(PU,110) IV(NITER), NF, V(F), RELDF, PRELDF, V(RELDX),
- 1 V(STPPAR)
- GO TO 120
-C
-C *** PRINT LONG SUMMARY LINE ***
-C
- 60 IF (IV(NEEDHD) .EQ. 1 .AND. ALG .EQ. 1) WRITE(PU,70)
- 70 FORMAT(/11H IT NF,6X,1HF,7X,5HRELDF,3X,6HPRELDF,3X,5HRELDX,
- 1 2X,13HMODEL STPPAR,2X,6HD*STEP,2X,7HNPRELDF)
- IF (IV(NEEDHD) .EQ. 1 .AND. ALG .EQ. 2) WRITE(PU,80)
- 80 FORMAT(/11H IT NF,7X,1HF,8X,5HRELDF,4X,6HPRELDF,4X,5HRELDX,
- 1 3X,6HSTPPAR,3X,6HD*STEP,3X,7HNPRELDF)
- IV(NEEDHD) = 0
- NRELDF = ZERO
- IF (OLDF .GT. ZERO) NRELDF = V(NREDUC) / OLDF
- IF (ALG .EQ. 2) GO TO 90
- M = IV(SUSED)
- WRITE(PU,100) IV(NITER), NF, V(F), RELDF, PRELDF, V(RELDX),
- 1 MODEL1(M), MODEL2(M), V(STPPAR), V(DSTNRM), NRELDF
- GO TO 120
-C
- 90 WRITE(PU,110) IV(NITER), NF, V(F), RELDF, PRELDF,
- 1 V(RELDX), V(STPPAR), V(DSTNRM), NRELDF
- 100 FORMAT(I6,I5,E10.3,2E9.2,E8.1,A3,A4,2E8.1,E9.2)
- 110 FORMAT(I6,I5,E11.3,2E10.2,3E9.1,E10.2)
-C
- 120 IF (IV1 .LE. 2) GO TO 999
- I = IV(STATPR)
- IF (I .EQ. (-1)) GO TO 460
- IF (I + IV1 .LT. 0) GO TO 460
- GO TO (999, 999, 130, 150, 170, 190, 210, 230, 250, 270, 290, 310,
- 1 330, 350, 500), IV1
-C
- 130 WRITE(PU,140)
- 140 FORMAT(/26H ***** X-CONVERGENCE *****)
- GO TO 430
-C
- 150 WRITE(PU,160)
- 160 FORMAT(/42H ***** RELATIVE FUNCTION CONVERGENCE *****)
- GO TO 430
-C
- 170 WRITE(PU,180)
- 180 FORMAT(/49H ***** X- AND RELATIVE FUNCTION CONVERGENCE *****)
- GO TO 430
-C
- 190 WRITE(PU,200)
- 200 FORMAT(/42H ***** ABSOLUTE FUNCTION CONVERGENCE *****)
- GO TO 430
-C
- 210 WRITE(PU,220)
- 220 FORMAT(/33H ***** SINGULAR CONVERGENCE *****)
- GO TO 430
-C
- 230 WRITE(PU,240)
- 240 FORMAT(/30H ***** FALSE CONVERGENCE *****)
- GO TO 430
-C
- 250 WRITE(PU,260)
- 260 FORMAT(/38H ***** FUNCTION EVALUATION LIMIT *****)
- GO TO 430
-C
- 270 WRITE(PU,280)
- 280 FORMAT(/28H ***** ITERATION LIMIT *****)
- GO TO 430
-C
- 290 WRITE(PU,300)
- 300 FORMAT(/18H ***** STOPX *****)
- GO TO 430
-C
- 310 WRITE(PU,320)
- 320 FORMAT(/44H ***** INITIAL F(X) CANNOT BE COMPUTED *****)
-C
- GO TO 390
-C
- 330 WRITE(PU,340)
- 340 FORMAT(/37H ***** BAD PARAMETERS TO ASSESS *****)
- GO TO 999
-C
- 350 WRITE(PU,360)
- 360 FORMAT(/43H ***** GRADIENT COULD NOT BE COMPUTED *****)
- IF (IV(NITER) .GT. 0) GO TO 460
- GO TO 390
-C
- 370 WRITE(PU,380) IV(1)
- 380 FORMAT(/14H ***** IV(1) =,I5,6H *****)
- GO TO 999
-C
-C *** INITIAL CALL ON ITSUM ***
-C
- 390 IF (IV(X0PRT) .NE. 0) WRITE(PU,400) (I, X(I), D(I), I = 1, P)
- 400 FORMAT(/23H I INITIAL X(I),8X,4HD(I)//(1X,I5,E17.6,E14.3))
-C *** THE FOLLOWING ARE TO AVOID UNDEFINED VARIABLES WHEN THE
-C *** FUNCTION EVALUATION LIMIT IS 1...
- V(DSTNRM) = ZERO
- V(FDIF) = ZERO
- V(NREDUC) = ZERO
- V(PREDUC) = ZERO
- V(RELDX) = ZERO
- IF (IV1 .GE. 12) GO TO 999
- IV(NEEDHD) = 0
- IV(PRNTIT) = 0
- IF (OL .EQ. 0) GO TO 999
- IF (OL .LT. 0 .AND. ALG .EQ. 1) WRITE(PU,30)
- IF (OL .LT. 0 .AND. ALG .EQ. 2) WRITE(PU,40)
- IF (OL .GT. 0 .AND. ALG .EQ. 1) WRITE(PU,70)
- IF (OL .GT. 0 .AND. ALG .EQ. 2) WRITE(PU,80)
- IF (ALG .EQ. 1) WRITE(PU,410) IV(NFCALL), V(F)
- IF (ALG .EQ. 2) WRITE(PU,420) IV(NFCALL), V(F)
- 410 FORMAT(/6H 0,I5,E10.3)
- 420 FORMAT(/6H 0,I5,E11.3)
- GO TO 999
-C
-C *** PRINT VARIOUS INFORMATION REQUESTED ON SOLUTION ***
-C
- 430 IV(NEEDHD) = 1
- IF (IV(STATPR) .LE. 0) GO TO 460
- OLDF = AMAX1( ABS(V(F0)), ABS(V(F)))
- PRELDF = ZERO
- NRELDF = ZERO
- IF (OLDF .LE. ZERO) GO TO 440
- PRELDF = V(PREDUC) / OLDF
- NRELDF = V(NREDUC) / OLDF
- 440 NF = IV(NFCALL) - IV(NFCOV)
- NG = IV(NGCALL) - IV(NGCOV)
- WRITE(PU,450) V(F), V(RELDX), NF, NG, PRELDF, NRELDF
- 450 FORMAT(/9H FUNCTION,E17.6,8H RELDX,E17.3/12H FUNC. EVALS,
- 1 I8,9X,11HGRAD. EVALS,I8/7H PRELDF,E16.3,6X,7HNPRELDF,E15.3)
-C
- 460 IF (IV(SOLPRT) .EQ. 0) GO TO 999
- IV(NEEDHD) = 1
- IF (IV(ALGSAV) .GT. 2) GO TO 999
- WRITE(PU,470)
- 470 FORMAT(/22H I FINAL X(I),8X,4HD(I),10X,4HG(I)/)
- DO 480 I = 1, P
- 480 WRITE(PU,490) I, X(I), D(I), G(I)
- 490 FORMAT(1X,I5,E16.6,2E14.3)
- GO TO 999
-C
- 500 WRITE(PU,510)
- 510 FORMAT(/24H INCONSISTENT DIMENSIONS)
- 999 RETURN
-C *** LAST CARD OF ITSUM FOLLOWS ***
- END
diff --git a/CEP/PyBDSM/src/port3/ivset.f b/CEP/PyBDSM/src/port3/ivset.f
deleted file mode 100644
index b1e002fb1c98663208d0154c851062b8696bb3b3..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ivset.f
+++ /dev/null
@@ -1,118 +0,0 @@
- SUBROUTINE IVSET(ALG, IV, LIV, LV, V)
-C
-C *** SUPPLY ***SOL (VERSION 2.3) DEFAULT VALUES TO IV AND V ***
-C
-C *** ALG = 1 MEANS REGRESSION CONSTANTS.
-C *** ALG = 2 MEANS GENERAL UNCONSTRAINED OPTIMIZATION CONSTANTS.
-C
- INTEGER LIV, LV
- INTEGER ALG, IV(LIV)
- REAL V(LV)
-C
- INTEGER I7MDCN
- EXTERNAL I7MDCN, V7DFL
-C I7MDCN... RETURNS MACHINE-DEPENDENT INTEGER CONSTANTS.
-C V7DFL.... PROVIDES DEFAULT VALUES TO V.
-C
- INTEGER ALG1, MIV, MV
- INTEGER MINIV(4), MINV(4)
-C
-C *** SUBSCRIPTS FOR IV ***
-C
- INTEGER ALGSAV, COVPRT, COVREQ, DRADPR, DTYPE, HC, IERR, INITH,
- 1 INITS, IPIVOT, IVNEED, LASTIV, LASTV, LMAT, MXFCAL,
- 2 MXITER, NFCOV, NGCOV, NVDFLT, NVSAVE, OUTLEV, PARPRT,
- 3 PARSAV, PERM, PRUNIT, QRTYP, RDREQ, RMAT, SOLPRT, STATPR,
- 4 VNEED, VSAVE, X0PRT
-C
-C *** IV SUBSCRIPT VALUES ***
-C
-C/6
-C DATA ALGSAV/51/, COVPRT/14/, COVREQ/15/, DRADPR/101/, DTYPE/16/,
-C 1 HC/71/, IERR/75/, INITH/25/, INITS/25/, IPIVOT/76/,
-C 2 IVNEED/3/, LASTIV/44/, LASTV/45/, LMAT/42/, MXFCAL/17/,
-C 3 MXITER/18/, NFCOV/52/, NGCOV/53/, NVDFLT/50/, NVSAVE/9/,
-C 4 OUTLEV/19/, PARPRT/20/, PARSAV/49/, PERM/58/, PRUNIT/21/,
-C 5 QRTYP/80/, RDREQ/57/, RMAT/78/, SOLPRT/22/, STATPR/23/,
-C 6 VNEED/4/, VSAVE/60/, X0PRT/24/
-C/7
- PARAMETER (ALGSAV=51, COVPRT=14, COVREQ=15, DRADPR=101, DTYPE=16,
- 1 HC=71, IERR=75, INITH=25, INITS=25, IPIVOT=76,
- 2 IVNEED=3, LASTIV=44, LASTV=45, LMAT=42, MXFCAL=17,
- 3 MXITER=18, NFCOV=52, NGCOV=53, NVDFLT=50, NVSAVE=9,
- 4 OUTLEV=19, PARPRT=20, PARSAV=49, PERM=58, PRUNIT=21,
- 5 QRTYP=80, RDREQ=57, RMAT=78, SOLPRT=22, STATPR=23,
- 6 VNEED=4, VSAVE=60, X0PRT=24)
-C/
- DATA MINIV(1)/82/, MINIV(2)/59/, MINIV(3)/103/, MINIV(4)/103/,
- 1 MINV(1)/98/, MINV(2)/71/, MINV(3)/101/, MINV(4)/85/
-C
-C------------------------------- BODY --------------------------------
-C
- IF (PRUNIT .LE. LIV) IV(PRUNIT) = I7MDCN(1)
- IF (ALGSAV .LE. LIV) IV(ALGSAV) = ALG
- IF (ALG .LT. 1 .OR. ALG .GT. 4) GO TO 40
- MIV = MINIV(ALG)
- IF (LIV .LT. MIV) GO TO 20
- MV = MINV(ALG)
- IF (LV .LT. MV) GO TO 30
- ALG1 = MOD(ALG-1,2) + 1
- CALL V7DFL(ALG1, LV, V)
- IV(1) = 12
- IF (ALG .GT. 2) IV(DRADPR) = 1
- IV(IVNEED) = 0
- IV(LASTIV) = MIV
- IV(LASTV) = MV
- IV(LMAT) = MV + 1
- IV(MXFCAL) = 200
- IV(MXITER) = 150
- IV(OUTLEV) = 1
- IV(PARPRT) = 1
- IV(PERM) = MIV + 1
- IV(SOLPRT) = 1
- IV(STATPR) = 1
- IV(VNEED) = 0
- IV(X0PRT) = 1
-C
- IF (ALG1 .GE. 2) GO TO 10
-C
-C *** REGRESSION VALUES
-C
- IV(COVPRT) = 3
- IV(COVREQ) = 1
- IV(DTYPE) = 1
- IV(HC) = 0
- IV(IERR) = 0
- IV(INITS) = 0
- IV(IPIVOT) = 0
- IV(NVDFLT) = 32
- IV(VSAVE) = 58
- IF (ALG .GT. 2) IV(VSAVE) = IV(VSAVE) + 3
- IV(PARSAV) = IV(VSAVE) + NVSAVE
- IV(QRTYP) = 1
- IV(RDREQ) = 3
- IV(RMAT) = 0
- GO TO 999
-C
-C *** GENERAL OPTIMIZATION VALUES
-C
- 10 IV(DTYPE) = 0
- IV(INITH) = 1
- IV(NFCOV) = 0
- IV(NGCOV) = 0
- IV(NVDFLT) = 25
- IV(PARSAV) = 47
- IF (ALG .GT. 2) IV(PARSAV) = 61
- GO TO 999
-C
- 20 IV(1) = 15
- GO TO 999
-C
- 30 IV(1) = 16
- GO TO 999
-C
- 40 IV(1) = 67
-C
- 999 RETURN
-C *** LAST CARD OF IVSET FOLLOWS ***
- END
diff --git a/CEP/PyBDSM/src/port3/l5stp.f b/CEP/PyBDSM/src/port3/l5stp.f
deleted file mode 100644
index 8f15c6c1e85ec54b3aec31fcda74d0ca08c98aa7..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/l5stp.f
+++ /dev/null
@@ -1,67 +0,0 @@
- SUBROUTINE L5STP(NPTS, MESH, FN, QK, DELK, M, N, P, Q)
- INTEGER NPTS
- INTEGER M, N
- REAL MESH(NPTS), FN(NPTS), QK(NPTS), DELK, P(1), Q(1)
- COMMON /CSTAK/ DSTAK
- DOUBLE PRECISION DSTAK(500)
- INTEGER APTR, XPTR, ISTKGT, ISTAK(1000)
- INTEGER BC, BX, C, G, IW, LIW, LW, MM, NN, W
- REAL WS(500)
- EQUIVALENCE (DSTAK(1), ISTAK(1))
- EQUIVALENCE (DSTAK(1), WS(1))
-C THIS ROUTINE ALLOCATES STORAGE SO THAT
-C L9STP CAN DEFINE THE LINEAR PROGRAMMING SUBPROBLEM OF
-C THE DIFFERENTIAL CORRECTION ALGORITHM AND CALL A GENERAL
-C PURPOSE LINEAR PROGRAMMING PACKAGE.
-C INPUT...
-C NPTS - THE NUMBER OF MESH POINTS.
-C MESH - THE ARRAY OF MESH POINTS.
-C FN - THE ARRAY OF FUNCTION VALUES.
-C QK - THE ARRAY OF CURRENT DENOMINATOR VALUES.
-C DELK - THE CURRENT MINIMAX ERROR.
-C M - THE DEGREE OF THE NUMERATOR POLYNOMIAL.
-C N - THE DEGREE OF THE DENOMINATOR POLYNOMIAL.
-C P - THE CURRENT NUMERATOR POLYNOMIAL.
-C Q - THE CURRENT DENOMINATOR POLYNOMIAL.
-C OUTPUT...
-C P - THE ARRAY OF COEFFICIENTS FOR THE NUMERATOR POLYNOMIAL.
-C Q - THE ARRAY OF COEFFICIENTS FOR THE DENOMINATOR POLYNOMIAL.
-C ERROR STATES (ASTERISK INDICATES FATAL)...
-C 1* - INVALID DEGREE
-C 2* - TOO FEW MESH POINTS
-C 3* - NONPOSITIVE DELK
-C 4 - NO IMPROVEMENT IN THE LP SUBPROBLEM
-C
-C *** BODY ***
-C
- CALL ENTER(1)
-C/6S
-C IF (M .LT. 0 .OR. N .LT. 0) CALL SETERR(
-C 1 23H L5STP - INVALID DEGREE, 23, 1, 2)
-C IF (NPTS .LT. M+N+2) CALL SETERR(28H L5STP - TOO FEW MESH POINTS,
-C 1 28, 2, 2)
-C/7S
- IF (M .LT. 0 .OR. N .LT. 0) CALL SETERR(
- 1 ' L5STP - INVALID DEGREE', 23, 1, 2)
- IF (NPTS .LT. M+N+2) CALL SETERR(' L5STP - TOO FEW MESH POINTS',
- 1 28, 2, 2)
-C/
- MM = 2 * NPTS
- NN = M + N + 3
- LIW = MM + NN + 7
- LW = NN*(3*NN+17)/2 + MM + 2
- G = ISTKGT(NN, 3)
- C = ISTKGT(NN*MM, 3)
- BC = ISTKGT(2*MM, 3)
- BX = ISTKGT(2*NN, 3)
- W = ISTKGT(LW, 3)
- IW = ISTKGT(LIW, 2)
- APTR = ISTKGT(3*NPTS+1, 3)
- XPTR = ISTKGT(NN, 3)
- CALL L9STP(NPTS, MESH, FN, QK, DELK, M, N, P, Q, WS(APTR),
- 1 WS(BC), WS(BX), WS(C), WS(G), ISTAK(IW), LIW, LW,
- 2 MM, NN, WS(W), WS(XPTR))
- CALL LEAVE
- RETURN
-C *** LAST LINE OF L5STP FOLLOWS ***
- END
diff --git a/CEP/PyBDSM/src/port3/l7itv.f b/CEP/PyBDSM/src/port3/l7itv.f
deleted file mode 100644
index 0b24fd6735b83096d1bd8b46ec94af691745624b..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/l7itv.f
+++ /dev/null
@@ -1,36 +0,0 @@
- SUBROUTINE L7ITV(N, X, L, Y)
-C
-C *** SOLVE (L**T)*X = Y, WHERE L IS AN N X N LOWER TRIANGULAR
-C *** MATRIX STORED COMPACTLY BY ROWS. X AND Y MAY OCCUPY THE SAME
-C *** STORAGE. ***
-C
- INTEGER N
- REAL X(N), L(1), Y(N)
- INTEGER I, II, IJ, IM1, I0, J, NP1
- REAL XI, ZERO
-C/6
-C DATA ZERO/0.E+0/
-C/7
- PARAMETER (ZERO=0.E+0)
-C/
-C
- DO 10 I = 1, N
- 10 X(I) = Y(I)
- NP1 = N + 1
- I0 = N*(N+1)/2
- DO 30 II = 1, N
- I = NP1 - II
- XI = X(I)/L(I0)
- X(I) = XI
- IF (I .LE. 1) GO TO 999
- I0 = I0 - I
- IF (XI .EQ. ZERO) GO TO 30
- IM1 = I - 1
- DO 20 J = 1, IM1
- IJ = I0 + J
- X(J) = X(J) - XI*L(IJ)
- 20 CONTINUE
- 30 CONTINUE
- 999 RETURN
-C *** LAST CARD OF L7ITV FOLLOWS ***
- END
diff --git a/CEP/PyBDSM/src/port3/l7ivm.f b/CEP/PyBDSM/src/port3/l7ivm.f
deleted file mode 100644
index ff621d8fcef0e9d3824f53eeb68440cf1b91206a..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/l7ivm.f
+++ /dev/null
@@ -1,35 +0,0 @@
- SUBROUTINE L7IVM(N, X, L, Y)
-C
-C *** SOLVE L*X = Y, WHERE L IS AN N X N LOWER TRIANGULAR
-C *** MATRIX STORED COMPACTLY BY ROWS. X AND Y MAY OCCUPY THE SAME
-C *** STORAGE. ***
-C
- INTEGER N
- REAL X(N), L(1), Y(N)
- REAL D7TPR
- EXTERNAL D7TPR
- INTEGER I, J, K
- REAL T, ZERO
-C/6
-C DATA ZERO/0.E+0/
-C/7
- PARAMETER (ZERO=0.E+0)
-C/
-C
- DO 10 K = 1, N
- IF (Y(K) .NE. ZERO) GO TO 20
- X(K) = ZERO
- 10 CONTINUE
- GO TO 999
- 20 J = K*(K+1)/2
- X(K) = Y(K) / L(J)
- IF (K .GE. N) GO TO 999
- K = K + 1
- DO 30 I = K, N
- T = D7TPR(I-1, L(J+1), X)
- J = J + I
- X(I) = (Y(I) - T)/L(J)
- 30 CONTINUE
- 999 RETURN
-C *** LAST CARD OF L7IVM FOLLOWS ***
- END
diff --git a/CEP/PyBDSM/src/port3/l7msb.f b/CEP/PyBDSM/src/port3/l7msb.f
deleted file mode 100644
index 593b7d142e649bd9a820da81fd2ec7405a144aa9..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/l7msb.f
+++ /dev/null
@@ -1,119 +0,0 @@
- SUBROUTINE L7MSB(B, D, G, IERR, IPIV, IPIV1, IPIV2, KA, LMAT,
- 1 LV, P, P0, PC, QTR, RMAT, STEP, TD, TG, V,
- 2 W, WLM, X, X0)
-C
-C *** COMPUTE HEURISTIC BOUNDED NEWTON STEP ***
-C
- INTEGER IERR, KA, LV, P, P0, PC
- INTEGER IPIV(P), IPIV1(P), IPIV2(P)
- REAL B(2,P), D(P), G(P), LMAT(1), QTR(P), RMAT(1),
- 1 STEP(P,3), TD(P), TG(P), V(LV), W(P), WLM(1),
- 2 X0(P), X(P)
-C DIMENSION LMAT(P*(P+1)/2), RMAT(P*(P+1)/2), WLM(P*(P+5)/2 + 4)
-C
- REAL D7TPR
- EXTERNAL D7MLP, D7TPR, L7MST, L7TVM, Q7RSH, S7BQN,
- 1 V2AXY, V7CPY, V7IPR, V7SCP, V7VMP
-C
-C *** LOCAL VARIABLES ***
-C
- INTEGER I, J, K, K0, KB, KINIT, L, NS, P1, P10, P11
- REAL DS0, NRED, PRED, RAD
- REAL ONE, ZERO
-C
-C *** V SUBSCRIPTS ***
-C
- INTEGER DST0, DSTNRM, GTSTEP, NREDUC, PREDUC, RADIUS
-C
-C/6
-C DATA DST0/3/, DSTNRM/2/, GTSTEP/4/, NREDUC/6/, PREDUC/7/,
-C 1 RADIUS/8/
-C/7
- PARAMETER (DST0=3, DSTNRM=2, GTSTEP=4, NREDUC=6, PREDUC=7,
- 1 RADIUS=8)
-C/
- DATA ONE/1.E+0/, ZERO/0.E+0/
-C
-C+++++++++++++++++++++++++++++++ BODY ++++++++++++++++++++++++++++++++
-C
- P1 = PC
- IF (KA .LT. 0) GO TO 10
- NRED = V(NREDUC)
- DS0 = V(DST0)
- GO TO 20
- 10 P0 = 0
- KA = -1
-C
- 20 KINIT = -1
- IF (P0 .EQ. P1) KINIT = KA
- CALL V7CPY(P, X, X0)
- CALL V7CPY(P, TD, D)
-C *** _USE_ STEP(1,3) AS TEMP. COPY OF QTR ***
- CALL V7CPY(P, STEP(1,3), QTR)
- CALL V7IPR(P, IPIV, TD)
- PRED = ZERO
- RAD = V(RADIUS)
- KB = -1
- V(DSTNRM) = ZERO
- IF (P1 .GT. 0) GO TO 30
- NRED = ZERO
- DS0 = ZERO
- CALL V7SCP(P, STEP, ZERO)
- GO TO 90
-C
- 30 CALL V7VMP(P, TG, G, D, -1)
- CALL V7IPR(P, IPIV, TG)
- P10 = P1
- 40 K = KINIT
- KINIT = -1
- V(RADIUS) = RAD - V(DSTNRM)
- CALL V7VMP(P1, TG, TG, TD, 1)
- DO 50 I = 1, P1
- 50 IPIV1(I) = I
- K0 = MAX0(0, K)
- CALL L7MST(TD, TG, IERR, IPIV1, K, P1, STEP(1,3), RMAT, STEP,
- 1 V, WLM)
- CALL V7VMP(P1, TG, TG, TD, -1)
- P0 = P1
- IF (KA .GE. 0) GO TO 60
- NRED = V(NREDUC)
- DS0 = V(DST0)
-C
- 60 KA = K
- V(RADIUS) = RAD
- L = P1 + 5
- IF (K .LE. K0) CALL D7MLP(P1, LMAT, TD, RMAT, -1)
- IF (K .GT. K0) CALL D7MLP(P1, LMAT, TD, WLM(L), -1)
- CALL S7BQN(B, D, STEP(1,2), IPIV, IPIV1, IPIV2, KB, LMAT,
- 1 LV, NS, P, P1, STEP, TD, TG, V, W, X, X0)
- PRED = PRED + V(PREDUC)
- IF (NS .EQ. 0) GO TO 80
- P0 = 0
-C
-C *** UPDATE RMAT AND QTR ***
-C
- P11 = P1 + 1
- L = P10 + P11
- DO 70 K = P11, P10
- J = L - K
- I = IPIV2(J)
- IF (I .LT. J) CALL Q7RSH(I, J, .TRUE., QTR, RMAT, W)
- 70 CONTINUE
-C
- 80 IF (KB .GT. 0) GO TO 90
-C
-C *** UPDATE LOCAL COPY OF QTR ***
-C
- CALL V7VMP(P10, W, STEP(1,2), TD, -1)
- CALL L7TVM(P10, W, LMAT, W)
- CALL V2AXY(P10, STEP(1,3), ONE, W, QTR)
- GO TO 40
-C
- 90 V(DST0) = DS0
- V(NREDUC) = NRED
- V(PREDUC) = PRED
- V(GTSTEP) = D7TPR(P, G, STEP)
-C
- 999 RETURN
-C *** LAST LINE OF L7MSB FOLLOWS ***
- END
diff --git a/CEP/PyBDSM/src/port3/l7mst.f b/CEP/PyBDSM/src/port3/l7mst.f
deleted file mode 100644
index 781fbdc9967e67296058fce7d1211dd55b99f65c..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/l7mst.f
+++ /dev/null
@@ -1,497 +0,0 @@
- SUBROUTINE L7MST(D, G, IERR, IPIVOT, KA, P, QTR, R, STEP, V, W)
-C
-C *** COMPUTE LEVENBERG-MARQUARDT STEP USING MORE-HEBDEN TECHNIQUE **
-C *** NL2SOL VERSION 2.2. ***
-C
-C *** PARAMETER DECLARATIONS ***
-C
- INTEGER IERR, KA, P
- INTEGER IPIVOT(P)
- REAL D(P), G(P), QTR(P), R(1), STEP(P), V(21), W(1)
-C DIMENSION W(P*(P+5)/2 + 4)
-C
-C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
-C
-C *** PURPOSE ***
-C
-C GIVEN THE R MATRIX FROM THE QR DECOMPOSITION OF A JACOBIAN
-C MATRIX, J, AS WELL AS Q-TRANSPOSE TIMES THE CORRESPONDING
-C RESIDUAL VECTOR, RESID, THIS SUBROUTINE COMPUTES A LEVENBERG-
-C MARQUARDT STEP OF APPROXIMATE LENGTH V(RADIUS) BY THE MORE-
-C TECHNIQUE.
-C
-C *** PARAMETER DESCRIPTION ***
-C
-C D (IN) = THE SCALE VECTOR.
-C G (IN) = THE GRADIENT VECTOR (J**T)*R.
-C IERR (I/O) = RETURN CODE FROM QRFACT OR Q7RGS -- 0 MEANS R HAS
-C FULL RANK.
-C IPIVOT (I/O) = PERMUTATION ARRAY FROM QRFACT OR Q7RGS, WHICH COMPUTE
-C QR DECOMPOSITIONS WITH COLUMN PIVOTING.
-C KA (I/O). KA .LT. 0 ON INPUT MEANS THIS IS THE FIRST CALL ON
-C L7MST FOR THE CURRENT R AND QTR. ON OUTPUT KA CON-
-C TAINS THE NUMBER OF HEBDEN ITERATIONS NEEDED TO DETERMINE
-C STEP. KA = 0 MEANS A GAUSS-NEWTON STEP.
-C P (IN) = NUMBER OF PARAMETERS.
-C QTR (IN) = (Q**T)*RESID = Q-TRANSPOSE TIMES THE RESIDUAL VECTOR.
-C R (IN) = THE R MATRIX, STORED COMPACTLY BY COLUMNS.
-C STEP (OUT) = THE LEVENBERG-MARQUARDT STEP COMPUTED.
-C V (I/O) CONTAINS VARIOUS CONSTANTS AND VARIABLES DESCRIBED BELOW.
-C W (I/O) = WORKSPACE OF LENGTH P*(P+5)/2 + 4.
-C
-C *** ENTRIES IN V ***
-C
-C V(DGNORM) (I/O) = 2-NORM OF (D**-1)*G.
-C V(DSTNRM) (I/O) = 2-NORM OF D*STEP.
-C V(DST0) (I/O) = 2-NORM OF GAUSS-NEWTON STEP (FOR NONSING. J).
-C V(EPSLON) (IN) = MAX. REL. ERROR ALLOWED IN TWONORM(R)**2 MINUS
-C TWONORM(R - J*STEP)**2. (SEE ALGORITHM NOTES BELOW.)
-C V(GTSTEP) (OUT) = INNER PRODUCT BETWEEN G AND STEP.
-C V(NREDUC) (OUT) = HALF THE REDUCTION IN THE SUM OF SQUARES PREDICTED
-C FOR A GAUSS-NEWTON STEP.
-C V(PHMNFC) (IN) = TOL. (TOGETHER WITH V(PHMXFC)) FOR ACCEPTING STEP
-C (MORE*S SIGMA). THE ERROR V(DSTNRM) - V(RADIUS) MUST LIE
-C BETWEEN V(PHMNFC)*V(RADIUS) AND V(PHMXFC)*V(RADIUS).
-C V(PHMXFC) (IN) (SEE V(PHMNFC).)
-C V(PREDUC) (OUT) = HALF THE REDUCTION IN THE SUM OF SQUARES PREDICTED
-C BY THE STEP RETURNED.
-C V(RADIUS) (IN) = RADIUS OF CURRENT (SCALED) TRUST REGION.
-C V(RAD0) (I/O) = VALUE OF V(RADIUS) FROM PREVIOUS CALL.
-C V(STPPAR) (I/O) = MARQUARDT PARAMETER (OR ITS NEGATIVE IF THE SPECIAL
-C CASE MENTIONED BELOW IN THE ALGORITHM NOTES OCCURS).
-C
-C NOTE -- SEE DATA STATEMENT BELOW FOR VALUES OF ABOVE SUBSCRIPTS.
-C
-C *** USAGE NOTES ***
-C
-C IF IT IS DESIRED TO RECOMPUTE STEP USING A DIFFERENT VALUE OF
-C V(RADIUS), THEN THIS ROUTINE MAY BE RESTARTED BY CALLING IT
-C WITH ALL PARAMETERS UNCHANGED EXCEPT V(RADIUS). (THIS EXPLAINS
-C WHY MANY PARAMETERS ARE LISTED AS I/O). ON AN INTIIAL CALL (ONE
-C WITH KA = -1), THE CALLER NEED ONLY HAVE INITIALIZED D, G, KA, P,
-C QTR, R, V(EPSLON), V(PHMNFC), V(PHMXFC), V(RADIUS), AND V(RAD0).
-C
-C *** APPLICATION AND USAGE RESTRICTIONS ***
-C
-C THIS ROUTINE IS CALLED AS PART OF THE NL2SOL (NONLINEAR LEAST-
-C SQUARES) PACKAGE (REF. 1).
-C
-C *** ALGORITHM NOTES ***
-C
-C THIS CODE IMPLEMENTS THE STEP COMPUTATION SCHEME DESCRIBED IN
-C REFS. 2 AND 4. FAST GIVENS TRANSFORMATIONS (SEE REF. 3, PP. 60-
-C 62) ARE USED TO COMPUTE STEP WITH A NONZERO MARQUARDT PARAMETER.
-C A SPECIAL CASE OCCURS IF J IS (NEARLY) SINGULAR AND V(RADIUS)
-C IS SUFFICIENTLY LARGE. IN THIS CASE THE STEP RETURNED IS SUCH
-C THAT TWONORM(R)**2 - TWONORM(R - J*STEP)**2 DIFFERS FROM ITS
-C OPTIMAL VALUE BY LESS THAN V(EPSLON) TIMES THIS OPTIMAL VALUE,
-C WHERE J AND R DENOTE THE ORIGINAL JACOBIAN AND RESIDUAL. (SEE
-C REF. 2 FOR MORE DETAILS.)
-C
-C *** FUNCTIONS AND SUBROUTINES CALLED ***
-C
-C D7TPR - RETURNS INNER PRODUCT OF TWO VECTORS.
-C L7ITV - APPLY INVERSE-TRANSPOSE OF COMPACT LOWER TRIANG. MATRIX.
-C L7IVM - APPLY INVERSE OF COMPACT LOWER TRIANG. MATRIX.
-C V7CPY - COPIES ONE VECTOR TO ANOTHER.
-C V2NRM - RETURNS 2-NORM OF A VECTOR.
-C
-C *** REFERENCES ***
-C
-C 1. DENNIS, J.E., GAY, D.M., AND WELSCH, R.E. (1981), AN ADAPTIVE
-C NONLINEAR LEAST-SQUARES ALGORITHM, ACM TRANS. MATH.
-C SOFTWARE, VOL. 7, NO. 3.
-C 2. GAY, D.M. (1981), COMPUTING OPTIMAL LOCALLY CONSTRAINED STEPS,
-C SIAM J. SCI. STATIST. COMPUTING, VOL. 2, NO. 2, PP.
-C 186-197.
-C 3. LAWSON, C.L., AND HANSON, R.J. (1974), SOLVING LEAST SQUARES
-C PROBLEMS, PRENTICE-HALL, ENGLEWOOD CLIFFS, N.J.
-C 4. MORE, J.J. (1978), THE LEVENBERG-MARQUARDT ALGORITHM, IMPLEMEN-
-C TATION AND THEORY, PP.105-116 OF SPRINGER LECTURE NOTES
-C IN MATHEMATICS NO. 630, EDITED BY G.A. WATSON, SPRINGER-
-C VERLAG, BERLIN AND NEW YORK.
-C
-C *** GENERAL ***
-C
-C CODED BY DAVID M. GAY.
-C THIS SUBROUTINE WAS WRITTEN IN CONNECTION WITH RESEARCH
-C SUPPORTED BY THE NATIONAL SCIENCE FOUNDATION UNDER GRANTS
-C MCS-7600324, DCR75-10143, 76-14311DSS, MCS76-11989, AND
-C MCS-7906671.
-C
-C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
-C
-C *** LOCAL VARIABLES ***
-C
- INTEGER DSTSAV, I, IP1, I1, J1, K, KALIM, L, LK0, PHIPIN,
- 1 PP1O2, RES, RES0, RMAT, RMAT0, UK0
- REAL A, ADI, ALPHAK, B, DFACSQ, DST, DTOL, D1, D2,
- 1 LK, OLDPHI, PHI, PHIMAX, PHIMIN, PSIFAC, RAD,
- 2 SI, SJ, SQRTAK, T, TWOPSI, UK, WL
-C
-C *** CONSTANTS ***
- REAL DFAC, EIGHT, HALF, NEGONE, ONE, P001, THREE,
- 1 TTOL, ZERO
- REAL BIG
-C
-C *** INTRINSIC FUNCTIONS ***
-C/+
- REAL SQRT
-C/
-C *** EXTERNAL FUNCTIONS AND SUBROUTINES ***
-C
- REAL D7TPR, L7SVN, R7MDC, V2NRM
- EXTERNAL D7TPR, L7ITV, L7IVM, L7SVN, R7MDC, V7CPY, V2NRM
-C
-C *** SUBSCRIPTS FOR V ***
-C
- INTEGER DGNORM, DSTNRM, DST0, EPSLON, GTSTEP, NREDUC, PHMNFC,
- 1 PHMXFC, PREDUC, RADIUS, RAD0, STPPAR
-C/6
-C DATA DGNORM/1/, DSTNRM/2/, DST0/3/, EPSLON/19/, GTSTEP/4/,
-C 1 NREDUC/6/, PHMNFC/20/, PHMXFC/21/, PREDUC/7/, RADIUS/8/,
-C 2 RAD0/9/, STPPAR/5/
-C/7
- PARAMETER (DGNORM=1, DSTNRM=2, DST0=3, EPSLON=19, GTSTEP=4,
- 1 NREDUC=6, PHMNFC=20, PHMXFC=21, PREDUC=7, RADIUS=8,
- 2 RAD0=9, STPPAR=5)
-C/
-C
-C/6
-C DATA DFAC/256.E+0/, EIGHT/8.E+0/, HALF/0.5E+0/, NEGONE/-1.E+0/,
-C 1 ONE/1.E+0/, P001/1.E-3/, THREE/3.E+0/, TTOL/2.5E+0/,
-C 2 ZERO/0.E+0/
-C/7
- PARAMETER (DFAC=256.E+0, EIGHT=8.E+0, HALF=0.5E+0, NEGONE=-1.E+0,
- 1 ONE=1.E+0, P001=1.E-3, THREE=3.E+0, TTOL=2.5E+0,
- 2 ZERO=0.E+0)
- SAVE BIG
-C/
- DATA BIG/0.E+0/
-C
-C *** BODY ***
-C
-C *** FOR _USE_ IN RECOMPUTING STEP, THE FINAL VALUES OF LK AND UK,
-C *** THE INVERSE DERIVATIVE OF MORE*S PHI AT 0 (FOR NONSING. J)
-C *** AND THE VALUE RETURNED AS V(DSTNRM) ARE STORED AT W(LK0),
-C *** W(UK0), W(PHIPIN), AND W(DSTSAV) RESPECTIVELY.
- LK0 = P + 1
- PHIPIN = LK0 + 1
- UK0 = PHIPIN + 1
- DSTSAV = UK0 + 1
- RMAT0 = DSTSAV
-C *** A COPY OF THE R-MATRIX FROM THE QR DECOMPOSITION OF J IS
-C *** STORED IN W STARTING AT W(RMAT), AND A COPY OF THE RESIDUAL
-C *** VECTOR IS STORED IN W STARTING AT W(RES). THE LOOPS BELOW
-C *** THAT UPDATE THE QR DECOMP. FOR A NONZERO MARQUARDT PARAMETER
-C *** WORK ON THESE COPIES.
- RMAT = RMAT0 + 1
- PP1O2 = P * (P + 1) / 2
- RES0 = PP1O2 + RMAT0
- RES = RES0 + 1
- RAD = V(RADIUS)
- IF (RAD .GT. ZERO)
- 1 PSIFAC = V(EPSLON)/((EIGHT*(V(PHMNFC) + ONE) + THREE) * RAD**2)
- IF (BIG .LE. ZERO) BIG = R7MDC(6)
- PHIMAX = V(PHMXFC) * RAD
- PHIMIN = V(PHMNFC) * RAD
-C *** DTOL, DFAC, AND DFACSQ ARE USED IN RESCALING THE FAST GIVENS
-C *** REPRESENTATION OF THE UPDATED QR DECOMPOSITION.
- DTOL = ONE/DFAC
- DFACSQ = DFAC*DFAC
-C *** OLDPHI IS USED TO DETECT LIMITS OF NUMERICAL ACCURACY. IF
-C *** WE RECOMPUTE STEP AND IT DOES NOT CHANGE, THEN WE ACCEPT IT.
- OLDPHI = ZERO
- LK = ZERO
- UK = ZERO
- KALIM = KA + 12
-C
-C *** START OR RESTART, DEPENDING ON KA ***
-C
- IF (KA) 10, 20, 370
-C
-C *** FRESH START -- COMPUTE V(NREDUC) ***
-C
- 10 KA = 0
- KALIM = 12
- K = P
- IF (IERR .NE. 0) K = IABS(IERR) - 1
- V(NREDUC) = HALF* D7TPR(K, QTR, QTR)
-C
-C *** SET UP TO TRY INITIAL GAUSS-NEWTON STEP ***
-C
- 20 V(DST0) = NEGONE
- IF (IERR .NE. 0) GO TO 90
- T = L7SVN(P, R, STEP, W(RES))
- IF (T .GE. ONE) GO TO 30
- IF ( V2NRM(P, QTR) .GE. BIG*T) GO TO 90
-C
-C *** COMPUTE GAUSS-NEWTON STEP ***
-C
-C *** NOTE -- THE R-MATRIX IS STORED COMPACTLY BY COLUMNS IN
-C *** R(1), R(2), R(3), ... IT IS THE TRANSPOSE OF A
-C *** LOWER TRIANGULAR MATRIX STORED COMPACTLY BY ROWS, AND WE
-C *** TREAT IT AS SUCH WHEN USING L7ITV AND L7IVM.
- 30 CALL L7ITV(P, W, R, QTR)
-C *** TEMPORARILY STORE PERMUTED -D*STEP IN STEP.
- DO 60 I = 1, P
- J1 = IPIVOT(I)
- STEP(I) = D(J1)*W(I)
- 60 CONTINUE
- DST = V2NRM(P, STEP)
- V(DST0) = DST
- PHI = DST - RAD
- IF (PHI .LE. PHIMAX) GO TO 410
-C *** IF THIS IS A RESTART, GO TO 110 ***
- IF (KA .GT. 0) GO TO 110
-C
-C *** GAUSS-NEWTON STEP WAS UNACCEPTABLE. COMPUTE L0 ***
-C
- DO 70 I = 1, P
- J1 = IPIVOT(I)
- STEP(I) = D(J1)*(STEP(I)/DST)
- 70 CONTINUE
- CALL L7IVM(P, STEP, R, STEP)
- T = ONE / V2NRM(P, STEP)
- W(PHIPIN) = (T/RAD)*T
- LK = PHI*W(PHIPIN)
-C
-C *** COMPUTE U0 ***
-C
- 90 DO 100 I = 1, P
- 100 W(I) = G(I)/D(I)
- V(DGNORM) = V2NRM(P, W)
- UK = V(DGNORM)/RAD
- IF (UK .LE. ZERO) GO TO 390
-C
-C *** ALPHAK WILL BE USED AS THE CURRENT MARQUARDT PARAMETER. WE
-C *** _USE_ MORE*S SCHEME FOR INITIALIZING IT.
-C
- ALPHAK = ABS(V(STPPAR)) * V(RAD0)/RAD
- ALPHAK = AMIN1(UK, AMAX1(ALPHAK, LK))
-C
-C
-C *** TOP OF LOOP -- INCREMENT KA, COPY R TO RMAT, QTR TO RES ***
-C
- 110 KA = KA + 1
- CALL V7CPY(PP1O2, W(RMAT), R)
- CALL V7CPY(P, W(RES), QTR)
-C
-C *** SAFEGUARD ALPHAK AND INITIALIZE FAST GIVENS SCALE VECTOR. ***
-C
- IF (ALPHAK .LE. ZERO .OR. ALPHAK .LT. LK .OR. ALPHAK .GE. UK)
- 1 ALPHAK = UK * AMAX1(P001, SQRT(LK/UK))
- IF (ALPHAK .LE. ZERO) ALPHAK = HALF * UK
- SQRTAK = SQRT(ALPHAK)
- DO 120 I = 1, P
- 120 W(I) = ONE
-C
-C *** ADD ALPHAK*D AND UPDATE QR DECOMP. USING FAST GIVENS TRANS. ***
-C
- DO 270 I = 1, P
-C *** GENERATE, APPLY 1ST GIVENS TRANS. FOR ROW I OF ALPHAK*D.
-C *** (USE STEP TO STORE TEMPORARY ROW) ***
- L = I*(I+1)/2 + RMAT0
- WL = W(L)
- D2 = ONE
- D1 = W(I)
- J1 = IPIVOT(I)
- ADI = SQRTAK*D(J1)
- IF (ADI .GE. ABS(WL)) GO TO 150
- 130 A = ADI/WL
- B = D2*A/D1
- T = A*B + ONE
- IF (T .GT. TTOL) GO TO 150
- W(I) = D1/T
- D2 = D2/T
- W(L) = T*WL
- A = -A
- DO 140 J1 = I, P
- L = L + J1
- STEP(J1) = A*W(L)
- 140 CONTINUE
- GO TO 170
-C
- 150 B = WL/ADI
- A = D1*B/D2
- T = A*B + ONE
- IF (T .GT. TTOL) GO TO 130
- W(I) = D2/T
- D2 = D1/T
- W(L) = T*ADI
- DO 160 J1 = I, P
- L = L + J1
- WL = W(L)
- STEP(J1) = -WL
- W(L) = A*WL
- 160 CONTINUE
-C
- 170 IF (I .EQ. P) GO TO 280
-C
-C *** NOW _USE_ GIVENS TRANS. TO ZERO ELEMENTS OF TEMP. ROW ***
-C
- IP1 = I + 1
- DO 260 I1 = IP1, P
- SI = STEP(I1-1)
- IF (SI .EQ. ZERO) GO TO 260
- L = I1*(I1+1)/2 + RMAT0
- WL = W(L)
- D1 = W(I1)
-C
-C *** RESCALE ROW I1 IF NECESSARY ***
-C
- IF (D1 .GE. DTOL) GO TO 190
- D1 = D1*DFACSQ
- WL = WL/DFAC
- K = L
- DO 180 J1 = I1, P
- K = K + J1
- W(K) = W(K)/DFAC
- 180 CONTINUE
-C
-C *** _USE_ GIVENS TRANS. TO ZERO NEXT ELEMENT OF TEMP. ROW
-C
- 190 IF ( ABS(SI) .GT. ABS(WL)) GO TO 220
- 200 A = SI/WL
- B = D2*A/D1
- T = A*B + ONE
- IF (T .GT. TTOL) GO TO 220
- W(L) = T*WL
- W(I1) = D1/T
- D2 = D2/T
- DO 210 J1 = I1, P
- L = L + J1
- WL = W(L)
- SJ = STEP(J1)
- W(L) = WL + B*SJ
- STEP(J1) = SJ - A*WL
- 210 CONTINUE
- GO TO 240
-C
- 220 B = WL/SI
- A = D1*B/D2
- T = A*B + ONE
- IF (T .GT. TTOL) GO TO 200
- W(I1) = D2/T
- D2 = D1/T
- W(L) = T*SI
- DO 230 J1 = I1, P
- L = L + J1
- WL = W(L)
- SJ = STEP(J1)
- W(L) = A*WL + SJ
- STEP(J1) = B*SJ - WL
- 230 CONTINUE
-C
-C *** RESCALE TEMP. ROW IF NECESSARY ***
-C
- 240 IF (D2 .GE. DTOL) GO TO 260
- D2 = D2*DFACSQ
- DO 250 K = I1, P
- 250 STEP(K) = STEP(K)/DFAC
- 260 CONTINUE
- 270 CONTINUE
-C
-C *** COMPUTE STEP ***
-C
- 280 CALL L7ITV(P, W(RES), W(RMAT), W(RES))
-C *** RECOVER STEP AND STORE PERMUTED -D*STEP AT W(RES) ***
- DO 290 I = 1, P
- J1 = IPIVOT(I)
- K = RES0 + I
- T = W(K)
- STEP(J1) = -T
- W(K) = T*D(J1)
- 290 CONTINUE
- DST = V2NRM(P, W(RES))
- PHI = DST - RAD
- IF (PHI .LE. PHIMAX .AND. PHI .GE. PHIMIN) GO TO 430
- IF (OLDPHI .EQ. PHI) GO TO 430
- OLDPHI = PHI
-C
-C *** CHECK FOR (AND HANDLE) SPECIAL CASE ***
-C
- IF (PHI .GT. ZERO) GO TO 310
- IF (KA .GE. KALIM) GO TO 430
- TWOPSI = ALPHAK*DST*DST - D7TPR(P, STEP, G)
- IF (ALPHAK .GE. TWOPSI*PSIFAC) GO TO 310
- V(STPPAR) = -ALPHAK
- GO TO 440
-C
-C *** UNACCEPTABLE STEP -- UPDATE LK, UK, ALPHAK, AND TRY AGAIN ***
-C
- 300 IF (PHI .LT. ZERO) UK = AMIN1(UK, ALPHAK)
- GO TO 320
- 310 IF (PHI .LT. ZERO) UK = ALPHAK
- 320 DO 330 I = 1, P
- J1 = IPIVOT(I)
- K = RES0 + I
- STEP(I) = D(J1) * (W(K)/DST)
- 330 CONTINUE
- CALL L7IVM(P, STEP, W(RMAT), STEP)
- DO 340 I = 1, P
- 340 STEP(I) = STEP(I) / SQRT(W(I))
- T = ONE / V2NRM(P, STEP)
- ALPHAK = ALPHAK + T*PHI*T/RAD
- LK = AMAX1(LK, ALPHAK)
- ALPHAK = LK
- GO TO 110
-C
-C *** RESTART ***
-C
- 370 LK = W(LK0)
- UK = W(UK0)
- IF (V(DST0) .GT. ZERO .AND. V(DST0) - RAD .LE. PHIMAX) GO TO 20
- ALPHAK = ABS(V(STPPAR))
- DST = W(DSTSAV)
- PHI = DST - RAD
- T = V(DGNORM)/RAD
- IF (RAD .GT. V(RAD0)) GO TO 380
-C
-C *** SMALLER RADIUS ***
- UK = T
- IF (ALPHAK .LE. ZERO) LK = ZERO
- IF (V(DST0) .GT. ZERO) LK = AMAX1(LK, (V(DST0)-RAD)*W(PHIPIN))
- GO TO 300
-C
-C *** BIGGER RADIUS ***
- 380 IF (ALPHAK .LE. ZERO .OR. UK .GT. T) UK = T
- LK = ZERO
- IF (V(DST0) .GT. ZERO) LK = AMAX1(LK, (V(DST0)-RAD)*W(PHIPIN))
- GO TO 300
-C
-C *** SPECIAL CASE -- RAD .LE. 0 OR (G = 0 AND J IS SINGULAR) ***
-C
- 390 V(STPPAR) = ZERO
- DST = ZERO
- LK = ZERO
- UK = ZERO
- V(GTSTEP) = ZERO
- V(PREDUC) = ZERO
- DO 400 I = 1, P
- 400 STEP(I) = ZERO
- GO TO 450
-C
-C *** ACCEPTABLE GAUSS-NEWTON STEP -- RECOVER STEP FROM W ***
-C
- 410 ALPHAK = ZERO
- DO 420 I = 1, P
- J1 = IPIVOT(I)
- STEP(J1) = -W(I)
- 420 CONTINUE
-C
-C *** SAVE VALUES FOR _USE_ IN A POSSIBLE RESTART ***
-C
- 430 V(STPPAR) = ALPHAK
- 440 V(GTSTEP) = AMIN1( D7TPR(P,STEP,G), ZERO)
- V(PREDUC) = HALF * (ALPHAK*DST*DST - V(GTSTEP))
- 450 V(DSTNRM) = DST
- W(DSTSAV) = DST
- W(LK0) = LK
- W(UK0) = UK
- V(RAD0) = RAD
-C
- 999 RETURN
-C
-C *** LAST CARD OF L7MST FOLLOWS ***
- END
diff --git a/CEP/PyBDSM/src/port3/l7nvr.f b/CEP/PyBDSM/src/port3/l7nvr.f
deleted file mode 100644
index bbeb6d402ada45c43f514de9af8272dd6dfae0a6..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/l7nvr.f
+++ /dev/null
@@ -1,47 +0,0 @@
- SUBROUTINE L7NVR(N, LIN, L)
-C
-C *** COMPUTE LIN = L**-1, BOTH N X N LOWER TRIANG. STORED ***
-C *** COMPACTLY BY ROWS. LIN AND L MAY SHARE THE SAME STORAGE. ***
-C
-C *** PARAMETERS ***
-C
- INTEGER N
- REAL L(1), LIN(1)
-C DIMENSION L(N*(N+1)/2), LIN(N*(N+1)/2)
-C
-C *** LOCAL VARIABLES ***
-C
- INTEGER I, II, IM1, JJ, J0, J1, K, K0, NP1
- REAL ONE, T, ZERO
-C/6
-C DATA ONE/1.E+0/, ZERO/0.E+0/
-C/7
- PARAMETER (ONE=1.E+0, ZERO=0.E+0)
-C/
-C
-C *** BODY ***
-C
- NP1 = N + 1
- J0 = N*(NP1)/2
- DO 30 II = 1, N
- I = NP1 - II
- LIN(J0) = ONE/L(J0)
- IF (I .LE. 1) GO TO 999
- J1 = J0
- IM1 = I - 1
- DO 20 JJ = 1, IM1
- T = ZERO
- J0 = J1
- K0 = J1 - JJ
- DO 10 K = 1, JJ
- T = T - L(K0)*LIN(J0)
- J0 = J0 - 1
- K0 = K0 + K - I
- 10 CONTINUE
- LIN(J0) = T/L(K0)
- 20 CONTINUE
- J0 = J0 - 1
- 30 CONTINUE
- 999 RETURN
-C *** LAST CARD OF L7NVR FOLLOWS ***
- END
diff --git a/CEP/PyBDSM/src/port3/l7sqr.f b/CEP/PyBDSM/src/port3/l7sqr.f
deleted file mode 100644
index 8b99f85785a4a4085c20c79fa2783e3bcda0fc99..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/l7sqr.f
+++ /dev/null
@@ -1,39 +0,0 @@
- SUBROUTINE L7SQR(N, A, L)
-C
-C *** COMPUTE A = LOWER TRIANGLE OF L*(L**T), WITH BOTH
-C *** L AND A STORED COMPACTLY BY ROWS. (BOTH MAY OCCUPY THE
-C *** SAME STORAGE.
-C
-C *** PARAMETERS ***
-C
- INTEGER N
- REAL A(1), L(1)
-C DIMENSION A(N*(N+1)/2), L(N*(N+1)/2)
-C
-C *** LOCAL VARIABLES ***
-C
- INTEGER I, II, IJ, IK, IP1, I0, J, JJ, JK, J0, K, NP1
- REAL T
-C
- NP1 = N + 1
- I0 = N*(N+1)/2
- DO 30 II = 1, N
- I = NP1 - II
- IP1 = I + 1
- I0 = I0 - I
- J0 = I*(I+1)/2
- DO 20 JJ = 1, I
- J = IP1 - JJ
- J0 = J0 - J
- T = 0.0E0
- DO 10 K = 1, J
- IK = I0 + K
- JK = J0 + K
- T = T + L(IK)*L(JK)
- 10 CONTINUE
- IJ = I0 + J
- A(IJ) = T
- 20 CONTINUE
- 30 CONTINUE
- 999 RETURN
- END
diff --git a/CEP/PyBDSM/src/port3/l7srt.f b/CEP/PyBDSM/src/port3/l7srt.f
deleted file mode 100644
index 21bbe6060f232851bd88f71b012b0192c22fd710..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/l7srt.f
+++ /dev/null
@@ -1,69 +0,0 @@
- SUBROUTINE L7SRT(N1, N, L, A, IRC)
-C
-C *** COMPUTE ROWS N1 THROUGH N OF THE CHOLESKY FACTOR L OF
-C *** A = L*(L**T), WHERE L AND THE LOWER TRIANGLE OF A ARE BOTH
-C *** STORED COMPACTLY BY ROWS (AND MAY OCCUPY THE SAME STORAGE).
-C *** IRC = 0 MEANS ALL WENT WELL. IRC = J MEANS THE LEADING
-C *** PRINCIPAL J X J SUBMATRIX OF A IS NOT POSITIVE DEFINITE --
-C *** AND L(J*(J+1)/2) CONTAINS THE (NONPOS.) REDUCED J-TH DIAGONAL.
-C
-C *** PARAMETERS ***
-C
- INTEGER N1, N, IRC
- REAL L(1), A(1)
-C DIMENSION L(N*(N+1)/2), A(N*(N+1)/2)
-C
-C *** LOCAL VARIABLES ***
-C
- INTEGER I, IJ, IK, IM1, I0, J, JK, JM1, J0, K
- REAL T, TD, ZERO
-C
-C *** INTRINSIC FUNCTIONS ***
-C/+
- REAL SQRT
-C/
-C/6
-C DATA ZERO/0.E+0/
-C/7
- PARAMETER (ZERO=0.E+0)
-C/
-C
-C *** BODY ***
-C
- I0 = N1 * (N1 - 1) / 2
- DO 50 I = N1, N
- TD = ZERO
- IF (I .EQ. 1) GO TO 40
- J0 = 0
- IM1 = I - 1
- DO 30 J = 1, IM1
- T = ZERO
- IF (J .EQ. 1) GO TO 20
- JM1 = J - 1
- DO 10 K = 1, JM1
- IK = I0 + K
- JK = J0 + K
- T = T + L(IK)*L(JK)
- 10 CONTINUE
- 20 IJ = I0 + J
- J0 = J0 + J
- T = (A(IJ) - T) / L(J0)
- L(IJ) = T
- TD = TD + T*T
- 30 CONTINUE
- 40 I0 = I0 + I
- T = A(I0) - TD
- IF (T .LE. ZERO) GO TO 60
- L(I0) = SQRT(T)
- 50 CONTINUE
-C
- IRC = 0
- GO TO 999
-C
- 60 L(I0) = T
- IRC = I
-C
- 999 RETURN
-C
-C *** LAST CARD OF L7SRT ***
- END
diff --git a/CEP/PyBDSM/src/port3/l7svn.f b/CEP/PyBDSM/src/port3/l7svn.f
deleted file mode 100644
index 0fd8e2c2e01d1c632da9f824e0f0bf1f5eb717af..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/l7svn.f
+++ /dev/null
@@ -1,175 +0,0 @@
- REAL FUNCTION L7SVN(P, L, X, Y)
-C
-C *** ESTIMATE SMALLEST SING. VALUE OF PACKED LOWER TRIANG. MATRIX L
-C
-C *** PARAMETER DECLARATIONS ***
-C
- INTEGER P
- REAL L(1), X(P), Y(P)
-C DIMENSION L(P*(P+1)/2)
-C
-C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
-C
-C *** PURPOSE ***
-C
-C THIS FUNCTION RETURNS A GOOD OVER-ESTIMATE OF THE SMALLEST
-C SINGULAR VALUE OF THE PACKED LOWER TRIANGULAR MATRIX L.
-C
-C *** PARAMETER DESCRIPTION ***
-C
-C P (IN) = THE ORDER OF L. L IS A P X P LOWER TRIANGULAR MATRIX.
-C L (IN) = ARRAY HOLDING THE ELEMENTS OF L IN ROW ORDER, I.E.
-C L(1,1), L(2,1), L(2,2), L(3,1), L(3,2), L(3,3), ETC.
-C X (OUT) IF L7SVN RETURNS A POSITIVE VALUE, THEN X IS A NORMALIZED
-C APPROXIMATE LEFT SINGULAR VECTOR CORRESPONDING TO THE
-C SMALLEST SINGULAR VALUE. THIS APPROXIMATION MAY BE VERY
-C CRUDE. IF L7SVN RETURNS ZERO, THEN SOME COMPONENTS OF X
-C ARE ZERO AND THE REST RETAIN THEIR INPUT VALUES.
-C Y (OUT) IF L7SVN RETURNS A POSITIVE VALUE, THEN Y = (L**-1)*X IS AN
-C UNNORMALIZED APPROXIMATE RIGHT SINGULAR VECTOR CORRESPOND-
-C ING TO THE SMALLEST SINGULAR VALUE. THIS APPROXIMATION
-C MAY BE CRUDE. IF L7SVN RETURNS ZERO, THEN Y RETAINS ITS
-C INPUT VALUE. THE CALLER MAY PASS THE SAME VECTOR FOR X
-C AND Y (NONSTANDARD FORTRAN USAGE), IN WHICH CASE Y OVER-
-C WRITES X (FOR NONZERO L7SVN RETURNS).
-C
-C *** ALGORITHM NOTES ***
-C
-C THE ALGORITHM IS BASED ON (1), WITH THE ADDITIONAL PROVISION THAT
-C L7SVN = 0 IS RETURNED IF THE SMALLEST DIAGONAL ELEMENT OF L
-C (IN MAGNITUDE) IS NOT MORE THAN THE UNIT ROUNDOFF TIMES THE
-C LARGEST. THE ALGORITHM USES A RANDOM NUMBER GENERATOR PROPOSED
-C IN (4), WHICH PASSES THE SPECTRAL TEST WITH FLYING COLORS -- SEE
-C (2) AND (3).
-C
-C *** SUBROUTINES AND FUNCTIONS CALLED ***
-C
-C V2NRM - FUNCTION, RETURNS THE 2-NORM OF A VECTOR.
-C
-C *** REFERENCES ***
-C
-C (1) CLINE, A., MOLER, C., STEWART, G., AND WILKINSON, J.H.(1977),
-C AN ESTIMATE FOR THE CONDITION NUMBER OF A MATRIX, REPORT
-C TM-310, APPLIED MATH. DIV., ARGONNE NATIONAL LABORATORY.
-C
-C (2) HOAGLIN, D.C. (1976), THEORETICAL PROPERTIES OF CONGRUENTIAL
-C RANDOM-NUMBER GENERATORS -- AN EMPIRICAL VIEW,
-C MEMORANDUM NS-340, DEPT. OF STATISTICS, HARVARD UNIV.
-C
-C (3) KNUTH, D.E. (1969), THE ART OF COMPUTER PROGRAMMING, VOL. 2
-C (SEMINUMERICAL ALGORITHMS), ADDISON-WESLEY, READING, MASS.
-C
-C (4) SMITH, C.S. (1971), MULTIPLICATIVE PSEUDO-RANDOM NUMBER
-C GENERATORS WITH PRIME MODULUS, J. ASSOC. COMPUT. MACH. 18,
-C PP. 586-593.
-C
-C *** HISTORY ***
-C
-C DESIGNED AND CODED BY DAVID M. GAY (WINTER 1977/SUMMER 1978).
-C
-C *** GENERAL ***
-C
-C THIS SUBROUTINE WAS WRITTEN IN CONNECTION WITH RESEARCH
-C SUPPORTED BY THE NATIONAL SCIENCE FOUNDATION UNDER GRANTS
-C MCS-7600324, DCR75-10143, 76-14311DSS, AND MCS76-11989.
-C
-C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
-C
-C *** LOCAL VARIABLES ***
-C
- INTEGER I, II, IX, J, JI, JJ, JJJ, JM1, J0, PM1
- REAL B, SMINUS, SPLUS, T, XMINUS, XPLUS
-C
-C *** CONSTANTS ***
-C
- REAL HALF, ONE, R9973, ZERO
-C
-C *** EXTERNAL FUNCTIONS AND SUBROUTINES ***
-C
- REAL D7TPR, V2NRM
- EXTERNAL D7TPR, V2NRM, V2AXY
-C
-C/6
-C DATA HALF/0.5E+0/, ONE/1.E+0/, R9973/9973.E+0/, ZERO/0.E+0/
-C/7
- PARAMETER (HALF=0.5E+0, ONE=1.E+0, R9973=9973.E+0, ZERO=0.E+0)
-C/
-C
-C *** BODY ***
-C
- IX = 2
- PM1 = P - 1
-C
-C *** FIRST CHECK WHETHER TO RETURN L7SVN = 0 AND INITIALIZE X ***
-C
- II = 0
- J0 = P*PM1/2
- JJ = J0 + P
- IF (L(JJ) .EQ. ZERO) GO TO 110
- IX = MOD(3432*IX, 9973)
- B = HALF*(ONE + FLOAT(IX)/R9973)
- XPLUS = B / L(JJ)
- X(P) = XPLUS
- IF (P .LE. 1) GO TO 60
- DO 10 I = 1, PM1
- II = II + I
- IF (L(II) .EQ. ZERO) GO TO 110
- JI = J0 + I
- X(I) = XPLUS * L(JI)
- 10 CONTINUE
-C
-C *** SOLVE (L**T)*X = B, WHERE THE COMPONENTS OF B HAVE RANDOMLY
-C *** CHOSEN MAGNITUDES IN (.5,1) WITH SIGNS CHOSEN TO MAKE X LARGE.
-C
-C DO J = P-1 TO 1 BY -1...
- DO 50 JJJ = 1, PM1
- J = P - JJJ
-C *** DETERMINE X(J) IN THIS ITERATION. NOTE FOR I = 1,2,...,J
-C *** THAT X(I) HOLDS THE CURRENT PARTIAL SUM FOR ROW I.
- IX = MOD(3432*IX, 9973)
- B = HALF*(ONE + FLOAT(IX)/R9973)
- XPLUS = (B - X(J))
- XMINUS = (-B - X(J))
- SPLUS = ABS(XPLUS)
- SMINUS = ABS(XMINUS)
- JM1 = J - 1
- J0 = J*JM1/2
- JJ = J0 + J
- XPLUS = XPLUS/L(JJ)
- XMINUS = XMINUS/L(JJ)
- IF (JM1 .EQ. 0) GO TO 30
- DO 20 I = 1, JM1
- JI = J0 + I
- SPLUS = SPLUS + ABS(X(I) + L(JI)*XPLUS)
- SMINUS = SMINUS + ABS(X(I) + L(JI)*XMINUS)
- 20 CONTINUE
- 30 IF (SMINUS .GT. SPLUS) XPLUS = XMINUS
- X(J) = XPLUS
-C *** UPDATE PARTIAL SUMS ***
- IF (JM1 .GT. 0) CALL V2AXY(JM1, X, XPLUS, L(J0+1), X)
- 50 CONTINUE
-C
-C *** NORMALIZE X ***
-C
- 60 T = ONE/ V2NRM(P, X)
- DO 70 I = 1, P
- 70 X(I) = T*X(I)
-C
-C *** SOLVE L*Y = X AND RETURN L7SVN = 1/TWONORM(Y) ***
-C
- DO 100 J = 1, P
- JM1 = J - 1
- J0 = J*JM1/2
- JJ = J0 + J
- T = ZERO
- IF (JM1 .GT. 0) T = D7TPR(JM1, L(J0+1), Y)
- Y(J) = (X(J) - T) / L(JJ)
- 100 CONTINUE
-C
- L7SVN = ONE/ V2NRM(P, Y)
- GO TO 999
-C
- 110 L7SVN = ZERO
- 999 RETURN
-C *** LAST CARD OF L7SVN FOLLOWS ***
- END
diff --git a/CEP/PyBDSM/src/port3/l7svx.f b/CEP/PyBDSM/src/port3/l7svx.f
deleted file mode 100644
index cd8a445fac39e25dc7c3eec5ec559ab95f6bc36d..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/l7svx.f
+++ /dev/null
@@ -1,171 +0,0 @@
- REAL FUNCTION L7SVX(P, L, X, Y)
-C
-C *** ESTIMATE LARGEST SING. VALUE OF PACKED LOWER TRIANG. MATRIX L
-C
-C *** PARAMETER DECLARATIONS ***
-C
- INTEGER P
- REAL L(1), X(P), Y(P)
-C DIMENSION L(P*(P+1)/2)
-C
-C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
-C
-C *** PURPOSE ***
-C
-C THIS FUNCTION RETURNS A GOOD UNDER-ESTIMATE OF THE LARGEST
-C SINGULAR VALUE OF THE PACKED LOWER TRIANGULAR MATRIX L.
-C
-C *** PARAMETER DESCRIPTION ***
-C
-C P (IN) = THE ORDER OF L. L IS A P X P LOWER TRIANGULAR MATRIX.
-C L (IN) = ARRAY HOLDING THE ELEMENTS OF L IN ROW ORDER, I.E.
-C L(1,1), L(2,1), L(2,2), L(3,1), L(3,2), L(3,3), ETC.
-C X (OUT) IF L7SVX RETURNS A POSITIVE VALUE, THEN X = (L**T)*Y IS AN
-C (UNNORMALIZED) APPROXIMATE RIGHT SINGULAR VECTOR
-C CORRESPONDING TO THE LARGEST SINGULAR VALUE. THIS
-C APPROXIMATION MAY BE CRUDE.
-C Y (OUT) IF L7SVX RETURNS A POSITIVE VALUE, THEN Y = L*X IS A
-C NORMALIZED APPROXIMATE LEFT SINGULAR VECTOR CORRESPOND-
-C ING TO THE LARGEST SINGULAR VALUE. THIS APPROXIMATION
-C MAY BE VERY CRUDE. THE CALLER MAY PASS THE SAME VECTOR
-C FOR X AND Y (NONSTANDARD FORTRAN USAGE), IN WHICH CASE X
-C OVER-WRITES Y.
-C
-C *** ALGORITHM NOTES ***
-C
-C THE ALGORITHM IS BASED ON ANALOGY WITH (1). IT USES A
-C RANDOM NUMBER GENERATOR PROPOSED IN (4), WHICH PASSES THE
-C SPECTRAL TEST WITH FLYING COLORS -- SEE (2) AND (3).
-C
-C *** SUBROUTINES AND FUNCTIONS CALLED ***
-C
-C V2NRM - FUNCTION, RETURNS THE 2-NORM OF A VECTOR.
-C
-C *** REFERENCES ***
-C
-C (1) CLINE, A., MOLER, C., STEWART, G., AND WILKINSON, J.H.(1977),
-C AN ESTIMATE FOR THE CONDITION NUMBER OF A MATRIX, REPORT
-C TM-310, APPLIED MATH. DIV., ARGONNE NATIONAL LABORATORY.
-C
-C (2) HOAGLIN, D.C. (1976), THEORETICAL PROPERTIES OF CONGRUENTIAL
-C RANDOM-NUMBER GENERATORS -- AN EMPIRICAL VIEW,
-C MEMORANDUM NS-340, DEPT. OF STATISTICS, HARVARD UNIV.
-C
-C (3) KNUTH, D.E. (1969), THE ART OF COMPUTER PROGRAMMING, VOL. 2
-C (SEMINUMERICAL ALGORITHMS), ADDISON-WESLEY, READING, MASS.
-C
-C (4) SMITH, C.S. (1971), MULTIPLICATIVE PSEUDO-RANDOM NUMBER
-C GENERATORS WITH PRIME MODULUS, J. ASSOC. COMPUT. MACH. 18,
-C PP. 586-593.
-C
-C *** HISTORY ***
-C
-C DESIGNED AND CODED BY DAVID M. GAY (WINTER 1977/SUMMER 1978).
-C
-C *** GENERAL ***
-C
-C THIS SUBROUTINE WAS WRITTEN IN CONNECTION WITH RESEARCH
-C SUPPORTED BY THE NATIONAL SCIENCE FOUNDATION UNDER GRANTS
-C MCS-7600324, DCR75-10143, 76-14311DSS, AND MCS76-11989.
-C
-C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
-C
-C *** LOCAL VARIABLES ***
-C
- INTEGER I, IX, J, JI, JJ, JJJ, JM1, J0, PM1, PPLUS1
- REAL B, BLJI, SMINUS, SPLUS, T, YI
-C
-C *** CONSTANTS ***
-C
- REAL HALF, ONE, R9973, ZERO
-C
-C *** EXTERNAL FUNCTIONS AND SUBROUTINES ***
-C
- REAL D7TPR, V2NRM
- EXTERNAL D7TPR, V2NRM, V2AXY
-C
-C/6
-C DATA HALF/0.5E+0/, ONE/1.E+0/, R9973/9973.E+0/, ZERO/0.E+0/
-C/7
- PARAMETER (HALF=0.5E+0, ONE=1.E+0, R9973=9973.E+0, ZERO=0.E+0)
-C/
-C
-C *** BODY ***
-C
- IX = 2
- PPLUS1 = P + 1
- PM1 = P - 1
-C
-C *** FIRST INITIALIZE X TO PARTIAL SUMS ***
-C
- J0 = P*PM1/2
- JJ = J0 + P
- IX = MOD(3432*IX, 9973)
- B = HALF*(ONE + FLOAT(IX)/R9973)
- X(P) = B * L(JJ)
- IF (P .LE. 1) GO TO 40
- DO 10 I = 1, PM1
- JI = J0 + I
- X(I) = B * L(JI)
- 10 CONTINUE
-C
-C *** COMPUTE X = (L**T)*B, WHERE THE COMPONENTS OF B HAVE RANDOMLY
-C *** CHOSEN MAGNITUDES IN (.5,1) WITH SIGNS CHOSEN TO MAKE X LARGE.
-C
-C DO J = P-1 TO 1 BY -1...
- DO 30 JJJ = 1, PM1
- J = P - JJJ
-C *** DETERMINE X(J) IN THIS ITERATION. NOTE FOR I = 1,2,...,J
-C *** THAT X(I) HOLDS THE CURRENT PARTIAL SUM FOR ROW I.
- IX = MOD(3432*IX, 9973)
- B = HALF*(ONE + FLOAT(IX)/R9973)
- JM1 = J - 1
- J0 = J*JM1/2
- SPLUS = ZERO
- SMINUS = ZERO
- DO 20 I = 1, J
- JI = J0 + I
- BLJI = B * L(JI)
- SPLUS = SPLUS + ABS(BLJI + X(I))
- SMINUS = SMINUS + ABS(BLJI - X(I))
- 20 CONTINUE
- IF (SMINUS .GT. SPLUS) B = -B
- X(J) = ZERO
-C *** UPDATE PARTIAL SUMS ***
- CALL V2AXY(J, X, B, L(J0+1), X)
- 30 CONTINUE
-C
-C *** NORMALIZE X ***
-C
- 40 T = V2NRM(P, X)
- IF (T .LE. ZERO) GO TO 80
- T = ONE / T
- DO 50 I = 1, P
- 50 X(I) = T*X(I)
-C
-C *** COMPUTE L*X = Y AND RETURN SVMAX = TWONORM(Y) ***
-C
- DO 60 JJJ = 1, P
- J = PPLUS1 - JJJ
- JI = J*(J-1)/2 + 1
- Y(J) = D7TPR(J, L(JI), X)
- 60 CONTINUE
-C
-C *** NORMALIZE Y AND SET X = (L**T)*Y ***
-C
- T = ONE / V2NRM(P, Y)
- JI = 1
- DO 70 I = 1, P
- YI = T * Y(I)
- X(I) = ZERO
- CALL V2AXY(I, X, YI, L(JI), X)
- JI = JI + I
- 70 CONTINUE
- L7SVX = V2NRM(P, X)
- GO TO 999
-C
- 80 L7SVX = ZERO
-C
- 999 RETURN
-C *** LAST CARD OF L7SVX FOLLOWS ***
- END
diff --git a/CEP/PyBDSM/src/port3/l7tsq.f b/CEP/PyBDSM/src/port3/l7tsq.f
deleted file mode 100644
index 4b47ae0ef5720f0d65b176727d066cec57e646ea..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/l7tsq.f
+++ /dev/null
@@ -1,36 +0,0 @@
- SUBROUTINE L7TSQ(N, A, L)
-C
-C *** SET A TO LOWER TRIANGLE OF (L**T) * L ***
-C
-C *** L = N X N LOWER TRIANG. MATRIX STORED ROWWISE. ***
-C *** A IS ALSO STORED ROWWISE AND MAY SHARE STORAGE WITH L. ***
-C
- INTEGER N
- REAL A(1), L(1)
-C DIMENSION A(N*(N+1)/2), L(N*(N+1)/2)
-C
- INTEGER I, II, IIM1, I1, J, K, M
- REAL LII, LJ
-C
- II = 0
- DO 50 I = 1, N
- I1 = II + 1
- II = II + I
- M = 1
- IF (I .EQ. 1) GO TO 30
- IIM1 = II - 1
- DO 20 J = I1, IIM1
- LJ = L(J)
- DO 10 K = I1, J
- A(M) = A(M) + LJ*L(K)
- M = M + 1
- 10 CONTINUE
- 20 CONTINUE
- 30 LII = L(II)
- DO 40 J = I1, II
- 40 A(J) = LII * L(J)
- 50 CONTINUE
-C
- 999 RETURN
-C *** LAST CARD OF L7TSQ FOLLOWS ***
- END
diff --git a/CEP/PyBDSM/src/port3/l7tvm.f b/CEP/PyBDSM/src/port3/l7tvm.f
deleted file mode 100644
index 58e323fd97ee120107963fabc0b7cacff82777b0..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/l7tvm.f
+++ /dev/null
@@ -1,30 +0,0 @@
- SUBROUTINE L7TVM(N, X, L, Y)
-C
-C *** COMPUTE X = (L**T)*Y, WHERE L IS AN N X N LOWER
-C *** TRIANGULAR MATRIX STORED COMPACTLY BY ROWS. X AND Y MAY
-C *** OCCUPY THE SAME STORAGE. ***
-C
- INTEGER N
- REAL X(N), L(1), Y(N)
-C DIMENSION L(N*(N+1)/2)
- INTEGER I, IJ, I0, J
- REAL YI, ZERO
-C/6
-C DATA ZERO/0.E+0/
-C/7
- PARAMETER (ZERO=0.E+0)
-C/
-C
- I0 = 0
- DO 20 I = 1, N
- YI = Y(I)
- X(I) = ZERO
- DO 10 J = 1, I
- IJ = I0 + J
- X(J) = X(J) + YI*L(IJ)
- 10 CONTINUE
- I0 = I0 + I
- 20 CONTINUE
- 999 RETURN
-C *** LAST CARD OF L7TVM FOLLOWS ***
- END
diff --git a/CEP/PyBDSM/src/port3/l7upd.f b/CEP/PyBDSM/src/port3/l7upd.f
deleted file mode 100644
index bd21c0a1aeecdd597b9c34bcfd6b5eadf8c0fce1..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/l7upd.f
+++ /dev/null
@@ -1,142 +0,0 @@
- SUBROUTINE L7UPD(BETA, GAMMA, L, LAMBDA, LPLUS, N, W, Z)
-C
-C *** COMPUTE LPLUS = SECANT UPDATE OF L ***
-C
-C *** PARAMETER DECLARATIONS ***
-C
- INTEGER N
- REAL BETA(N), GAMMA(N), L(1), LAMBDA(N), LPLUS(1),
- 1 W(N), Z(N)
-C DIMENSION L(N*(N+1)/2), LPLUS(N*(N+1)/2)
-C
-C-------------------------- PARAMETER USAGE --------------------------
-C
-C BETA = SCRATCH VECTOR.
-C GAMMA = SCRATCH VECTOR.
-C L (INPUT) LOWER TRIANGULAR MATRIX, STORED ROWWISE.
-C LAMBDA = SCRATCH VECTOR.
-C LPLUS (OUTPUT) LOWER TRIANGULAR MATRIX, STORED ROWWISE, WHICH MAY
-C OCCUPY THE SAME STORAGE AS L.
-C N (INPUT) LENGTH OF VECTOR PARAMETERS AND ORDER OF MATRICES.
-C W (INPUT, DESTROYED ON OUTPUT) RIGHT SINGULAR VECTOR OF RANK 1
-C CORRECTION TO L.
-C Z (INPUT, DESTROYED ON OUTPUT) LEFT SINGULAR VECTOR OF RANK 1
-C CORRECTION TO L.
-C
-C------------------------------- NOTES -------------------------------
-C
-C *** APPLICATION AND USAGE RESTRICTIONS ***
-C
-C THIS ROUTINE UPDATES THE CHOLESKY FACTOR L OF A SYMMETRIC
-C POSITIVE DEFINITE MATRIX TO WHICH A SECANT UPDATE IS BEING
-C APPLIED -- IT COMPUTES A CHOLESKY FACTOR LPLUS OF
-C L * (I + Z*W**T) * (I + W*Z**T) * L**T. IT IS ASSUMED THAT W
-C AND Z HAVE BEEN CHOSEN SO THAT THE UPDATED MATRIX IS STRICTLY
-C POSITIVE DEFINITE.
-C
-C *** ALGORITHM NOTES ***
-C
-C THIS CODE USES RECURRENCE 3 OF REF. 1 (WITH D(J) = 1 FOR ALL J)
-C TO COMPUTE LPLUS OF THE FORM L * (I + Z*W**T) * Q, WHERE Q
-C IS AN ORTHOGONAL MATRIX THAT MAKES THE RESULT LOWER TRIANGULAR.
-C LPLUS MAY HAVE SOME NEGATIVE DIAGONAL ELEMENTS.
-C
-C *** REFERENCES ***
-C
-C 1. GOLDFARB, D. (1976), FACTORIZED VARIABLE METRIC METHODS FOR UNCON-
-C STRAINED OPTIMIZATION, MATH. COMPUT. 30, PP. 796-811.
-C
-C *** GENERAL ***
-C
-C CODED BY DAVID M. GAY (FALL 1979).
-C THIS SUBROUTINE WAS WRITTEN IN CONNECTION WITH RESEARCH SUPPORTED
-C BY THE NATIONAL SCIENCE FOUNDATION UNDER GRANTS MCS-7600324 AND
-C MCS-7906671.
-C
-C------------------------ EXTERNAL QUANTITIES ------------------------
-C
-C *** INTRINSIC FUNCTIONS ***
-C/+
- REAL SQRT
-C/
-C-------------------------- LOCAL VARIABLES --------------------------
-C
- INTEGER I, IJ, J, JJ, JP1, K, NM1, NP1
- REAL A, B, BJ, ETA, GJ, LJ, LIJ, LJJ, NU, S, THETA,
- 1 WJ, ZJ
- REAL ONE, ZERO
-C
-C *** DATA INITIALIZATIONS ***
-C
-C/6
-C DATA ONE/1.E+0/, ZERO/0.E+0/
-C/7
- PARAMETER (ONE=1.E+0, ZERO=0.E+0)
-C/
-C
-C+++++++++++++++++++++++++++++++ BODY ++++++++++++++++++++++++++++++++
-C
- NU = ONE
- ETA = ZERO
- IF (N .LE. 1) GO TO 30
- NM1 = N - 1
-C
-C *** TEMPORARILY STORE S(J) = SUM OVER K = J+1 TO N OF W(K)**2 IN
-C *** LAMBDA(J).
-C
- S = ZERO
- DO 10 I = 1, NM1
- J = N - I
- S = S + W(J+1)**2
- LAMBDA(J) = S
- 10 CONTINUE
-C
-C *** COMPUTE LAMBDA, GAMMA, AND BETA BY GOLDFARB*S RECURRENCE 3.
-C
- DO 20 J = 1, NM1
- WJ = W(J)
- A = NU*Z(J) - ETA*WJ
- THETA = ONE + A*WJ
- S = A*LAMBDA(J)
- LJ = SQRT(THETA**2 + A*S)
- IF (THETA .GT. ZERO) LJ = -LJ
- LAMBDA(J) = LJ
- B = THETA*WJ + S
- GAMMA(J) = B * NU / LJ
- BETA(J) = (A - B*ETA) / LJ
- NU = -NU / LJ
- ETA = -(ETA + (A**2)/(THETA - LJ)) / LJ
- 20 CONTINUE
- 30 LAMBDA(N) = ONE + (NU*Z(N) - ETA*W(N))*W(N)
-C
-C *** UPDATE L, GRADUALLY OVERWRITING W AND Z WITH L*W AND L*Z.
-C
- NP1 = N + 1
- JJ = N * (N + 1) / 2
- DO 60 K = 1, N
- J = NP1 - K
- LJ = LAMBDA(J)
- LJJ = L(JJ)
- LPLUS(JJ) = LJ * LJJ
- WJ = W(J)
- W(J) = LJJ * WJ
- ZJ = Z(J)
- Z(J) = LJJ * ZJ
- IF (K .EQ. 1) GO TO 50
- BJ = BETA(J)
- GJ = GAMMA(J)
- IJ = JJ + J
- JP1 = J + 1
- DO 40 I = JP1, N
- LIJ = L(IJ)
- LPLUS(IJ) = LJ*LIJ + BJ*W(I) + GJ*Z(I)
- W(I) = W(I) + LIJ*WJ
- Z(I) = Z(I) + LIJ*ZJ
- IJ = IJ + I
- 40 CONTINUE
- 50 JJ = JJ - J
- 60 CONTINUE
-C
- 999 RETURN
-C *** LAST CARD OF L7UPD FOLLOWS ***
- END
diff --git a/CEP/PyBDSM/src/port3/l7vml.f b/CEP/PyBDSM/src/port3/l7vml.f
deleted file mode 100644
index bbeeaab31383c4a4f7a83370f2a8aca5981476f2..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/l7vml.f
+++ /dev/null
@@ -1,32 +0,0 @@
- SUBROUTINE L7VML(N, X, L, Y)
-C
-C *** COMPUTE X = L*Y, WHERE L IS AN N X N LOWER TRIANGULAR
-C *** MATRIX STORED COMPACTLY BY ROWS. X AND Y MAY OCCUPY THE SAME
-C *** STORAGE. ***
-C
- INTEGER N
- REAL X(N), L(1), Y(N)
-C DIMENSION L(N*(N+1)/2)
- INTEGER I, II, IJ, I0, J, NP1
- REAL T, ZERO
-C/6
-C DATA ZERO/0.E+0/
-C/7
- PARAMETER (ZERO=0.E+0)
-C/
-C
- NP1 = N + 1
- I0 = N*(N+1)/2
- DO 20 II = 1, N
- I = NP1 - II
- I0 = I0 - I
- T = ZERO
- DO 10 J = 1, I
- IJ = I0 + J
- T = T + L(IJ)*Y(J)
- 10 CONTINUE
- X(I) = T
- 20 CONTINUE
- 999 RETURN
-C *** LAST CARD OF L7VML FOLLOWS ***
- END
diff --git a/CEP/PyBDSM/src/port3/leave.f b/CEP/PyBDSM/src/port3/leave.f
deleted file mode 100644
index 77ba27d6b89281bec8e0fa28c66310a7992ff2c9..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/leave.f
+++ /dev/null
@@ -1,74 +0,0 @@
- SUBROUTINE LEAVE
-C
-C THIS ROUTINE
-C
-C 1) DE-ALLOCATES ALL SCRATCH SPACE ALLOCATED SINCE THE LAST ENTER,
-C INCLUDING THE LAST ENTER-BLOCK.
-C 2) RESTORES THE RECOVERY LEVEL TO ITS VALUE
-C AT THE TIME OF THE LAST CALL TO ENTER.
-C
-C ERROR STATES -
-C
-C 1 - CANNOT LEAVE BEYOND THE FIRST ENTER.
-C 2 - ISTACK(INOW) HAS BEEN OVERWRITTEN.
-C 3 - TOO MANY ISTKRLS OR ISTACK(1 AND/OR INOW) CLOBBERED.
-C 4 - ISTACK(INOW+1) HAS BEEN OVERWRITTEN.
-C 5 - ISTACK(INOW+2) HAS BEEN OVERWRITTEN.
-C
- COMMON /CSTAK/DSTACK
- DOUBLE PRECISION DSTACK(500)
- INTEGER ISTACK(1000)
- EQUIVALENCE (DSTACK(1),ISTACK(1))
- EQUIVALENCE (ISTACK(1),LOUT)
-C
-C GET THE POINTER TO THE CURRENT ENTER-BLOCK.
-C
- INOW=I8TSEL(-1)
-C
-C/6S
-C IF (INOW.EQ.0)
-C 1 CALL SETERR(43HLEAVE - CANNOT LEAVE BEYOND THE FIRST ENTER,43,
-C 2 1,2)
-C IF (ISTACK(INOW).LT.1)
-C 1 CALL SETERR(41HLEAVE - ISTACK(INOW) HAS BEEN OVERWRITTEN,41,2,2)
-C IF (LOUT.LT.ISTACK(INOW)) CALL SETERR(
-C 1 59HLEAVE - TOO MANY ISTKRLS OR ISTACK(1 AND/OR INOW) CLOBBERED,
-C 2 59,3,2)
-C IF (ISTACK(INOW+1).LT.1 .OR. ISTACK(INOW+1).GT.2)
-C 1 CALL SETERR(43HLEAVE - ISTACK(INOW+1) HAS BEEN OVERWRITTEN,
-C 2 43,4,2)
-C IF (ISTACK(INOW+2).GT.INOW-3 .OR. ISTACK(INOW+2).LT.0)
-C 1 CALL SETERR(43HLEAVE - ISTACK(INOW+2) HAS BEEN OVERWRITTEN,
-C 2 43,5,2)
-C/7S
- IF (INOW.EQ.0)
- 1 CALL SETERR('LEAVE - CANNOT LEAVE BEYOND THE FIRST ENTER',43,
- 2 1,2)
- IF (ISTACK(INOW).LT.1)
- 1 CALL SETERR('LEAVE - ISTACK(INOW) HAS BEEN OVERWRITTEN',41,2,2)
- IF (LOUT.LT.ISTACK(INOW)) CALL SETERR(
- 1 'LEAVE - TOO MANY ISTKRLS OR ISTACK(1 AND/OR INOW) CLOBBERED',
- 2 59,3,2)
- IF (ISTACK(INOW+1).LT.1 .OR. ISTACK(INOW+1).GT.2)
- 1 CALL SETERR('LEAVE - ISTACK(INOW+1) HAS BEEN OVERWRITTEN',
- 2 43,4,2)
- IF (ISTACK(INOW+2).GT.INOW-3 .OR. ISTACK(INOW+2).LT.0)
- 1 CALL SETERR('LEAVE - ISTACK(INOW+2) HAS BEEN OVERWRITTEN',
- 2 43,5,2)
-C/
-C
-C DE-ALLOCATE THE SCRATCH SPACE.
-C
- CALL ISTKRL(LOUT-ISTACK(INOW)+1)
-C
-C RESTORE THE RECOVERY LEVEL.
-C
- CALL RETSRC(ISTACK(INOW+1))
-C
-C LOWER THE BACK-POINTER.
-C
- ITEMP=I8TSEL(ISTACK(INOW+2))
-C
- RETURN
-C
- END
diff --git a/CEP/PyBDSM/src/port3/m7seq.f b/CEP/PyBDSM/src/port3/m7seq.f
deleted file mode 100644
index 25a96640c37ec7c1d751438d01715e8391fb6d45..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/m7seq.f
+++ /dev/null
@@ -1,162 +0,0 @@
- SUBROUTINE M7SEQ(N,INDROW,JPNTR,INDCOL,IPNTR,LIST,NGRP,MAXGRP,
- * IWA,BWA)
- INTEGER N,MAXGRP
- INTEGER INDROW(1),JPNTR(1),INDCOL(1),IPNTR(1),LIST(N),NGRP(N),
- * IWA(N)
- LOGICAL BWA(N)
-C **********
-C
-C SUBROUTINE M7SEQ
-C
-C GIVEN THE SPARSITY PATTERN OF AN M BY N MATRIX A, THIS
-C SUBROUTINE DETERMINES A CONSISTENT PARTITION OF THE
-C COLUMNS OF A BY A SEQUENTIAL ALGORITHM.
-C
-C A CONSISTENT PARTITION IS DEFINED IN TERMS OF THE LOOPLESS
-C GRAPH G WITH VERTICES A(J), J = 1,2,...,N WHERE A(J) IS THE
-C J-TH COLUMN OF A AND WITH EDGE (A(I),A(J)) IF AND ONLY IF
-C COLUMNS I AND J HAVE A NON-ZERO IN THE SAME ROW POSITION.
-C
-C A PARTITION OF THE COLUMNS OF A INTO GROUPS IS CONSISTENT
-C IF THE COLUMNS IN ANY GROUP ARE NOT ADJACENT IN THE GRAPH G.
-C IN GRAPH-THEORY TERMINOLOGY, A CONSISTENT PARTITION OF THE
-C COLUMNS OF A CORRESPONDS TO A COLORING OF THE GRAPH G.
-C
-C THE SUBROUTINE EXAMINES THE COLUMNS IN THE ORDER SPECIFIED
-C BY THE ARRAY LIST, AND ASSIGNS THE CURRENT COLUMN TO THE
-C GROUP WITH THE SMALLEST POSSIBLE NUMBER.
-C
-C NOTE THAT THE VALUE OF M IS NOT NEEDED BY M7SEQ AND IS
-C THEREFORE NOT PRESENT IN THE SUBROUTINE STATEMENT.
-C
-C THE SUBROUTINE STATEMENT IS
-C
-C SUBROUTINE M7SEQ(N,INDROW,JPNTR,INDCOL,IPNTR,LIST,NGRP,MAXGRP,
-C IWA,BWA)
-C
-C WHERE
-C
-C N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER
-C OF COLUMNS OF A.
-C
-C INDROW IS AN INTEGER INPUT ARRAY WHICH CONTAINS THE ROW
-C INDICES FOR THE NON-ZEROES IN THE MATRIX A.
-C
-C JPNTR IS AN INTEGER INPUT ARRAY OF LENGTH N + 1 WHICH
-C SPECIFIES THE LOCATIONS OF THE ROW INDICES IN INDROW.
-C THE ROW INDICES FOR COLUMN J ARE
-C
-C INDROW(K), K = JPNTR(J),...,JPNTR(J+1)-1.
-C
-C NOTE THAT JPNTR(N+1)-1 IS THEN THE NUMBER OF NON-ZERO
-C ELEMENTS OF THE MATRIX A.
-C
-C INDCOL IS AN INTEGER INPUT ARRAY WHICH CONTAINS THE
-C COLUMN INDICES FOR THE NON-ZEROES IN THE MATRIX A.
-C
-C IPNTR IS AN INTEGER INPUT ARRAY OF LENGTH M + 1 WHICH
-C SPECIFIES THE LOCATIONS OF THE COLUMN INDICES IN INDCOL.
-C THE COLUMN INDICES FOR ROW I ARE
-C
-C INDCOL(K), K = IPNTR(I),...,IPNTR(I+1)-1.
-C
-C NOTE THAT IPNTR(M+1)-1 IS THEN THE NUMBER OF NON-ZERO
-C ELEMENTS OF THE MATRIX A.
-C
-C LIST IS AN INTEGER INPUT ARRAY OF LENGTH N WHICH SPECIFIES
-C THE ORDER TO BE USED BY THE SEQUENTIAL ALGORITHM.
-C THE J-TH COLUMN IN THIS ORDER IS LIST(J).
-C
-C NGRP IS AN INTEGER OUTPUT ARRAY OF LENGTH N WHICH SPECIFIES
-C THE PARTITION OF THE COLUMNS OF A. COLUMN JCOL BELONGS
-C TO GROUP NGRP(JCOL).
-C
-C MAXGRP IS AN INTEGER OUTPUT VARIABLE WHICH SPECIFIES THE
-C NUMBER OF GROUPS IN THE PARTITION OF THE COLUMNS OF A.
-C
-C IWA IS AN INTEGER WORK ARRAY OF LENGTH N.
-C
-C BWA IS A LOGICAL WORK ARRAY OF LENGTH N.
-C
-C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. JUNE 1982.
-C THOMAS F. COLEMAN, BURTON S. GARBOW, JORGE J. MORE
-C
-C **********
- INTEGER DEG,IC,IP,IPL,IPU,IR,J,JCOL,JP,JPL,JPU,L,NUMGRP
-C
-C INITIALIZATION BLOCK.
-C
- MAXGRP = 0
- DO 10 JP = 1, N
- NGRP(JP) = N
- BWA(JP) = .FALSE.
- 10 CONTINUE
- BWA(N) = .TRUE.
-C
-C BEGINNING OF ITERATION LOOP.
-C
- DO 100 J = 1, N
- JCOL = LIST(J)
-C
-C FIND ALL COLUMNS ADJACENT TO COLUMN JCOL.
-C
- DEG = 0
-C
-C DETERMINE ALL POSITIONS (IR,JCOL) WHICH CORRESPOND
-C TO NON-ZEROES IN THE MATRIX.
-C
- JPL = JPNTR(JCOL)
- JPU = JPNTR(JCOL+1) - 1
- IF (JPU .LT. JPL) GO TO 50
- DO 40 JP = JPL, JPU
- IR = INDROW(JP)
-C
-C FOR EACH ROW IR, DETERMINE ALL POSITIONS (IR,IC)
-C WHICH CORRESPOND TO NON-ZEROES IN THE MATRIX.
-C
- IPL = IPNTR(IR)
- IPU = IPNTR(IR+1) - 1
- DO 30 IP = IPL, IPU
- IC = INDCOL(IP)
- L = NGRP(IC)
-C
-C ARRAY BWA MARKS THE GROUP NUMBERS OF THE
-C COLUMNS WHICH ARE ADJACENT TO COLUMN JCOL.
-C ARRAY IWA RECORDS THE MARKED GROUP NUMBERS.
-C
- IF (BWA(L)) GO TO 20
- BWA(L) = .TRUE.
- DEG = DEG + 1
- IWA(DEG) = L
- 20 CONTINUE
- 30 CONTINUE
- 40 CONTINUE
- 50 CONTINUE
-C
-C ASSIGN THE SMALLEST UN-MARKED GROUP NUMBER TO JCOL.
-C
- DO 60 JP = 1, N
- NUMGRP = JP
- IF (.NOT. BWA(JP)) GO TO 70
- 60 CONTINUE
- 70 CONTINUE
- NGRP(JCOL) = NUMGRP
- MAXGRP = MAX0(MAXGRP,NUMGRP)
-C
-C UN-MARK THE GROUP NUMBERS.
-C
- IF (DEG .LT. 1) GO TO 90
- DO 80 JP = 1, DEG
- L = IWA(JP)
- BWA(L) = .FALSE.
- 80 CONTINUE
- 90 CONTINUE
- 100 CONTINUE
-C
-C END OF ITERATION LOOP.
-C
- RETURN
-C
-C LAST CARD OF SUBROUTINE M7SEQ.
-C
- END
diff --git a/CEP/PyBDSM/src/port3/m7slo.f b/CEP/PyBDSM/src/port3/m7slo.f
deleted file mode 100644
index 9e37af5968279ae0efe63b30eec48d5b7b4b38c7..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/m7slo.f
+++ /dev/null
@@ -1,245 +0,0 @@
- SUBROUTINE M7SLO(N,INDROW,JPNTR,INDCOL,IPNTR,NDEG,LIST,
- * MAXCLQ,IWA1,IWA2,IWA3,IWA4,BWA)
- INTEGER N,MAXCLQ
- INTEGER INDROW(1),JPNTR(1),INDCOL(1),IPNTR(1),NDEG(N),
- * LIST(N),IWA1(N),IWA2(N),IWA3(N),IWA4(N)
- LOGICAL BWA(N)
-C **********
-C
-C SUBROUTINE M7SLO
-C
-C GIVEN THE SPARSITY PATTERN OF AN M BY N MATRIX A, THIS
-C SUBROUTINE DETERMINES THE SMALLEST-LAST ORDERING OF THE
-C COLUMNS OF A.
-C
-C THE SMALLEST-LAST ORDERING IS DEFINED FOR THE LOOPLESS
-C GRAPH G WITH VERTICES A(J), J = 1,2,...,N WHERE A(J) IS THE
-C J-TH COLUMN OF A AND WITH EDGE (A(I),A(J)) IF AND ONLY IF
-C COLUMNS I AND J HAVE A NON-ZERO IN THE SAME ROW POSITION.
-C
-C THE SMALLEST-LAST ORDERING IS DETERMINED RECURSIVELY BY
-C LETTING LIST(K), K = N,...,1 BE A COLUMN WITH LEAST DEGREE
-C IN THE SUBGRAPH SPANNED BY THE UN-ORDERED COLUMNS.
-C
-C NOTE THAT THE VALUE OF M IS NOT NEEDED BY M7SLO AND IS
-C THEREFORE NOT PRESENT IN THE SUBROUTINE STATEMENT.
-C
-C THE SUBROUTINE STATEMENT IS
-C
-C SUBROUTINE M7SLO(N,INDROW,JPNTR,INDCOL,IPNTR,NDEG,LIST,
-C MAXCLQ,IWA1,IWA2,IWA3,IWA4,BWA)
-C
-C WHERE
-C
-C N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER
-C OF COLUMNS OF A.
-C
-C INDROW IS AN INTEGER INPUT ARRAY WHICH CONTAINS THE ROW
-C INDICES FOR THE NON-ZEROES IN THE MATRIX A.
-C
-C JPNTR IS AN INTEGER INPUT ARRAY OF LENGTH N + 1 WHICH
-C SPECIFIES THE LOCATIONS OF THE ROW INDICES IN INDROW.
-C THE ROW INDICES FOR COLUMN J ARE
-C
-C INDROW(K), K = JPNTR(J),...,JPNTR(J+1)-1.
-C
-C NOTE THAT JPNTR(N+1)-1 IS THEN THE NUMBER OF NON-ZERO
-C ELEMENTS OF THE MATRIX A.
-C
-C INDCOL IS AN INTEGER INPUT ARRAY WHICH CONTAINS THE
-C COLUMN INDICES FOR THE NON-ZEROES IN THE MATRIX A.
-C
-C IPNTR IS AN INTEGER INPUT ARRAY OF LENGTH M + 1 WHICH
-C SPECIFIES THE LOCATIONS OF THE COLUMN INDICES IN INDCOL.
-C THE COLUMN INDICES FOR ROW I ARE
-C
-C INDCOL(K), K = IPNTR(I),...,IPNTR(I+1)-1.
-C
-C NOTE THAT IPNTR(M+1)-1 IS THEN THE NUMBER OF NON-ZERO
-C ELEMENTS OF THE MATRIX A.
-C
-C NDEG IS AN INTEGER INPUT ARRAY OF LENGTH N WHICH SPECIFIES
-C THE DEGREE SEQUENCE. THE DEGREE OF THE J-TH COLUMN
-C OF A IS NDEG(J).
-C
-C LIST IS AN INTEGER OUTPUT ARRAY OF LENGTH N WHICH SPECIFIES
-C THE SMALLEST-LAST ORDERING OF THE COLUMNS OF A. THE J-TH
-C COLUMN IN THIS ORDER IS LIST(J).
-C
-C MAXCLQ IS AN INTEGER OUTPUT VARIABLE SET TO THE SIZE
-C OF THE LARGEST CLIQUE FOUND DURING THE ORDERING.
-C
-C IWA1,IWA2,IWA3, AND IWA4 ARE INTEGER WORK ARRAYS OF LENGTH N.
-C
-C BWA IS A LOGICAL WORK ARRAY OF LENGTH N.
-C
-C SUBPROGRAMS CALLED
-C
-C FORTRAN-SUPPLIED ... MIN0
-C
-C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. JUNE 1982.
-C THOMAS F. COLEMAN, BURTON S. GARBOW, JORGE J. MORE
-C
-C **********
- INTEGER DEG,HEAD,IC,IP,IPL,IPU,IR,JCOL,JP,JPL,JPU,
- * L,MINDEG,NUMDEG,NUMORD
-C
-C INITIALIZATION BLOCK.
-C
- MINDEG = N
- DO 10 JP = 1, N
- IWA1(JP) = 0
- BWA(JP) = .FALSE.
- LIST(JP) = NDEG(JP)
- MINDEG = MIN0(MINDEG,NDEG(JP))
- 10 CONTINUE
-C
-C CREATE A DOUBLY-LINKED LIST TO ACCESS THE DEGREES OF THE
-C COLUMNS. THE POINTERS FOR THE LINKED LIST ARE AS FOLLOWS.
-C
-C EACH UN-ORDERED COLUMN JCOL IS IN A LIST (THE DEGREE
-C LIST) OF COLUMNS WITH THE SAME DEGREE.
-C
-C IWA1(NUMDEG+1) IS THE FIRST COLUMN IN THE NUMDEG LIST
-C UNLESS IWA1(NUMDEG+1) = 0. IN THIS CASE THERE ARE
-C NO COLUMNS IN THE NUMDEG LIST.
-C
-C IWA2(JCOL) IS THE COLUMN BEFORE JCOL IN THE DEGREE LIST
-C UNLESS IWA2(JCOL) = 0. IN THIS CASE JCOL IS THE FIRST
-C COLUMN IN THIS DEGREE LIST.
-C
-C IWA3(JCOL) IS THE COLUMN AFTER JCOL IN THE DEGREE LIST
-C UNLESS IWA3(JCOL) = 0. IN THIS CASE JCOL IS THE LAST
-C COLUMN IN THIS DEGREE LIST.
-C
-C IF JCOL IS AN UN-ORDERED COLUMN, THEN LIST(JCOL) IS THE
-C DEGREE OF JCOL IN THE GRAPH INDUCED BY THE UN-ORDERED
-C COLUMNS. IF JCOL IS AN ORDERED COLUMN, THEN LIST(JCOL)
-C IS THE SMALLEST-LAST ORDER OF COLUMN JCOL.
-C
- DO 20 JP = 1, N
- NUMDEG = NDEG(JP)
- HEAD = IWA1(NUMDEG+1)
- IWA1(NUMDEG+1) = JP
- IWA2(JP) = 0
- IWA3(JP) = HEAD
- IF (HEAD .GT. 0) IWA2(HEAD) = JP
- 20 CONTINUE
- MAXCLQ = 0
- NUMORD = N
-C
-C BEGINNING OF ITERATION LOOP.
-C
- 30 CONTINUE
-C
-C MARK THE SIZE OF THE LARGEST CLIQUE
-C FOUND DURING THE ORDERING.
-C
- IF (MINDEG + 1 .EQ. NUMORD .AND. MAXCLQ .EQ. 0)
- * MAXCLQ = NUMORD
-C
-C CHOOSE A COLUMN JCOL OF MINIMAL DEGREE MINDEG.
-C
- 40 CONTINUE
- JCOL = IWA1(MINDEG+1)
- IF (JCOL .GT. 0) GO TO 50
- MINDEG = MINDEG + 1
- GO TO 40
- 50 CONTINUE
- LIST(JCOL) = NUMORD
- NUMORD = NUMORD - 1
-C
-C TERMINATION TEST.
-C
- IF (NUMORD .EQ. 0) GO TO 120
-C
-C DELETE COLUMN JCOL FROM THE MINDEG LIST.
-C
- L = IWA3(JCOL)
- IWA1(MINDEG+1) = L
- IF (L .GT. 0) IWA2(L) = 0
-C
-C FIND ALL COLUMNS ADJACENT TO COLUMN JCOL.
-C
- BWA(JCOL) = .TRUE.
- DEG = 0
-C
-C DETERMINE ALL POSITIONS (IR,JCOL) WHICH CORRESPOND
-C TO NON-ZEROES IN THE MATRIX.
-C
- JPL = JPNTR(JCOL)
- JPU = JPNTR(JCOL+1) - 1
- IF (JPU .LT. JPL) GO TO 90
- DO 80 JP = JPL, JPU
- IR = INDROW(JP)
-C
-C FOR EACH ROW IR, DETERMINE ALL POSITIONS (IR,IC)
-C WHICH CORRESPOND TO NON-ZEROES IN THE MATRIX.
-C
- IPL = IPNTR(IR)
- IPU = IPNTR(IR+1) - 1
- DO 70 IP = IPL, IPU
- IC = INDCOL(IP)
-C
-C ARRAY BWA MARKS COLUMNS WHICH ARE ADJACENT TO
-C COLUMN JCOL. ARRAY IWA4 RECORDS THE MARKED COLUMNS.
-C
- IF (BWA(IC)) GO TO 60
- BWA(IC) = .TRUE.
- DEG = DEG + 1
- IWA4(DEG) = IC
- 60 CONTINUE
- 70 CONTINUE
- 80 CONTINUE
- 90 CONTINUE
-C
-C UPDATE THE POINTERS TO THE CURRENT DEGREE LISTS.
-C
- IF (DEG .LT. 1) GO TO 110
- DO 100 JP = 1, DEG
- IC = IWA4(JP)
- NUMDEG = LIST(IC)
- LIST(IC) = LIST(IC) - 1
- MINDEG = MIN0(MINDEG,LIST(IC))
-C
-C DELETE COLUMN IC FROM THE NUMDEG LIST.
-C
- L = IWA2(IC)
- IF (L .EQ. 0) IWA1(NUMDEG+1) = IWA3(IC)
- IF (L .GT. 0) IWA3(L) = IWA3(IC)
- L = IWA3(IC)
- IF (L .GT. 0) IWA2(L) = IWA2(IC)
-C
-C ADD COLUMN IC TO THE NUMDEG-1 LIST.
-C
- HEAD = IWA1(NUMDEG)
- IWA1(NUMDEG) = IC
- IWA2(IC) = 0
- IWA3(IC) = HEAD
- IF (HEAD .GT. 0) IWA2(HEAD) = IC
-C
-C UN-MARK COLUMN IC IN THE ARRAY BWA.
-C
- BWA(IC) = .FALSE.
- 100 CONTINUE
- 110 CONTINUE
-C
-C END OF ITERATION LOOP.
-C
- GO TO 30
- 120 CONTINUE
-C
-C INVERT THE ARRAY LIST.
-C
- DO 130 JCOL = 1, N
- NUMORD = LIST(JCOL)
- IWA1(NUMORD) = JCOL
- 130 CONTINUE
- DO 140 JP = 1, N
- LIST(JP) = IWA1(JP)
- 140 CONTINUE
- RETURN
-C
-C LAST CARD OF SUBROUTINE M7SLO.
-C
- END
diff --git a/CEP/PyBDSM/src/port3/mnf.f b/CEP/PyBDSM/src/port3/mnf.f
deleted file mode 100644
index cf21d183d74eec56102bfef1660b8c565fa5fbdf..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/mnf.f
+++ /dev/null
@@ -1,97 +0,0 @@
- SUBROUTINE MNF(N, D, X, CALCF, IV, LIV, LV, V,
- 1 UIPARM, URPARM, UFPARM)
-C
-C *** MINIMIZE GENERAL UNCONSTRAINED OBJECTIVE FUNCTION USING
-C *** FINITE-DIFFERENCE GRADIENTS AND SECANT HESSIAN APPROXIMATIONS.
-C
- INTEGER N, LIV, LV
- INTEGER IV(LIV), UIPARM(1)
- REAL D(N), X(N), V(LV), URPARM(1)
-C DIMENSION V(77 + N*(N+17)/2), UIPARM(*), URPARM(*)
- EXTERNAL CALCF, UFPARM
-C
-C *** PURPOSE ***
-C
-C THIS ROUTINE INTERACTS WITH SUBROUTINE RMNF IN AN ATTEMPT
-C TO FIND AN N-VECTOR X* THAT MINIMIZES THE (UNCONSTRAINED)
-C OBJECTIVE FUNCTION COMPUTED BY CALCF. (OFTEN THE X* FOUND IS
-C A LOCAL MINIMIZER RATHER THAN A GLOBAL ONE.)
-C
-C *** PARAMETERS ***
-C
-C THE PARAMETERS FOR MNF ARE THE SAME AS THOSE FOR MNG
-C (WHICH SEE), EXCEPT THAT CALCG IS OMITTED. INSTEAD OF CALLING
-C CALCG TO OBTAIN THE GRADIENT OF THE OBJECTIVE FUNCTION AT X,
-C MNF CALLS S7GRD, WHICH COMPUTES AN APPROXIMATION TO THE
-C GRADIENT BY FINITE (FORWARD AND CENTRAL) DIFFERENCES USING THE
-C METHOD OF REF. 1. THE FOLLOWING INPUT COMPONENT IS OF INTEREST
-C IN THIS REGARD (AND IS NOT DESCRIBED IN MNG).
-C
-C V(ETA0)..... V(42) IS AN ESTIMATED BOUND ON THE RELATIVE ERROR IN THE
-C OBJECTIVE FUNCTION VALUE COMPUTED BY CALCF...
-C (TRUE VALUE) = (COMPUTED VALUE) * (1 + E),
-C WHERE ABS(E) .LE. V(ETA0). DEFAULT = MACHEP * 10**3,
-C WHERE MACHEP IS THE UNIT ROUNDOFF.
-C
-C THE OUTPUT VALUES IV(NFCALL) AND IV(NGCALL) HAVE DIFFERENT
-C MEANINGS FOR MNF THAN FOR MNG...
-C
-C IV(NFCALL)... IV(6) IS THE NUMBER OF CALLS SO FAR MADE ON CALCF (I.E.,
-C FUNCTION EVALUATIONS) EXCLUDING THOSE MADE ONLY FOR
-C COMPUTING GRADIENTS. THE INPUT VALUE IV(MXFCAL) IS A
-C LIMIT ON IV(NFCALL).
-C IV(NGCALL)... IV(30) IS THE NUMBER OF FUNCTION EVALUATIONS MADE ONLY
-C FOR COMPUTING GRADIENTS. THE TOTAL NUMBER OF FUNCTION
-C EVALUATIONS IS THUS IV(NFCALL) + IV(NGCALL).
-C
-C *** REFERENCE ***
-C
-C 1. STEWART, G.W. (1967), A MODIFICATION OF DAVIDON*S MINIMIZATION
-C METHOD TO ACCEPT DIFFERENCE APPROXIMATIONS OF DERIVATIVES,
-C J. ASSOC. COMPUT. MACH. 14, PP. 72-83.
-C.
-C *** GENERAL ***
-C
-C CODED BY DAVID M. GAY (WINTER 1980). REVISED SEPT. 1982.
-C THIS SUBROUTINE WAS WRITTEN IN CONNECTION WITH RESEARCH
-C SUPPORTED IN PART BY THE NATIONAL SCIENCE FOUNDATION UNDER
-C GRANTS MCS-7600324, DCR75-10143, 76-14311DSS, MCS76-11989,
-C AND MCS-7906671.
-C
-C
-C---------------------------- DECLARATIONS ---------------------------
-C
- EXTERNAL RMNF
-C
-C RMNF.... OVERSEES COMPUTATION OF FINITE-DIFFERENCE GRADIENT AND
-C CALLS RMNG TO CARRY OUT MNG ALGORITHM.
-C
- INTEGER NF
- REAL FX
-C
-C *** SUBSCRIPTS FOR IV ***
-C
- INTEGER NFCALL, TOOBIG
-C
-C/6
-C DATA NFCALL/6/, TOOBIG/2/
-C/7
- PARAMETER (NFCALL=6, TOOBIG=2)
-C/
-C
-C+++++++++++++++++++++++++++++++ BODY ++++++++++++++++++++++++++++++++
-C
- 10 CALL RMNF(D, FX, IV, LIV, LV, N, V, X)
- IF (IV(1) .GT. 2) GO TO 999
-C
-C *** COMPUTE FUNCTION ***
-C
- NF = IV(NFCALL)
- CALL CALCF(N, X, NF, FX, UIPARM, URPARM, UFPARM)
- IF (NF .LE. 0) IV(TOOBIG) = 1
- GO TO 10
-C
-C
- 999 RETURN
-C *** LAST CARD OF MNF FOLLOWS ***
- END
diff --git a/CEP/PyBDSM/src/port3/mnfb.f b/CEP/PyBDSM/src/port3/mnfb.f
deleted file mode 100644
index 7638fd28f82de83d4242009703318088d51d9602..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/mnfb.f
+++ /dev/null
@@ -1,102 +0,0 @@
- SUBROUTINE MNFB(P, D, X, B, CALCF, IV, LIV, LV, V,
- 1 UIPARM, URPARM, UFPARM)
-C
-C *** MINIMIZE GENERAL UNCONSTRAINED OBJECTIVE FUNCTION USING
-C *** FINITE-DIFFERENCE GRADIENTS AND SECANT HESSIAN APPROXIMATIONS.
-C
- INTEGER P, LIV, LV
-C/6S
-C INTEGER IV(LIV), UIPARM(1)
-C REAL B(2,P), D(P), X(P), V(LV), URPARM(1)
-C/7S
- INTEGER IV(LIV), UIPARM(*)
- REAL B(2,P), D(P), X(P), V(LV), URPARM(*)
-C/
-C DIMENSION V(59 + P), V(77 + P*(P+23)/2), UIPARM(*), URPARM(*)
- EXTERNAL CALCF, UFPARM
-C
-C *** PURPOSE ***
-C
-C THIS ROUTINE INTERACTS WITH SUBROUTINE RMNF IN AN ATTEMPT
-C TO FIND AN P-VECTOR X* THAT MINIMIZES THE (UNCONSTRAINED)
-C OBJECTIVE FUNCTION COMPUTED BY CALCF. (OFTEN THE X* FOUND IS
-C A LOCAL MINIMIZER RATHER THAN A GLOBAL ONE.)
-C
-C *** PARAMETERS ***
-C
-C THE PARAMETERS FOR MNFB ARE THE SAME AS THOSE FOR MNGB
-C (WHICH SEE), EXCEPT THAT CALCG IS OMITTED. INSTEAD OF CALLING
-C CALCG TO OBTAIN THE GRADIENT OF THE OBJECTIVE FUNCTION AT X,
-C MNFB CALLS S3GRD, WHICH COMPUTES AN APPROXIMATION TO THE
-C GRADIENT BY FINITE (FORWARD AND CENTRAL) DIFFERENCES USING THE
-C METHOD OF REF. 1. THE FOLLOWING INPUT COMPONENT IS OF INTEREST
-C IN THIS REGARD (AND IS NOT DESCRIBED IN MNG OR MNGB).
-C
-C V(ETA0)..... V(42) IS AN ESTIMATED BOUND ON THE RELATIVE ERROR IN THE
-C OBJECTIVE FUNCTION VALUE COMPUTED BY CALCF...
-C (TRUE VALUE) = (COMPUTED VALUE) * (1 + E),
-C WHERE ABS(E) .LE. V(ETA0). DEFAULT = MACHEP * 10**3,
-C WHERE MACHEP IS THE UNIT ROUNDOFF.
-C
-C THE OUTPUT VALUES IV(NFCALL) AND IV(NGCALL) HAVE DIFFERENT
-C MEANINGS FOR MNFB THAN FOR MNG...
-C
-C IV(NFCALL)... IV(6) IS THE NUMBER OF CALLS SO FAR MADE ON CALCF (I.E.,
-C FUNCTION EVALUATIONS) EXCLUDING THOSE MADE ONLY FOR
-C COMPUTING GRADIENTS. THE INPUT VALUE IV(MXFCAL) IS A
-C LIMIT ON IV(NFCALL).
-C IV(NGCALL)... IV(30) IS THE NUMBER OF FUNCTION EVALUATIONS MADE ONLY
-C FOR COMPUTING GRADIENTS. THE TOTAL NUMBER OF FUNCTION
-C EVALUATIONS IS THUS IV(NFCALL) + IV(NGCALL).
-C
-C *** REFERENCE ***
-C
-C 1. STEWART, G.W. (1967), A MODIFICATION OF DAVIDON*S MINIMIZATION
-C METHOD TO ACCEPT DIFFERENCE APPROXIMATIONS OF DERIVATIVES,
-C J. ASSOC. COMPUT. MACH. 14, PP. 72-83.
-C.
-C *** GENERAL ***
-C
-C CODED BY DAVID M. GAY (WINTER 1980). REVISED SEPT. 1982.
-C THIS SUBROUTINE WAS WRITTEN IN CONNECTION WITH RESEARCH
-C SUPPORTED IN PART BY THE NATIONAL SCIENCE FOUNDATION UNDER
-C GRANTS MCS-7600324, DCR75-10143, 76-14311DSS, MCS76-11989,
-C AND MCS-7906671.
-C
-C
-C---------------------------- DECLARATIONS ---------------------------
-C
- EXTERNAL RMNFB
-C
-C RMNFB... OVERSEES COMPUTATION OF FINITE-DIFFERENCE GRADIENT AND
-C CALLS RMNG TO CARRY OUT MNG ALGORITHM.
-C
- INTEGER NF
- REAL FX
-C
-C *** SUBSCRIPTS FOR IV ***
-C
- INTEGER NFCALL, TOOBIG
-C
-C/6
-C DATA NFCALL/6/, TOOBIG/2/
-C/7
- PARAMETER (NFCALL=6, TOOBIG=2)
-C/
-C
-C+++++++++++++++++++++++++++++++ BODY ++++++++++++++++++++++++++++++++
-C
- 10 CALL RMNFB(B, D, FX, IV, LIV, LV, P, V, X)
- IF (IV(1) .GT. 2) GO TO 999
-C
-C *** COMPUTE FUNCTION ***
-C
- NF = IV(NFCALL)
- CALL CALCF(P, X, NF, FX, UIPARM, URPARM, UFPARM)
- IF (NF .LE. 0) IV(TOOBIG) = 1
- GO TO 10
-C
-C
- 999 RETURN
-C *** LAST CARD OF MNFB FOLLOWS ***
- END
diff --git a/CEP/PyBDSM/src/port3/mng.f b/CEP/PyBDSM/src/port3/mng.f
deleted file mode 100644
index ce4f3d010fb0389ea65f6704f706835671bbb346..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/mng.f
+++ /dev/null
@@ -1,481 +0,0 @@
- SUBROUTINE MNG(N, D, X, CALCF, CALCG, IV, LIV, LV, V,
- 1 UIPARM, URPARM, UFPARM)
-C
-C *** MINIMIZE GENERAL UNCONSTRAINED OBJECTIVE FUNCTION USING ***
-C *** ANALYTIC GRADIENT AND HESSIAN APPROX. FROM SECANT UPDATE ***
-C
- INTEGER N, LIV, LV
- INTEGER IV(LIV), UIPARM(1)
- REAL D(N), X(N), V(LV), URPARM(1)
-C DIMENSION V(71 + N*(N+15)/2), UIPARM(*), URPARM(*)
- EXTERNAL CALCF, CALCG, UFPARM
-C
-C *** PURPOSE ***
-C
-C THIS ROUTINE INTERACTS WITH SUBROUTINE RMNG IN AN ATTEMPT
-C TO FIND AN N-VECTOR X* THAT MINIMIZES THE (UNCONSTRAINED)
-C OBJECTIVE FUNCTION COMPUTED BY CALCF. (OFTEN THE X* FOUND IS
-C A LOCAL MINIMIZER RATHER THAN A GLOBAL ONE.)
-C
-C-------------------------- PARAMETER USAGE --------------------------
-C
-C N........ (INPUT) THE NUMBER OF VARIABLES ON WHICH F DEPENDS, I.E.,
-C THE NUMBER OF COMPONENTS IN X.
-C D........ (INPUT/OUTPUT) A SCALE VECTOR SUCH THAT D(I)*X(I),
-C I = 1,2,...,N, ARE ALL IN COMPARABLE UNITS.
-C D CAN STRONGLY AFFECT THE BEHAVIOR OF MNG.
-C FINDING THE BEST CHOICE OF D IS GENERALLY A TRIAL-
-C AND-ERROR PROCESS. CHOOSING D SO THAT D(I)*X(I)
-C HAS ABOUT THE SAME VALUE FOR ALL I OFTEN WORKS WELL.
-C THE DEFAULTS PROVIDED BY SUBROUTINE IVSET (SEE IV
-C BELOW) REQUIRE THE CALLER TO SUPPLY D.
-C X........ (INPUT/OUTPUT) BEFORE (INITIALLY) CALLING MNG, THE CALL-
-C ER SHOULD SET X TO AN INITIAL GUESS AT X*. WHEN
-C MNG RETURNS, X CONTAINS THE BEST POINT SO FAR
-C FOUND, I.E., THE ONE THAT GIVES THE LEAST VALUE SO
-C FAR SEEN FOR F(X).
-C CALCF.... (INPUT) A SUBROUTINE THAT, GIVEN X, COMPUTES F(X). CALCF
-C MUST BE DECLARED EXTERNAL IN THE CALLING PROGRAM.
-C IT IS INVOKED BY
-C CALL CALCF(N, X, NF, F, UIPARM, URPARM, UFPARM)
-C WHEN CALCF IS CALLED, NF IS THE INVOCATION
-C COUNT FOR CALCF. NF IS INCLUDED FOR POSSIBLE USE
-C WITH CALCG. IF X IS OUT OF BOUNDS (E.G., IF IT
-C WOULD CAUSE OVERFLOW IN COMPUTING F(X)), THEN CALCF
-C SHOULD SET NF TO 0. THIS WILL CAUSE A SHORTER STEP
-C TO BE ATTEMPTED. (IF X IS IN BOUNDS, THEN CALCF
-C SHOULD NOT CHANGE NF.) THE OTHER PARAMETERS ARE AS
-C DESCRIBED ABOVE AND BELOW. CALCF SHOULD NOT CHANGE
-C N, P, OR X.
-C CALCG.... (INPUT) A SUBROUTINE THAT, GIVEN X, COMPUTES G(X), THE GRA-
-C DIENT OF F AT X. CALCG MUST BE DECLARED EXTERNAL IN
-C THE CALLING PROGRAM. IT IS INVOKED BY
-C CALL CALCG(N, X, NF, G, UIPARM, URPARM, UFAPRM)
-C WHEN CALCG IS CALLED, NF IS THE INVOCATION
-C COUNT FOR CALCF AT THE TIME F(X) WAS EVALUATED. THE
-C X PASSED TO CALCG IS USUALLY THE ONE PASSED TO CALCF
-C ON EITHER ITS MOST RECENT INVOCATION OR THE ONE
-C PRIOR TO IT. IF CALCF SAVES INTERMEDIATE RESULTS
-C FOR _USE_ BY CALCG, THEN IT IS POSSIBLE TO TELL FROM
-C NF WHETHER THEY ARE VALID FOR THE CURRENT X (OR
-C WHICH COPY IS VALID IF TWO COPIES ARE KEPT). IF G
-C CANNOT BE COMPUTED AT X, THEN CALCG SHOULD SET NF TO
-C 0. IN THIS CASE, MNG WILL RETURN WITH IV(1) = 65.
-C (IF G CAN BE COMPUTED AT X, THEN CALCG SHOULD NOT
-C CHANGED NF.) THE OTHER PARAMETERS TO CALCG ARE AS
-C DESCRIBED ABOVE AND BELOW. CALCG SHOULD NOT CHANGE
-C N OR X.
-C IV....... (INPUT/OUTPUT) AN INTEGER VALUE ARRAY OF LENGTH LIV (SEE
-C BELOW) THAT HELPS CONTROL THE MNG ALGORITHM AND
-C THAT IS USED TO STORE VARIOUS INTERMEDIATE QUANTI-
-C TIES. OF PARTICULAR INTEREST ARE THE INITIALIZATION/
-C RETURN CODE IV(1) AND THE ENTRIES IN IV THAT CONTROL
-C PRINTING AND LIMIT THE NUMBER OF ITERATIONS AND FUNC-
-C TION EVALUATIONS. SEE THE SECTION ON IV INPUT
-C VALUES BELOW.
-C LIV...... (INPUT) LENGTH OF IV ARRAY. MUST BE AT LEAST 60. IF LIV
-C IS TOO SMALL, THEN MNG RETURNS WITH IV(1) = 15.
-C WHEN MNG RETURNS, THE SMALLEST ALLOWED VALUE OF
-C LIV IS STORED IN IV(LASTIV) -- SEE THE SECTION ON
-C IV OUTPUT VALUES BELOW. (THIS IS INTENDED FOR USE
-C WITH EXTENSIONS OF MNG THAT HANDLE CONSTRAINTS.)
-C LV....... (INPUT) LENGTH OF V ARRAY. MUST BE AT LEAST 71+N*(N+15)/2.
-C (AT LEAST 77+N*(N+17)/2 FOR MNF, AT LEAST
-C 78+N*(N+12) FOR MNH). IF LV IS TOO SMALL, THEN
-C MNG RETURNS WITH IV(1) = 16. WHEN MNG RETURNS,
-C THE SMALLEST ALLOWED VALUE OF LV IS STORED IN
-C IV(LASTV) -- SEE THE SECTION ON IV OUTPUT VALUES
-C BELOW.
-C V........ (INPUT/OUTPUT) A FLOATING-POINT VALUE ARRAY OF LENGTH LV
-C (SEE BELOW) THAT HELPS CONTROL THE MNG ALGORITHM
-C AND THAT IS USED TO STORE VARIOUS INTERMEDIATE
-C QUANTITIES. OF PARTICULAR INTEREST ARE THE ENTRIES
-C IN V THAT LIMIT THE LENGTH OF THE FIRST STEP
-C ATTEMPTED (LMAX0) AND SPECIFY CONVERGENCE TOLERANCES
-C (AFCTOL, LMAXS, RFCTOL, SCTOL, XCTOL, XFTOL).
-C UIPARM... (INPUT) USER INTEGER PARAMETER ARRAY PASSED WITHOUT CHANGE
-C TO CALCF AND CALCG.
-C URPARM... (INPUT) USER FLOATING-POINT PARAMETER ARRAY PASSED WITHOUT
-C CHANGE TO CALCF AND CALCG.
-C UFPARM... (INPUT) USER EXTERNAL SUBROUTINE OR FUNCTION PASSED WITHOUT
-C CHANGE TO CALCF AND CALCG.
-C
-C *** IV INPUT VALUES (FROM SUBROUTINE IVSET) ***
-C
-C IV(1)... ON INPUT, IV(1) SHOULD HAVE A VALUE BETWEEN 0 AND 14......
-C 0 AND 12 MEAN THIS IS A FRESH START. 0 MEANS THAT
-C IVSET(2, IV, LIV, LV, V)
-C IS TO BE CALLED TO PROVIDE ALL DEFAULT VALUES TO IV AND
-C V. 12 (THE VALUE THAT IVSET ASSIGNS TO IV(1)) MEANS THE
-C CALLER HAS ALREADY CALLED IVSET AND HAS POSSIBLY CHANGED
-C SOME IV AND/OR V ENTRIES TO NON-DEFAULT VALUES.
-C 13 MEANS IVSET HAS BEEN CALLED AND THAT MNG (AND
-C RMNG) SHOULD ONLY DO THEIR STORAGE ALLOCATION. THAT IS,
-C THEY SHOULD SET THE OUTPUT COMPONENTS OF IV THAT TELL
-C WHERE VARIOUS SUBARRAYS ARRAYS OF V BEGIN, SUCH AS IV(G)
-C (AND, FOR MNH AND RMNH ONLY, IV(DTOL)), AND RETURN.
-C 14 MEANS THAT A STORAGE HAS BEEN ALLOCATED (BY A CALL
-C WITH IV(1) = 13) AND THAT THE ALGORITHM SHOULD BE
-C STARTED. WHEN CALLED WITH IV(1) = 13, MNG RETURNS
-C IV(1) = 14 UNLESS LIV OR LV IS TOO SMALL (OR N IS NOT
-C POSITIVE). DEFAULT = 12.
-C IV(INITH).... IV(25) TELLS WHETHER THE HESSIAN APPROXIMATION H SHOULD
-C BE INITIALIZED. 1 (THE DEFAULT) MEANS RMNG SHOULD
-C INITIALIZE H TO THE DIAGONAL MATRIX WHOSE I-TH DIAGONAL
-C ELEMENT IS D(I)**2. 0 MEANS THE CALLER HAS SUPPLIED A
-C CHOLESKY FACTOR L OF THE INITIAL HESSIAN APPROXIMATION
-C H = L*(L**T) IN V, STARTING AT V(IV(LMAT)) = V(IV(42))
-C (AND STORED COMPACTLY BY ROWS). NOTE THAT IV(LMAT) MAY
-C BE INITIALIZED BY CALLING MNG WITH IV(1) = 13 (SEE
-C THE IV(1) DISCUSSION ABOVE). DEFAULT = 1.
-C IV(MXFCAL)... IV(17) GIVES THE MAXIMUM NUMBER OF FUNCTION EVALUATIONS
-C (CALLS ON CALCF) ALLOWED. IF THIS NUMBER DOES NOT SUF-
-C FICE, THEN MNG RETURNS WITH IV(1) = 9. DEFAULT = 200.
-C IV(MXITER)... IV(18) GIVES THE MAXIMUM NUMBER OF ITERATIONS ALLOWED.
-C IT ALSO INDIRECTLY LIMITS THE NUMBER OF GRADIENT EVALUA-
-C TIONS (CALLS ON CALCG) TO IV(MXITER) + 1. IF IV(MXITER)
-C ITERATIONS DO NOT SUFFICE, THEN MNG RETURNS WITH
-C IV(1) = 10. DEFAULT = 150.
-C IV(OUTLEV)... IV(19) CONTROLS THE NUMBER AND LENGTH OF ITERATION SUM-
-C MARY LINES PRINTED (BY ITSUM). IV(OUTLEV) = 0 MEANS DO
-C NOT PRINT ANY SUMMARY LINES. OTHERWISE, PRINT A SUMMARY
-C LINE AFTER EACH ABS(IV(OUTLEV)) ITERATIONS. IF IV(OUTLEV)
-C IS POSITIVE, THEN SUMMARY LINES OF LENGTH 78 (PLUS CARRI-
-C AGE CONTROL) ARE PRINTED, INCLUDING THE FOLLOWING... THE
-C ITERATION AND FUNCTION EVALUATION COUNTS, F = THE CURRENT
-C FUNCTION VALUE, RELATIVE DIFFERENCE IN FUNCTION VALUES
-C ACHIEVED BY THE LATEST STEP (I.E., RELDF = (F0-V(F))/F01,
-C WHERE F01 IS THE MAXIMUM OF ABS(V(F)) AND ABS(V(F0)) AND
-C V(F0) IS THE FUNCTION VALUE FROM THE PREVIOUS ITERA-
-C TION), THE RELATIVE FUNCTION REDUCTION PREDICTED FOR THE
-C STEP JUST TAKEN (I.E., PRELDF = V(PREDUC) / F01, WHERE
-C V(PREDUC) IS DESCRIBED BELOW), THE SCALED RELATIVE CHANGE
-C IN X (SEE V(RELDX) BELOW), THE STEP PARAMETER FOR THE
-C STEP JUST TAKEN (STPPAR = 0 MEANS A FULL NEWTON STEP,
-C BETWEEN 0 AND 1 MEANS A RELAXED NEWTON STEP, BETWEEN 1
-C AND 2 MEANS A DOUBLE DOGLEG STEP, GREATER THAN 2 MEANS
-C A SCALED DOWN CAUCHY STEP -- SEE SUBROUTINE DBLDOG), THE
-C 2-NORM OF THE SCALE VECTOR D TIMES THE STEP JUST TAKEN
-C (SEE V(DSTNRM) BELOW), AND NPRELDF, I.E.,
-C V(NREDUC)/F01, WHERE V(NREDUC) IS DESCRIBED BELOW -- IF
-C NPRELDF IS POSITIVE, THEN IT IS THE RELATIVE FUNCTION
-C REDUCTION PREDICTED FOR A NEWTON STEP (ONE WITH
-C STPPAR = 0). IF NPRELDF IS NEGATIVE, THEN IT IS THE
-C NEGATIVE OF THE RELATIVE FUNCTION REDUCTION PREDICTED
-C FOR A STEP COMPUTED WITH STEP BOUND V(LMAXS) FOR _USE_ IN
-C TESTING FOR SINGULAR CONVERGENCE.
-C IF IV(OUTLEV) IS NEGATIVE, THEN LINES OF LENGTH 50
-C ARE PRINTED, INCLUDING ONLY THE FIRST 6 ITEMS LISTED
-C ABOVE (THROUGH RELDX).
-C DEFAULT = 1.
-C IV(PARPRT)... IV(20) = 1 MEANS PRINT ANY NONDEFAULT V VALUES ON A
-C FRESH START OR ANY CHANGED V VALUES ON A RESTART.
-C IV(PARPRT) = 0 MEANS SKIP THIS PRINTING. DEFAULT = 1.
-C IV(PRUNIT)... IV(21) IS THE OUTPUT UNIT NUMBER ON WHICH ALL PRINTING
-C IS DONE. IV(PRUNIT) = 0 MEANS SUPPRESS ALL PRINTING.
-C DEFAULT = STANDARD OUTPUT UNIT (UNIT 6 ON MOST SYSTEMS).
-C IV(SOLPRT)... IV(22) = 1 MEANS PRINT OUT THE VALUE OF X RETURNED (AS
-C WELL AS THE GRADIENT AND THE SCALE VECTOR D).
-C IV(SOLPRT) = 0 MEANS SKIP THIS PRINTING. DEFAULT = 1.
-C IV(STATPR)... IV(23) = 1 MEANS PRINT SUMMARY STATISTICS UPON RETURN-
-C ING. THESE CONSIST OF THE FUNCTION VALUE, THE SCALED
-C RELATIVE CHANGE IN X CAUSED BY THE MOST RECENT STEP (SEE
-C V(RELDX) BELOW), THE NUMBER OF FUNCTION AND GRADIENT
-C EVALUATIONS (CALLS ON CALCF AND CALCG), AND THE RELATIVE
-C FUNCTION REDUCTIONS PREDICTED FOR THE LAST STEP TAKEN AND
-C FOR A NEWTON STEP (OR PERHAPS A STEP BOUNDED BY V(LMAXS)
-C -- SEE THE DESCRIPTIONS OF PRELDF AND NPRELDF UNDER
-C IV(OUTLEV) ABOVE).
-C IV(STATPR) = 0 MEANS SKIP THIS PRINTING.
-C IV(STATPR) = -1 MEANS SKIP THIS PRINTING AS WELL AS THAT
-C OF THE ONE-LINE TERMINATION REASON MESSAGE. DEFAULT = 1.
-C IV(X0PRT).... IV(24) = 1 MEANS PRINT THE INITIAL X AND SCALE VECTOR D
-C (ON A FRESH START ONLY). IV(X0PRT) = 0 MEANS SKIP THIS
-C PRINTING. DEFAULT = 1.
-C
-C *** (SELECTED) IV OUTPUT VALUES ***
-C
-C IV(1)........ ON OUTPUT, IV(1) IS A RETURN CODE....
-C 3 = X-CONVERGENCE. THE SCALED RELATIVE DIFFERENCE (SEE
-C V(RELDX)) BETWEEN THE CURRENT PARAMETER VECTOR X AND
-C A LOCALLY OPTIMAL PARAMETER VECTOR IS VERY LIKELY AT
-C MOST V(XCTOL).
-C 4 = RELATIVE FUNCTION CONVERGENCE. THE RELATIVE DIFFER-
-C ENCE BETWEEN THE CURRENT FUNCTION VALUE AND ITS LO-
-C CALLY OPTIMAL VALUE IS VERY LIKELY AT MOST V(RFCTOL).
-C 5 = BOTH X- AND RELATIVE FUNCTION CONVERGENCE (I.E., THE
-C CONDITIONS FOR IV(1) = 3 AND IV(1) = 4 BOTH HOLD).
-C 6 = ABSOLUTE FUNCTION CONVERGENCE. THE CURRENT FUNCTION
-C VALUE IS AT MOST V(AFCTOL) IN ABSOLUTE VALUE.
-C 7 = SINGULAR CONVERGENCE. THE HESSIAN NEAR THE CURRENT
-C ITERATE APPEARS TO BE SINGULAR OR NEARLY SO, AND A
-C STEP OF LENGTH AT MOST V(LMAXS) IS UNLIKELY TO YIELD
-C A RELATIVE FUNCTION DECREASE OF MORE THAN V(SCTOL).
-C 8 = FALSE CONVERGENCE. THE ITERATES APPEAR TO BE CONVERG-
-C ING TO A NONCRITICAL POINT. THIS MAY MEAN THAT THE
-C CONVERGENCE TOLERANCES (V(AFCTOL), V(RFCTOL),
-C V(XCTOL)) ARE TOO SMALL FOR THE ACCURACY TO WHICH
-C THE FUNCTION AND GRADIENT ARE BEING COMPUTED, THAT
-C THERE IS AN ERROR IN COMPUTING THE GRADIENT, OR THAT
-C THE FUNCTION OR GRADIENT IS DISCONTINUOUS NEAR X.
-C 9 = FUNCTION EVALUATION LIMIT REACHED WITHOUT OTHER CON-
-C VERGENCE (SEE IV(MXFCAL)).
-C 10 = ITERATION LIMIT REACHED WITHOUT OTHER CONVERGENCE
-C (SEE IV(MXITER)).
-C 11 = STOPX RETURNED .TRUE. (EXTERNAL INTERRUPT). SEE THE
-C USAGE NOTES BELOW.
-C 14 = STORAGE HAS BEEN ALLOCATED (AFTER A CALL WITH
-C IV(1) = 13).
-C 17 = RESTART ATTEMPTED WITH N CHANGED.
-C 18 = D HAS A NEGATIVE COMPONENT AND IV(DTYPE) .LE. 0.
-C 19...43 = V(IV(1)) IS OUT OF RANGE.
-C 63 = F(X) CANNOT BE COMPUTED AT THE INITIAL X.
-C 64 = BAD PARAMETERS PASSED TO ASSESS (WHICH SHOULD NOT
-C OCCUR).
-C 65 = THE GRADIENT COULD NOT BE COMPUTED AT X (SEE CALCG
-C ABOVE).
-C 67 = BAD FIRST PARAMETER TO IVSET.
-C 80 = IV(1) WAS OUT OF RANGE.
-C 81 = N IS NOT POSITIVE.
-C IV(G)........ IV(28) IS THE STARTING SUBSCRIPT IN V OF THE CURRENT
-C GRADIENT VECTOR (THE ONE CORRESPONDING TO X).
-C IV(LASTIV)... IV(44) IS THE LEAST ACCEPTABLE VALUE OF LIV. (IT IS
-C ONLY SET IF LIV IS AT LEAST 44.)
-C IV(LASTV).... IV(45) IS THE LEAST ACCEPTABLE VALUE OF LV. (IT IS
-C ONLY SET IF LIV IS LARGE ENOUGH, AT LEAST IV(LASTIV).)
-C IV(NFCALL)... IV(6) IS THE NUMBER OF CALLS SO FAR MADE ON CALCF (I.E.,
-C FUNCTION EVALUATIONS).
-C IV(NGCALL)... IV(30) IS THE NUMBER OF GRADIENT EVALUATIONS (CALLS ON
-C CALCG).
-C IV(NITER).... IV(31) IS THE NUMBER OF ITERATIONS PERFORMED.
-C
-C *** (SELECTED) V INPUT VALUES (FROM SUBROUTINE IVSET) ***
-C
-C V(BIAS)..... V(43) IS THE BIAS PARAMETER USED IN SUBROUTINE DBLDOG --
-C SEE THAT SUBROUTINE FOR DETAILS. DEFAULT = 0.8.
-C V(AFCTOL)... V(31) IS THE ABSOLUTE FUNCTION CONVERGENCE TOLERANCE.
-C IF MNG FINDS A POINT WHERE THE FUNCTION VALUE IS LESS
-C THAN V(AFCTOL) IN ABSOLUTE VALUE, AND IF MNG DOES NOT
-C RETURN WITH IV(1) = 3, 4, OR 5, THEN IT RETURNS WITH
-C IV(1) = 6. THIS TEST CAN BE TURNED OFF BY SETTING
-C V(AFCTOL) TO ZERO. DEFAULT = MAX(10**-20, MACHEP**2),
-C WHERE MACHEP IS THE UNIT ROUNDOFF.
-C V(DINIT).... V(38), IF NONNEGATIVE, IS THE VALUE TO WHICH THE SCALE
-C VECTOR D IS INITIALIZED. DEFAULT = -1.
-C V(LMAX0).... V(35) GIVES THE MAXIMUM 2-NORM ALLOWED FOR D TIMES THE
-C VERY FIRST STEP THAT MNG ATTEMPTS. THIS PARAMETER CAN
-C MARKEDLY AFFECT THE PERFORMANCE OF MNG.
-C V(LMAXS).... V(36) IS USED IN TESTING FOR SINGULAR CONVERGENCE -- IF
-C THE FUNCTION REDUCTION PREDICTED FOR A STEP OF LENGTH
-C BOUNDED BY V(LMAXS) IS AT MOST V(SCTOL) * ABS(F0), WHERE
-C F0 IS THE FUNCTION VALUE AT THE START OF THE CURRENT
-C ITERATION, AND IF MNG DOES NOT RETURN WITH IV(1) = 3,
-C 4, 5, OR 6, THEN IT RETURNS WITH IV(1) = 7. DEFAULT = 1.
-C V(RFCTOL)... V(32) IS THE RELATIVE FUNCTION CONVERGENCE TOLERANCE.
-C IF THE CURRENT MODEL PREDICTS A MAXIMUM POSSIBLE FUNCTION
-C REDUCTION (SEE V(NREDUC)) OF AT MOST V(RFCTOL)*ABS(F0)
-C AT THE START OF THE CURRENT ITERATION, WHERE F0 IS THE
-C THEN CURRENT FUNCTION VALUE, AND IF THE LAST STEP ATTEMPT-
-C ED ACHIEVED NO MORE THAN TWICE THE PREDICTED FUNCTION
-C DECREASE, THEN MNG RETURNS WITH IV(1) = 4 (OR 5).
-C DEFAULT = MAX(10**-10, MACHEP**(2/3)), WHERE MACHEP IS
-C THE UNIT ROUNDOFF.
-C V(SCTOL).... V(37) IS THE SINGULAR CONVERGENCE TOLERANCE -- SEE THE
-C DESCRIPTION OF V(LMAXS) ABOVE.
-C V(TUNER1)... V(26) HELPS DECIDE WHEN TO CHECK FOR FALSE CONVERGENCE.
-C THIS IS DONE IF THE ACTUAL FUNCTION DECREASE FROM THE
-C CURRENT STEP IS NO MORE THAN V(TUNER1) TIMES ITS PREDICT-
-C ED VALUE. DEFAULT = 0.1.
-C V(XCTOL).... V(33) IS THE X-CONVERGENCE TOLERANCE. IF A NEWTON STEP
-C (SEE V(NREDUC)) IS TRIED THAT HAS V(RELDX) .LE. V(XCTOL)
-C AND IF THIS STEP YIELDS AT MOST TWICE THE PREDICTED FUNC-
-C TION DECREASE, THEN MNG RETURNS WITH IV(1) = 3 (OR 5).
-C (SEE THE DESCRIPTION OF V(RELDX) BELOW.)
-C DEFAULT = MACHEP**0.5, WHERE MACHEP IS THE UNIT ROUNDOFF.
-C V(XFTOL).... V(34) IS THE FALSE CONVERGENCE TOLERANCE. IF A STEP IS
-C TRIED THAT GIVES NO MORE THAN V(TUNER1) TIMES THE PREDICT-
-C ED FUNCTION DECREASE AND THAT HAS V(RELDX) .LE. V(XFTOL),
-C AND IF MNG DOES NOT RETURN WITH IV(1) = 3, 4, 5, 6, OR
-C 7, THEN IT RETURNS WITH IV(1) = 8. (SEE THE DESCRIPTION
-C OF V(RELDX) BELOW.) DEFAULT = 100*MACHEP, WHERE
-C MACHEP IS THE UNIT ROUNDOFF.
-C V(*)........ IVSET SUPPLIES TO V A NUMBER OF TUNING CONSTANTS, WITH
-C WHICH IT SHOULD ORDINARILY BE UNNECESSARY TO TINKER. SEE
-C SECTION 17 OF VERSION 2.2 OF THE NL2SOL USAGE SUMMARY
-C (I.E., THE APPENDIX TO REF. 1) FOR DETAILS ON V(I),
-C I = DECFAC, INCFAC, PHMNFC, PHMXFC, RDFCMN, RDFCMX,
-C TUNER2, TUNER3, TUNER4, TUNER5.
-C
-C *** (SELECTED) V OUTPUT VALUES ***
-C
-C V(DGNORM)... V(1) IS THE 2-NORM OF (DIAG(D)**-1)*G, WHERE G IS THE
-C MOST RECENTLY COMPUTED GRADIENT.
-C V(DSTNRM)... V(2) IS THE 2-NORM OF DIAG(D)*STEP, WHERE STEP IS THE
-C CURRENT STEP.
-C V(F)........ V(10) IS THE CURRENT FUNCTION VALUE.
-C V(F0)....... V(13) IS THE FUNCTION VALUE AT THE START OF THE CURRENT
-C ITERATION.
-C V(NREDUC)... V(6), IF POSITIVE, IS THE MAXIMUM FUNCTION REDUCTION
-C POSSIBLE ACCORDING TO THE CURRENT MODEL, I.E., THE FUNC-
-C TION REDUCTION PREDICTED FOR A NEWTON STEP (I.E.,
-C STEP = -H**-1 * G, WHERE G IS THE CURRENT GRADIENT AND
-C H IS THE CURRENT HESSIAN APPROXIMATION).
-C IF V(NREDUC) IS NEGATIVE, THEN IT IS THE NEGATIVE OF
-C THE FUNCTION REDUCTION PREDICTED FOR A STEP COMPUTED WITH
-C A STEP BOUND OF V(LMAXS) FOR _USE_ IN TESTING FOR SINGULAR
-C CONVERGENCE.
-C V(PREDUC)... V(7) IS THE FUNCTION REDUCTION PREDICTED (BY THE CURRENT
-C QUADRATIC MODEL) FOR THE CURRENT STEP. THIS (DIVIDED BY
-C V(F0)) IS USED IN TESTING FOR RELATIVE FUNCTION
-C CONVERGENCE.
-C V(RELDX).... V(17) IS THE SCALED RELATIVE CHANGE IN X CAUSED BY THE
-C CURRENT STEP, COMPUTED AS
-C MAX(ABS(D(I)*(X(I)-X0(I)), 1 .LE. I .LE. P) /
-C MAX(D(I)*(ABS(X(I))+ABS(X0(I))), 1 .LE. I .LE. P),
-C WHERE X = X0 + STEP.
-C
-C------------------------------- NOTES -------------------------------
-C
-C *** ALGORITHM NOTES ***
-C
-C THIS ROUTINE USES A HESSIAN APPROXIMATION COMPUTED FROM THE
-C BFGS UPDATE (SEE REF 3). ONLY A CHOLESKY FACTOR OF THE HESSIAN
-C APPROXIMATION IS STORED, AND THIS IS UPDATED USING IDEAS FROM
-C REF. 4. STEPS ARE COMPUTED BY THE DOUBLE DOGLEG SCHEME DESCRIBED
-C IN REF. 2. THE STEPS ARE ASSESSED AS IN REF. 1.
-C
-C *** USAGE NOTES ***
-C
-C AFTER A RETURN WITH IV(1) .LE. 11, IT IS POSSIBLE TO RESTART,
-C I.E., TO CHANGE SOME OF THE IV AND V INPUT VALUES DESCRIBED ABOVE
-C AND CONTINUE THE ALGORITHM FROM THE POINT WHERE IT WAS INTERRUPT-
-C ED. IV(1) SHOULD NOT BE CHANGED, NOR SHOULD ANY ENTRIES OF IV
-C AND V OTHER THAN THE INPUT VALUES (THOSE SUPPLIED BY IVSET).
-C THOSE WHO DO NOT WISH TO WRITE A CALCG WHICH COMPUTES THE
-C GRADIENT ANALYTICALLY SHOULD CALL MNF RATHER THAN MNG.
-C MNF USES FINITE DIFFERENCES TO COMPUTE AN APPROXIMATE GRADIENT.
-C THOSE WHO WOULD PREFER TO PROVIDE F AND G (THE FUNCTION AND
-C GRADIENT) BY REVERSE COMMUNICATION RATHER THAN BY WRITING SUBROU-
-C TINES CALCF AND CALCG MAY CALL ON RMNG DIRECTLY. SEE THE COM-
-C MENTS AT THE BEGINNING OF RMNG.
-C THOSE WHO _USE_ MNG INTERACTIVELY MAY WISH TO SUPPLY THEIR
-C OWN STOPX FUNCTION, WHICH SHOULD RETURN .TRUE. IF THE BREAK KEY
-C HAS BEEN PRESSED SINCE STOPX WAS LAST INVOKED. THIS MAKES IT
-C POSSIBLE TO EXTERNALLY INTERRUPT MNG (WHICH WILL RETURN WITH
-C IV(1) = 11 IF STOPX RETURNS .TRUE.).
-C STORAGE FOR G IS ALLOCATED AT THE END OF V. THUS THE CALLER
-C MAY MAKE V LONGER THAN SPECIFIED ABOVE AND MAY ALLOW CALCG TO USE
-C ELEMENTS OF G BEYOND THE FIRST N AS SCRATCH STORAGE.
-C
-C *** PORTABILITY NOTES ***
-C
-C THE MNG DISTRIBUTION TAPE CONTAINS BOTH SINGLE- AND DOUBLE-
-C PRECISION VERSIONS OF THE MNG SOURCE CODE, SO IT SHOULD BE UN-
-C NECESSARY TO CHANGE PRECISIONS.
-C ONLY THE FUNCTIONS I7MDCN AND R7MDC CONTAIN MACHINE-DEPENDENT
-C CONSTANTS. TO CHANGE FROM ONE MACHINE TO ANOTHER, IT SHOULD
-C SUFFICE TO CHANGE THE (FEW) RELEVANT LINES IN THESE FUNCTIONS.
-C INTRINSIC FUNCTIONS ARE EXPLICITLY DECLARED. ON CERTAIN COM-
-C PUTERS (E.G. UNIVAC), IT MAY BE NECESSARY TO COMMENT OUT THESE
-C DECLARATIONS. SO THAT THIS MAY BE DONE AUTOMATICALLY BY A SIMPLE
-C PROGRAM, SUCH DECLARATIONS ARE PRECEDED BY A COMMENT HAVING C/+
-C IN COLUMNS 1-3 AND BLANKS IN COLUMNS 4-72 AND ARE FOLLOWED BY
-C A COMMENT HAVING C/ IN COLUMNS 1 AND 2 AND BLANKS IN COLUMNS 3-72.
-C THE MNG SOURCE CODE IS EXPRESSED IN 1966 ANSI STANDARD
-C FORTRAN. IT MAY BE CONVERTED TO FORTRAN 77 BY COMMENTING OUT ALL
-C LINES THAT FALL BETWEEN A LINE HAVING C/6 IN COLUMNS 1-3 AND A
-C LINE HAVING C/7 IN COLUMNS 1-3 AND BY REMOVING (I.E., REPLACING
-C BY A BLANK) THE C IN COLUMN 1 OF THE LINES THAT FOLLOW THE C/7
-C LINE AND PRECEDE A LINE HAVING C/ IN COLUMNS 1-2 AND BLANKS IN
-C COLUMNS 3-72. THESE CHANGES CONVERT SOME DATA STATEMENTS INTO
-C PARAMETER STATEMENTS, CONVERT SOME VARIABLES FROM REAL TO
-C CHARACTER*4, AND MAKE THE DATA STATEMENTS THAT INITIALIZE THESE
-C VARIABLES _USE_ CHARACTER STRINGS DELIMITED BY PRIMES INSTEAD
-C OF HOLLERITH CONSTANTS. (SUCH VARIABLES AND DATA STATEMENTS
-C APPEAR ONLY IN MODULES ITSUM AND PARCK. PARAMETER STATEMENTS
-C APPEAR NEARLY EVERYWHERE.) THESE CHANGES ALSO ADD SAVE STATE-
-C MENTS FOR VARIABLES GIVEN MACHINE-DEPENDENT CONSTANTS BY R7MDC.
-C
-C *** REFERENCES ***
-C
-C 1. DENNIS, J.E., GAY, D.M., AND WELSCH, R.E. (1981), ALGORITHM 573 --
-C AN ADAPTIVE NONLINEAR LEAST-SQUARES ALGORITHM, ACM TRANS.
-C MATH. SOFTWARE 7, PP. 369-383.
-C
-C 2. DENNIS, J.E., AND MEI, H.H.W. (1979), TWO NEW UNCONSTRAINED OPTI-
-C MIZATION ALGORITHMS WHICH _USE_ FUNCTION AND GRADIENT
-C VALUES, J. OPTIM. THEORY APPLIC. 28, PP. 453-482.
-C
-C 3. DENNIS, J.E., AND MORE, J.J. (1977), QUASI-NEWTON METHODS, MOTIVA-
-C TION AND THEORY, SIAM REV. 19, PP. 46-89.
-C
-C 4. GOLDFARB, D. (1976), FACTORIZED VARIABLE METRIC METHODS FOR UNCON-
-C STRAINED OPTIMIZATION, MATH. COMPUT. 30, PP. 796-811.
-C
-C *** GENERAL ***
-C
-C CODED BY DAVID M. GAY (WINTER 1980). REVISED SUMMER 1982.
-C THIS SUBROUTINE WAS WRITTEN IN CONNECTION WITH RESEARCH
-C SUPPORTED IN PART BY THE NATIONAL SCIENCE FOUNDATION UNDER
-C GRANTS MCS-7600324, DCR75-10143, 76-14311DSS, MCS76-11989,
-C AND MCS-7906671.
-C.
-C
-C---------------------------- DECLARATIONS ---------------------------
-C
- EXTERNAL IVSET, RMNG
-C
-C IVSET... SUPPLIES DEFAULT IV AND V INPUT COMPONENTS.
-C RMNG... REVERSE-COMMUNICATION ROUTINE THAT CARRIES OUT MNG ALGO-
-C RITHM.
-C
- INTEGER G1, IV1, NF
- REAL F
-C
-C *** SUBSCRIPTS FOR IV ***
-C
- INTEGER NEXTV, NFCALL, NFGCAL, G, TOOBIG, VNEED
-C
-C/6
-C DATA NEXTV/47/, NFCALL/6/, NFGCAL/7/, G/28/, TOOBIG/2/, VNEED/4/
-C/7
- PARAMETER (NEXTV=47, NFCALL=6, NFGCAL=7, G=28, TOOBIG=2, VNEED=4)
-C/
-C
-C+++++++++++++++++++++++++++++++ BODY ++++++++++++++++++++++++++++++++
-C
- IF (IV(1) .EQ. 0) CALL IVSET(2, IV, LIV, LV, V)
- IV1 = IV(1)
- IF (IV1 .EQ. 12 .OR. IV1 .EQ. 13) IV(VNEED) = IV(VNEED) + N
- IF (IV1 .EQ. 14) GO TO 10
- IF (IV1 .GT. 2 .AND. IV1 .LT. 12) GO TO 10
- G1 = 1
- IF (IV1 .EQ. 12) IV(1) = 13
- GO TO 20
-C
- 10 G1 = IV(G)
-C
- 20 CALL RMNG(D, F, V(G1), IV, LIV, LV, N, V, X)
- IF (IV(1) - 2) 30, 40, 50
-C
- 30 NF = IV(NFCALL)
- CALL CALCF(N, X, NF, F, UIPARM, URPARM, UFPARM)
- IF (NF .LE. 0) IV(TOOBIG) = 1
- GO TO 20
-C
- 40 NF = IV(NFGCAL)
- CALL CALCG(N, X, NF, V(G1), UIPARM, URPARM, UFPARM)
- IF (NF .LE. 0) IV(TOOBIG) = 1
- GO TO 20
-C
- 50 IF (IV(1) .NE. 14) GO TO 999
-C
-C *** STORAGE ALLOCATION
-C
- IV(G) = IV(NEXTV)
- IV(NEXTV) = IV(G) + N
- IF (IV1 .NE. 13) GO TO 10
-C
- 999 RETURN
-C *** LAST CARD OF MNG FOLLOWS ***
- END
diff --git a/CEP/PyBDSM/src/port3/mngb.f b/CEP/PyBDSM/src/port3/mngb.f
deleted file mode 100644
index e18e55d06c2b8f95e762174d99ba683a2701e6a5..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/mngb.f
+++ /dev/null
@@ -1,81 +0,0 @@
- SUBROUTINE MNGB(N, D, X, B, CALCF, CALCG, IV, LIV, LV, V,
- 1 UIPARM, URPARM, UFPARM)
-C
-C *** MINIMIZE GENERAL SIMPLY BOUNDED OBJECTIVE FUNCTION USING ***
-C *** ANALYTIC GRADIENT AND HESSIAN APPROX. FROM SECANT UPDATE ***
-C
- INTEGER N, LIV, LV
-C/6S
-C INTEGER IV(LIV), UIPARM(1)
-C REAL D(N), X(N), B(2,N), V(LV), URPARM(1)
-C/7S
- INTEGER IV(LIV), UIPARM(*)
- REAL D(N), X(N), B(2,N), V(LV), URPARM(*)
-C/
-C DIMENSION IV(59 + N), V(71 + N*(N+21)/2), UIPARM(*), URPARM(*)
- EXTERNAL CALCF, CALCG, UFPARM
-C
-C *** DISCUSSION ***
-C
-C THIS ROUTINE IS LIKE MNG, EXCEPT FOR THE EXTRA PARAMETER B,
-C AN ARRAY OF LOWER AND UPPER BOUNDS ON X... MNGB ENFORCES THE
-C CONSTRAINTS THAT B(1,I) .LE. X(I) .LE. B(2,I), I = 1(1)N.
-C (INSTEAD OF CALLING RMNG, MNGB CALLS RMNGB.)
-C.
-C
-C---------------------------- DECLARATIONS ---------------------------
-C
- EXTERNAL IVSET, RMNGB
-C
-C IVSET.... SUPPLIES DEFAULT IV AND V INPUT COMPONENTS.
-C RMNGB... REVERSE-COMMUNICATION ROUTINE THAT CARRIES OUT MNG ALGO-
-C RITHM.
-C
- INTEGER G1, IV1, NF
- REAL F
-C
-C *** SUBSCRIPTS FOR IV ***
-C
- INTEGER NEXTV, NFCALL, NFGCAL, G, TOOBIG, VNEED
-C
-C/6
-C DATA NEXTV/47/, NFCALL/6/, NFGCAL/7/, G/28/, TOOBIG/2/, VNEED/4/
-C/7
- PARAMETER (NEXTV=47, NFCALL=6, NFGCAL=7, G=28, TOOBIG=2, VNEED=4)
-C/
-C
-C+++++++++++++++++++++++++++++++ BODY ++++++++++++++++++++++++++++++++
-C
- IF (IV(1) .EQ. 0) CALL IVSET(2, IV, LIV, LV, V)
- IV1 = IV(1)
- IF (IV1 .EQ. 14) GO TO 10
- IF (IV1 .GT. 2 .AND. IV1 .LT. 12) GO TO 10
- IF (IV1 .EQ. 12) IV(1) = 13
- IF (IV(1) .EQ. 13) IV(VNEED) = IV(VNEED) + N
- CALL RMNGB(B, D, F, V, IV, LIV, LV, N, V, X)
- IF (IV(1) .NE. 14) GO TO 999
-C
-C *** STORAGE ALLOCATION
-C
- IV(G) = IV(NEXTV)
- IV(NEXTV) = IV(G) + N
- IF (IV1 .EQ. 13) GO TO 999
-C
- 10 G1 = IV(G)
-C
- 20 CALL RMNGB(B, D, F, V(G1), IV, LIV, LV, N, V, X)
- IF (IV(1) - 2) 30, 40, 999
-C
- 30 NF = IV(NFCALL)
- CALL CALCF(N, X, NF, F, UIPARM, URPARM, UFPARM)
- IF (NF .LE. 0) IV(TOOBIG) = 1
- GO TO 20
-C
- 40 NF = IV(NFGCAL)
- CALL CALCG(N, X, NF, V(G1), UIPARM, URPARM, UFPARM)
- IF (NF .LE. 0) IV(TOOBIG) = 1
- GO TO 20
-C
- 999 RETURN
-C *** LAST CARD OF MNGB FOLLOWS ***
- END
diff --git a/CEP/PyBDSM/src/port3/mnh.f b/CEP/PyBDSM/src/port3/mnh.f
deleted file mode 100644
index 929e74606faa3164000314ec9b03be0f9a67ec88..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/mnh.f
+++ /dev/null
@@ -1,141 +0,0 @@
- SUBROUTINE MNH(N, D, X, CALCF, CALCGH, IV, LIV, LV, V,
- 1 UIPARM, URPARM, UFPARM)
-C
-C *** MINIMIZE GENERAL UNCONSTRAINED OBJECTIVE FUNCTION USING ***
-C *** (ANALYTIC) GRADIENT AND HESSIAN PROVIDED BY THE CALLER. ***
-C
- INTEGER LIV, LV, N
- INTEGER IV(LIV), UIPARM(1)
- REAL D(N), X(N), V(LV), URPARM(1)
-C DIMENSION V(78 + N*(N+12)), UIPARM(*), URPARM(*)
- EXTERNAL CALCF, CALCGH, UFPARM
-C
-C------------------------------ DISCUSSION ---------------------------
-C
-C THIS ROUTINE IS LIKE MNG, EXCEPT THAT THE SUBROUTINE PARA-
-C METER CALCG OF MNG (WHICH COMPUTES THE GRADIENT OF THE OBJEC-
-C TIVE FUNCTION) IS REPLACED BY THE SUBROUTINE PARAMETER CALCGH,
-C WHICH COMPUTES BOTH THE GRADIENT AND (LOWER TRIANGLE OF THE)
-C HESSIAN OF THE OBJECTIVE FUNCTION. THE CALLING SEQUENCE IS...
-C CALL CALCGH(N, X, NF, G, H, UIPARM, URPARM, UFPARM)
-C PARAMETERS N, X, NF, G, UIPARM, URPARM, AND UFPARM ARE THE SAME
-C AS FOR MNG, WHILE H IS AN ARRAY OF LENGTH N*(N+1)/2 IN WHICH
-C CALCGH MUST STORE THE LOWER TRIANGLE OF THE HESSIAN AT X. START-
-C ING AT H(1), CALCGH MUST STORE THE HESSIAN ENTRIES IN THE ORDER
-C (1,1), (2,1), (2,2), (3,1), (3,2), (3,3), ...
-C THE VALUE PRINTED (BY ITSUM) IN THE COLUMN LABELLED STPPAR
-C IS THE LEVENBERG-MARQUARDT USED IN COMPUTING THE CURRENT STEP.
-C ZERO MEANS A FULL NEWTON STEP. IF THE SPECIAL CASE DESCRIBED IN
-C REF. 1 IS DETECTED, THEN STPPAR IS NEGATED. THE VALUE PRINTED
-C IN THE COLUMN LABELLED NPRELDF IS ZERO IF THE CURRENT HESSIAN
-C IS NOT POSITIVE DEFINITE.
-C IT SOMETIMES PROVES WORTHWHILE TO LET D BE DETERMINED FROM THE
-C DIAGONAL OF THE HESSIAN MATRIX BY SETTING IV(DTYPE) = 1 AND
-C V(DINIT) = 0. THE FOLLOWING IV AND V COMPONENTS ARE RELEVANT...
-C
-C IV(DTOL)..... IV(59) GIVES THE STARTING SUBSCRIPT IN V OF THE DTOL
-C ARRAY USED WHEN D IS UPDATED. (IV(DTOL) CAN BE
-C INITIALIZED BY CALLING MNH WITH IV(1) = 13.)
-C IV(DTYPE).... IV(16) TELLS HOW THE SCALE VECTOR D SHOULD BE CHOSEN.
-C IV(DTYPE) .LE. 0 MEANS THAT D SHOULD NOT BE UPDATED, AND
-C IV(DTYPE) .GE. 1 MEANS THAT D SHOULD BE UPDATED AS
-C DESCRIBED BELOW WITH V(DFAC). DEFAULT = 0.
-C V(DFAC)..... V(41) AND THE DTOL AND D0 ARRAYS (SEE V(DTINIT) AND
-C V(D0INIT)) ARE USED IN UPDATING THE SCALE VECTOR D WHEN
-C IV(DTYPE) .GT. 0. (D IS INITIALIZED ACCORDING TO
-C V(DINIT), DESCRIBED IN MNG.) LET
-C D1(I) = MAX(SQRT(ABS(H(I,I))), V(DFAC)*D(I)),
-C WHERE H(I,I) IS THE I-TH DIAGONAL ELEMENT OF THE CURRENT
-C HESSIAN. IF IV(DTYPE) = 1, THEN D(I) IS SET TO D1(I)
-C UNLESS D1(I) .LT. DTOL(I), IN WHICH CASE D(I) IS SET TO
-C MAX(D0(I), DTOL(I)).
-C IF IV(DTYPE) .GE. 2, THEN D IS UPDATED DURING THE FIRST
-C ITERATION AS FOR IV(DTYPE) = 1 (AFTER ANY INITIALIZATION
-C DUE TO V(DINIT)) AND IS LEFT UNCHANGED THEREAFTER.
-C DEFAULT = 0.6.
-C V(DTINIT)... V(39), IF POSITIVE, IS THE VALUE TO WHICH ALL COMPONENTS
-C OF THE DTOL ARRAY (SEE V(DFAC)) ARE INITIALIZED. IF
-C V(DTINIT) = 0, THEN IT IS ASSUMED THAT THE CALLER HAS
-C STORED DTOL IN V STARTING AT V(IV(DTOL)).
-C DEFAULT = 10**-6.
-C V(D0INIT)... V(40), IF POSITIVE, IS THE VALUE TO WHICH ALL COMPONENTS
-C OF THE D0 VECTOR (SEE V(DFAC)) ARE INITIALIZED. IF
-C V(DFAC) = 0, THEN IT IS ASSUMED THAT THE CALLER HAS
-C STORED D0 IN V STARTING AT V(IV(DTOL)+N). DEFAULT = 1.0.
-C
-C *** REFERENCE ***
-C
-C 1. GAY, D.M. (1981), COMPUTING OPTIMAL LOCALLY CONSTRAINED STEPS,
-C SIAM J. SCI. STATIST. COMPUT. 2, PP. 186-197.
-C.
-C *** GENERAL ***
-C
-C CODED BY DAVID M. GAY (WINTER 1980). REVISED SEPT. 1982.
-C THIS SUBROUTINE WAS WRITTEN IN CONNECTION WITH RESEARCH SUPPORTED
-C IN PART BY THE NATIONAL SCIENCE FOUNDATION UNDER GRANTS
-C MCS-7600324 AND MCS-7906671.
-C
-C---------------------------- DECLARATIONS ---------------------------
-C
- EXTERNAL IVSET, RMNH
-C
-C IVSET... PROVIDES DEFAULT INPUT VALUES FOR IV AND V.
-C RMNH... REVERSE-COMMUNICATION ROUTINE THAT DOES MNH ALGORITHM.
-C
- INTEGER G1, H1, IV1, LH, NF
- REAL F
-C
-C *** SUBSCRIPTS FOR IV ***
-C
- INTEGER G, H, NEXTV, NFCALL, NFGCAL, TOOBIG, VNEED
-C
-C/6
-C DATA NEXTV/47/, NFCALL/6/, NFGCAL/7/, G/28/, H/56/, TOOBIG/2/,
-C 1 VNEED/4/
-C/7
- PARAMETER (NEXTV=47, NFCALL=6, NFGCAL=7, G=28, H=56, TOOBIG=2,
- 1 VNEED=4)
-C/
-C
-C+++++++++++++++++++++++++++++++ BODY ++++++++++++++++++++++++++++++++
-C
- LH = N * (N + 1) / 2
- IF (IV(1) .EQ. 0) CALL IVSET(2, IV, LIV, LV, V)
- IF (IV(1) .EQ. 12 .OR. IV(1) .EQ. 13)
- 1 IV(VNEED) = IV(VNEED) + N*(N+3)/2
- IV1 = IV(1)
- IF (IV1 .EQ. 14) GO TO 10
- IF (IV1 .GT. 2 .AND. IV1 .LT. 12) GO TO 10
- G1 = 1
- H1 = 1
- IF (IV1 .EQ. 12) IV(1) = 13
- GO TO 20
-C
- 10 G1 = IV(G)
- H1 = IV(H)
-C
- 20 CALL RMNH(D, F, V(G1), V(H1), IV, LH, LIV, LV, N, V, X)
- IF (IV(1) - 2) 30, 40, 50
-C
- 30 NF = IV(NFCALL)
- CALL CALCF(N, X, NF, F, UIPARM, URPARM, UFPARM)
- IF (NF .LE. 0) IV(TOOBIG) = 1
- GO TO 20
-C
- 40 NF = IV(NFGCAL)
- CALL CALCGH(N, X, NF, V(G1), V(H1), UIPARM, URPARM, UFPARM)
- IF (NF .LE. 0) IV(TOOBIG) = 1
- GO TO 20
-C
- 50 IF (IV(1) .NE. 14) GO TO 999
-C
-C *** STORAGE ALLOCATION
-C
- IV(G) = IV(NEXTV)
- IV(H) = IV(G) + N
- IV(NEXTV) = IV(H) + N*(N+1)/2
- IF (IV1 .NE. 13) GO TO 10
-C
- 999 RETURN
-C *** LAST CARD OF MNH FOLLOWS ***
- END
diff --git a/CEP/PyBDSM/src/port3/mnhb.f b/CEP/PyBDSM/src/port3/mnhb.f
deleted file mode 100644
index 8581e2cca2539931e0b014117a8e9563c7cb1ade..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/mnhb.f
+++ /dev/null
@@ -1,139 +0,0 @@
- SUBROUTINE MNHB(N, D, X, B, CALCF, CALCGH, IV, LIV, LV, V,
- 1 UIPARM, URPARM, UFPARM)
-C
-C *** MINIMIZE GENERAL SIMPLY BOUNDED OBJECTIVE FUNCTION USING ***
-C *** (ANALYTIC) GRADIENT AND HESSIAN PROVIDED BY THE CALLER. ***
-C
- INTEGER LIV, LV, N
-C/6S
-C INTEGER IV(LIV), UIPARM(1)
-C REAL B(2,N), D(N), X(N), V(LV), URPARM(1)
-C/7S
- INTEGER IV(LIV), UIPARM(*)
- REAL B(2,N), D(N), X(N), V(LV), URPARM(*)
-C/
-C DIMENSION IV(59 + 3*N), V(78 + N*(N+15))
- EXTERNAL CALCF, CALCGH, UFPARM
-C
-C------------------------------ DISCUSSION ---------------------------
-C
-C THIS ROUTINE IS LIKE MNGB, EXCEPT THAT THE SUBROUTINE PARA-
-C METER CALCG OF MNGB (WHICH COMPUTES THE GRADIENT OF THE OBJEC-
-C TIVE FUNCTION) IS REPLACED BY THE SUBROUTINE PARAMETER CALCGH,
-C WHICH COMPUTES BOTH THE GRADIENT AND (LOWER TRIANGLE OF THE)
-C HESSIAN OF THE OBJECTIVE FUNCTION. THE CALLING SEQUENCE IS...
-C CALL CALCGH(N, X, NF, G, H, UIPARM, URPARM, UFPARM)
-C PARAMETERS N, X, NF, G, UIPARM, URPARM, AND UFPARM ARE THE SAME
-C AS FOR MNGB, WHILE H IS AN ARRAY OF LENGTH N*(N+1)/2 IN WHICH
-C CALCGH MUST STORE THE LOWER TRIANGLE OF THE HESSIAN AT X. START-
-C ING AT H(1), CALCGH MUST STORE THE HESSIAN ENTRIES IN THE ORDER
-C (1,1), (2,1), (2,2), (3,1), (3,2), (3,3), ...
-C THE VALUE PRINTED (BY ITSUM) IN THE COLUMN LABELLED STPPAR
-C IS THE LEVENBERG-MARQUARDT USED IN COMPUTING THE CURRENT STEP.
-C ZERO MEANS A FULL NEWTON STEP. IF THE SPECIAL CASE DESCRIBED IN
-C REF. 1 IS DETECTED, THEN STPPAR IS NEGATED. THE VALUE PRINTED
-C IN THE COLUMN LABELLED NPRELDF IS ZERO IF THE CURRENT HESSIAN
-C IS NOT POSITIVE DEFINITE.
-C IT SOMETIMES PROVES WORTHWHILE TO LET D BE DETERMINED FROM THE
-C DIAGONAL OF THE HESSIAN MATRIX BY SETTING IV(DTYPE) = 1 AND
-C V(DINIT) = 0. THE FOLLOWING IV AND V COMPONENTS ARE RELEVANT...
-C
-C IV(DTOL)..... IV(59) GIVES THE STARTING SUBSCRIPT IN V OF THE DTOL
-C ARRAY USED WHEN D IS UPDATED. (IV(DTOL) CAN BE
-C INITIALIZED BY CALLING MNHB WITH IV(1) = 13.)
-C IV(DTYPE).... IV(16) TELLS HOW THE SCALE VECTOR D SHOULD BE CHOSEN.
-C IV(DTYPE) .LE. 0 MEANS THAT D SHOULD NOT BE UPDATED, AND
-C IV(DTYPE) .GE. 1 MEANS THAT D SHOULD BE UPDATED AS
-C DESCRIBED BELOW WITH V(DFAC). DEFAULT = 0.
-C V(DFAC)..... V(41) AND THE DTOL AND D0 ARRAYS (SEE V(DTINIT) AND
-C V(D0INIT)) ARE USED IN UPDATING THE SCALE VECTOR D WHEN
-C IV(DTYPE) .GT. 0. (D IS INITIALIZED ACCORDING TO
-C V(DINIT), DESCRIBED IN MNG.) LET
-C D1(I) = MAX(SQRT(ABS(H(I,I))), V(DFAC)*D(I)),
-C WHERE H(I,I) IS THE I-TH DIAGONAL ELEMENT OF THE CURRENT
-C HESSIAN. IF IV(DTYPE) = 1, THEN D(I) IS SET TO D1(I)
-C UNLESS D1(I) .LT. DTOL(I), IN WHICH CASE D(I) IS SET TO
-C MAX(D0(I), DTOL(I)).
-C IF IV(DTYPE) .GE. 2, THEN D IS UPDATED DURING THE FIRST
-C ITERATION AS FOR IV(DTYPE) = 1 (AFTER ANY INITIALIZATION
-C DUE TO V(DINIT)) AND IS LEFT UNCHANGED THEREAFTER.
-C DEFAULT = 0.6.
-C V(DTINIT)... V(39), IF POSITIVE, IS THE VALUE TO WHICH ALL COMPONENTS
-C OF THE DTOL ARRAY (SEE V(DFAC)) ARE INITIALIZED. IF
-C V(DTINIT) = 0, THEN IT IS ASSUMED THAT THE CALLER HAS
-C STORED DTOL IN V STARTING AT V(IV(DTOL)).
-C DEFAULT = 10**-6.
-C V(D0INIT)... V(40), IF POSITIVE, IS THE VALUE TO WHICH ALL COMPONENTS
-C OF THE D0 VECTOR (SEE V(DFAC)) ARE INITIALIZED. IF
-C V(DFAC) = 0, THEN IT IS ASSUMED THAT THE CALLER HAS
-C STORED D0 IN V STARTING AT V(IV(DTOL)+N). DEFAULT = 1.0.
-C
-C *** REFERENCE ***
-C
-C 1. GAY, D.M. (1981), COMPUTING OPTIMAL LOCALLY CONSTRAINED STEPS,
-C SIAM J. SCI. STATIST. COMPUT. 2, PP. 186-197.
-C.
-C *** GENERAL ***
-C
-C CODED BY DAVID M. GAY (WINTER, SPRING 1983).
-C
-C---------------------------- DECLARATIONS ---------------------------
-C
- EXTERNAL IVSET, RMNHB
-C
-C IVSET.... PROVIDES DEFAULT INPUT VALUES FOR IV AND V.
-C RMNHB... REVERSE-COMMUNICATION ROUTINE THAT DOES MNHB ALGORITHM.
-C
- INTEGER G1, H1, IV1, LH, NF
- REAL F
-C
-C *** SUBSCRIPTS FOR IV ***
-C
- INTEGER G, H, NEXTV, NFCALL, NFGCAL, TOOBIG, VNEED
-C
-C/6
-C DATA NEXTV/47/, NFCALL/6/, NFGCAL/7/, G/28/, H/56/, TOOBIG/2/,
-C 1 VNEED/4/
-C/7
- PARAMETER (NEXTV=47, NFCALL=6, NFGCAL=7, G=28, H=56, TOOBIG=2,
- 1 VNEED=4)
-C/
-C
-C+++++++++++++++++++++++++++++++ BODY ++++++++++++++++++++++++++++++++
-C
- LH = N * (N + 1) / 2
- IF (IV(1) .EQ. 0) CALL IVSET(2, IV, LIV, LV, V)
- IV1 = IV(1)
- IF (IV1 .EQ. 14) GO TO 10
- IF (IV1 .GT. 2 .AND. IV1 .LT. 12) GO TO 10
- IF (IV1 .EQ. 12) IV(1) = 13
- IF (IV(1) .EQ. 13) IV(VNEED) = IV(VNEED) + N*(N+3)/2
- CALL RMNHB(B, D, F, V, V, IV, LH, LIV, LV, N, V, X)
- IF (IV(1) .NE. 14) GO TO 999
-C
-C *** STORAGE ALLOCATION
-C
- IV(G) = IV(NEXTV)
- IV(H) = IV(G) + N
- IV(NEXTV) = IV(H) + N*(N+1)/2
- IF (IV1 .EQ. 13) GO TO 999
-C
- 10 G1 = IV(G)
- H1 = IV(H)
-C
- 20 CALL RMNHB(B, D, F, V(G1), V(H1), IV, LH, LIV, LV, N, V, X)
- IF (IV(1) - 2) 30, 40, 999
-C
- 30 NF = IV(NFCALL)
- CALL CALCF(N, X, NF, F, UIPARM, URPARM, UFPARM)
- IF (NF .LE. 0) IV(TOOBIG) = 1
- GO TO 20
-C
- 40 NF = IV(NFGCAL)
- CALL CALCGH(N, X, NF, V(G1), V(H1), UIPARM, URPARM, UFPARM)
- IF (NF .LE. 0) IV(TOOBIG) = 1
- GO TO 20
-C
- 999 RETURN
-C *** LAST CARD OF MNHB FOLLOWS ***
- END
diff --git a/CEP/PyBDSM/src/port3/movebc.f b/CEP/PyBDSM/src/port3/movebc.f
deleted file mode 100644
index 366219dfc747e2f64323135937a5debcd001ad19..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/movebc.f
+++ /dev/null
@@ -1,24 +0,0 @@
- SUBROUTINE MOVEBC(N,A,B)
-C
-C MOVEBC MOVES N COMPLEX ITEMS FROM A TO B
-C USING A BACKWARDS DO LOOP
-C
-C/R
-C REAL A(2,N), B(2,N)
-C/C
- COMPLEX A(1),B(1)
-C/
-C
- I = N
-C
- 10 IF(I .LE. 0) RETURN
-C/R
-C B(2,I) = A(2,I)
-C B(1,I) = A(1,I)
-C/C
- B(I) = A(I)
-C/
- I = I - 1
- GO TO 10
-C
- END
diff --git a/CEP/PyBDSM/src/port3/movebd.f b/CEP/PyBDSM/src/port3/movebd.f
deleted file mode 100644
index 66b4634773435858b1650573b0ea3f50a8df6e95..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/movebd.f
+++ /dev/null
@@ -1,15 +0,0 @@
- SUBROUTINE MOVEBD(N,A,B)
-C
-C MOVEBD MOVES N DOUBLE PRECISION ITEMS FROM A TO B
-C USING A BACKWARDS DO LOOP
-C
- DOUBLE PRECISION A(1),B(1)
-C
- I = N
-C
- 10 IF(I .LE. 0) RETURN
- B(I) = A(I)
- I = I - 1
- GO TO 10
-C
- END
diff --git a/CEP/PyBDSM/src/port3/movebi.f b/CEP/PyBDSM/src/port3/movebi.f
deleted file mode 100644
index 29c7b8326cc5c3900c5fc4848e5d32b3c5244f5d..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/movebi.f
+++ /dev/null
@@ -1,15 +0,0 @@
- SUBROUTINE MOVEBI(N,A,B)
-C
-C MOVEBI MOVES N INTEGER ITEMS FROM A TO B
-C USING A BACKWARDS DO LOOP
-C
- INTEGER A(1),B(1)
-C
- I = N
-C
- 10 IF(I .LE. 0) RETURN
- B(I) = A(I)
- I = I - 1
- GO TO 10
-C
- END
diff --git a/CEP/PyBDSM/src/port3/movebl.f b/CEP/PyBDSM/src/port3/movebl.f
deleted file mode 100644
index 764aa48d122f36e244688eb1928fbf8090b4f6c2..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/movebl.f
+++ /dev/null
@@ -1,15 +0,0 @@
- SUBROUTINE MOVEBL(N,A,B)
-C
-C MOVEBL MOVES N LOGICAL ITEMS FROM A TO B
-C USING A BACKWARDS DO LOOP
-C
- LOGICAL A(1),B(1)
-C
- I = N
-C
- 10 IF(I .LE. 0) RETURN
- B(I) = A(I)
- I = I - 1
- GO TO 10
-C
- END
diff --git a/CEP/PyBDSM/src/port3/movebr.f b/CEP/PyBDSM/src/port3/movebr.f
deleted file mode 100644
index 091eafb8d0ab97dd3f42618dc7182aaa6ae7c1c1..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/movebr.f
+++ /dev/null
@@ -1,15 +0,0 @@
- SUBROUTINE MOVEBR(N,A,B)
-C
-C MOVEBR MOVES N REAL ITEMS FROM A TO B
-C USING A BACKWARDS DO LOOP
-C
- REAL A(1),B(1)
-C
- I = N
-C
- 10 IF(I .LE. 0) RETURN
- B(I) = A(I)
- I = I - 1
- GO TO 10
-C
- END
diff --git a/CEP/PyBDSM/src/port3/movefc.f b/CEP/PyBDSM/src/port3/movefc.f
deleted file mode 100644
index 70b264351452a9216752af1ca1f92259a7204243..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/movefc.f
+++ /dev/null
@@ -1,24 +0,0 @@
- SUBROUTINE MOVEFC(N,A,B)
-C
-C MOVEFC MOVES N COMPLEX ITEMS FROM A TO B
-C USING A FORWARDS DO LOOP
-C
-C/R
-C REAL A(2,N), B(2,N)
-C/C
- COMPLEX A(1),B(1)
-C/
-C
- IF(N .LE. 0) RETURN
-C
- DO 10 I = 1, N
-C/R
-C B(1,I) = A(1,I)
-C10 B(2,I) = A(2,I)
-C/C
- 10 B(I) = A(I)
-C/
-C
- RETURN
-C
- END
diff --git a/CEP/PyBDSM/src/port3/movefd.f b/CEP/PyBDSM/src/port3/movefd.f
deleted file mode 100644
index 9349c041bf7f2fe68446e8717a844ae68b612175..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/movefd.f
+++ /dev/null
@@ -1,15 +0,0 @@
- SUBROUTINE MOVEFD(N,A,B)
-C
-C MOVEFD MOVES N DOUBLE PRECISION ITEMS FROM A TO B
-C USING A FORWARDS DO LOOP
-C
- DOUBLE PRECISION A(1),B(1)
-C
- IF(N .LE. 0) RETURN
-C
- DO 10 I = 1, N
- 10 B(I) = A(I)
-C
- RETURN
-C
- END
diff --git a/CEP/PyBDSM/src/port3/movefi.f b/CEP/PyBDSM/src/port3/movefi.f
deleted file mode 100644
index fafeef59b662d5f0679dd52bf659698a67aeac45..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/movefi.f
+++ /dev/null
@@ -1,15 +0,0 @@
- SUBROUTINE MOVEFI(N,A,B)
-C
-C MOVEFI MOVES N INTEGER ITEMS FROM A TO B
-C USING A FORWARDS DO LOOP
-C
- INTEGER A(1),B(1)
-C
- IF(N .LE. 0) RETURN
-C
- DO 10 I = 1, N
- 10 B(I) = A(I)
-C
- RETURN
-C
- END
diff --git a/CEP/PyBDSM/src/port3/movefl.f b/CEP/PyBDSM/src/port3/movefl.f
deleted file mode 100644
index bdb44bd789c8f11f57343db04c72b4ed50849a95..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/movefl.f
+++ /dev/null
@@ -1,15 +0,0 @@
- SUBROUTINE MOVEFL(N,A,B)
-C
-C MOVEFL MOVES N LOGICAL ITEMS FROM A TO B
-C USING A FORWARDS DO LOOP
-C
- LOGICAL A(1),B(1)
-C
- IF(N .LE. 0) RETURN
-C
- DO 10 I = 1, N
- 10 B(I) = A(I)
-C
- RETURN
-C
- END
diff --git a/CEP/PyBDSM/src/port3/movefr.f b/CEP/PyBDSM/src/port3/movefr.f
deleted file mode 100644
index 370edd5b2faae5de241f72c0bad45a209e0dc560..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/movefr.f
+++ /dev/null
@@ -1,15 +0,0 @@
- SUBROUTINE MOVEFR(N,A,B)
-C
-C MOVEFR MOVES N REAL ITEMS FROM A TO B
-C USING A FORWARDS DO LOOP
-C
- REAL A(1),B(1)
-C
- IF(N .LE. 0) RETURN
-C
- DO 10 I = 1, N
- 10 B(I) = A(I)
-C
- RETURN
-C
- END
diff --git a/CEP/PyBDSM/src/port3/mtstak.f b/CEP/PyBDSM/src/port3/mtstak.f
deleted file mode 100644
index 12b8e3e129b781202a9de903d940c9d117b030ff..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/mtstak.f
+++ /dev/null
@@ -1,8 +0,0 @@
- INTEGER FUNCTION MTSTAK(NITEMS)
-C
- CALL I0TK01
- MTSTAK = ISTKMD(NITEMS)
-C
- RETURN
-C
- END
diff --git a/CEP/PyBDSM/src/port3/n2cvp.f b/CEP/PyBDSM/src/port3/n2cvp.f
deleted file mode 100644
index c06a6533957db94bdedf63d570c337246d60b966..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/n2cvp.f
+++ /dev/null
@@ -1,85 +0,0 @@
- SUBROUTINE N2CVP(IV, LIV, LV, P, V)
-C
-C *** PRINT COVARIANCE MATRIX FOR RN2G ***
-C
- INTEGER LIV, LV, P
- INTEGER IV(LIV)
- REAL V(LV)
-C
-C *** LOCAL VARIABLES ***
-C
- INTEGER COV1, I, II, I1, J, PU
- REAL T
-C
-C *** IV SUBSCRIPTS ***
-C
- INTEGER COVMAT, COVPRT, COVREQ, NEEDHD, NFCOV, NGCOV, PRUNIT,
- 1 RCOND, REGD, STATPR
-C
-C/6
-C DATA COVMAT/26/, COVPRT/14/, COVREQ/15/, NEEDHD/36/, NFCOV/52/,
-C 1 NGCOV/53/, PRUNIT/21/, RCOND/53/, REGD/67/, STATPR/23/
-C/7
- PARAMETER (COVMAT=26, COVPRT=14, COVREQ=15, NEEDHD=36, NFCOV=52,
- 1 NGCOV=53, PRUNIT=21, RCOND=53, REGD=67, STATPR=23)
-C/
-C *** BODY ***
-C
- IF (IV(1) .GT. 8) GO TO 999
- PU = IV(PRUNIT)
- IF (PU .EQ. 0) GO TO 999
- IF (IV(STATPR) .EQ. 0) GO TO 30
- IF (IV(NFCOV) .GT. 0) WRITE(PU,10) IV(NFCOV)
- 10 FORMAT(/1X,I4,50H EXTRA FUNC. EVALS FOR COVARIANCE AND DIAGNOST
- 1ICS.)
- IF (IV(NGCOV) .GT. 0) WRITE(PU,20) IV(NGCOV)
- 20 FORMAT(1X,I4,50H EXTRA GRAD. EVALS FOR COVARIANCE AND DIAGNOSTI
- 1CS.)
-C
- 30 IF (IV(COVPRT) .LE. 0) GO TO 999
- COV1 = IV(COVMAT)
- IF (IV(REGD) .LE. 0 .AND. COV1 .LE. 0) GO TO 70
- IV(NEEDHD) = 1
- T = V(RCOND)**2
- IF (IABS(IV(COVREQ)) .GT. 2) GO TO 50
-C
- WRITE(PU,40) T
- 40 FORMAT(/47H RECIPROCAL CONDITION OF F.D. HESSIAN = AT MOST,E10.2)
- GO TO 70
-C
- 50 WRITE(PU,60) T
- 60 FORMAT(/44H RECIPROCAL CONDITION OF (J**T)*J = AT LEAST,E10.2)
-C
- 70 IF (MOD(IV(COVPRT),2) .EQ. 0) GO TO 999
- IV(NEEDHD) = 1
- IF (COV1) 80,110,130
- 80 IF (-1 .EQ. COV1) WRITE(PU,90)
- 90 FORMAT(/43H ++++++ INDEFINITE COVARIANCE MATRIX ++++++)
- IF (-2 .EQ. COV1) WRITE(PU,100)
- 100 FORMAT(/52H ++++++ OVERSIZE STEPS IN COMPUTING COVARIANCE +++++)
- GO TO 999
-C
- 110 WRITE(PU,120)
- 120 FORMAT(/45H ++++++ COVARIANCE MATRIX NOT COMPUTED ++++++)
- GO TO 999
-C
- 130 I = IABS(IV(COVREQ))
- IF (I .LE. 1) WRITE(PU,140)
- 140 FORMAT(/48H COVARIANCE = SCALE * H**-1 * (J**T * J) * H**-1/
- 1 23H WHERE H = F.D. HESSIAN/)
- IF (I .EQ. 2) WRITE(PU,150)
- 150 FORMAT(/56H COVARIANCE = H**-1, WHERE H = FINITE-DIFFERENCE HESSIA
- 1N/)
- IF (I .GT. 2) WRITE(PU,160)
- 160 FORMAT(/30H COVARIANCE = SCALE * J**T * J/)
- II = COV1 - 1
- DO 170 I = 1, P
- I1 = II + 1
- II = II + I
- WRITE(PU,180) I, (V(J), J = I1, II)
- 170 CONTINUE
- 180 FORMAT(4H ROW,I3,2X,5E12.3/(9X,5E12.3))
-C
- 999 RETURN
-C *** LAST CARD OF N2CVP FOLLOWS ***
- END
diff --git a/CEP/PyBDSM/src/port3/n2f.f b/CEP/PyBDSM/src/port3/n2f.f
deleted file mode 100644
index 9e5ae4b1dba2c752b196bf78fed6ea741ec63371..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/n2f.f
+++ /dev/null
@@ -1,168 +0,0 @@
- SUBROUTINE N2F(N, P, X, CALCR, IV, LIV, LV, V,
- 1 UIPARM, URPARM, UFPARM)
-C
-C *** MINIMIZE A NONLINEAR SUM OF SQUARES USING RESIDUAL VALUES ONLY..
-C *** THIS AMOUNTS TO N2G WITHOUT THE SUBROUTINE PARAMETER CALCJ.
-C
-C *** PARAMETERS ***
-C
- INTEGER N, P, LIV, LV
-C/6
-C INTEGER IV(LIV), UIPARM(1)
-C REAL X(P), V(LV), URPARM(1)
-C/7
- INTEGER IV(LIV), UIPARM(*)
- REAL X(P), V(LV), URPARM(*)
-C/
- EXTERNAL CALCR, UFPARM
-C
-C----------------------------- DISCUSSION ----------------------------
-C
-C THIS AMOUNTS TO SUBROUTINE NL2SNO (REF. 1) MODIFIED TO CALL
-C RN2G.
-C THE PARAMETERS FOR N2F ARE THE SAME AS THOSE FOR N2G
-C (WHICH SEE), EXCEPT THAT CALCJ IS OMITTED. INSTEAD OF CALLING
-C CALCJ TO OBTAIN THE JACOBIAN MATRIX OF R AT X, N2F COMPUTES
-C AN APPROXIMATION TO IT BY FINITE (FORWARD) DIFFERENCES -- SEE
-C V(DLTFDJ) BELOW. N2F USES FUNCTION VALUES ONLY WHEN COMPUT-
-C THE COVARIANCE MATRIX (RATHER THAN THE FUNCTIONS AND GRADIENTS
-C THAT N2G MAY USE). TO DO SO, N2F SETS IV(COVREQ) TO MINUS
-C ITS ABSOLUTE VALUE. THUS V(DELTA0) IS NEVER REFERENCED AND ONLY
-C V(DLTFDC) MATTERS -- SEE NL2SOL FOR A DESCRIPTION OF V(DLTFDC).
-C THE NUMBER OF EXTRA CALLS ON CALCR USED IN COMPUTING THE JACO-
-C BIAN APPROXIMATION ARE NOT INCLUDED IN THE FUNCTION EVALUATION
-C COUNT IV(NFCALL), BUT ARE RECORDED IN IV(NGCALL) INSTEAD.
-C
-C V(DLTFDJ)... V(43) HELPS CHOOSE THE STEP SIZE USED WHEN COMPUTING THE
-C FINITE-DIFFERENCE JACOBIAN MATRIX. FOR DIFFERENCES IN-
-C VOLVING X(I), THE STEP SIZE FIRST TRIED IS
-C V(DLTFDJ) * MAX(ABS(X(I)), 1/D(I)),
-C WHERE D IS THE CURRENT SCALE VECTOR (SEE REF. 1). (IF
-C THIS STEP IS TOO BIG, I.E., IF CALCR SETS NF TO 0, THEN
-C SMALLER STEPS ARE TRIED UNTIL THE STEP SIZE IS SHRUNK BE-
-C LOW 1000 * MACHEP, WHERE MACHEP IS THE UNIT ROUNDOFF.
-C DEFAULT = MACHEP**0.5.
-C
-C *** REFERENCE ***
-C
-C 1. DENNIS, J.E., GAY, D.M., AND WELSCH, R.E. (1981), AN ADAPTIVE
-C NONLINEAR LEAST-SQUARES ALGORITHM, ACM TRANS. MATH.
-C SOFTWARE, VOL. 7, NO. 3.
-C
-C *** GENERAL ***
-C
-C CODED BY DAVID M. GAY.
-C
-C+++++++++++++++++++++++++++ DECLARATIONS +++++++++++++++++++++++++++
-C
-C *** EXTERNAL SUBROUTINES ***
-C
- EXTERNAL IVSET, RN2G, N2RDP, V7SCP
-C
-C IVSET.... PROVIDES DEFAULT IV AND V INPUT COMPONENTS.
-C RN2G... CARRIES OUT OPTIMIZATION ITERATIONS.
-C N2RDP... PRINTS REGRESSION DIAGNOSTICS.
-C V7SCP... SETS ALL COMPONENTS OF A VECTOR TO A SCALAR.
-C
-C *** LOCAL VARIABLES ***
-C
- INTEGER D1, DK, DR1, I, IV1, J1K, K, N1, N2, NF, NG, RD1, R1, RN
- REAL H, H0, HLIM, NEGPT5, ONE, XK, ZERO
-C
-C *** IV AND V COMPONENTS ***
-C
- INTEGER COVREQ, D, DINIT, DLTFDJ, J, MODE, NEXTV, NFCALL, NFGCAL,
- 1 NGCALL, NGCOV, R, REGD, REGD0, TOOBIG, VNEED
-C/6
-C DATA COVREQ/15/, D/27/, DINIT/38/, DLTFDJ/43/, J/70/, MODE/35/,
-C 1 NEXTV/47/, NFCALL/6/, NFGCAL/7/, NGCALL/30/, NGCOV/53/,
-C 2 R/61/, REGD/67/, REGD0/82/, TOOBIG/2/, VNEED/4/
-C/7
- PARAMETER (COVREQ=15, D=27, DINIT=38, DLTFDJ=43, J=70, MODE=35,
- 1 NEXTV=47, NFCALL=6, NFGCAL=7, NGCALL=30, NGCOV=53,
- 2 R=61, REGD=67, REGD0=82, TOOBIG=2, VNEED=4)
-C/
- DATA HLIM/0.1E+0/, NEGPT5/-0.5E+0/, ONE/1.E+0/, ZERO/0.E+0/
-C
-C--------------------------------- BODY ------------------------------
-C
- IF (IV(1) .EQ. 0) CALL IVSET(1, IV, LIV, LV, V)
- IV(COVREQ) = -IABS(IV(COVREQ))
- IV1 = IV(1)
- IF (IV1 .EQ. 14) GO TO 10
- IF (IV1 .GT. 2 .AND. IV1 .LT. 12) GO TO 10
- IF (IV1 .EQ. 12) IV(1) = 13
- IF (IV(1) .EQ. 13) IV(VNEED) = IV(VNEED) + P + N*(P+2)
- CALL RN2G(X, V, IV, LIV, LV, N, N, N1, N2, P, V, V, V, X)
- IF (IV(1) .NE. 14) GO TO 999
-C
-C *** STORAGE ALLOCATION ***
-C
- IV(D) = IV(NEXTV)
- IV(R) = IV(D) + P
- IV(REGD0) = IV(R) + N
- IV(J) = IV(REGD0) + N
- IV(NEXTV) = IV(J) + N*P
- IF (IV1 .EQ. 13) GO TO 999
-C
- 10 D1 = IV(D)
- DR1 = IV(J)
- R1 = IV(R)
- RN = R1 + N - 1
- RD1 = IV(REGD0)
-C
- 20 CALL RN2G(V(D1), V(DR1), IV, LIV, LV, N, N, N1, N2, P, V(R1),
- 1 V(RD1), V, X)
- IF (IV(1)-2) 30, 50, 100
-C
-C *** NEW FUNCTION VALUE (R VALUE) NEEDED ***
-C
- 30 NF = IV(NFCALL)
- CALL CALCR(N, P, X, NF, V(R1), UIPARM, URPARM, UFPARM)
- IF (NF .GT. 0) GO TO 40
- IV(TOOBIG) = 1
- GO TO 20
- 40 IF (IV(1) .GT. 0) GO TO 20
-C
-C *** COMPUTE FINITE-DIFFERENCE APPROXIMATION TO DR = GRAD. OF R ***
-C
-C *** INITIALIZE D IF NECESSARY ***
-C
- 50 IF (IV(MODE) .LT. 0 .AND. V(DINIT) .EQ. ZERO)
- 1 CALL V7SCP(P, V(D1), ONE)
-C
- J1K = DR1
- DK = D1
- NG = IV(NGCALL) - 1
- IF (IV(1) .EQ. (-1)) IV(NGCOV) = IV(NGCOV) - 1
- DO 90 K = 1, P
- XK = X(K)
- H = V(DLTFDJ) * AMAX1( ABS(XK), ONE/V(DK))
- H0 = H
- DK = DK + 1
- 60 X(K) = XK + H
- NF = IV(NFGCAL)
- CALL CALCR (N, P, X, NF, V(J1K), UIPARM, URPARM, UFPARM)
- NG = NG + 1
- IF (NF .GT. 0) GO TO 70
- H = NEGPT5 * H
- IF ( ABS(H/H0) .GE. HLIM) GO TO 60
- IV(TOOBIG) = 1
- IV(NGCALL) = NG
- GO TO 20
- 70 X(K) = XK
- IV(NGCALL) = NG
- DO 80 I = R1, RN
- V(J1K) = (V(J1K) - V(I)) / H
- J1K = J1K + 1
- 80 CONTINUE
- 90 CONTINUE
- GO TO 20
-C
- 100 IF (IV(REGD) .GT. 0) IV(REGD) = RD1
- CALL N2RDP(IV, LIV, LV, N, V(RD1), V)
-C
- 999 RETURN
-C
-C *** LAST LINE OF N2F FOLLOWS ***
- END
diff --git a/CEP/PyBDSM/src/port3/n2fb.f b/CEP/PyBDSM/src/port3/n2fb.f
deleted file mode 100644
index 2b0a470829e9c95216fc3e896f9f8f0d5f822405..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/n2fb.f
+++ /dev/null
@@ -1,177 +0,0 @@
- SUBROUTINE N2FB(N, P, X, B, CALCR, IV, LIV, LV, V, UI, UR, UF)
-C
-C *** MINIMIZE A NONLINEAR SUM OF SQUARES USING RESIDUAL VALUES ONLY..
-C *** THIS AMOUNTS TO N2G WITHOUT THE SUBROUTINE PARAMETER CALCJ.
-C
-C *** PARAMETERS ***
-C
- INTEGER N, P, LIV, LV
-C/6
-C INTEGER IV(LIV), UI(1)
-C REAL X(P), B(2,P), V(LV), UR(1)
-C/7
- INTEGER IV(LIV), UI(*)
- REAL X(P), B(2,P), V(LV), UR(*)
-C/
- EXTERNAL CALCR, UF
-C
-C----------------------------- DISCUSSION ----------------------------
-C
-C THIS AMOUNTS TO SUBROUTINE NL2SNO (REF. 1) MODIFIED TO HANDLE
-C SIMPLE BOUNDS ON THE VARIABLES...
-C B(1,I) .LE. X(I) .LE. B(2,I), I = 1(1)P.
-C THE PARAMETERS FOR N2FB ARE THE SAME AS THOSE FOR N2GB
-C (WHICH SEE), EXCEPT THAT CALCJ IS OMITTED. INSTEAD OF CALLING
-C CALCJ TO OBTAIN THE JACOBIAN MATRIX OF R AT X, N2FB COMPUTES
-C AN APPROXIMATION TO IT BY FINITE (FORWARD) DIFFERENCES -- SEE
-C V(DLTFDJ) BELOW. N2FB DOES NOT COMPUTE A COVARIANCE MATRIX.
-C THE NUMBER OF EXTRA CALLS ON CALCR USED IN COMPUTING THE JACO-
-C BIAN APPROXIMATION ARE NOT INCLUDED IN THE FUNCTION EVALUATION
-C COUNT IV(NFCALL), BUT ARE RECORDED IN IV(NGCALL) INSTEAD.
-C
-C V(DLTFDJ)... V(43) HELPS CHOOSE THE STEP SIZE USED WHEN COMPUTING THE
-C FINITE-DIFFERENCE JACOBIAN MATRIX. FOR DIFFERENCES IN-
-C VOLVING X(I), THE STEP SIZE FIRST TRIED IS
-C V(DLTFDJ) * MAX(ABS(X(I)), 1/D(I)),
-C WHERE D IS THE CURRENT SCALE VECTOR (SEE REF. 1). (IF
-C THIS STEP IS TOO BIG, I.E., IF CALCR SETS NF TO 0, THEN
-C SMALLER STEPS ARE TRIED UNTIL THE STEP SIZE IS SHRUNK BE-
-C LOW 1000 * MACHEP, WHERE MACHEP IS THE UNIT ROUNDOFF.
-C DEFAULT = MACHEP**0.5.
-C
-C *** REFERENCE ***
-C
-C 1. DENNIS, J.E., GAY, D.M., AND WELSCH, R.E. (1981), AN ADAPTIVE
-C NONLINEAR LEAST-SQUARES ALGORITHM, ACM TRANS. MATH.
-C SOFTWARE, VOL. 7, NO. 3.
-C
-C *** GENERAL ***
-C
-C CODED BY DAVID M. GAY.
-C
-C+++++++++++++++++++++++++++ DECLARATIONS +++++++++++++++++++++++++++
-C
-C *** EXTERNAL SUBROUTINES ***
-C
- EXTERNAL IVSET, RN2GB, V7SCP
-C
-C IVSET.... PROVIDES DEFAULT IV AND V INPUT COMPONENTS.
-C RN2GB... CARRIES OUT OPTIMIZATION ITERATIONS.
-C N2RDP... PRINTS REGRESSION DIAGNOSTICS.
-C V7SCP... SETS ALL ELEMENTS OF A VECTOR TO A SCALAR.
-C
-C *** LOCAL VARIABLES ***
-C
- INTEGER D1, DK, DR1, I, IV1, J1K, K, N1, N2, NF, NG, RD1, R1, RN
- REAL H, H0, HLIM, NEGPT5, ONE, T, XK, XK1, ZERO
-C
-C *** IV AND V COMPONENTS ***
-C
- INTEGER COVREQ, D, DINIT, DLTFDJ, J, MODE, NEXTV, NFCALL, NFGCAL,
- 1 NGCALL, NGCOV, R, REGD0, TOOBIG, VNEED
-C/6
-C DATA COVREQ/15/, D/27/, DINIT/38/, DLTFDJ/43/, J/70/, MODE/35/,
-C 1 NEXTV/47/, NFCALL/6/, NFGCAL/7/, NGCALL/30/, NGCOV/53/,
-C 2 R/61/, REGD0/82/, TOOBIG/2/, VNEED/4/
-C/7
- PARAMETER (COVREQ=15, D=27, DINIT=38, DLTFDJ=43, J=70, MODE=35,
- 1 NEXTV=47, NFCALL=6, NFGCAL=7, NGCALL=30, NGCOV=53,
- 2 R=61, REGD0=82, TOOBIG=2, VNEED=4)
-C/
- DATA HLIM/0.1E+0/, NEGPT5/-0.5E+0/, ONE/1.E+0/, ZERO/0.E+0/
-C
-C--------------------------------- BODY ------------------------------
-C
- IF (IV(1) .EQ. 0) CALL IVSET(1, IV, LIV, LV, V)
- IV(COVREQ) = 0
- IV1 = IV(1)
- IF (IV1 .EQ. 14) GO TO 10
- IF (IV1 .GT. 2 .AND. IV1 .LT. 12) GO TO 10
- IF (IV1 .EQ. 12) IV(1) = 13
- IF (IV(1) .EQ. 13) IV(VNEED) = IV(VNEED) + P + N*(P+2)
- CALL RN2GB(B, X, V, IV, LIV, LV, N, N, N1, N2, P, V, V, V, X)
- IF (IV(1) .NE. 14) GO TO 999
-C
-C *** STORAGE ALLOCATION ***
-C
- IV(D) = IV(NEXTV)
- IV(R) = IV(D) + P
- IV(REGD0) = IV(R) + N
- IV(J) = IV(REGD0) + N
- IV(NEXTV) = IV(J) + N*P
- IF (IV1 .EQ. 13) GO TO 999
-C
- 10 D1 = IV(D)
- DR1 = IV(J)
- R1 = IV(R)
- RN = R1 + N - 1
- RD1 = IV(REGD0)
-C
- 20 CALL RN2GB(B, V(D1), V(DR1), IV, LIV, LV, N, N, N1, N2, P, V(R1),
- 1 V(RD1), V, X)
- IF (IV(1)-2) 30, 50, 999
-C
-C *** NEW FUNCTION VALUE (R VALUE) NEEDED ***
-C
- 30 NF = IV(NFCALL)
- CALL CALCR(N, P, X, NF, V(R1), UI, UR, UF)
- IF (NF .GT. 0) GO TO 40
- IV(TOOBIG) = 1
- GO TO 20
- 40 IF (IV(1) .GT. 0) GO TO 20
-C
-C *** COMPUTE FINITE-DIFFERENCE APPROXIMATION TO DR = GRAD. OF R ***
-C
-C *** INITIALIZE D IF NECESSARY ***
-C
- 50 IF (IV(MODE) .LT. 0 .AND. V(DINIT) .EQ. ZERO)
- 1 CALL V7SCP(P, V(D1), ONE)
-C
- J1K = DR1
- DK = D1
- NG = IV(NGCALL) - 1
- IF (IV(1) .EQ. (-1)) IV(NGCOV) = IV(NGCOV) - 1
- DO 120 K = 1, P
- IF (B(1,K) .GE. B(2,K)) GO TO 110
- XK = X(K)
- H = V(DLTFDJ) * AMAX1( ABS(XK), ONE/V(DK))
- H0 = H
- DK = DK + 1
- T = NEGPT5
- XK1 = XK + H
- IF (XK - H .GE. B(1,K)) GO TO 60
- T = -T
- IF (XK1 .GT. B(2,K)) GO TO 80
- 60 IF (XK1 .LE. B(2,K)) GO TO 70
- T = -T
- H = -H
- XK1 = XK + H
- IF (XK1 .LT. B(1,K)) GO TO 80
- 70 X(K) = XK1
- NF = IV(NFGCAL)
- CALL CALCR (N, P, X, NF, V(J1K), UI, UR, UF)
- NG = NG + 1
- IF (NF .GT. 0) GO TO 90
- H = T * H
- XK1 = XK + H
- IF ( ABS(H/H0) .GE. HLIM) GO TO 70
- 80 IV(TOOBIG) = 1
- IV(NGCALL) = NG
- GO TO 20
- 90 X(K) = XK
- IV(NGCALL) = NG
- DO 100 I = R1, RN
- V(J1K) = (V(J1K) - V(I)) / H
- J1K = J1K + 1
- 100 CONTINUE
- GO TO 120
-C *** SUPPLY A ZERO DERIVATIVE FOR CONSTANT COMPONENTS...
- 110 CALL V7SCP(N, V(J1K), ZERO)
- J1K = J1K + N
- 120 CONTINUE
- GO TO 20
-C
- 999 RETURN
-C
-C *** LAST CARD OF N2FB FOLLOWS ***
- END
diff --git a/CEP/PyBDSM/src/port3/n2g.f b/CEP/PyBDSM/src/port3/n2g.f
deleted file mode 100644
index 9b11e6ec0f354a7cff1a844eeebb20c5b4bb8cfe..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/n2g.f
+++ /dev/null
@@ -1,202 +0,0 @@
- SUBROUTINE N2G(N, P, X, CALCR, CALCJ, IV, LIV, LV, V,
- 1 UI, UR, UF)
-C
-C *** VERSION OF NL2SOL THAT CALLS RN2G ***
-C
-C *** PARAMETERS ***
-C
- INTEGER N, P, LIV, LV
-C/6
-C INTEGER IV(LIV), UI(1)
-C REAL X(P), V(LV), UR(1)
-C/7
- INTEGER IV(LIV), UI(*)
- REAL X(P), V(LV), UR(*)
-C/
- EXTERNAL CALCR, CALCJ, UF
-C
-C *** PARAMETER USAGE ***
-C
-C N....... TOTAL NUMBER OF RESIDUALS.
-C P....... NUMBER OF PARAMETERS (COMPONENTS OF X) BEING ESTIMATED.
-C X....... PARAMETER VECTOR BEING ESTIMATED (INPUT = INITIAL GUESS,
-C OUTPUT = BEST VALUE FOUND).
-C CALCR... SUBROUTINE FOR COMPUTING RESIDUAL VECTOR.
-C CALCJ... SUBROUTINE FOR COMPUTING JACOBIAN MATRIX = MATRIX OF FIRST
-C PARTIALS OF THE RESIDUAL VECTOR.
-C IV...... INTEGER VALUES ARRAY.
-C LIV..... LENGTH OF IV (SEE DISCUSSION BELOW).
-C LV...... LENGTH OF V (SEE DISCUSSION BELOW).
-C V....... FLOATING-POINT VALUES ARRAY.
-C UI...... PASSED UNCHANGED TO CALCR AND CALCJ.
-C UR...... PASSED UNCHANGED TO CALCR AND CALCJ.
-C UF...... PASSED UNCHANGED TO CALCR AND CALCJ.
-C
-C
-C *** DISCUSSION ***
-C
-C NOTE... NL2SOL (MENTIONED BELOW) IS A CODE FOR SOLVING
-C NONLINEAR LEAST-SQUARES PROBLEMS. IT IS DESCRIBED IN
-C ACM TRANS. MATH. SOFTWARE, VOL. 7 (1981), PP. 369-383
-C (AN ADAPTIVE NONLINEAR LEAST-SQUARES ALGORITHM, BY J.E. DENNIS,
-C D.M. GAY, AND R.E. WELSCH).
-C
-C LIV GIVES THE LENGTH OF IV. IT MUST BE AT LEAST 82+P. IF NOT,
-C THEN N2G RETURNS WITH IV(1) = 15. WHEN N2G RETURNS, THE
-C MINIMUM ACCEPTABLE VALUE OF LIV IS STORED IN IV(LASTIV) = IV(44),
-C (PROVIDED THAT LIV .GE. 44).
-C
-C LV GIVES THE LENGTH OF V. THE MINIMUM VALUE FOR LV IS
-C LV0 = 105 + P*(N + 2*P + 17) + 2*N. IF LV IS SMALLER THAN THIS,
-C THEN N2G RETURNS WITH IV(1) = 16. WHEN N2G RETURNS, THE
-C MINIMUM ACCEPTABLE VALUE OF LV IS STORED IN IV(LASTV) = IV(45)
-C (PROVIDED LIV .GE. 45).
-C
-C RETURN CODES AND CONVERGENCE TOLERANCES ARE THE SAME AS FOR
-C NL2SOL, WITH SOME SMALL EXTENSIONS... IV(1) = 15 MEANS LIV WAS
-C TOO SMALL. IV(1) = 16 MEANS LV WAS TOO SMALL.
-C
-C THERE ARE TWO NEW V INPUT COMPONENTS... V(LMAXS) = V(36) AND
-C V(SCTOL) = V(37) SERVE WHERE V(LMAX0) AND V(RFCTOL) FORMERLY DID
-C IN THE SINGULAR CONVERGENCE TEST -- SEE THE NL2SOL DOCUMENTATION.
-C
-C *** DEFAULT VALUES ***
-C
-C DEFAULT VALUES ARE PROVIDED BY SUBROUTINE IVSET, RATHER THAN
-C DFAULT. THE CALLING SEQUENCE IS...
-C CALL IVSET(1, IV, LIV, LV, V)
-C THE FIRST PARAMETER IS AN INTEGER 1. IF LIV AND LV ARE LARGE
-C ENOUGH FOR IVSET, THEN IVSET SETS IV(1) TO 12. OTHERWISE IT
-C SETS IV(1) TO 15 OR 16. CALLING N2G WITH IV(1) = 0 CAUSES ALL
-C DEFAULT VALUES TO BE USED FOR THE INPUT COMPONENTS OF IV AND V.
-C IF YOU FIRST CALL IVSET, THEN SET IV(1) TO 13 AND CALL N2G,
-C THEN STORAGE ALLOCATION ONLY WILL BE PERFORMED. IN PARTICULAR,
-C IV(D) = IV(27), IV(J) = IV(70), AND IV(R) = IV(61) WILL BE SET
-C TO THE FIRST SUBSCRIPT IN V OF THE SCALE VECTOR, THE JACOBIAN
-C MATRIX, AND THE RESIDUAL VECTOR RESPECTIVELY, PROVIDED LIV AND LV
-C ARE LARGE ENOUGH. IF SO, THEN N2G RETURNS WITH IV(1) = 14.
-C WHEN CALLED WITH IV(1) = 14, N2G ASSUMES THAT STORAGE HAS
-C BEEN ALLOCATED, AND IT BEGINS THE MINIMIZATION ALGORITHM.
-C
-C *** SCALE VECTOR ***
-C
-C ONE DIFFERENCE WITH NL2SOL IS THAT THE SCALE VECTOR D IS
-C STORED IN V, STARTING AT A DIFFERENT SUBSCRIPT. THE STARTING
-C SUBSCRIPT VALUE IS STILL STORED IN IV(D) = IV(27). THE
-C DISCUSSION OF DEFAULT VALUES ABOVE TELLS HOW TO HAVE IV(D) SET
-C BEFORE THE ALGORITHM IS STARTED.
-C
-C *** REGRESSION DIAGNOSTICS ***
-C
-C IF IV(RDREQ) SO DICTATES, THEN ESTIMATES ARE COMPUTED OF THE
-C INFLUENCE EACH RESIDUAL COMPONENT HAS ON THE FINAL PARAMETER
-C ESTIMATE X. THE GENERAL IDEA IS THAT ONE MAY WISH TO EXAMINE
-C RESIDUAL COMPONENTS (AND THE DATA BEHIND THEM) FOR WHICH THE
-C INFLUENCE ESTIMATE IS SIGNIFICANTLY LARGER THAN MOST OF THE OTHER
-C INFLUENCE ESTIMATES. THESE ESTIMATES, HEREAFTER CALLED
-C REGRESSION DIAGNOSTICS, ARE ONLY COMPUTED IF IV(RDREQ) = 2 OR 3.
-C IN THIS CASE, FOR I = 1(1)N,
-C SQRT( G(I)**T * H(I)**-1 * G(I) )
-C IS COMPUTED AND STORED IN V, STARTING AT V(IV(REGD)), WHERE
-C RDREQ = 57 AND REGD = 67. HERE G(I) STANDS FOR THE GRADIENT
-C RESULTING WHEN THE I-TH OBSERVATION IS DELETED AND H(I) STANDS
-C FOR AN APPROXIMATION TO THE CORRESPONDING HESSIAN AT X, THE SOLU-
-C TION CORRESPONDING TO ALL OBSERVATIONS. (THIS APPROXIMATION IS
-C OBTAINED BY SUBTRACTING THE FIRST-ORDER CONTRIBUTION OF THE I-TH
-C OBSERVATION TO THE HESSIAN FROM A FINITE-DIFFERENCE HESSIAN
-C APPROXIMATION. IF H IS INDEFINITE, THEN IV(REGD) IS SET TO -1.
-C IF H(I) IS INDEFINITE, THEN -1 IS RETURNED AS THE DIAGNOSTIC FOR
-C OBSERVATION I. IF NO DIAGNOSTICS ARE COMPUTED, PERHAPS BECAUSE
-C OF A FAILURE TO CONVERGE, THEN IV(REGD) = 0 IS RETURNED.)
-C PRINTING OF THE REGRESSION DIAGNOSTICS IS CONTROLLED BY
-C IV(COVPRT) = IV(14)... IF IV(COVPRT) = 3, THEN BOTH THE
-C COVARIANCE MATRIX AND THE REGRESSION DIAGNOSTICS ARE PRINTED.
-C IV(COVPRT) = 2 CAUSES ONLY THE REGRESSION DIAGNOSTICS TO BE
-C PRINTED, IV(COVPRT) = 1 CAUSES ONLY THE COVARIANCE MATRIX TO BE
-C PRINTED, AND IV(COVPRT) = 0 CAUSES NEITHER TO BE PRINTED.
-C
-C RDREQ = 57 AND REGD = 67.
-C
-C *** GENERAL ***
-C
-C CODED BY DAVID M. GAY.
-C
-C+++++++++++++++++++++++++++ DECLARATIONS +++++++++++++++++++++++++++
-C
-C *** EXTERNAL SUBROUTINES ***
-C
- EXTERNAL IVSET, RN2G, N2RDP
-C IVSET.... PROVIDES DEFAULT IV AND V INPUT COMPONENTS.
-C RN2G... CARRIES OUT OPTIMIZATION ITERATIONS.
-C N2RDP... PRINTS REGRESSION DIAGNOSTICS.
-C
-C *** NO INTRINSIC FUNCTIONS ***
-C
-C *** LOCAL VARIABLES ***
-C
- INTEGER D1, DR1, IV1, N1, N2, NF, R1, RD1
-C
-C *** IV COMPONENTS ***
-C
- INTEGER D, J, NEXTV, NFCALL, NFGCAL, R, REGD, REGD0, TOOBIG, VNEED
-C/6
-C DATA D/27/, J/70/, NEXTV/47/, NFCALL/6/, NFGCAL/7/, R/61/,
-C 1 REGD/67/, REGD0/82/, TOOBIG/2/, VNEED/4/
-C/7
- PARAMETER (D=27, J=70, NEXTV=47, NFCALL=6, NFGCAL=7, R=61,
- 1 REGD=67, REGD0=82, TOOBIG=2, VNEED=4)
-C/
-C--------------------------------- BODY ------------------------------
-C
- IF (IV(1) .EQ. 0) CALL IVSET(1, IV, LIV, LV, V)
- IV1 = IV(1)
- IF (IV1 .EQ. 14) GO TO 10
- IF (IV1 .GT. 2 .AND. IV1 .LT. 12) GO TO 10
- IF (IV1 .EQ. 12) IV(1) = 13
- IF (IV(1) .EQ. 13) IV(VNEED) = IV(VNEED) + P + N*(P+2)
- CALL RN2G(X, V, IV, LIV, LV, N, N, N1, N2, P, V, V, V, X)
- IF (IV(1) .NE. 14) GO TO 999
-C
-C *** STORAGE ALLOCATION ***
-C
- IV(D) = IV(NEXTV)
- IV(R) = IV(D) + P
- IV(REGD0) = IV(R) + N
- IV(J) = IV(REGD0) + N
- IV(NEXTV) = IV(J) + N*P
- IF (IV1 .EQ. 13) GO TO 999
-C
- 10 D1 = IV(D)
- DR1 = IV(J)
- R1 = IV(R)
- RD1 = IV(REGD0)
-C
- 20 CALL RN2G(V(D1), V(DR1), IV, LIV, LV, N, N, N1, N2, P, V(R1),
- 1 V(RD1), V, X)
- IF (IV(1)-2) 30, 50, 60
-C
-C *** NEW FUNCTION VALUE (R VALUE) NEEDED ***
-C
- 30 NF = IV(NFCALL)
- CALL CALCR(N, P, X, NF, V(R1), UI, UR, UF)
- IF (NF .GT. 0) GO TO 40
- IV(TOOBIG) = 1
- GO TO 20
- 40 IF (IV(1) .GT. 0) GO TO 20
-C
-C *** COMPUTE DR = GRADIENT OF R COMPONENTS ***
-C
- 50 CALL CALCJ(N, P, X, IV(NFGCAL), V(DR1), UI, UR, UF)
- IF (IV(NFGCAL) .EQ. 0) IV(TOOBIG) = 1
- GO TO 20
-C
-C *** INDICATE WHETHER THE REGRESSION DIAGNOSTIC ARRAY WAS COMPUTED
-C *** AND PRINT IT IF SO REQUESTED...
-C
- 60 IF (IV(REGD) .GT. 0) IV(REGD) = RD1
- CALL N2RDP(IV, LIV, LV, N, V(RD1), V)
-C
- 999 RETURN
-C
-C *** LAST LINE OF N2G FOLLOWS ***
- END
diff --git a/CEP/PyBDSM/src/port3/n2gb.f b/CEP/PyBDSM/src/port3/n2gb.f
deleted file mode 100644
index a4f312b800ec9e53242462eeeab10c0c3d3c71df..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/n2gb.f
+++ /dev/null
@@ -1,146 +0,0 @@
- SUBROUTINE N2GB(N, P, X, B, CALCR, CALCJ, IV, LIV, LV, V,
- 1 UIPARM, URPARM, UFPARM)
-C
-C *** VERSION OF NL2SOL THAT HANDLES SIMPLE BOUNDS ON X ***
-C
-C *** PARAMETERS ***
-C
- INTEGER N, P, LIV, LV
-C/6
-C INTEGER IV(LIV), UIPARM(1)
-C REAL X(P), B(2,P), V(LV), URPARM(1)
-C/7
- INTEGER IV(LIV), UIPARM(*)
- REAL X(P), B(2,P), V(LV), URPARM(*)
-C/
- EXTERNAL CALCR, CALCJ, UFPARM
-C
-C *** DISCUSSION ***
-C
-C NOTE... NL2SOL (MENTIONED BELOW) IS A CODE FOR SOLVING
-C NONLINEAR LEAST-SQUARES PROBLEMS. IT IS DESCRIBED IN
-C ACM TRANS. MATH. SOFTWARE, VOL. 7 (1981), PP. 369-383
-C (AN ADAPTIVE NONLINEAR LEAST-SQUARES ALGORITHM, BY J.E. DENNIS,
-C D.M. GAY, AND R.E. WELSCH).
-C
-C LIV GIVES THE LENGTH OF IV. IT MUST BE AT LEAST 82 + 4*P.
-C IF NOT, THEN N2GB RETURNS WITH IV(1) = 15. WHEN N2GB
-C RETURNS, THE MINIMUM ACCEPTABLE VALUE OF LIV IS STORED IN
-C IV(LASTIV) = IV(44), (PROVIDED THAT LIV .GE. 44).
-C
-C LV GIVES THE LENGTH OF V. THE MINIMUM VALUE FOR LV IS
-C LV0 = 105 + P*(N + 2*P + 21) + 2*N. IF LV IS SMALLER THAN THIS,
-C THEN N2GB RETURNS WITH IV(1) = 16. WHEN N2GB RETURNS, THE
-C MINIMUM ACCEPTABLE VALUE OF LV IS STORED IN IV(LASTV) = IV(45)
-C (PROVIDED LIV .GE. 45).
-C
-C RETURN CODES AND CONVERGENCE TOLERANCES ARE THE SAME AS FOR
-C NL2SOL, WITH SOME SMALL EXTENSIONS... IV(1) = 15 MEANS LIV WAS
-C TOO SMALL. IV(1) = 16 MEANS LV WAS TOO SMALL.
-C
-C THERE ARE TWO NEW V INPUT COMPONENTS... V(LMAXS) = V(36) AND
-C V(SCTOL) = V(37) SERVE WHERE V(LMAX0) AND V(RFCTOL) FORMERLY DID
-C IN THE SINGULAR CONVERGENCE TEST -- SEE THE NL2SOL DOCUMENTATION.
-C
-C *** BOUNDS ***
-C
-C THE BOUNDS B(1,I) .LE. X(I) .LE. B(2,I), I = 1(1)P, ARE ENFORCED.
-C
-C *** DEFAULT VALUES ***
-C
-C DEFAULT VALUES ARE PROVIDED BY SUBROUTINE IVSET, RATHER THAN
-C DFAULT. THE CALLING SEQUENCE IS...
-C CALL IVSET(1, IV, LIV, LV, V)
-C THE FIRST PARAMETER IS AN INTEGER 1. IF LIV AND LV ARE LARGE
-C ENOUGH FOR IVSET, THEN IVSET SETS IV(1) TO 12. OTHERWISE IT
-C SETS IV(1) TO 15 OR 16. CALLING N2GB WITH IV(1) = 0 CAUSES ALL
-C DEFAULT VALUES TO BE USED FOR THE INPUT COMPONENTS OF IV AND V.
-C IF YOU FIRST CALL IVSET, THEN SET IV(1) TO 13 AND CALL N2GB,
-C THEN STORAGE ALLOCATION ONLY WILL BE PERFORMED. IN PARTICULAR,
-C IV(D) = IV(27), IV(J) = IV(70), AND IV(R) = IV(61) WILL BE SET
-C TO THE FIRST SUBSCRIPT IN V OF THE SCALE VECTOR, THE JACOBIAN
-C MATRIX, AND THE RESIDUAL VECTOR RESPECTIVELY, PROVIDED LIV AND LV
-C ARE LARGE ENOUGH. IF SO, THEN N2GB RETURNS WITH IV(1) = 14.
-C WHEN CALLED WITH IV(1) = 14, N2GB ASSUMES THAT STORAGE HAS
-C BEEN ALLOCATED, AND IT BEGINS THE MINIMIZATION ALGORITHM.
-C
-C *** SCALE VECTOR ***
-C
-C ONE DIFFERENCE WITH NL2SOL IS THAT THE SCALE VECTOR D IS
-C STORED IN V, STARTING AT A DIFFERENT SUBSCRIPT. THE STARTING
-C SUBSCRIPT VALUE IS STILL STORED IN IV(D) = IV(27). THE
-C DISCUSSION OF DEFAULT VALUES ABOVE TELLS HOW TO HAVE IV(D) SET
-C BEFORE THE ALGORITHM IS STARTED.
-C
-C *** GENERAL ***
-C
-C CODED BY DAVID M. GAY.
-C
-C *** EXTERNAL SUBROUTINES ***
-C
- EXTERNAL IVSET, RN2GB
-C IVSET.... PROVIDES DEFAULT IV AND V INPUT COMPONENTS.
-C RN2GB... CARRIES OUT OPTIMIZATION ITERATIONS.
-C
-C *** LOCAL VARIABLES ***
-C
- INTEGER D1, DR1, IV1, N1, N2, NF, R1, RD1
-C
-C *** IV COMPONENTS ***
-C
- INTEGER D, J, NEXTV, NFCALL, NFGCAL, R, REGD0, TOOBIG, VNEED
-C/6
-C DATA D/27/, J/70/, NEXTV/47/, NFCALL/6/, NFGCAL/7/, R/61/,
-C 1 REGD0/82/, TOOBIG/2/, VNEED/4/
-C/7
- PARAMETER (D=27, J=70, NEXTV=47, NFCALL=6, NFGCAL=7, R=61,
- 1 REGD0=82, TOOBIG=2, VNEED=4)
-C/
-C--------------------------------- BODY ------------------------------
-C
- IF (IV(1) .EQ. 0) CALL IVSET(1, IV, LIV, LV, V)
- IV1 = IV(1)
- IF (IV1 .EQ. 14) GO TO 10
- IF (IV1 .GT. 2 .AND. IV1 .LT. 12) GO TO 10
- IF (IV1 .EQ. 12) IV(1) = 13
- IF (IV(1) .EQ. 13) IV(VNEED) = IV(VNEED) + P + N*(P+2)
- CALL RN2GB(B, X, V, IV, LIV, LV, N, N, N1, N2, P, V, V, V, X)
- IF (IV(1) .NE. 14) GO TO 999
-C
-C *** STORAGE ALLOCATION ***
-C
- IV(D) = IV(NEXTV)
- IV(R) = IV(D) + P
- IV(REGD0) = IV(R) + N
- IV(J) = IV(REGD0) + N
- IV(NEXTV) = IV(J) + N*P
- IF (IV1 .EQ. 13) GO TO 999
-C
- 10 D1 = IV(D)
- DR1 = IV(J)
- R1 = IV(R)
- RD1 = IV(REGD0)
-C
- 20 CALL RN2GB(B, V(D1), V(DR1), IV, LIV, LV, N, N, N1, N2, P, V(R1),
- 1 V(RD1), V, X)
- IF (IV(1)-2) 30, 50, 999
-C
-C *** NEW FUNCTION VALUE (R VALUE) NEEDED ***
-C
- 30 NF = IV(NFCALL)
- CALL CALCR(N, P, X, NF, V(R1), UIPARM, URPARM, UFPARM)
- IF (NF .GT. 0) GO TO 40
- IV(TOOBIG) = 1
- GO TO 20
- 40 IF (IV(1) .GT. 0) GO TO 20
-C
-C *** COMPUTE DR = GRADIENT OF R COMPONENTS ***
-C
- 50 CALL CALCJ(N, P, X, IV(NFGCAL), V(DR1), UIPARM, URPARM, UFPARM)
- IF (IV(NFGCAL) .EQ. 0) IV(TOOBIG) = 1
- GO TO 20
-C
- 999 RETURN
-C
-C *** LAST CARD OF N2GB FOLLOWS ***
- END
diff --git a/CEP/PyBDSM/src/port3/n2lrd.f b/CEP/PyBDSM/src/port3/n2lrd.f
deleted file mode 100644
index 1afded3f7ea7d436d8b6ec07321dda82dec53ae0..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/n2lrd.f
+++ /dev/null
@@ -1,90 +0,0 @@
- SUBROUTINE N2LRD(DR, IV, L, LH, LIV, LV, ND, NN, P, R, RD, V)
-C
-C *** COMPUTE REGRESSION DIAGNOSTIC AND DEFAULT COVARIANCE MATRIX FOR
-C RN2G ***
-C
-C *** PARAMETERS ***
-C
- INTEGER LH, LIV, LV, ND, NN, P
- INTEGER IV(LIV)
- REAL DR(ND,P), L(LH), R(NN), RD(NN), V(LV)
-C
-C *** CODED BY DAVID M. GAY (WINTER 1982, FALL 1983) ***
-C
-C *** EXTERNAL FUNCTIONS AND SUBROUTINES ***
-C
- REAL D7TPR
- EXTERNAL D7TPR, L7ITV, L7IVM, O7PRD, V7SCP
-C
-C *** LOCAL VARIABLES ***
-C
- INTEGER COV, I, J, M, STEP1
- REAL A, FF, S, T
-C
-C *** CONSTANTS ***
-C
- REAL NEGONE, ONE, ONEV(1), ZERO
-C
-C *** INTRINSIC FUNCTIONS ***
-C/+
- REAL SQRT
-C/
-C
-C *** IV AND V SUBSCRIPTS ***
-C
- INTEGER F, H, MODE, RDREQ, STEP
-C/6
-C DATA F/10/, H/56/, MODE/35/, RDREQ/57/, STEP/40/
-C/7
- PARAMETER (F=10, H=56, MODE=35, RDREQ=57, STEP=40)
-C/
-C/6
-C DATA NEGONE/-1.E+0/, ONE/1.E+0/, ZERO/0.E+0/
-C/7
- PARAMETER (NEGONE=-1.E+0, ONE=1.E+0, ZERO=0.E+0)
-C/
- DATA ONEV(1)/1.E+0/
-C
-C++++++++++++++++++++++++++++++++ BODY +++++++++++++++++++++++++++++++
-C
- STEP1 = IV(STEP)
- I = IV(RDREQ)
- IF (I .LE. 0) GO TO 999
- IF (MOD(I,4) .LT. 2) GO TO 30
- FF = ONE
- IF (V(F) .NE. ZERO) FF = ONE / SQRT( ABS(V(F)))
- CALL V7SCP(NN, RD, NEGONE)
- DO 20 I = 1, NN
- A = R(I)**2
- M = STEP1
- DO 10 J = 1, P
- V(M) = DR(I,J)
- M = M + 1
- 10 CONTINUE
- CALL L7IVM(P, V(STEP1), L, V(STEP1))
- S = D7TPR(P, V(STEP1), V(STEP1))
- T = ONE - S
- IF (T .LE. ZERO) GO TO 20
- A = A * S / T
- RD(I) = SQRT(A) * FF
- 20 CONTINUE
-C
- 30 IF (IV(MODE) - P .LT. 2) GO TO 999
-C
-C *** COMPUTE DEFAULT COVARIANCE MATRIX ***
-C
- COV = IABS(IV(H))
- DO 50 I = 1, NN
- M = STEP1
- DO 40 J = 1, P
- V(M) = DR(I,J)
- M = M + 1
- 40 CONTINUE
- CALL L7IVM(P, V(STEP1), L, V(STEP1))
- CALL L7ITV(P, V(STEP1), L, V(STEP1))
- CALL O7PRD(1, LH, P, V(COV), ONEV, V(STEP1), V(STEP1))
- 50 CONTINUE
-C
- 999 RETURN
-C *** LAST LINE OF N2LRD FOLLOWS ***
- END
diff --git a/CEP/PyBDSM/src/port3/n2p.f b/CEP/PyBDSM/src/port3/n2p.f
deleted file mode 100644
index a76e14cb07ea3c7490878db27742134ce98286cc..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/n2p.f
+++ /dev/null
@@ -1,177 +0,0 @@
- SUBROUTINE N2P(N, ND, P, X, CALCR, CALCJ, IV, LIV, LV, V,
- 1 UI, UR, UF)
-C
-C *** VERSION OF NL2SOL THAT CALLS RN2G AND HAS EXPANDED CALLING
-C *** SEQUENCES FOR CALCR, CALCJ, ALLOWING THEM TO PROVIDE R AND J
-C *** (RESIDUALS AND JACOBIAN) IN CHUNKS.
-C
-C *** PARAMETERS ***
-C
- INTEGER N, ND, P, LIV, LV
-C/6
-C INTEGER IV(LIV), UI(1)
-C REAL X(P), V(LV), UR(1)
-C/7
- INTEGER IV(LIV), UI(*)
- REAL X(P), V(LV), UR(*)
-C/
- EXTERNAL CALCR, CALCJ, UF
-C
-C
-C *** PARAMETER USAGE ***
-C
-C N....... TOTAL NUMBER OF RESIDUALS.
-C ND...... MAXIMUM NUMBER OF RESIDUAL COMPONENTS PROVIDED BY ANY CALL
-C ON CALCR.
-C P....... NUMBER OF PARAMETERS (COMPONENTS OF X) BEING ESTIMATED.
-C X....... PARAMETER VECTOR BEING ESTIMATED (INPUT = INITIAL GUESS,
-C OUTPUT = BEST VALUE FOUND).
-C CALCR... SUBROUTINE FOR COMPUTING RESIDUAL VECTOR.
-C CALCJ... SUBROUTINE FOR COMPUTING JACOBIAN MATRIX = MATRIX OF FIRST
-C PARTIALS OF THE RESIDUAL VECTOR.
-C IV...... INTEGER VALUES ARRAY.
-C LIV..... LENGTH OF IV (SEE DISCUSSION BELOW).
-C LV...... LENGTH OF V (SEE DISCUSSION BELOW).
-C V....... FLOATING-POINT VALUES ARRAY.
-C UI...... PASSED UNCHANGED TO CALCR AND CALCJ.
-C UR...... PASSED UNCHANGED TO CALCR AND CALCJ.
-C UF...... PASSED UNCHANGED TO CALCR AND CALCJ.
-C
-C
-C *** DISCUSSION ***
-C
-C THIS ROUTINE IS SIMILAR TO N2G (WHICH SEE), EXCEPT THAT THE
-C CALLING SEQUENCE FOR CALCR AND CALCJ IS DIFFERENT -- IT ALLOWS
-C THE RESIDUAL VECTOR AND JACOBIAN MATRIX TO BE PASSED IN BLOCKS.
-C
-C FOR CALCR, THE CALLING SEQUENCE IS...
-C
-C CALCR(N, ND1, N1, N2, P, X, NF, R, UI, UR, UF)
-C
-C PARAMETERS N, P, X, NF, R, UI, UR, UF ARE AS FOR THE CALCR USED
-C BY NL2SOL OR N2G.
-C PARAMETERS ND1, N1, AND N2 ARE INPUTS TO CALCR. CALCR SHOULD NOT
-C CHANGE ND1 OR N1 (BUT MAY CHANGE N2).
-C ND1 = MIN(N,ND) IS THE MAXIMUM NUMBER OF RESIDUAL COMPONENTS THAT
-C CALCR SHOULD SUPPLY ON ONE CALL.
-C N1 IS THE INDEX OF THE FIRST RESIDUAL COMPONENT THAT CALCR SHOULD
-C SUPPLY ON THIS CALL.
-C N2 HAS THE VALUE MIN(N, N1+ND1-1) WHEN CALCR IS CALLED. CALCR
-C MAY SET N2 TO A LOWER VALUE (AT LEAST 1) AND FOR N1 .LE. I .LE. N2
-C SHOULD RETURN RESIDUAL COMPONENT I IN R(I-N1+1), I.E., IN COMPONENTS
-C R(1), R(2), ..., R(N2-N1+1).
-C
-C FOR CALCJ, THE CALLING SEQUENCE IS...
-C
-C CALCJ(N, ND1, N1, N2, P, X, NF, J, UI, UR, UF)
-C
-C ALL PARAMETERS EXCEPT N2 AND J ARE AS FOR CALCR. N2 MAY NOT BE
-C CHANGED, BUT OTHERWISE IS AS FOR CALCR. (WHENEVER CALCJ IS CALLED,
-C CALCR WILL JUST HAVE BEEN CALLED WITH THE SAME VALUE OF N1 BUT
-C POSSIBLY A DIFFERENT X -- NF IDENTIFIES THE X PASSED. IF CALCR
-C CHANGES N2, THEN THIS CHANGED VALUE IS PASSED TO CALCJ.)
-C J IS A FLOATING-POINT ARRAY DIMENSIONED J(ND1,P). FOR I = N1(1)N2
-C AND K = 1(1)P, CALCJ MUST STORE THE PARTIAL DERIVATIVE AT X OF
-C RESIDUAL COMPONENT I WITH RESPECT TO X(K) IN J(I-N1+1,K).
-C
-C LIV MUST BE AT LEAST 82 + P. LV MUST BE AT LEAST
-C 105 + P*(17 + 2*P) + (P+1)*MIN(ND,N) + N
-C IF ND .LT. N AND NO REGRESSION DIAGNOSTIC ARRAY IS REQUESTED
-C (I.E., IV(RDREQ) = 0 OR 1), THEN LV CAN BE N LESS THAN THIS.
-C
-C+++++++++++++++++++++++++++ DECLARATIONS +++++++++++++++++++++++++++
-C
-C *** EXTERNAL SUBROUTINES ***
-C
- EXTERNAL IVSET, N2RDP, RN2G
-C IVSET.... PROVIDES DEFAULT IV AND V INPUT COMPONENTS.
-C N2RDP... PRINTS REGRESSION DIAGNOSTICS.
-C RN2G... CARRIES OUT OPTIMIZATION ITERATIONS.
-C
-C *** LOCAL VARIABLES ***
-C
- LOGICAL ONERD
- INTEGER D1, DR1, I, IV1, N1, N2, ND1, NF, R1, RD0, RD1, X01
-C
-C *** IV COMPONENTS ***
-C
- INTEGER D, J, NEXTV, NF00, NFCALL, NFGCAL, R, RDREQ, REGD,
- 1 REGD0, TOOBIG, VNEED, X0
-C/6
-C DATA D/27/, J/70/, NEXTV/47/, NF00/81/, NFCALL/6/, NFGCAL/7/,
-C 1 R/61/, RDREQ/57/, REGD/67/, REGD0/82/, TOOBIG/2/, VNEED/4/,
-C 2 X0/43/
-C/7
- PARAMETER (D=27, J=70, NEXTV=47, NF00=81, NFCALL=6, NFGCAL=7,
- 1 R=61, RDREQ=57, REGD=67, REGD0=82, TOOBIG=2, VNEED=4,
- 2 X0=43)
-C/
-C--------------------------------- BODY ------------------------------
-C
- IF (IV(1) .EQ. 0) CALL IVSET(1, IV, LIV, LV, V)
- ND1 = MIN0(ND, N)
- IV1 = IV(1)
- IF (IV1 .EQ. 14) GO TO 10
- IF (IV1 .GT. 2 .AND. IV1 .LT. 12) GO TO 10
- IF (IV1 .EQ. 12) IV(1) = 13
- I = IV(VNEED) + P + ND1*(P+1)
- ONERD = IV(RDREQ) .GE. 2 .OR. ND .GE. N
- IF (ONERD) I = I + N
- IF (IV(1) .EQ. 13) IV(VNEED) = I
- CALL RN2G(V, V, IV, LIV, LV, N, ND1, N1, N2, P, V, V, V, X)
- IF (IV(1) .NE. 14) GO TO 999
-C
-C *** STORAGE ALLOCATION ***
-C
- IV(D) = IV(NEXTV)
- IV(R) = IV(D) + P
- I = IV(R) + ND1
- IV(REGD0) = I
- IF (ONERD) I = I + N
- IV(J) = I
- IV(NEXTV) = I + ND1*P
- IF (IV1 .EQ. 13) GO TO 999
-C
- 10 D1 = IV(D)
- DR1 = IV(J)
- R1 = IV(R)
- RD1 = IV(REGD0)
- RD0 = RD1 - 1
-C
- 20 CALL RN2G(V(D1), V(DR1), IV, LIV, LV, N, ND1, N1, N2, P, V(R1),
- 1 V(RD1), V, X)
- IV1 = IV(1)
- IF (IV1-2) 40, 30, 80
- 30 IF (ND .GE. N) GO TO 70
-C
-C *** FIRST COMPUTE RELEVANT PORTION OF R ***
-C
- 40 NF = IV(NFCALL)
- IF (IABS(IV1) .GE. 2) NF = IV(NFGCAL)
- CALL CALCR(N, ND1, N1, N2, P, X, NF, V(R1), UI, UR, UF)
- IF (NF .GT. 0) GO TO 50
- IV(TOOBIG) = 1
- GO TO 20
- 50 I = IV1 + 4
- GO TO (70, 60, 70, 20, 20, 70), I
- 60 X01 = IV(X0)
- CALL CALCJ(N, ND1, N1, N2, P, V(X01), IV(NF00), V(DR1), UI,
- 1 UR, UF)
- IF (IV(NF00) .LE. 0) IV(TOOBIG) = 1
- GO TO 20
-C
-C *** COMPUTE DR = GRADIENT OF R COMPONENTS ***
-C
- 70 CALL CALCJ(N, ND1, N1, N2, P, X, IV(NFGCAL), V(DR1), UI, UR, UF)
- IF (IV(NFGCAL) .EQ. 0) IV(TOOBIG) = 1
- RD1 = RD0 + N1
- GO TO 20
-C
- 80 RD1 = RD0 + 1
- IF (IV(REGD) .GT. 0) IV(REGD) = RD1
- IF (IV(1) .LE. 8) CALL N2RDP(IV, LIV, LV, N, V(RD1), V)
-C
- 999 RETURN
-C
-C *** LAST LINE OF N2P FOLLOWS ***
- END
diff --git a/CEP/PyBDSM/src/port3/n2pb.f b/CEP/PyBDSM/src/port3/n2pb.f
deleted file mode 100644
index ddca6900e77ee998eba371342cf4a58dec3bd81e..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/n2pb.f
+++ /dev/null
@@ -1,168 +0,0 @@
- SUBROUTINE N2PB(N, ND, P, X, B, CALCR, CALCJ, IV, LIV, LV, V,
- 1 UI, UR, UF)
-C
-C *** SIMPLY BOUNDED VERSION OF NL2SOL THAT HAS EXPANDED CALLING
-C *** SEQUENCES FOR CALCR, CALCJ, ALLOWING THEM TO PROVIDE R AND J
-C *** (RESIDUALS AND JACOBIAN) IN CHUNKS.
-C
-C *** PARAMETERS ***
-C
- INTEGER N, ND, P, LIV, LV
-C/6
-C INTEGER IV(LIV), UI(1)
-C REAL B(2,P), X(P), V(LV), UR(1)
-C/7
- INTEGER IV(LIV), UI(*)
- REAL B(2,P), X(P), V(LV), UR(*)
-C/
- EXTERNAL CALCR, CALCJ, UF
-C
-C
-C *** PARAMETER USAGE ***
-C
-C N....... TOTAL NUMBER OF RESIDUALS.
-C ND...... MAXIMUM NUMBER OF RESIDUAL COMPONENTS PROVIDED BY ANY CALL
-C ON CALCR.
-C P....... NUMBER OF PARAMETERS (COMPONENTS OF X) BEING ESTIMATED.
-C X....... PARAMETER VECTOR BEING ESTIMATED (INPUT = INITIAL GUESS,
-C OUTPUT = BEST VALUE FOUND).
-C CALCR... SUBROUTINE FOR COMPUTING RESIDUAL VECTOR.
-C CALCJ... SUBROUTINE FOR COMPUTING JACOBIAN MATRIX = MATRIX OF FIRST
-C PARTIALS OF THE RESIDUAL VECTOR.
-C IV...... INTEGER VALUES ARRAY.
-C LIV..... LENGTH OF IV (SEE DISCUSSION BELOW).
-C LV...... LENGTH OF V (SEE DISCUSSION BELOW).
-C V....... FLOATING-POINT VALUES ARRAY.
-C UI...... PASSED UNCHANGED TO CALCR AND CALCJ.
-C UR...... PASSED UNCHANGED TO CALCR AND CALCJ.
-C UF...... PASSED UNCHANGED TO CALCR AND CALCJ.
-C
-C
-C *** DISCUSSION ***
-C
-C THIS ROUTINE IS SIMILAR TO N2G (WHICH SEE), EXCEPT THAT THE
-C CALLING SEQUENCE FOR CALCR AND CALCJ IS DIFFERENT -- IT ALLOWS
-C THE RESIDUAL VECTOR AND JACOBIAN MATRIX TO BE PASSED IN BLOCKS.
-C
-C FOR CALCR, THE CALLING SEQUENCE IS...
-C
-C CALCR(N, ND1, N1, N2, P, X, NF, R, UI, UR, UF)
-C
-C PARAMETERS N, P, X, NF, R, UI, UR, UF ARE AS FOR THE CALCR USED
-C BY NL2SOL OR N2G.
-C PARAMETERS ND1, N1, AND N2 ARE INPUTS TO CALCR. CALCR SHOULD NOT
-C CHANGE ND1 OR N1 (BUT MAY CHANGE N2).
-C ND1 = MIN(N,ND) IS THE MAXIMUM NUMBER OF RESIDUAL COMPONENTS THAT
-C CALCR SHOULD SUPPLY ON ONE CALL.
-C N1 IS THE INDEX OF THE FIRST RESIDUAL COMPONENT THAT CALCR SHOULD
-C SUPPLY ON THIS CALL.
-C N2 HAS THE VALUE MIN(N, N1+ND1-1) WHEN CALCR IS CALLED. CALCR
-C MAY SET N2 TO A LOWER VALUE (AT LEAST 1) AND FOR N1 .LE. I .LE. N2
-C SHOULD RETURN RESIDUAL COMPONENT I IN R(I-N1+1), I.E., IN COMPONENTS
-C R(1), R(2), ..., R(N2-N1+1).
-C
-C FOR CALCJ, THE CALLING SEQUENCE IS...
-C
-C CALCJ(N, ND1, N1, N2, P, X, NF, J, UI, UR, UF)
-C
-C ALL PARAMETERS EXCEPT N2 AND J ARE AS FOR CALCR. N2 MAY NOT BE
-C CHANGED, BUT OTHERWISE IS AS FOR CALCR. (WHENEVER CALCJ IS CALLED,
-C CALCR WILL JUST HAVE BEEN CALLED WITH THE SAME VALUE OF N1 BUT
-C POSSIBLY A DIFFERENT X -- NF IDENTIFIES THE X PASSED. IF CALCR
-C CHANGES N2, THEN THIS CHANGED VALUE IS PASSED TO CALCJ.)
-C J IS A FLOATING-POINT ARRAY DIMENSIONED J(ND1,P). FOR I = N1(1)N2
-C AND K = 1(1)P, CALCJ MUST STORE THE PARTIAL DERIVATIVE AT X OF
-C RESIDUAL COMPONENT I WITH RESPECT TO X(K) IN J(I-N1+1,K).
-C
-C LIV MUST BE AT LEAST 82 + P. LV MUST BE AT LEAST
-C 105 + P*(17 + 2*P) + (P+1)*MIN(ND,N) + N
-C IF ND .LT. N AND NO REGRESSION DIAGNOSTIC ARRAY IS REQUESTED
-C (I.E., IV(RDREQ) = 0 OR 1), THEN LV CAN BE N LESS THAN THIS.
-C
-C+++++++++++++++++++++++++++ DECLARATIONS +++++++++++++++++++++++++++
-C
-C *** EXTERNAL SUBROUTINES ***
-C
- EXTERNAL IVSET, RN2GB
-C IVSET.... PROVIDES DEFAULT IV AND V INPUT COMPONENTS.
-C RN2GB... CARRIES OUT OPTIMIZATION ITERATIONS.
-C
-C *** LOCAL VARIABLES ***
-C
- LOGICAL ONERD
- INTEGER D1, DR1, I, IV1, N1, N2, ND1, NF, R1, RD1, X01
-C
-C *** IV COMPONENTS ***
-C
- INTEGER D, J, NEXTV, NF00, NFCALL, NFGCAL, R,
- 1 REGD0, TOOBIG, VNEED, X0
-C/6
-C DATA D/27/, J/70/, NEXTV/47/, NF00/81/, NFCALL/6/, NFGCAL/7/,
-C 1 R/61/, REGD0/82/, TOOBIG/2/, VNEED/4/, X0/43/
-C/7
- PARAMETER (D=27, J=70, NEXTV=47, NF00=81, NFCALL=6, NFGCAL=7,
- 1 R=61, REGD0=82, TOOBIG=2, VNEED=4, X0=43)
-C/
-C--------------------------------- BODY ------------------------------
-C
- IF (IV(1) .EQ. 0) CALL IVSET(1, IV, LIV, LV, V)
- ND1 = MIN0(ND, N)
- IV1 = IV(1)
- IF (IV1 .EQ. 14) GO TO 10
- IF (IV1 .GT. 2 .AND. IV1 .LT. 12) GO TO 10
- IF (IV1 .EQ. 12) IV(1) = 13
- I = IV(VNEED) + P + ND1*(P+1)
- ONERD = ND .GE. N
- IF (ONERD) I = I + N
- IF (IV(1) .EQ. 13) IV(VNEED) = I
- CALL RN2GB(B, V, V, IV, LIV, LV, N, ND1, N1, N2, P, V, V, V, X)
- IF (IV(1) .NE. 14) GO TO 999
-C
-C *** STORAGE ALLOCATION ***
-C
- IV(D) = IV(NEXTV)
- IV(R) = IV(D) + P
- I = IV(R) + ND1
- IV(REGD0) = I
- IF (ONERD) I = I + N
- IV(J) = I
- IV(NEXTV) = I + ND1*P
- IF (IV1 .EQ. 13) GO TO 999
-C
- 10 D1 = IV(D)
- DR1 = IV(J)
- R1 = IV(R)
- RD1 = IV(REGD0)
-C
- 20 CALL RN2GB(B, V(D1), V(DR1), IV, LIV, LV, N, ND1, N1, N2, P,
- 1 V(R1), V(RD1), V, X)
- IV1 = IV(1)
- IF (IV1-2) 40, 30, 999
- 30 IF (ND .GE. N) GO TO 70
-C
-C *** FIRST COMPUTE RELEVANT PORTION OF R ***
-C
- 40 NF = IV(NFCALL)
- IF (IABS(IV1) .GE. 2) NF = IV(NFGCAL)
- CALL CALCR(N, ND1, N1, N2, P, X, NF, V(R1), UI, UR, UF)
- IF (NF .GT. 0) GO TO 50
- IV(TOOBIG) = 1
- GO TO 20
- 50 I = IV1 + 4
- GO TO (70, 60, 70, 20, 20, 70), I
- 60 X01 = IV(X0)
- CALL CALCJ(N, ND1, N1, N2, P, V(X01), IV(NF00), V(DR1), UI,
- 1 UR, UF)
- IF (IV(NF00) .LE. 0) IV(TOOBIG) = 1
- GO TO 20
-C
-C *** COMPUTE DR = GRADIENT OF R COMPONENTS ***
-C
- 70 CALL CALCJ(N, ND1, N1, N2, P, X, IV(NFGCAL), V(DR1), UI, UR, UF)
- IF (IV(NFGCAL) .EQ. 0) IV(TOOBIG) = 1
- GO TO 20
-C
- 999 RETURN
-C
-C *** LAST LINE OF N2PB FOLLOWS ***
- END
diff --git a/CEP/PyBDSM/src/port3/n2rdp.f b/CEP/PyBDSM/src/port3/n2rdp.f
deleted file mode 100644
index ffb11d70aea43e3e830786c8f75a5811c189b040..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/n2rdp.f
+++ /dev/null
@@ -1,42 +0,0 @@
- SUBROUTINE N2RDP(IV, LIV, LV, N, RD, V)
-C
-C *** PRINT REGRESSION DIAGNOSTICS FOR MLPSL AND NL2S1 ***
-C
- INTEGER LIV, LV, N
- INTEGER IV(LIV)
- REAL RD(N), V(LV)
-C
-C *** NOTE -- V IS PASSED FOR POSSIBLE _USE_ BY REVISED VERSIONS OF
-C *** THIS ROUTINE.
-C
- INTEGER PU
-C
-C *** IV AND V SUBSCRIPTS ***
-C
- INTEGER COVPRT, F, NEEDHD, PRUNIT, REGD
-C
-C/6
-C DATA COVPRT/14/, F/10/, NEEDHD/36/, PRUNIT/21/, REGD/67/
-C/7
- PARAMETER (COVPRT=14, F=10, NEEDHD=36, PRUNIT=21, REGD=67)
-C/
-C
-C+++++++++++++++++++++++++++++++ BODY ++++++++++++++++++++++++++++++++
-C
- PU = IV(PRUNIT)
- IF (PU .EQ. 0) GO TO 999
- IF (IV(COVPRT) .LT. 2) GO TO 999
- IF (IV(REGD) .LE. 0) GO TO 999
- IV(NEEDHD) = 1
- IF (V(F)) 10, 30, 10
- 10 WRITE(PU,20) RD
- 20 FORMAT(/70H REGRESSION DIAGNOSTIC = SQRT( G(I)**T * H(I)**-1 * G(I
- 1) / ABS(F) ).../(6E12.3))
- GO TO 999
- 30 WRITE(PU,40) RD
- 40 FORMAT(/61H REGRESSION DIAGNOSTIC = SQRT( G(I)**T * H(I)**-1 * G(I
- 1) ).../(6E12.3))
-C
- 999 RETURN
-C *** LAST LINE OF N2RDP FOLLOWS ***
- END
diff --git a/CEP/PyBDSM/src/port3/n7msrt.f b/CEP/PyBDSM/src/port3/n7msrt.f
deleted file mode 100644
index 24f687494a3178929b46c783940f0192b94a0e48..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/n7msrt.f
+++ /dev/null
@@ -1,104 +0,0 @@
- SUBROUTINE N7MSRT(N,NMAX,NUM,MODE,INDEX,LAST,NEXT)
- INTEGER N,NMAX,MODE
- INTEGER NUM(N),INDEX(N),LAST(1),NEXT(N)
-C **********.
-C
-C SUBROUTINE N7MSRT
-C
-C GIVEN A SEQUENCE OF INTEGERS, THIS SUBROUTINE GROUPS
-C TOGETHER THOSE INDICES WITH THE SAME SEQUENCE VALUE
-C AND, OPTIONALLY, SORTS THE SEQUENCE INTO EITHER
-C ASCENDING OR DESCENDING ORDER.
-C
-C THE SEQUENCE OF INTEGERS IS DEFINED BY THE ARRAY NUM,
-C AND IT IS ASSUMED THAT THE INTEGERS ARE EACH FROM THE SET
-C 0,1,...,NMAX. ON OUTPUT THE INDICES K SUCH THAT NUM(K) = L
-C FOR ANY L = 0,1,...,NMAX CAN BE OBTAINED FROM THE ARRAYS
-C LAST AND NEXT AS FOLLOWS.
-C
-C K = LAST(L+1)
-C WHILE (K .NE. 0) K = NEXT(K)
-C
-C OPTIONALLY, THE SUBROUTINE PRODUCES AN ARRAY INDEX SO THAT
-C THE SEQUENCE NUM(INDEX(I)), I = 1,2,...,N IS SORTED.
-C
-C THE SUBROUTINE STATEMENT IS
-C
-C SUBROUTINE N7MSRT(N,NMAX,NUM,MODE,INDEX,LAST,NEXT)
-C
-C WHERE
-C
-C N IS A POSITIVE INTEGER INPUT VARIABLE.
-C
-C NMAX IS A POSITIVE INTEGER INPUT VARIABLE.
-C
-C NUM IS AN INPUT ARRAY OF LENGTH N WHICH CONTAINS THE
-C SEQUENCE OF INTEGERS TO BE GROUPED AND SORTED. IT
-C IS ASSUMED THAT THE INTEGERS ARE EACH FROM THE SET
-C 0,1,...,NMAX.
-C
-C MODE IS AN INTEGER INPUT VARIABLE. THE SEQUENCE NUM IS
-C SORTED IN ASCENDING ORDER IF MODE IS POSITIVE AND IN
-C DESCENDING ORDER IF MODE IS NEGATIVE. IF MODE IS 0,
-C NO SORTING IS DONE.
-C
-C INDEX IS AN INTEGER OUTPUT ARRAY OF LENGTH N SET SO
-C THAT THE SEQUENCE
-C
-C NUM(INDEX(I)), I = 1,2,...,N
-C
-C IS SORTED ACCORDING TO THE SETTING OF MODE. IF MODE
-C IS 0, INDEX IS NOT REFERENCED.
-C
-C LAST IS AN INTEGER OUTPUT ARRAY OF LENGTH NMAX + 1. THE
-C INDEX OF NUM FOR THE LAST OCCURRENCE OF L IS LAST(L+1)
-C FOR ANY L = 0,1,...,NMAX UNLESS LAST(L+1) = 0. IN
-C THIS CASE L DOES NOT APPEAR IN NUM.
-C
-C NEXT IS AN INTEGER OUTPUT ARRAY OF LENGTH N. IF
-C NUM(K) = L, THEN THE INDEX OF NUM FOR THE PREVIOUS
-C OCCURRENCE OF L IS NEXT(K) FOR ANY L = 0,1,...,NMAX
-C UNLESS NEXT(K) = 0. IN THIS CASE THERE IS NO PREVIOUS
-C OCCURRENCE OF L IN NUM.
-C
-C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. JUNE 1982.
-C THOMAS F. COLEMAN, BURTON S. GARBOW, JORGE J. MORE
-C
-C **********
- INTEGER I,J,JP,K,L,NMAXP1,NMAXP2
-C
-C DETERMINE THE ARRAYS NEXT AND LAST.
-C
- NMAXP1 = NMAX + 1
- DO 10 I = 1, NMAXP1
- LAST(I) = 0
- 10 CONTINUE
- DO 20 K = 1, N
- L = NUM(K)
- NEXT(K) = LAST(L+1)
- LAST(L+1) = K
- 20 CONTINUE
- IF (MODE .EQ. 0) GO TO 60
-C
-C STORE THE POINTERS TO THE SORTED ARRAY IN INDEX.
-C
- I = 1
- NMAXP2 = NMAXP1 + 1
- DO 50 J = 1, NMAXP1
- JP = J
- IF (MODE .LT. 0) JP = NMAXP2 - J
- K = LAST(JP)
- 30 CONTINUE
- IF (K .EQ. 0) GO TO 40
- INDEX(I) = K
- I = I + 1
- K = NEXT(K)
- GO TO 30
- 40 CONTINUE
- 50 CONTINUE
- 60 CONTINUE
- RETURN
-C
-C LAST CARD OF SUBROUTINE N7MSRT.
-C
- END
diff --git a/CEP/PyBDSM/src/port3/nerror.f b/CEP/PyBDSM/src/port3/nerror.f
deleted file mode 100644
index 23f4b4fe2d3699c0ba952101412f02b515b66535..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/nerror.f
+++ /dev/null
@@ -1,9 +0,0 @@
- INTEGER FUNCTION NERROR(NERR)
-C
-C RETURNS NERROR = NERR = THE VALUE OF THE ERROR FLAG LERROR.
-C
- NERROR=I8SAVE(1,0,.FALSE.)
- NERR=NERROR
- RETURN
-C
- END
diff --git a/CEP/PyBDSM/src/port3/nirall.f b/CEP/PyBDSM/src/port3/nirall.f
deleted file mode 100644
index 3a3dd3da7804776852fa0e7fb4fc604315d2f428..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/nirall.f
+++ /dev/null
@@ -1,8 +0,0 @@
- INTEGER FUNCTION NIRALL(ISIZE)
-C
- CALL I0TK01
- NIRALL = ISTKQU(ISIZE+2)
-C
- RETURN
-C
- END
diff --git a/CEP/PyBDSM/src/port3/nsf.f b/CEP/PyBDSM/src/port3/nsf.f
deleted file mode 100644
index f774ca4db2182916b5656ed8c666ec29728ac605..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/nsf.f
+++ /dev/null
@@ -1,308 +0,0 @@
- SUBROUTINE NSF(N, P, L, ALF, C, Y, CALCA, INC, IINC, IV,
- 1 LIV, LV, V, UIPARM, URPARM, UFPARM)
-C
-C *** SOLVE SEPARABLE NONLINEAR LEAST SQUARES USING
-C *** FINITE-DIFFERENCE DERIVATIVES.
-C
-C *** PARAMETER DECLARATIONS ***
-C
- INTEGER IINC, L, LIV, LV, N, P
-C/6
-C INTEGER INC(IINC,P), IV(LIV), UIPARM(1)
-C REAL ALF(P), C(L), URPARM(1), V(LV), Y(N)
-C/7
- INTEGER INC(IINC,P), IV(LIV), UIPARM(*)
- REAL ALF(P), C(L), URPARM(*), V(LV), Y(N)
-C/
- EXTERNAL CALCA, UFPARM
-C
-C *** PARAMETERS ***
-C
-C N (IN) NUMBER OF OBSERVATIONS.
-C P (IN) NUMBER OF NONLINEAR PARAMETERS TO BE ESTIMATED.
-C L (IN) NUMBER OF LINEAR PARAMETERS TO BE ESTIMATED.
-C ALF (I/O) NONLINEAR PARAMETERS.
-C INPUT = INITIAL GUESS,
-C OUTPUT = BEST ESTIMATE FOUND.
-C C (OUT) LINEAR PARAMETERS (ESTIMATED).
-C Y (IN) RIGHT-HAND SIDE VECTOR.
-C CALCA (IN) SUBROUTINE TO COMPUTE A MATRIX.
-C INC (IN) INCIDENCE MATRIX OF DEPENDENCIES OF COLUMNS OF A ON
-C COMPONENTS OF ALF -- INC(I,J) = 1 MEANS COLUMN I
-C OF A DEPENDS ON ALF(J).
-C IINC (IN) DECLARED LEAD DIMENSION OF INC. MUST BE AT LEAST L+1.
-C IV (I/O) INTEGER PARAMETER AND SCRATCH VECTOR.
-C LIV (IN) LENGTH OF IV. MUST BE AT LEAST
-C 122 + 2*M + 4*P + 2*L + MAX(L+1,6*P), WHERE M IS
-C THE NUMBER OF ONES IN INC.
-C LV (IN) LENGTH OF V. MUST BE AT LEAST
-C 105 + 2*N*(L+3) + JLEN + L*(L+3)/2 + P*(2*P + 18),
-C WHERE JLEN = (L+P)*(N+L+P+1), UNLESS NEITHER A
-C COVARIANCE MATRIX NOR REGRESSION DIAGNOSTICS ARE
-C REQUESTED, IN WHICH CASE JLEN = N*P. IF THE LAST
-C ROW OF INC CONTAINS ONLY ZEROS, THEN LV CAN BE 4*N
-C LESS THAN JUST DESCRIBED.
-C V (I/O) FLOATING-POINT PARAMETER AND SCRATCH VECTOR.
-C IF A COVARIANCE ESTIMATE IS REQUESTED, IT IS FOR
-C (ALF,C) -- NONLINEAR PARAMETERS ORDERED FIRST,
-C FOLLOWED BY LINEAR PARAMETERS.
-C UIPARM (I/O) INTEGER VECTOR PASSED WITHOUT CHANGE TO CALCA.
-C URPARM (I/O) FLOATING-POINT VECTOR PASSED WITHOUT CHANGE TO CALCA.
-C UFPARM (I/O) SUBROUTINE PASSED (WITHOUT HAVING BEEN CALLED) TO CALCA.
-C
-C
-C-------------------------- DECLARATIONS ----------------------------
-C
-C
-C *** EXTERNAL SUBROUTINES ***
-C
- EXTERNAL IVSET, DSM, RNSG, V2AXY, V7CPY, V7SCL
-C
-C IVSET.... PROVIDES DEFAULT IV AND V VALUES.
-C DSM...... DETERMINES EFFICIENT ORDER FOR FINITE DIFFERENCES.
-C RNSG... CARRIES OUT NL2SOL ALGORITHM.
-C V2AXY.... ADDS A MULTIPLE OF ONE VECTOR TO ANOTHER.
-C V7CPY.... COPIES ONE VECTOR TO ANOTHER.
-C V7SCL... SCALES AND COPIES ONE VECTOR TO ANOTHER.
-C
-C *** LOCAL VARIABLES ***
-C
- LOGICAL PARTJ
- INTEGER A0, A1, AJ, ALP1, BWA1, D0, DA0, DA1, DAJ, GPTR1, GRP1,
- 1 GRP2, I, I1, IN0, IN1, IN2, INI, INLEN, IPNTR1, IV1, IWA1,
- 2 IWALEN, J1, JN1, JPNTR1, K, L1, LP1, M, M0, NF, NG, NGRP0,
- 3 NGRP1, NGRP2, RSAVE0, RSAVE1, RSVLEN, X0I, XSAVE0, XSAVE1
- REAL DELTA, DI, H, XI
- REAL NEGONE, ONE, ZERO
-C
-C *** SUBSCRIPTS FOR IV AND V ***
-C
- INTEGER AMAT, COVREQ, D, DAMAT, DLTFDJ, GPTR, GRP, IN, IVNEED,
- 1 L1SAV, MAXGRP, MODE, MSAVE, NEXTIV, NEXTV, NFCALL, NFGCAL,
- 2 PERM, RESTOR, TOOBIG, VNEED, XSAVE
-C
-C *** IV SUBSCRIPT VALUES ***
-C
-C/6
-C DATA AMAT/113/, COVREQ/15/, D/27/, DAMAT/114/, DLTFDJ/43/,
-C 1 GPTR/117/, GRP/118/, IN/112/, IVNEED/3/, L1SAV/111/,
-C 2 MAXGRP/116/, MODE/35/, MSAVE/115/, NEXTIV/46/, NEXTV/47/,
-C 3 NFCALL/6/, NFGCAL/7/, PERM/58/, RESTOR/9/, TOOBIG/2/,
-C 4 VNEED/4/, XSAVE/119/
-C/7
- PARAMETER (AMAT=113, COVREQ=15, D=27, DAMAT=114, DLTFDJ=43,
- 1 GPTR=117, GRP=118, IN=112, IVNEED=3, L1SAV=111,
- 2 MAXGRP=116, MODE=35, MSAVE=115, NEXTIV=46, NEXTV=47,
- 3 NFCALL=6, NFGCAL=7, PERM=58, RESTOR=9, TOOBIG=2,
- 4 VNEED=4, XSAVE=119)
-C/
- DATA NEGONE/-1.E+0/, ONE/1.E+0/, ZERO/0.E+0/
-C
-C++++++++++++++++++++++++++++++++ BODY ++++++++++++++++++++++++++++++
-C
- LP1 = L + 1
- IF (IV(1) .EQ. 0) CALL IVSET(1, IV, LIV, LV, V)
- IF (P .LE. 0 .OR. L .LT. 0 .OR. IINC .LE. L) GO TO 80
- IV1 = IV(1)
- IF (IV1 .EQ. 14) GO TO 120
- IF (IV1 .GT. 2 .AND. IV1 .LT. 12) GO TO 120
- IF (IV1 .EQ. 12) IV(1) = 13
- IF (IV(1) .NE. 13) GO TO 50
-C
-C *** FRESH START ***
-C
- IF (IV(PERM) .LE. XSAVE) IV(PERM) = XSAVE + 1
-C
-C *** CHECK INC, COUNT ITS NONZEROS
-C
- L1 = 0
- M = 0
- DO 40 I = 1, P
- M0 = M
- IF (L .EQ. 0) GO TO 20
- DO 10 K = 1, L
- IF (INC(K,I) .LT. 0 .OR. INC(K,I) .GT. 1) GO TO 80
- IF (INC(K,I) .EQ. 1) M = M + 1
- 10 CONTINUE
- 20 IF (INC(LP1,I) .NE. 1) GO TO 30
- M = M + 1
- L1 = 1
- 30 IF (M .EQ. M0 .OR. INC(LP1,I) .LT. 0
- 1 .OR. INC(LP1,I) .GT. 1) GO TO 80
- 40 CONTINUE
-C
-C *** NOW L1 = 1 MEANS A HAS COLUMN L+1 ***
-C
-C *** COMPUTE STORAGE REQUIREMENTS ***
-C
- IWALEN = MAX0(LP1, 6*P)
- INLEN = 2 * M
- IV(IVNEED) = IV(IVNEED) + INLEN + 3*P + L + IWALEN + 3
- RSVLEN = 2 * L1 * N
- L1 = L + L1
- IV(VNEED) = IV(VNEED) + 2*N*L1 + RSVLEN + P
-C
- 50 CALL RNSG(V, ALF, C, V, IV, IV, L, 1, N, LIV, LV, N, M, P, V, Y)
- IF (IV(1) .NE. 14) GO TO 999
-C
-C *** STORAGE ALLOCATION ***
-C
- IV(IN) = IV(NEXTIV)
- IV(AMAT) = IV(NEXTV)
- IV(DAMAT) = IV(AMAT) + N*L1
- IV(XSAVE) = IV(DAMAT) + N*L1
- IV(NEXTV) = IV(XSAVE) + P + RSVLEN
- IV(L1SAV) = L1
- IV(MSAVE) = M
-C
-C *** DETERMINE HOW MANY GROUPS FOR FINITE DIFFERENCES
-C *** (SET UP TO CALL DSM)
-C
- IN1 = IV(IN)
- JN1 = IN1 + M
- DO 70 K = 1, P
- DO 60 I = 1, LP1
- IF (INC(I,K) .EQ. 0) GO TO 60
- IV(IN1) = I
- IN1 = IN1 + 1
- IV(JN1) = K
- JN1 = JN1 + 1
- 60 CONTINUE
- 70 CONTINUE
- IN1 = IV(IN)
- JN1 = IN1 + M
- IWA1 = IN1 + INLEN
- NGRP1 = IWA1 + IWALEN
- BWA1 = NGRP1 + P
- IPNTR1 = BWA1 + P
- JPNTR1 = IPNTR1 + L + 2
- CALL DSM(LP1, P, M, IV(IN1), IV(JN1), IV(NGRP1), NG, K, I,
- 1 IV(IPNTR1), IV(JPNTR1), IV(IWA1), IWALEN, IV(BWA1))
- IF (I .EQ. 1) GO TO 90
- IV(1) = 69
- GO TO 50
- 80 IV(1) = 66
- GO TO 50
-C
-C *** SET UP GRP AND GPTR ARRAYS FOR COMPUTING FINITE DIFFERENCES
-C
-C *** THERE ARE NG GROUPS. GROUP I CONTAINS ALF(GRP(J)) FOR
-C *** GPTR(I) .LE. J .LE. GPTR(I+1)-1.
-C
- 90 IV(MAXGRP) = NG
- IV(GPTR) = IN1 + 2*L1
- GPTR1 = IV(GPTR)
- IV(GRP) = GPTR1 + NG + 1
- IV(NEXTIV) = IV(GRP) + P
- GRP1 = IV(GRP)
- NGRP0 = NGRP1 - 1
- NGRP2 = NGRP0 + P
- DO 110 I = 1, NG
- IV(GPTR1) = GRP1
- GPTR1 = GPTR1 + 1
- DO 100 I1 = NGRP1, NGRP2
- IF (IV(I1) .NE. I) GO TO 100
- IV(GRP1) = I1 - NGRP0
- GRP1 = GRP1 + 1
- 100 CONTINUE
- 110 CONTINUE
- IV(GPTR1) = GRP1
- IF (IV1 .EQ. 13) GO TO 999
-C
-C *** INITIALIZE POINTERS ***
-C
- 120 A1 = IV(AMAT)
- A0 = A1 - N
- DA1 = IV(DAMAT)
- DA0 = DA1 - N
- IN1 = IV(IN)
- IN0 = IN1 - 2
- L1 = IV(L1SAV)
- IN2 = IN1 + 2*L1 - 1
- D0 = IV(D) - 1
- NG = IV(MAXGRP)
- XSAVE1 = IV(XSAVE)
- XSAVE0 = XSAVE1 - 1
- RSAVE1 = XSAVE1 + P
- RSAVE0 = RSAVE1 + N
- ALP1 = A1 + L*N
- DELTA = V(DLTFDJ)
- IV(COVREQ) = -IABS(IV(COVREQ))
-C
- 130 CALL RNSG(V(A1), ALF, C, V(DA1), IV(IN1), IV, L, L1, N, LIV, LV,
- 1 N, L1, P, V, Y)
- IF (IV(1)-2) 140, 150, 999
-C
-C *** NEW FUNCTION VALUE (R VALUE) NEEDED ***
-C
- 140 NF = IV(NFCALL)
- CALL CALCA(N, P, L, ALF, NF, V(A1), UIPARM, URPARM, UFPARM)
- IF (NF .LE. 0) IV(TOOBIG) = 1
- IF (L1 .LE. L) GO TO 130
- IF (IV(RESTOR) .EQ. 2) CALL V7CPY(N, V(RSAVE0), V(RSAVE1))
- CALL V7CPY(N, V(RSAVE1), V(ALP1))
- GO TO 130
-C
-C *** COMPUTE DR = GRADIENT OF R COMPONENTS ***
-C
- 150 IF (L1 .GT. L .AND. IV(NFGCAL) .EQ. IV(NFCALL))
- 1 CALL V7CPY(N, V(RSAVE0), V(RSAVE1))
- GPTR1 = IV(GPTR)
- DO 230 K = 1, NG
- CALL V7CPY(P, V(XSAVE1), ALF)
- GRP1 = IV(GPTR1)
- GRP2 = IV(GPTR1+1) - 1
- GPTR1 = GPTR1 + 1
- DO 160 I1 = GRP1, GRP2
- I = IV(I1)
- XI = ALF(I)
- J1 = D0 + I
- DI = V(J1)
- IF (DI .LE. ZERO) DI = ONE
- H = DELTA * AMAX1( ABS(XI), ONE/DI)
- IF (XI .LT. ZERO) H = -H
- X0I = XSAVE0 + I
- V(X0I) = XI + H
- 160 CONTINUE
- CALL CALCA(N, P, L, V(XSAVE1), IV(NFGCAL), V(DA1),
- 1 UIPARM, URPARM, UFPARM)
- IF (IV(NFGCAL) .GT. 0) GO TO 170
- IV(TOOBIG) = 1
- GO TO 130
- 170 JN1 = IN1
- DO 180 I = IN1, IN2
- 180 IV(I) = 0
- PARTJ = IV(MODE) .LE. P
- DO 220 I1 = GRP1, GRP2
- I = IV(I1)
- DO 210 J1 = 1, L1
- IF (INC(J1,I) .EQ. 0) GO TO 210
- INI = IN0 + 2*J1
- IV(INI) = I
- IV(INI+1) = J1
- X0I = XSAVE0 + I
- H = ONE / (V(X0I) - ALF(I))
- DAJ = DA0 + J1*N
- IF (PARTJ) GO TO 190
-C *** FULL FINITE DIFFERENCE FOR COV. AND REG. DIAG. ***
- AJ = A0 + J1*N
- CALL V2AXY(N, V(DAJ), NEGONE, V(AJ), V(DAJ))
- GO TO 200
- 190 IF (J1 .GT. L)
- 1 CALL V2AXY(N, V(DAJ), NEGONE, V(RSAVE0), V(DAJ))
- 200 CALL V7SCL(N, V(DAJ), H, V(DAJ))
- 210 CONTINUE
- 220 CONTINUE
- IF (K .GE. NG) GO TO 240
- IV(1) = -2
- CALL RNSG(V(A1), ALF, C, V(DA1), IV(IN1), IV, L, L1, N, LIV,
- 1 LV, N, L1, P, V, Y)
- IF (-2 .NE. IV(1)) GO TO 999
- 230 CONTINUE
- 240 IV(1) = 2
- GO TO 130
-C
- 999 RETURN
-C
-C *** LAST CARD OF NSF FOLLOWS ***
- END
diff --git a/CEP/PyBDSM/src/port3/nsfb.f b/CEP/PyBDSM/src/port3/nsfb.f
deleted file mode 100644
index 3e5a6f4458473fca1d9553f873b479daf11d0eb7..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/nsfb.f
+++ /dev/null
@@ -1,319 +0,0 @@
- SUBROUTINE NSFB(N, P, L, ALF, B, C, Y, CALCA, INC, IINC, IV,
- 1 LIV, LV, V, UIPARM, URPARM, UFPARM)
-C
-C *** SOLVE SEPARABLE NONLINEAR LEAST SQUARES USING
-C *** FINITE-DIFFERENCE DERIVATIVES.
-C
-C *** PARAMETER DECLARATIONS ***
-C
- INTEGER IINC, L, LIV, LV, N, P
-C/6
-C INTEGER INC(IINC,P), IV(LIV), UIPARM(1)
-C REAL ALF(P), C(L), B(2,P), URPARM(1), V(LV), Y(N)
-C/7
- INTEGER INC(IINC,P), IV(LIV), UIPARM(*)
- REAL ALF(P), C(L), B(2,P), URPARM(*), V(LV), Y(N)
-C/
- EXTERNAL CALCA, UFPARM
-C
-C *** PARAMETERS ***
-C
-C N (IN) NUMBER OF OBSERVATIONS.
-C P (IN) NUMBER OF NONLINEAR PARAMETERS TO BE ESTIMATED.
-C L (IN) NUMBER OF LINEAR PARAMETERS TO BE ESTIMATED.
-C ALF (I/O) NONLINEAR PARAMETERS.
-C INPUT = INITIAL GUESS,
-C OUTPUT = BEST ESTIMATE FOUND.
-C B (IN) SIMBLE BOUNDS ON ALF.. B(1,I) .LE. ALF(I) .LE. B(2,I).
-C C (OUT) LINEAR PARAMETERS (ESTIMATED).
-C Y (IN) RIGHT-HAND SIDE VECTOR.
-C CALCA (IN) SUBROUTINE TO COMPUTE A MATRIX.
-C INC (IN) INCIDENCE MATRIX OF DEPENDENCIES OF COLUMNS OF A ON
-C COMPONENTS OF ALF -- INC(I,J) = 1 MEANS COLUMN I
-C OF A DEPENDS ON ALF(J).
-C IINC (IN) DECLARED LEAD DIMENSION OF INC. MUST BE AT LEAST L+1.
-C IV (I/O) INTEGER PARAMETER AND SCRATCH VECTOR.
-C LIV (IN) LENGTH OF IV. MUST BE AT LEAST
-C 122 + 2*M + 7*P + 2*L + MAX(L+1,6*P), WHERE M IS
-C THE NUMBER OF ONES IN INC.
-C LV (IN) LENGTH OF V. MUST BE AT LEAST
-C 105 + N*(2*L+6+P) + L*(L+3)/2 + P*(2*P + 22).
-C IF THE LAST ROW OF INC CONTAINS ONLY ZEROS, THEN LV
-C CAN BE 4*N LESS THAN JUST DESCRIBED.
-C V (I/O) FLOATING-POINT PARAMETER AND SCRATCH VECTOR.
-C UIPARM (I/O) INTEGER VECTOR PASSED WITHOUT CHANGE TO CALCA.
-C URPARM (I/O) FLOATING-POINT VECTOR PASSED WITHOUT CHANGE TO CALCA.
-C UFPARM (I/O) SUBROUTINE PASSED (WITHOUT HAVING BEEN CALLED) TO CALCA.
-C
-C
-C-------------------------- DECLARATIONS ----------------------------
-C
-C
-C *** EXTERNAL SUBROUTINES ***
-C
- EXTERNAL IVSET, DSM, RNSGB, V2AXY, V7CPY, V7SCL
-C
-C IVSET.... PROVIDES DEFAULT IV AND V VALUES.
-C DSM...... DETERMINES EFFICIENT ORDER FOR FINITE DIFFERENCES.
-C RNSGB... CARRIES OUT NL2SOL ALGORITHM.
-C V2AXY.... ADDS A MULTIPLE OF ONE VECTOR TO ANOTHER.
-C V7CPY.... COPIES ONE VECTOR TO ANOTHER.
-C V7SCL... SCALES AND COPIES ONE VECTOR TO ANOTHER.
-C
-C *** LOCAL VARIABLES ***
-C
- LOGICAL PARTJ
- INTEGER A0, A1, AJ, ALP1, BWA1, D0, DA0, DA1, DAJ, GPTR1, GRP1,
- 1 GRP2, I, I1, IN0, IN1, IN2, INI, INLEN, IPNTR1, IV1, IWA1,
- 2 IWALEN, J1, JN1, JPNTR1, K, L1, LP1, M, M0, NF, NG, NGRP0,
- 3 NGRP1, NGRP2, RSAVE0, RSAVE1, RSVLEN, X0I, XSAVE0, XSAVE1
- REAL DELTA, DI, H, XI, XI1
- REAL NEGONE, ONE, ZERO
-C
-C *** SUBSCRIPTS FOR IV AND V ***
-C
- INTEGER AMAT, COVREQ, D, DAMAT, DLTFDJ, GPTR, GRP, IN, IVNEED,
- 1 L1SAV, MAXGRP, MODE, MSAVE, NEXTIV, NEXTV, NFCALL, NFGCAL,
- 2 PERM, RESTOR, TOOBIG, VNEED, XSAVE
-C
-C *** IV SUBSCRIPT VALUES ***
-C
-C/6
-C DATA AMAT/113/, COVREQ/15/, D/27/, DAMAT/114/, DLTFDJ/43/,
-C 1 GPTR/117/, GRP/118/, IN/112/, IVNEED/3/, L1SAV/111/,
-C 2 MAXGRP/116/, MODE/35/, MSAVE/115/, NEXTIV/46/, NEXTV/47/,
-C 3 NFCALL/6/, NFGCAL/7/, PERM/58/, RESTOR/9/, TOOBIG/2/,
-C 4 VNEED/4/, XSAVE/119/
-C/7
- PARAMETER (AMAT=113, COVREQ=15, D=27, DAMAT=114, DLTFDJ=43,
- 1 GPTR=117, GRP=118, IN=112, IVNEED=3, L1SAV=111,
- 2 MAXGRP=116, MODE=35, MSAVE=115, NEXTIV=46, NEXTV=47,
- 3 NFCALL=6, NFGCAL=7, PERM=58, RESTOR=9, TOOBIG=2,
- 4 VNEED=4, XSAVE=119)
-C/
- DATA NEGONE/-1.E+0/, ONE/1.E+0/, ZERO/0.E+0/
-C
-C++++++++++++++++++++++++++++++++ BODY ++++++++++++++++++++++++++++++
-C
- LP1 = L + 1
- IF (IV(1) .EQ. 0) CALL IVSET(1, IV, LIV, LV, V)
- IF (P .LE. 0 .OR. L .LT. 0 .OR. IINC .LE. L) GO TO 80
- IV1 = IV(1)
- IF (IV1 .EQ. 14) GO TO 120
- IF (IV1 .GT. 2 .AND. IV1 .LT. 12) GO TO 120
- IF (IV1 .EQ. 12) IV(1) = 13
- IF (IV(1) .NE. 13) GO TO 50
-C
-C *** FRESH START ***
-C
- IF (IV(PERM) .LE. XSAVE) IV(PERM) = XSAVE + 1
-C
-C *** CHECK INC, COUNT ITS NONZEROS
-C
- L1 = 0
- M = 0
- DO 40 I = 1, P
- IF (B(1,I) .GE. B(2,I)) GO TO 40
- M0 = M
- IF (L .EQ. 0) GO TO 20
- DO 10 K = 1, L
- IF (INC(K,I) .LT. 0 .OR. INC(K,I) .GT. 1) GO TO 80
- IF (INC(K,I) .EQ. 1) M = M + 1
- 10 CONTINUE
- 20 IF (INC(LP1,I) .NE. 1) GO TO 30
- M = M + 1
- L1 = 1
- GO TO 40
- 30 IF (M .EQ. M0 .OR. INC(LP1,I) .LT. 0
- 1 .OR. INC(LP1,I) .GT. 1) GO TO 80
- 40 CONTINUE
-C
-C *** NOW L1 = 1 MEANS A HAS COLUMN L+1 ***
-C
-C *** COMPUTE STORAGE REQUIREMENTS ***
-C
- IWALEN = MAX0(LP1, 6*P)
- INLEN = 2 * M
- IV(IVNEED) = IV(IVNEED) + INLEN + 3*P + L + IWALEN + 3
- RSVLEN = 2 * L1 * N
- L1 = L + L1
- IV(VNEED) = IV(VNEED) + 2*N*L1 + RSVLEN + P
-C
- 50 CALL RNSGB(V, ALF, B, C, V, IV, IV, L, 1, N, LIV, LV, N, M, P, V,
- 1 Y)
- IF (IV(1) .NE. 14) GO TO 999
-C
-C *** STORAGE ALLOCATION ***
-C
- IV(IN) = IV(NEXTIV)
- IV(AMAT) = IV(NEXTV)
- IV(DAMAT) = IV(AMAT) + N*L1
- IV(XSAVE) = IV(DAMAT) + N*L1
- IV(NEXTV) = IV(XSAVE) + P + RSVLEN
- IV(L1SAV) = L1
- IV(MSAVE) = M
-C
-C *** DETERMINE HOW MANY GROUPS FOR FINITE DIFFERENCES
-C *** (SET UP TO CALL DSM)
-C
- IN1 = IV(IN)
- JN1 = IN1 + M
- DO 70 K = 1, P
- IF (B(1,K) .GE. B(2,K)) GO TO 70
- DO 60 I = 1, LP1
- IF (INC(I,K) .EQ. 0) GO TO 60
- IV(IN1) = I
- IN1 = IN1 + 1
- IV(JN1) = K
- JN1 = JN1 + 1
- 60 CONTINUE
- 70 CONTINUE
- IN1 = IV(IN)
- JN1 = IN1 + M
- IWA1 = IN1 + INLEN
- NGRP1 = IWA1 + IWALEN
- BWA1 = NGRP1 + P
- IPNTR1 = BWA1 + P
- JPNTR1 = IPNTR1 + L + 2
- CALL DSM(LP1, P, M, IV(IN1), IV(JN1), IV(NGRP1), NG, K, I,
- 1 IV(IPNTR1), IV(JPNTR1), IV(IWA1), IWALEN, IV(BWA1))
- IF (I .EQ. 1) GO TO 90
- IV(1) = 69
- GO TO 50
- 80 IV(1) = 66
- GO TO 50
-C
-C *** SET UP GRP AND GPTR ARRAYS FOR COMPUTING FINITE DIFFERENCES
-C
-C *** THERE ARE NG GROUPS. GROUP I CONTAINS ALF(GRP(J)) FOR
-C *** GPTR(I) .LE. J .LE. GPTR(I+1)-1.
-C
- 90 IV(MAXGRP) = NG
- IV(GPTR) = IN1 + 2*L1
- GPTR1 = IV(GPTR)
- IV(GRP) = GPTR1 + NG + 1
- IV(NEXTIV) = IV(GRP) + P
- GRP1 = IV(GRP)
- NGRP0 = NGRP1 - 1
- NGRP2 = NGRP0 + P
- DO 110 I = 1, NG
- IV(GPTR1) = GRP1
- GPTR1 = GPTR1 + 1
- DO 100 I1 = NGRP1, NGRP2
- IF (IV(I1) .NE. I) GO TO 100
- K = I1 - NGRP0
- IF (B(1,K) .GE. B(2,K)) GO TO 100
- IV(GRP1) = K
- GRP1 = GRP1 + 1
- 100 CONTINUE
- 110 CONTINUE
- IV(GPTR1) = GRP1
- IF (IV1 .EQ. 13) GO TO 999
-C
-C *** INITIALIZE POINTERS ***
-C
- 120 A1 = IV(AMAT)
- A0 = A1 - N
- DA1 = IV(DAMAT)
- DA0 = DA1 - N
- IN1 = IV(IN)
- IN0 = IN1 - 2
- L1 = IV(L1SAV)
- IN2 = IN1 + 2*L1 - 1
- D0 = IV(D) - 1
- NG = IV(MAXGRP)
- XSAVE1 = IV(XSAVE)
- XSAVE0 = XSAVE1 - 1
- RSAVE1 = XSAVE1 + P
- RSAVE0 = RSAVE1 + N
- ALP1 = A1 + L*N
- DELTA = V(DLTFDJ)
- IV(COVREQ) = -IABS(IV(COVREQ))
-C
- 130 CALL RNSGB(V(A1), ALF, B, C, V(DA1), IV(IN1), IV, L, L1, N, LIV,
- 1 LV, N, L1, P, V, Y)
- IF (IV(1)-2) 140, 150, 999
-C
-C *** NEW FUNCTION VALUE (R VALUE) NEEDED ***
-C
- 140 NF = IV(NFCALL)
- CALL CALCA(N, P, L, ALF, NF, V(A1), UIPARM, URPARM, UFPARM)
- IF (NF .LE. 0) IV(TOOBIG) = 1
- IF (L1 .LE. L) GO TO 130
- IF (IV(RESTOR) .EQ. 2) CALL V7CPY(N, V(RSAVE0), V(RSAVE1))
- CALL V7CPY(N, V(RSAVE1), V(ALP1))
- GO TO 130
-C
-C *** COMPUTE DR = GRADIENT OF R COMPONENTS ***
-C
- 150 IF (L1 .GT. L .AND. IV(NFGCAL) .EQ. IV(NFCALL))
- 1 CALL V7CPY(N, V(RSAVE0), V(RSAVE1))
- GPTR1 = IV(GPTR)
- DO 260 K = 1, NG
- CALL V7CPY(P, V(XSAVE1), ALF)
- GRP1 = IV(GPTR1)
- GRP2 = IV(GPTR1+1) - 1
- GPTR1 = GPTR1 + 1
- DO 180 I1 = GRP1, GRP2
- I = IV(I1)
- XI = ALF(I)
- J1 = D0 + I
- DI = V(J1)
- IF (DI .LE. ZERO) DI = ONE
- H = DELTA * AMAX1( ABS(XI), ONE/DI)
- IF (XI .LT. ZERO) GO TO 160
- XI1 = XI + H
- IF (XI1 .LE. B(2,I)) GO TO 170
- XI1 = XI - H
- IF (XI1 .GE. B(1,I)) GO TO 170
- GO TO 190
- 160 XI1 = XI - H
- IF (XI1 .GE. B(1,I)) GO TO 170
- XI1 = XI + H
- IF (XI1 .LE. B(2,I)) GO TO 170
- GO TO 190
- 170 X0I = XSAVE0 + I
- V(X0I) = XI1
- 180 CONTINUE
- CALL CALCA(N, P, L, V(XSAVE1), NF, V(DA1), UIPARM, URPARM,
- 1 UFPARM)
- IF (IV(NFGCAL) .GT. 0) GO TO 200
- 190 IV(TOOBIG) = 1
- GO TO 130
- 200 JN1 = IN1
- DO 210 I = IN1, IN2
- 210 IV(I) = 0
- PARTJ = IV(MODE) .LE. P
- DO 250 I1 = GRP1, GRP2
- I = IV(I1)
- DO 240 J1 = 1, L1
- IF (INC(J1,I) .EQ. 0) GO TO 240
- INI = IN0 + 2*J1
- IV(INI) = I
- IV(INI+1) = J1
- X0I = XSAVE0 + I
- H = ONE / (V(X0I) - ALF(I))
- DAJ = DA0 + J1*N
- IF (PARTJ) GO TO 220
-C *** FULL FINITE DIFFERENCE FOR COV. AND REG. DIAG. ***
- AJ = A0 + J1*N
- CALL V2AXY(N, V(DAJ), NEGONE, V(AJ), V(DAJ))
- GO TO 230
- 220 IF (J1 .GT. L)
- 1 CALL V2AXY(N, V(DAJ), NEGONE, V(RSAVE0), V(DAJ))
- 230 CALL V7SCL(N, V(DAJ), H, V(DAJ))
- 240 CONTINUE
- 250 CONTINUE
- IF (K .GE. NG) GO TO 270
- IV(1) = -2
- CALL RNSGB(V(A1), ALF, B, C, V(DA1), IV(IN1), IV, L, L1, N,
- 1 LIV, LV, N, L1, P, V, Y)
- IF (-2 .NE. IV(1)) GO TO 999
- 260 CONTINUE
- 270 IV(1) = 2
- GO TO 130
-C
- 999 RETURN
-C
-C *** LAST CARD OF NSFB FOLLOWS ***
- END
diff --git a/CEP/PyBDSM/src/port3/nsg.f b/CEP/PyBDSM/src/port3/nsg.f
deleted file mode 100644
index b80aaa0e25af0fba8051974aada54f56b41b028c..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/nsg.f
+++ /dev/null
@@ -1,327 +0,0 @@
- SUBROUTINE NSG(N, P, L, ALF, C, Y, CALCA, CALCB, INC, IINC, IV,
- 1 LIV, LV, V, UIPARM, URPARM, UFPARM)
-C
-C *** SOLVE SEPARABLE NONLINEAR LEAST SQUARES USING ***
-C *** ANALYTICALLY COMPUTED DERIVATIVES. ***
-C
-C *** PARAMETER DECLARATIONS ***
-C
- INTEGER IINC, L, LIV, LV, N, P
-C/6
-C INTEGER INC(IINC,P), IV(LIV), UIPARM(1)
-C REAL ALF(P), C(L), URPARM(1), V(LV), Y(N)
-C/7
- INTEGER INC(IINC,P), IV(LIV), UIPARM(*)
- REAL ALF(P), C(L), URPARM(*), V(LV), Y(N)
-C/
- EXTERNAL CALCA, CALCB, UFPARM
-C
-C *** PURPOSE ***
-C
-C GIVEN A SET OF N OBSERVATIONS Y(1)....Y(N) OF A DEPENDENT VARIABLE
-C T(1)...T(N), NSG ATTEMPTS TO COMPUTE A LEAST SQUARES FIT
-C TO A FUNCTION ETA (THE MODEL) WHICH IS A LINEAR COMBINATION
-C
-C L
-C ETA(C,ALF,T) = SUM C * PHI(ALF,T) +PHI (ALF,T)
-C J=1 J J L+1
-C
-C OF NONLINEAR FUNCTIONS PHI(J) DEPENDENT ON T AND ALF(1),...,ALF(P)
-C (.E.G. A SUM OF EXPONENTIALS OR GAUSSIANS). THAT IS, IT DETERMINES
-C NONLINEAR PARAMETERS ALF WHICH MINIMIZE
-C
-C 2 N 2
-C NORM(RESIDUAL) = SUM (Y - ETA(C,ALF,T )).
-C I=1 I I
-C
-C THE (L+1)ST TERM IS OPTIONAL.
-C
-C-------------------------- PARAMETER USAGE -------------------------
-C
-C INPUT PARAMETERS
-C
-C N INTEGER NUMBER OF OBSERVATIONS (MUST BE .GE. MAX(L,P)).
-C
-C P INTEGER NUMBER OF NONLINEAR PARAMETERS (MUST BE .GE. 1).
-C
-C L INTEGER NUMBER OF LINEAR PARAMETERS (MUST BE .GE. 0).
-C
-C ALF D.P. ARRAY P VECTOR = INITIAL ESTIMATE OF THE NONLINEAR
-C PARAMETERS.
-C
-C CALCA SUBROUTINE USER PROVIDED FUNCTION TO CALCULATE THE MODEL
-C (I.E., TO CALCULATE PHI) -- SEE THE NOTE BELOW
-C ON THE CALLING SEQUENCE FOR CALCA.
-C CALCA MUST BE DECLARED EXTERNAL IN THE CALLING
-C PROGRAM.
-C
-C CALCB SUBROUTINE USER PROVIDED FUNCTION TO CALCULATE THE DERIVA-
-C TIVE OF THE MODEL (I.E., OF PHI) WITH RESPECT TO
-C ALF -- SEE THE NOTE BELOW ON THE CALLING
-C SEQUENCE FOR CALCB. CALCB MUST BE DECLARED
-C EXTERNAL IN THE CALLING PROGRAM.
-C
-C Y D.P. ARRAY VECTOR OF OBSERVATIONS.
-C
-C INC INTEGER ARRAY A 2 DIM. ARRAY OF DIMENSION AT LEAST (L+1,P)
-C INDICATING THE POSITION OF THE NONLINEAR PARA-
-C METERS IN THE MODEL. SET INC(J,K) = 1 IF ALF(K)
-C APPEARS IN PHI(J). OTHERWISE SET INC(J,K) = 0.
-C IF PHI((L+1)) IS NOT IN THE MODEL, SET THE L+1ST
-C ROW OF INC TO ALL ZEROS. EVERY COLUMN OF INC
-C MUST CONTAIN AT LEAST ONE 1.
-C
-C IINC INTEGER DECLARED ROW DIMENSION OF INC, WHICH MUST BE AT
-C LEAST L+1.
-C
-C IV INTEGER ARRAY OF LENGTH AT LEAST LIV THAT CONTAINS
-C VARIOUS PARAMETERS FOR THE SUBROUTINE, SUCH AS
-C THE ITERATION AND FUNCTION EVALUATION LIMITS AND
-C SWITCHES THAT CONTROL PRINTING. THE INPUT COM-
-C PONENTS OF IV ARE DESCRIBED IN DETAIL IN THE
-C PORT OPTIMIZATION DOCUMENTATION.
-C IF IV(1)=0 ON INPUT, THEN DEFAULT PARAMETERS
-C ARE SUPPLIED TO IV AND V. THE CALLER MAY SUPPLY
-C NONDEFAULT PARAMETERS TO IV AND V BY EXECUTING A
-C CALL IVSET(1,IV,LIV,LV,V) AND THEN ASSIGNING
-C NONDEFAULT VALUES TO THE APPROPRIATE COMPONENTS
-C OF IV AND V BEFORE CALLING NSG.
-C
-C LIV INTEGER LENGTH OF IV. MUST BE AT LEAST 115+P+L + 2*M,
-C WHERE M IS THE NUMBER OF ONES IN INC.
-C
-C LV INTEGER LENGTH OF V. MUST BE AT LEAST
-C 105 + N*(L+M+3) + JLEN + L*(L+3)/2 + P*(2*P+17),
-C WHERE M IS AS FOR LIV (SEE ABOVE) AND
-C JLEN = (L+P)*(N+L+P+1), UNLESS NEITHER A
-C COVARIANCE MATRIX NOR REGRESSION DIAGNOSTICS ARE
-C REQUESTED, IN WHICH CASE JLEN = N*P. IF THE
-C LAST ROW OF INC CONTAINS ONLY ZEROS, THEN LV
-C CAN BE N LESS THAN JUST DESCRIBED.
-C
-C V D.P. ARRAY WORK AND PARAMETER ARRAY OF LENGTH AT LEAST LV
-C THAT CONTAINS SUCH INPUT COMPONENTS AS THE
-C CONVERGENCE TOLERANCES. THE INPUT COMPONENTS OF
-C V MAY BE SUPPLIED AS FOR IV (SEE ABOVE). NOTE
-C THAT V(35) CONTAINS THE INITIAL STEP BOUND,
-C WHICH, IF TOO LARGE, MAY LEAD TO OVERFLOW.
-C
-C UIPARM INTEGER ARRAY SCRATCH SPACE FOR USER TO SEND INFORMATION
-C TO CALCA AND CALCB.
-C
-C URPARM D.P. ARRAY SCRATCH SPACE FOR USER TO SEND INFORMATION
-C TO CALCA AND CALCB.
-C
-C UFPARM EXTERNAL SUBROUTINE SENT TO CALCA AND CALCB FOR THEIR
-C USE. NOTE THAT THE SUBROUTINE PASSED FOR UFPARM
-C MUST BE DECLARED EXTERNAL IN THE CALLING PROGRAM.
-C
-C
-C OUTPUT PARAMETERS
-C
-C ALF D.P. ARRAY FINAL NONLINEAR PARAMETERS.
-C
-C C D.P. ARRAY L VECTOR OF LINEAR PARAMETERS -- NOTE THAT NO
-C INITIAL GUESS FOR C IS REQUIRED.
-C
-C IV IV(1) CONTAINS A RETURN CODE DESCRIBED IN THE
-C PORT OPTIMIZATION DOCUMENTATION. IF IV(1) LIES
-C BETWEEN 3 AND 7, THEN THE ALGORITHM HAS
-C CONVERGED (BUT IV(1) = 7 INDICATES POSSIBLE
-C TROUBLE WITH THE MODEL). IV(1) = 9 OR 10 MEANS
-C FUNCTION EVALUATION OR ITERATION LIMIT REACHED.
-C IV(1) = 66 MEANS BAD PARAMETERS (INCLUDING A
-C COLUMN OF ZEROS IN INC). NOTE THAT THE
-C ALGORITHM CAN BE RESTARTED AFTER ANY RETURN WITH
-C IV(1) .LT. 12 -- SEE THE PORT DOCUMENTATION.
-C
-C V VARIOUS ITEMS OF INTEREST, INCLUDING THE NORM OF
-C THE GRADIENT(1) AND THE FUNCTION VALUE(10). SEE
-C THE PORT DOCUMENTATION FOR A COMPLETE LIST. IF
-C A COVARIANCE ESTIMATE IS REQUESTED, IT IS FOR
-C (ALF,C) -- NONLINEAR PARAMETERS ORDERED FIRST,
-C FOLLOWED BY LINEAR PARAMETERS.
-C
-C
-C
-C PARAMETERS FOR CALCA(N,P,L,ALF,NF,PHI, UIPARM,URPARM,UFPARM)
-C
-C N,L,P,ALF ARE INPUT PARAMETERS AS DESCRIBED ABOVE
-C
-C PHI D.P. ARRAY N*(L+1) ARRAY WHOSE COLUMNS CONTAIN THE TERMS OF
-C THE MODEL. CALCA MUST EVALUATE PHI(ALF) AND STORE
-C THE RESULT IN PHI. IF THE (L+1)ST TERM IS NOT IN
-C THE MODEL, THEN NOTHING SHOULD BE STORED IN THE
-C (L+1)ST COLUMN OF PHI.
-C
-C NF INTEGER CURRENT INVOCATION COUNT FOR CALCA. IF PHI CANNOT
-C BE EVALUATED AT ALF (E.G. BECAUSE AN ARGUMENT TO
-C AN INTRINSIC FUNCTION IS OUT OF RANGE), THEN CALCA
-C SHOULD SIMPLY SET NF TO 0 AND RETURN. THIS
-C TELLS THE ALGORITHM TO TRY A SMALLER STEP.
-C
-C UIPARM,URPARM,UFPARM ARE AS DESCRIBED ABOVE
-C
-C N.B. THE DEPENDENT VARIABLE T IS NOT EXPLICITLY PASSED. IF REQUIRED,
-C IT MAY BE PASSED IN UIPARM OR URPARM OR STORED IN NAMED COMMON.
-C
-C
-C PARAMETERS FOR CALCB(N,P,L,ALF,NF,DER, UIPARM,URPARM,UFPARM)
-C
-C N,P,L,ALF,NF,UIPARM,URPARM,UFPARM ARE AS FOR CALCA
-C
-C DER D.P. ARRAY N*M ARRAY, WHERE M IS THE NUMBER OF ONES IN INC.
-C CALCB MUST SET DER TO THE DERIVATIVES OF THE MODEL
-C WITH RESPECT TO ALF. IF THE MODEL HAS K TERMS THAT
-C DEPEND ON ALF(I), THEN DER WILL HAVE K CONSECUTIVE
-C COLUMNS OF DERIVATIVES WITH RESPECT TO ALF(I). THE
-C COLUMNS OF DER CORRESPOND TO THE ONES IN INC WHEN
-C ONE TRAVELS THROUGH INC BY COLUMNS. FOR EXAMPLE,
-C IF INC HAS THE FORM...
-C 1 1 0
-C 0 1 0
-C 1 0 0
-C 0 0 1
-C THEN THE FIRST TWO COLUMNS OF DER ARE FOR THE
-C DERIVATIVES OF COLUMNS 1 AND 3 OF PHI WITH RESPECT
-C TO ALF(1), COLUMNS 3 AND 4 OF DER ARE FOR THE
-C DERIVATIVES OF COLUMNS 1 AND 2 OF PHI WITH RESPECT
-C TO ALF(2), AND COLUMN 5 OF DER IS FOR THE DERIVA-
-C TIVE OF COLUMN 4 OF PHI WITH RESPECT TO ALF(3).
-C MORE SPECIFICALLY, DER(I,2) IS FOR THE DERIVATIVE
-C OF PHI(I,3) WITH RESPECT TO ALF(1) AND DER(I,5) IS
-C FOR THE DERIVATIVE OF PHI(I,4) WITH RESPECT TO
-C ALF(3) (FOR I = 1,2,...,N).
-C THE VALUE OF ALF PASSED TO CALCB IS THE SAME AS
-C THAT PASSED TO CALCA THE LAST TIME IT WAS CALLED.
-C (IF DER CANNOT BE EVALUATED, THEN CALCB SHOULD SET
-C NF TO 0. THIS WILL CAUSE AN ERROR RETURN.)
-C
-C N.B. DER IS FOR DERIVATIVES WITH RESPECT TO ALF, NOT T.
-C
-C------------------------------ NOTES -------------------------------
-C
-C THIS PROGRAM WAS WRITTEN BY LINDA KAUFMAN AT BELL LABS, MURRAY
-C HILL, N.J. IN 1977 AND EXTENSIVELY REVISED BY HER AND DAVID GAY IN
-C 1980, 1981, 1983, 1984. THE WORK OF DAVID GAY WAS SUPPORTED IN PART
-C BY NATIONAL SCIENCE FOUNDATION GRANT MCS-7906671.
-C
-C-------------------------- DECLARATIONS ----------------------------
-C
-C
-C *** EXTERNAL SUBROUTINES ***
-C
- EXTERNAL IVSET, RNSG
-C
-C IVSET.... PROVIDES DEFAULT IV AND V VALUES.
-C RNSG... CARRIES OUT NL2SOL ALGORITHM.
-C
-C *** LOCAL VARIABLES ***
-C
- INTEGER A1, DA1, I, IN1, IV1, K, L1, LP1, M, M0, NF
-C
-C *** SUBSCRIPTS FOR IV AND V ***
-C
- INTEGER AMAT, DAMAT, IN, IVNEED, L1SAV, MSAVE, NEXTIV,
- 1 NEXTV, NFCALL, NFGCAL, PERM, TOOBIG, VNEED
-C
-C *** IV SUBSCRIPT VALUES ***
-C
-C/6
-C DATA AMAT/113/, DAMAT/114/, IN/112/, IVNEED/3/, L1SAV/111/,
-C 1 MSAVE/115/, NEXTIV/46/, NEXTV/47/, NFCALL/6/, NFGCAL/7/,
-C 2 PERM/58/, TOOBIG/2/, VNEED/4/
-C/7
- PARAMETER (AMAT=113, DAMAT=114, IN=112, IVNEED=3, L1SAV=111,
- 1 MSAVE=115, NEXTIV=46, NEXTV=47, NFCALL=6, NFGCAL=7,
- 2 PERM=58, TOOBIG=2, VNEED=4)
-C/
-C
-C++++++++++++++++++++++++++++++++ BODY ++++++++++++++++++++++++++++++
-C
- IF (IV(1) .EQ. 0) CALL IVSET(1, IV, LIV, LV, V)
- IF (P .LE. 0 .OR. L .LT. 0 .OR. IINC .LE. L) GO TO 50
- IV1 = IV(1)
- IF (IV1 .EQ. 14) GO TO 90
- IF (IV1 .GT. 2 .AND. IV1 .LT. 12) GO TO 90
- IF (IV1 .EQ. 12) IV(1) = 13
- IF (IV(1) .NE. 13) GO TO 60
- IF (IV(PERM) .LE. MSAVE) IV(PERM) = MSAVE + 1
- LP1 = L + 1
- L1 = 0
- M = 0
- DO 40 I = 1, P
- M0 = M
- IF (L .EQ. 0) GO TO 20
- DO 10 K = 1, L
- IF (INC(K,I) .LT. 0 .OR. INC(K,I) .GT. 1) GO TO 50
- IF (INC(K,I) .EQ. 1) M = M + 1
- 10 CONTINUE
- 20 IF (INC(LP1,I) .NE. 1) GO TO 30
- M = M + 1
- L1 = 1
- 30 IF (M .EQ. M0 .OR. INC(LP1,I) .LT. 0
- 1 .OR. INC(LP1,I) .GT. 1) GO TO 50
- 40 CONTINUE
-C
- IV(IVNEED) = IV(IVNEED) + 2*M
- L1 = L + L1
- IV(VNEED) = IV(VNEED) + N*(L1+M)
- GO TO 60
-C
- 50 IV(1) = 66
-C
- 60 CALL RNSG(V, ALF, C, V, IV, IV, L, 1, N, LIV, LV, N, M, P, V, Y)
- IF (IV(1) .NE. 14) GO TO 999
-C
-C *** STORAGE ALLOCATION ***
-C
- IV(IN) = IV(NEXTIV)
- IV(NEXTIV) = IV(IN) + 2*M
- IV(AMAT) = IV(NEXTV)
- IV(DAMAT) = IV(AMAT) + N*L1
- IV(NEXTV) = IV(DAMAT) + N*M
- IV(L1SAV) = L1
- IV(MSAVE) = M
-C
-C *** SET UP IN ARRAY ***
-C
- IN1 = IV(IN)
- DO 80 I = 1, P
- DO 70 K = 1, LP1
- IF (INC(K,I) .EQ. 0) GO TO 70
- IV(IN1) = I
- IV(IN1+1) = K
- IN1 = IN1 + 2
- 70 CONTINUE
- 80 CONTINUE
- IF (IV1 .EQ. 13) GO TO 999
-C
- 90 A1 = IV(AMAT)
- DA1 = IV(DAMAT)
- IN1 = IV(IN)
- L1 = IV(L1SAV)
- M = IV(MSAVE)
-C
- 100 CALL RNSG(V(A1), ALF, C, V(DA1), IV(IN1), IV, L, L1, N, LIV, LV,
- 1 N, M, P, V, Y)
- IF (IV(1)-2) 110, 120, 999
-C
-C *** NEW FUNCTION VALUE (R VALUE) NEEDED ***
-C
- 110 NF = IV(NFCALL)
- CALL CALCA(N, P, L, ALF, NF, V(A1), UIPARM, URPARM, UFPARM)
- IF (NF .LE. 0) IV(TOOBIG) = 1
- GO TO 100
-C
-C *** COMPUTE DR = GRADIENT OF R COMPONENTS ***
-C
- 120 CALL CALCB(N, P, L, ALF, IV(NFGCAL), V(DA1), UIPARM, URPARM,
- 1 UFPARM)
- IF (IV(NFGCAL) .EQ. 0) IV(TOOBIG) = 1
- GO TO 100
-C
- 999 RETURN
-C
-C *** LAST CARD OF NSG FOLLOWS ***
- END
diff --git a/CEP/PyBDSM/src/port3/nsgb.f b/CEP/PyBDSM/src/port3/nsgb.f
deleted file mode 100644
index 9c628648d0b0f0bff68a470344573906d0bede0d..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/nsgb.f
+++ /dev/null
@@ -1,326 +0,0 @@
- SUBROUTINE NSGB(N, P, L, ALF, B, C, Y, CALCA, CALCB, INC, IINC,
- 1 IV, LIV, LV, V, UIPARM, URPARM, UFPARM)
-C
-C *** SOLVE SEPARABLE NONLINEAR LEAST SQUARES USING ***
-C *** ANALYTICALLY COMPUTED DERIVATIVES. ***
-C
-C *** PARAMETER DECLARATIONS ***
-C
- INTEGER IINC, L, LIV, LV, N, P
-C/6
-C INTEGER INC(IINC,P), IV(LIV), UIPARM(1)
-C REAL ALF(P), B(2,P), C(L), URPARM(1), V(LV), Y(N)
-C/7
- INTEGER INC(IINC,P), IV(LIV), UIPARM(*)
- REAL ALF(P), B(2,P), C(L), URPARM(*), V(LV), Y(N)
-C/
- EXTERNAL CALCA, CALCB, UFPARM
-C
-C *** PURPOSE ***
-C
-C GIVEN A SET OF N OBSERVATIONS Y(1)....Y(N) OF A DEPENDENT VARIABLE
-C T(1)...T(N), NSGB ATTEMPTS TO COMPUTE A LEAST SQUARES FIT
-C TO A FUNCTION ETA (THE MODEL) WHICH IS A LINEAR COMBINATION
-C
-C L
-C ETA(C,ALF,T) = SUM C * PHI(ALF,T) +PHI (ALF,T)
-C J=1 J J L+1
-C
-C OF NONLINEAR FUNCTIONS PHI(J) DEPENDENT ON T AND ALF(1),...,ALF(P)
-C (.E.G. A SUM OF EXPONENTIALS OR GAUSSIANS). THAT IS, IT DETERMINES
-C NONLINEAR PARAMETERS ALF WHICH MINIMIZE
-C
-C 2 N 2
-C NORM(RESIDUAL) = SUM (Y - ETA(C,ALF,T )) ,
-C I=1 I I
-C
-C SUBJECT TO THE SIMPLE BOUND CONSTRAINTS
-C B(1,I) .LE. ALF(I) .LE. B(2,I), C I = 1(1)P.
-C
-C THE (L+1)ST TERM IS OPTIONAL.
-C
-C-------------------------- PARAMETER USAGE -------------------------
-C
-C INPUT PARAMETERS
-C
-C N INTEGER NUMBER OF OBSERVATIONS (MUST BE .GE. MAX(L,P)).
-C
-C P INTEGER NUMBER OF NONLINEAR PARAMETERS (MUST BE .GE. 1).
-C
-C L INTEGER NUMBER OF LINEAR PARAMETERS (MUST BE .GE. 0).
-C
-C ALF D.P. ARRAY P VECTOR = INITIAL ESTIMATE OF THE NONLINEAR
-C PARAMETERS.
-C
-C CALCA SUBROUTINE USER PROVIDED FUNCTION TO CALCULATE THE MODEL
-C (I.E., TO CALCULATE PHI) -- SEE THE NOTE BELOW
-C ON THE CALLING SEQUENCE FOR CALCA.
-C CALCA MUST BE DECLARED EXTERNAL IN THE CALLING
-C PROGRAM.
-C
-C CALCB SUBROUTINE USER PROVIDED FUNCTION TO CALCULATE THE DERIVA-
-C TIVE OF THE MODEL (I.E., OF PHI) WITH RESPECT TO
-C ALF -- SEE THE NOTE BELOW ON THE CALLING
-C SEQUENCE FOR CALCB. CALCB MUST BE DECLARED
-C EXTERNAL IN THE CALLING PROGRAM.
-C
-C Y D.P. ARRAY VECTOR OF OBSERVATIONS.
-C
-C INC INTEGER ARRAY A 2 DIM. ARRAY OF DIMENSION AT LEAST (L+1,P)
-C INDICATING THE POSITION OF THE NONLINEAR PARA-
-C METERS IN THE MODEL. SET INC(J,K) = 1 IF ALF(K)
-C APPEARS IN PHI(J). OTHERWISE SET INC(J,K) = 0.
-C IF PHI((L+1)) IS NOT IN THE MODEL, SET THE L+1ST
-C ROW OF INC TO ALL ZEROS. EVERY COLUMN OF INC
-C MUST CONTAIN AT LEAST ONE 1.
-C
-C IINC INTEGER DECLARED ROW DIMENSION OF INC, WHICH MUST BE AT
-C LEAST L+1.
-C
-C IV INTEGER ARRAY OF LENGTH AT LEAST LIV THAT CONTAINS
-C VARIOUS PARAMETERS FOR THE SUBROUTINE, SUCH AS
-C THE ITERATION AND FUNCTION EVALUATION LIMITS AND
-C SWITCHES THAT CONTROL PRINTING. THE INPUT COM-
-C PONENTS OF IV ARE DESCRIBED IN DETAIL IN THE
-C PORT OPTIMIZATION DOCUMENTATION.
-C IF IV(1)=0 ON INPUT, THEN DEFAULT PARAMETERS
-C ARE SUPPLIED TO IV AND V. THE CALLER MAY SUPPLY
-C NONDEFAULT PARAMETERS TO IV AND V BY EXECUTING A
-C CALL IVSET(1,IV,LIV,LV,V) AND THEN ASSIGNING
-C NONDEFAULT VALUES TO THE APPROPRIATE COMPONENTS
-C OF IV AND V BEFORE CALLING NSGB.
-C
-C LIV INTEGER LENGTH OF IV. MUST BE AT LEAST
-C 115 + 4*P + L + 2*M,
-C WHERE M IS THE NUMBER OF ONES IN INC.
-C
-C LV INTEGER LENGTH OF V. MUST BE AT LEAST
-C 105 + N*(L+M+P+3) + L*(L+3)/2 + P*(2*P+21),
-C WHERE M IS AS FOR LIV (SEE ABOVE). IF THE
-C LAST ROW OF INC CONTAINS ONLY ZEROS, THEN LV
-C CAN BE N LESS THAN JUST DESCRIBED.
-C
-C V D.P. ARRAY WORK AND PARAMETER ARRAY OF LENGTH AT LEAST LV
-C THAT CONTAINS SUCH INPUT COMPONENTS AS THE
-C CONVERGENCE TOLERANCES. THE INPUT COMPONENTS OF
-C V MAY BE SUPPLIED AS FOR IV (SEE ABOVE). NOTE
-C THAT V(35) CONTAINS THE INITIAL STEP BOUND,
-C WHICH, IF TOO LARGE, MAY LEAD TO OVERFLOW.
-C
-C UIPARM INTEGER ARRAY SCRATCH SPACE FOR USER TO SEND INFORMATION
-C TO CALCA AND CALCB.
-C
-C URPARM D.P. ARRAY SCRATCH SPACE FOR USER TO SEND INFORMATION
-C TO CALCA AND CALCB.
-C
-C UFPARM EXTERNAL SUBROUTINE SENT TO CALCA AND CALCB FOR THEIR
-C USE. NOTE THAT THE SUBROUTINE PASSED FOR UFPARM
-C MUST BE DECLARED EXTERNAL IN THE CALLING PROGRAM.
-C
-C
-C OUTPUT PARAMETERS
-C
-C ALF D.P. ARRAY FINAL NONLINEAR PARAMETERS.
-C
-C C D.P. ARRAY L VECTOR OF LINEAR PARAMETERS -- NOTE THAT NO
-C INITIAL GUESS FOR C IS REQUIRED.
-C
-C IV IV(1) CONTAINS A RETURN CODE DESCRIBED IN THE
-C PORT OPTIMIZATION DOCUMENTATION. IF IV(1) LIES
-C BETWEEN 3 AND 7, THEN THE ALGORITHM HAS
-C CONVERGED (BUT IV(1) = 7 INDICATES POSSIBLE
-C TROUBLE WITH THE MODEL). IV(1) = 9 OR 10 MEANS
-C FUNCTION EVALUATION OR ITERATION LIMIT REACHED.
-C IV(1) = 66 MEANS BAD PARAMETERS (INCLUDING A
-C COLUMN OF ZEROS IN INC). NOTE THAT THE
-C ALGORITHM CAN BE RESTARTED AFTER ANY RETURN WITH
-C IV(1) .LT. 12 -- SEE THE PORT DOCUMENTATION.
-C
-C V VARIOUS ITEMS OF INTEREST, INCLUDING THE NORM OF
-C THE GRADIENT(1) AND THE FUNCTION VALUE(10). SEE
-C THE PORT DOCUMENTATION FOR A COMPLETE LIST.
-C
-C
-C
-C PARAMETERS FOR CALCA(N,P,L,ALF,NF,PHI, UIPARM,URPARM,UFPARM)
-C
-C N,L,P,ALF ARE INPUT PARAMETERS AS DESCRIBED ABOVE
-C
-C PHI D.P. ARRAY N*(L+1) ARRAY WHOSE COLUMNS CONTAIN THE TERMS OF
-C THE MODEL. CALCA MUST EVALUATE PHI(ALF) AND STORE
-C THE RESULT IN PHI. IF THE (L+1)ST TERM IS NOT IN
-C THE MODEL, THEN NOTHING SHOULD BE STORED IN THE
-C (L+1)ST COLUMN OF PHI.
-C
-C NF INTEGER CURRENT INVOCATION COUNT FOR CALCA. IF PHI CANNOT
-C BE EVALUATED AT ALF (E.G. BECAUSE AN ARGUMENT TO
-C AN INTRINSIC FUNCTION IS OUT OF RANGE), THEN CALCA
-C SHOULD SIMPLY SET NF TO 0 AND RETURN. THIS
-C TELLS THE ALGORITHM TO TRY A SMALLER STEP.
-C
-C UIPARM,URPARM,UFPARM ARE AS DESCRIBED ABOVE
-C
-C N.B. THE DEPENDENT VARIABLE T IS NOT EXPLICITLY PASSED. IF REQUIRED,
-C IT MAY BE PASSED IN UIPARM OR URPARM OR STORED IN NAMED COMMON.
-C
-C
-C PARAMETERS FOR CALCB(N,P,L,ALF,NF,DER, UIPARM,URPARM,UFPARM)
-C
-C N,P,L,ALF,NF,UIPARM,URPARM,UFPARM ARE AS FOR CALCA
-C
-C DER D.P. ARRAY N*M ARRAY, WHERE M IS THE NUMBER OF ONES IN INC.
-C CALCB MUST SET DER TO THE DERIVATIVES OF THE MODEL
-C WITH RESPECT TO ALF. IF THE MODEL HAS K TERMS THAT
-C DEPEND ON ALF(I), THEN DER WILL HAVE K CONSECUTIVE
-C COLUMNS OF DERIVATIVES WITH RESPECT TO ALF(I). THE
-C COLUMNS OF DER CORRESPOND TO THE ONES IN INC WHEN
-C ONE TRAVELS THROUGH INC BY COLUMNS. FOR EXAMPLE,
-C IF INC HAS THE FORM...
-C 1 1 0
-C 0 1 0
-C 1 0 0
-C 0 0 1
-C THEN THE FIRST TWO COLUMNS OF DER ARE FOR THE
-C DERIVATIVES OF COLUMNS 1 AND 3 OF PHI WITH RESPECT
-C TO ALF(1), COLUMNS 3 AND 4 OF DER ARE FOR THE
-C DERIVATIVES OF COLUMNS 1 AND 2 OF PHI WITH RESPECT
-C TO ALF(2), AND COLUMN 5 OF DER IS FOR THE DERIVA-
-C TIVE OF COLUMN 4 OF PHI WITH RESPECT TO ALF(3).
-C MORE SPECIFICALLY, DER(I,2) IS FOR THE DERIVATIVE
-C OF PHI(I,3) WITH RESPECT TO ALF(1) AND DER(I,5) IS
-C FOR THE DERIVATIVE OF PHI(I,4) WITH RESPECT TO
-C ALF(3) (FOR I = 1,2,...,N).
-C THE VALUE OF ALF PASSED TO CALCB IS THE SAME AS
-C THAT PASSED TO CALCA THE LAST TIME IT WAS CALLED.
-C (IF DER CANNOT BE EVALUATED, THEN CALCB SHOULD SET
-C NF TO 0. THIS WILL CAUSE AN ERROR RETURN.)
-C
-C N.B. DER IS FOR DERIVATIVES WITH RESPECT TO ALF, NOT T.
-C
-C------------------------------ NOTES -------------------------------
-C
-C THIS PROGRAM WAS WRITTEN BY LINDA KAUFMAN AT BELL LABS, MURRAY
-C HILL, N.J. IN 1977 AND EXTENSIVELY REVISED BY HER AND DAVID GAY IN
-C 1980, 1981, 1983, 1984. THE WORK OF DAVID GAY WAS SUPPORTED IN PART
-C BY NATIONAL SCIENCE FOUNDATION GRANT MCS-7906671.
-C
-C-------------------------- DECLARATIONS ----------------------------
-C
-C
-C *** EXTERNAL SUBROUTINES ***
-C
- EXTERNAL IVSET, RNSGB
-C
-C IVSET.... PROVIDES DEFAULT IV AND V VALUES.
-C RNSGB... CARRIES OUT NL2SOL ALGORITHM.
-C
-C *** LOCAL VARIABLES ***
-C
- INTEGER A1, DA1, I, IN1, IV1, K, L1, LP1, M, M0, NF
-C
-C *** SUBSCRIPTS FOR IV AND V ***
-C
- INTEGER AMAT, DAMAT, IN, IVNEED, L1SAV, MSAVE, NEXTIV,
- 1 NEXTV, NFCALL, NFGCAL, PERM, TOOBIG, VNEED
-C
-C *** IV SUBSCRIPT VALUES ***
-C
-C/6
-C DATA AMAT/113/, DAMAT/114/, IN/112/, IVNEED/3/, L1SAV/111/,
-C 1 MSAVE/115/, NEXTIV/46/, NEXTV/47/, NFCALL/6/, NFGCAL/7/,
-C 2 PERM/58/, TOOBIG/2/, VNEED/4/
-C/7
- PARAMETER (AMAT=113, DAMAT=114, IN=112, IVNEED=3, L1SAV=111,
- 1 MSAVE=115, NEXTIV=46, NEXTV=47, NFCALL=6, NFGCAL=7,
- 2 PERM=58, TOOBIG=2, VNEED=4)
-C/
-C
-C++++++++++++++++++++++++++++++++ BODY ++++++++++++++++++++++++++++++
-C
- IF (IV(1) .EQ. 0) CALL IVSET(1, IV, LIV, LV, V)
- IF (P .LE. 0 .OR. L .LT. 0 .OR. IINC .LE. L) GO TO 50
- IV1 = IV(1)
- IF (IV1 .EQ. 14) GO TO 90
- IF (IV1 .GT. 2 .AND. IV1 .LT. 12) GO TO 90
- IF (IV1 .EQ. 12) IV(1) = 13
- IF (IV(1) .NE. 13) GO TO 60
- IF (IV(PERM) .LE. MSAVE) IV(PERM) = MSAVE + 1
- LP1 = L + 1
- L1 = 0
- M = 0
- DO 40 I = 1, P
- M0 = M
- IF (L .EQ. 0) GO TO 20
- DO 10 K = 1, L
- IF (INC(K,I) .LT. 0 .OR. INC(K,I) .GT. 1) GO TO 50
- IF (INC(K,I) .EQ. 1) M = M + 1
- 10 CONTINUE
- 20 IF (INC(LP1,I) .NE. 1) GO TO 30
- M = M + 1
- L1 = 1
- 30 IF (M .EQ. M0 .OR. INC(LP1,I) .LT. 0
- 1 .OR. INC(LP1,I) .GT. 1) GO TO 50
- 40 CONTINUE
-C
- IV(IVNEED) = IV(IVNEED) + 2*M
- L1 = L + L1
- IV(VNEED) = IV(VNEED) + N*(L1+M)
- GO TO 60
-C
- 50 IV(1) = 66
-C
- 60 CALL RNSGB(V, ALF, B, C, V, IV, IV, L, 1, N, LIV, LV, N, M, P, V,
- 1 Y)
- IF (IV(1) .NE. 14) GO TO 999
-C
-C *** STORAGE ALLOCATION ***
-C
- IV(IN) = IV(NEXTIV)
- IV(NEXTIV) = IV(IN) + 2*M
- IV(AMAT) = IV(NEXTV)
- IV(DAMAT) = IV(AMAT) + N*L1
- IV(NEXTV) = IV(DAMAT) + N*M
- IV(L1SAV) = L1
- IV(MSAVE) = M
-C
-C *** SET UP IN ARRAY ***
-C
- IN1 = IV(IN)
- DO 80 I = 1, P
- DO 70 K = 1, LP1
- IF (INC(K,I) .EQ. 0) GO TO 70
- IV(IN1) = I
- IV(IN1+1) = K
- IN1 = IN1 + 2
- 70 CONTINUE
- 80 CONTINUE
- IF (IV1 .EQ. 13) GO TO 999
-C
- 90 A1 = IV(AMAT)
- DA1 = IV(DAMAT)
- IN1 = IV(IN)
- L1 = IV(L1SAV)
- M = IV(MSAVE)
-C
- 100 CALL RNSGB(V(A1), ALF, B, C, V(DA1), IV(IN1), IV, L, L1, N, LIV,
- 1 LV, N, M, P, V, Y)
- IF (IV(1)-2) 110, 120, 999
-C
-C *** NEW FUNCTION VALUE (R VALUE) NEEDED ***
-C
- 110 NF = IV(NFCALL)
- CALL CALCA(N, P, L, ALF, NF, V(A1), UIPARM, URPARM, UFPARM)
- IF (NF .LE. 0) IV(TOOBIG) = 1
- GO TO 100
-C
-C *** COMPUTE DR = GRADIENT OF R COMPONENTS ***
-C
- 120 CALL CALCB(N, P, L, ALF, IV(NFGCAL), V(DA1), UIPARM, URPARM,
- 1 UFPARM)
- IF (IV(NFGCAL) .EQ. 0) IV(TOOBIG) = 1
- GO TO 100
-C
- 999 RETURN
-C
-C *** LAST CARD OF NSGB FOLLOWS ***
- END
diff --git a/CEP/PyBDSM/src/port3/o7prd.f b/CEP/PyBDSM/src/port3/o7prd.f
deleted file mode 100644
index 90cc2012c438ead29e6678e886ce3dc6004d741f..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/o7prd.f
+++ /dev/null
@@ -1,29 +0,0 @@
- SUBROUTINE O7PRD(L, LS, P, S, W, Y, Z)
-C
-C *** FOR I = 1..L, SET S = S + W(I)*Y(.,I)*(Z(.,I)**T), I.E.,
-C *** ADD W(I) TIMES THE OUTER PRODUCT OF Y(.,I) AND Z(.,I).
-C
- INTEGER L, LS, P
- REAL S(LS), W(L), Y(P,L), Z(P,L)
-C DIMENSION S(P*(P+1)/2)
-C
- INTEGER I, J, K, M
- REAL WK, YI, ZERO
- DATA ZERO/0.E+0/
-C
- DO 30 K = 1, L
- WK = W(K)
- IF (WK .EQ. ZERO) GO TO 30
- M = 1
- DO 20 I = 1, P
- YI = WK * Y(I,K)
- DO 10 J = 1, I
- S(M) = S(M) + YI*Z(J,K)
- M = M + 1
- 10 CONTINUE
- 20 CONTINUE
- 30 CONTINUE
-C
- 999 RETURN
-C *** LAST CARD OF O7PRD FOLLOWS ***
- END
diff --git a/CEP/PyBDSM/src/port3/orthe.f b/CEP/PyBDSM/src/port3/orthe.f
deleted file mode 100644
index e2f545d7fffd83c54f1f987431e920dc679a531e..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/orthe.f
+++ /dev/null
@@ -1,112 +0,0 @@
- SUBROUTINE ORTHE(NM,N,LOW,IGH,A,ORT)
-C
- INTEGER I,J,M,N,II,JJ,LA,MP,NM,IGH,KP1,LOW
- REAL A(NM,N),ORT(IGH)
- REAL F,G,H,SCALE
- REAL SQRT,ABS,SIGN
-C
-C THIS IS THE EISPACK ROUTINE, ORTHES, PUT INTO PORT
-C AUGUST 18, 1976.
-C
-C THE NAME CHANGE IS DUE TO THE PORT CONVENTION THAT ALL DOUBLE
-C PRECISION NAMES HAVE A D PUT IN FRONT OF THE SINGLE-PRECISION
-C ONES, WHICH THEREFORE HAVE TO HAVE ONLY 5 CHARACTERS.
-C
-C
-C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE ORTHES,
-C NUM. MATH. 12, 349-368(1968) BY MARTIN AND WILKINSON.
-C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 339-358(1971).
-C
-C GIVEN A REAL GENERAL MATRIX, THIS SUBROUTINE
-C REDUCES A SUBMATRIX SITUATED IN ROWS AND COLUMNS
-C LOW THROUGH IGH TO UPPER HESSENBERG FORM BY
-C ORTHOGONAL SIMILARITY TRANSFORMATIONS.
-C
-C ON INPUT-
-C
-C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
-C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
-C DIMENSION STATEMENT,
-C
-C N IS THE ORDER OF THE MATRIX,
-C
-C LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING
-C SUBROUTINE BALANC. IF BALANC HAS NOT BEEN USED,
-C SET LOW=1, IGH=N,
-C
-C A CONTAINS THE INPUT MATRIX.
-C
-C ON OUTPUT-
-C
-C A CONTAINS THE HESSENBERG MATRIX. INFORMATION ABOUT
-C THE ORTHOGONAL TRANSFORMATIONS USED IN THE REDUCTION
-C IS STORED IN THE REMAINING TRIANGLE UNDER THE
-C HESSENBERG MATRIX,
-C
-C ORT CONTAINS FURTHER INFORMATION ABOUT THE TRANSFORMATIONS.
-C ONLY ELEMENTS LOW THROUGH IGH ARE USED.
-C
-C ------------------------------------------------------------------
-C
- LA = IGH - 1
- KP1 = LOW + 1
- IF (LA .LT. KP1) GO TO 200
-C
- DO 180 M = KP1, LA
- H = 0.0
- ORT(M) = 0.0
- SCALE = 0.0
-C ********** SCALE COLUMN (ALGOL TOL THEN NOT NEEDED) **********
- DO 90 I = M, IGH
- 90 SCALE = SCALE + ABS(A(I,M-1))
-C
- IF (SCALE .EQ. 0.0) GO TO 180
- MP = M + IGH
-C ********** FOR I=IGH STEP -1 UNTIL M DO -- **********
- DO 100 II = M, IGH
- I = MP - II
- ORT(I) = A(I,M-1) / SCALE
- H = H + ORT(I) * ORT(I)
- 100 CONTINUE
-C
- G = -SIGN(SQRT(H),ORT(M))
- H = H - ORT(M) * G
- ORT(M) = ORT(M) - G
-C ********** FORM (I-(U*UT)/H) * A **********
- DO 130 J = M, N
- F = 0.0
-C ********** FOR I=IGH STEP -1 UNTIL M DO -- **********
- DO 110 II = M, IGH
- I = MP - II
- F = F + ORT(I) * A(I,J)
- 110 CONTINUE
-C
- F = F / H
-C
- DO 120 I = M, IGH
- 120 A(I,J) = A(I,J) - F * ORT(I)
-C
- 130 CONTINUE
-C ********** FORM (I-(U*UT)/H)*A*(I-(U*UT)/H) **********
- DO 160 I = 1, IGH
- F = 0.0
-C ********** FOR J=IGH STEP -1 UNTIL M DO -- **********
- DO 140 JJ = M, IGH
- J = MP - JJ
- F = F + ORT(J) * A(I,J)
- 140 CONTINUE
-C
- F = F / H
-C
- DO 150 J = M, IGH
- 150 A(I,J) = A(I,J) - F * ORT(J)
-C
- 160 CONTINUE
-C
- ORT(M) = SCALE * ORT(M)
- A(M,M-1) = SCALE * G
- 180 CONTINUE
-C
- 200 RETURN
-C ********** LAST CARD OF ORTHE **********
- END
diff --git a/CEP/PyBDSM/src/port3/ortra.f b/CEP/PyBDSM/src/port3/ortra.f
deleted file mode 100644
index 2a812995d5c49380e07aa7f87ec3a144ad5c7ea4..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ortra.f
+++ /dev/null
@@ -1,89 +0,0 @@
- SUBROUTINE ORTRA(NM,N,LOW,IGH,A,ORT,Z)
-C
- INTEGER I,J,N,KL,MM,MP,NM,IGH,LOW,MP1
- REAL A(NM,IGH),ORT(IGH),Z(NM,N)
- REAL G
-C
-C THIS IS THE EISPACK ROUTINE, ORTRAN, PUT INTO PORT
-C AUGUST 18, 1976.
-C
-C THE NAME CHANGE IS DUE TO THE PORT CONVENTION THAT ALL DOUBLE
-C PRECISION NAMES HAVE A D PUT IN FRONT OF THE SINGLE-
-C PRECISION ONES, WHICH THEREFORE CAN HAVE ONLY 5 CHARACTERS.
-C
-C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE ORTRANS,
-C NUM. MATH. 16, 181-204(1970) BY PETERS AND WILKINSON.
-C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 372-395(1971).
-C
-C THIS SUBROUTINE ACCUMULATES THE ORTHOGONAL SIMILARITY
-C TRANSFORMATIONS USED IN THE REDUCTION OF A REAL GENERAL
-C MATRIX TO UPPER HESSENBERG FORM BY ORTHE.
-C
-C ON INPUT-
-C
-C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
-C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
-C DIMENSION STATEMENT,
-C
-C N IS THE ORDER OF THE MATRIX,
-C
-C LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING
-C SUBROUTINE BALANC. IF BALANC HAS NOT BEEN USED,
-C SET LOW=1, IGH=N,
-C
-C A CONTAINS INFORMATION ABOUT THE ORTHOGONAL TRANS-
-C FORMATIONS USED IN THE REDUCTION BY ORTHE
-C IN ITS STRICT LOWER TRIANGLE,
-C
-C ORT CONTAINS FURTHER INFORMATION ABOUT THE TRANS-
-C FORMATIONS USED IN THE REDUCTION BY ORTHE.
-C ONLY ELEMENTS LOW THROUGH IGH ARE USED.
-C
-C ON OUTPUT-
-C
-C Z CONTAINS THE TRANSFORMATION MATRIX PRODUCED IN THE
-C REDUCTION BY ORTHE,
-C
-C ORT HAS BEEN ALTERED.
-C
-C ------------------------------------------------------------------
-C
-C ********** INITIALIZE Z TO IDENTITY MATRIX **********
- DO 80 I = 1, N
-C
- DO 60 J = 1, N
- 60 Z(I,J) = 0.0
-C
- Z(I,I) = 1.0
- 80 CONTINUE
-C
- KL = IGH - LOW - 1
- IF (KL .LT. 1) GO TO 200
-C ********** FOR MP=IGH-1 STEP -1 UNTIL LOW+1 DO -- **********
- DO 140 MM = 1, KL
- MP = IGH - MM
- IF (A(MP,MP-1) .EQ. 0.0) GO TO 140
- MP1 = MP + 1
-C
- DO 100 I = MP1, IGH
- 100 ORT(I) = A(I,MP-1)
-C
- DO 130 J = MP, IGH
- G = 0.0
-C
- DO 110 I = MP, IGH
- 110 G = G + ORT(I) * Z(I,J)
-C ********** DIVISOR BELOW IS NEGATIVE OF H FORMED IN ORTHE.
-C DOUBLE DIVISION AVOIDS POSSIBLE UNDERFLOW **********
- G = (G / ORT(MP)) / A(MP,MP-1)
-C
- DO 120 I = MP, IGH
- 120 Z(I,J) = Z(I,J) + G * ORT(I)
-C
- 130 CONTINUE
-C
- 140 CONTINUE
-C
- 200 RETURN
-C ********** LAST CARD OF ORTRA **********
- END
diff --git a/CEP/PyBDSM/src/port3/parck.f b/CEP/PyBDSM/src/port3/parck.f
deleted file mode 100644
index 18ff01a907a759566aed90cdef544d6511798fd9..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/parck.f
+++ /dev/null
@@ -1,333 +0,0 @@
- SUBROUTINE PARCK(ALG, D, IV, LIV, LV, N, V)
-C
-C *** CHECK ***SOL (VERSION 2.3) PARAMETERS, PRINT CHANGED VALUES ***
-C
-C *** ALG = 1 FOR REGRESSION, ALG = 2 FOR GENERAL UNCONSTRAINED OPT.
-C
- INTEGER ALG, LIV, LV, N
- INTEGER IV(LIV)
- REAL D(N), V(LV)
-C
- REAL R7MDC
- EXTERNAL IVSET, R7MDC, V7CPY, V7DFL
-C IVSET -- SUPPLIES DEFAULT VALUES TO BOTH IV AND V.
-C R7MDC -- RETURNS MACHINE-DEPENDENT CONSTANTS.
-C V7CPY -- COPIES ONE VECTOR TO ANOTHER.
-C V7DFL -- SUPPLIES DEFAULT PARAMETER VALUES TO V ALONE.
-C
-C *** LOCAL VARIABLES ***
-C
- INTEGER ALG1, I, II, IV1, J, K, L, M, MIV1, MIV2, NDFALT, PARSV1,
- 1 PU
- INTEGER IJMP, JLIM(4), MINIV(4), NDFLT(4)
-C/6S
-C INTEGER VARNM(2), SH(2)
-C REAL CNGD(3), DFLT(3), VN(2,34), WHICH(3)
-C/7S
- CHARACTER*1 VARNM(2), SH(2)
- CHARACTER*4 CNGD(3), DFLT(3), VN(2,34), WHICH(3)
-C/
- REAL BIG, MACHEP, TINY, VK, VM(34), VX(34), ZERO
-C
-C *** IV AND V SUBSCRIPTS ***
-C
- INTEGER ALGSAV, DINIT, DTYPE, DTYPE0, EPSLON, INITS, IVNEED,
- 1 LASTIV, LASTV, LMAT, NEXTIV, NEXTV, NVDFLT, OLDN,
- 2 PARPRT, PARSAV, PERM, PRUNIT, VNEED
-C
-C
-C/6
-C DATA ALGSAV/51/, DINIT/38/, DTYPE/16/, DTYPE0/54/, EPSLON/19/,
-C 1 INITS/25/, IVNEED/3/, LASTIV/44/, LASTV/45/, LMAT/42/,
-C 2 NEXTIV/46/, NEXTV/47/, NVDFLT/50/, OLDN/38/, PARPRT/20/,
-C 3 PARSAV/49/, PERM/58/, PRUNIT/21/, VNEED/4/
-C/7
- PARAMETER (ALGSAV=51, DINIT=38, DTYPE=16, DTYPE0=54, EPSLON=19,
- 1 INITS=25, IVNEED=3, LASTIV=44, LASTV=45, LMAT=42,
- 2 NEXTIV=46, NEXTV=47, NVDFLT=50, OLDN=38, PARPRT=20,
- 3 PARSAV=49, PERM=58, PRUNIT=21, VNEED=4)
- SAVE BIG, MACHEP, TINY
-C/
-C
- DATA BIG/0.E+0/, MACHEP/-1.E+0/, TINY/1.E+0/, ZERO/0.E+0/
-C/6S
-C DATA VN(1,1),VN(2,1)/4HEPSL,4HON../
-C DATA VN(1,2),VN(2,2)/4HPHMN,4HFC../
-C DATA VN(1,3),VN(2,3)/4HPHMX,4HFC../
-C DATA VN(1,4),VN(2,4)/4HDECF,4HAC../
-C DATA VN(1,5),VN(2,5)/4HINCF,4HAC../
-C DATA VN(1,6),VN(2,6)/4HRDFC,4HMN../
-C DATA VN(1,7),VN(2,7)/4HRDFC,4HMX../
-C DATA VN(1,8),VN(2,8)/4HTUNE,4HR1../
-C DATA VN(1,9),VN(2,9)/4HTUNE,4HR2../
-C DATA VN(1,10),VN(2,10)/4HTUNE,4HR3../
-C DATA VN(1,11),VN(2,11)/4HTUNE,4HR4../
-C DATA VN(1,12),VN(2,12)/4HTUNE,4HR5../
-C DATA VN(1,13),VN(2,13)/4HAFCT,4HOL../
-C DATA VN(1,14),VN(2,14)/4HRFCT,4HOL../
-C DATA VN(1,15),VN(2,15)/4HXCTO,4HL.../
-C DATA VN(1,16),VN(2,16)/4HXFTO,4HL.../
-C DATA VN(1,17),VN(2,17)/4HLMAX,4H0.../
-C DATA VN(1,18),VN(2,18)/4HLMAX,4HS.../
-C DATA VN(1,19),VN(2,19)/4HSCTO,4HL.../
-C DATA VN(1,20),VN(2,20)/4HDINI,4HT.../
-C DATA VN(1,21),VN(2,21)/4HDTIN,4HIT../
-C DATA VN(1,22),VN(2,22)/4HD0IN,4HIT../
-C DATA VN(1,23),VN(2,23)/4HDFAC,4H..../
-C DATA VN(1,24),VN(2,24)/4HDLTF,4HDC../
-C DATA VN(1,25),VN(2,25)/4HDLTF,4HDJ../
-C DATA VN(1,26),VN(2,26)/4HDELT,4HA0../
-C DATA VN(1,27),VN(2,27)/4HFUZZ,4H..../
-C DATA VN(1,28),VN(2,28)/4HRLIM,4HIT../
-C DATA VN(1,29),VN(2,29)/4HCOSM,4HIN../
-C DATA VN(1,30),VN(2,30)/4HHUBE,4HRC../
-C DATA VN(1,31),VN(2,31)/4HRSPT,4HOL../
-C DATA VN(1,32),VN(2,32)/4HSIGM,4HIN../
-C DATA VN(1,33),VN(2,33)/4HETA0,4H..../
-C DATA VN(1,34),VN(2,34)/4HBIAS,4H..../
-C/7S
- DATA VN(1,1),VN(2,1)/'EPSL','ON..'/
- DATA VN(1,2),VN(2,2)/'PHMN','FC..'/
- DATA VN(1,3),VN(2,3)/'PHMX','FC..'/
- DATA VN(1,4),VN(2,4)/'DECF','AC..'/
- DATA VN(1,5),VN(2,5)/'INCF','AC..'/
- DATA VN(1,6),VN(2,6)/'RDFC','MN..'/
- DATA VN(1,7),VN(2,7)/'RDFC','MX..'/
- DATA VN(1,8),VN(2,8)/'TUNE','R1..'/
- DATA VN(1,9),VN(2,9)/'TUNE','R2..'/
- DATA VN(1,10),VN(2,10)/'TUNE','R3..'/
- DATA VN(1,11),VN(2,11)/'TUNE','R4..'/
- DATA VN(1,12),VN(2,12)/'TUNE','R5..'/
- DATA VN(1,13),VN(2,13)/'AFCT','OL..'/
- DATA VN(1,14),VN(2,14)/'RFCT','OL..'/
- DATA VN(1,15),VN(2,15)/'XCTO','L...'/
- DATA VN(1,16),VN(2,16)/'XFTO','L...'/
- DATA VN(1,17),VN(2,17)/'LMAX','0...'/
- DATA VN(1,18),VN(2,18)/'LMAX','S...'/
- DATA VN(1,19),VN(2,19)/'SCTO','L...'/
- DATA VN(1,20),VN(2,20)/'DINI','T...'/
- DATA VN(1,21),VN(2,21)/'DTIN','IT..'/
- DATA VN(1,22),VN(2,22)/'D0IN','IT..'/
- DATA VN(1,23),VN(2,23)/'DFAC','....'/
- DATA VN(1,24),VN(2,24)/'DLTF','DC..'/
- DATA VN(1,25),VN(2,25)/'DLTF','DJ..'/
- DATA VN(1,26),VN(2,26)/'DELT','A0..'/
- DATA VN(1,27),VN(2,27)/'FUZZ','....'/
- DATA VN(1,28),VN(2,28)/'RLIM','IT..'/
- DATA VN(1,29),VN(2,29)/'COSM','IN..'/
- DATA VN(1,30),VN(2,30)/'HUBE','RC..'/
- DATA VN(1,31),VN(2,31)/'RSPT','OL..'/
- DATA VN(1,32),VN(2,32)/'SIGM','IN..'/
- DATA VN(1,33),VN(2,33)/'ETA0','....'/
- DATA VN(1,34),VN(2,34)/'BIAS','....'/
-C/
-C
- DATA VM(1)/1.0E-3/, VM(2)/-0.99E+0/, VM(3)/1.0E-3/, VM(4)/1.0E-2/,
- 1 VM(5)/1.2E+0/, VM(6)/1.E-2/, VM(7)/1.2E+0/, VM(8)/0.E+0/,
- 2 VM(9)/0.E+0/, VM(10)/1.E-3/, VM(11)/-1.E+0/, VM(13)/0.E+0/,
- 3 VM(15)/0.E+0/, VM(16)/0.E+0/, VM(19)/0.E+0/, VM(20)/-10.E+0/,
- 4 VM(21)/0.E+0/, VM(22)/0.E+0/, VM(23)/0.E+0/, VM(27)/1.01E+0/,
- 5 VM(28)/1.E+10/, VM(30)/0.E+0/, VM(31)/0.E+0/, VM(32)/0.E+0/,
- 6 VM(34)/0.E+0/
- DATA VX(1)/0.9E+0/, VX(2)/-1.E-3/, VX(3)/1.E+1/, VX(4)/0.8E+0/,
- 1 VX(5)/1.E+2/, VX(6)/0.8E+0/, VX(7)/1.E+2/, VX(8)/0.5E+0/,
- 2 VX(9)/0.5E+0/, VX(10)/1.E+0/, VX(11)/1.E+0/, VX(14)/0.1E+0/,
- 3 VX(15)/1.E+0/, VX(16)/1.E+0/, VX(19)/1.E+0/, VX(23)/1.E+0/,
- 4 VX(24)/1.E+0/, VX(25)/1.E+0/, VX(26)/1.E+0/, VX(27)/1.E+10/,
- 5 VX(29)/1.E+0/, VX(31)/1.E+0/, VX(32)/1.E+0/, VX(33)/1.E+0/,
- 6 VX(34)/1.E+0/
-C
-C/6S
-C DATA VARNM(1)/1HP/, VARNM(2)/1HP/, SH(1)/1HS/, SH(2)/1HH/
-C DATA CNGD(1),CNGD(2),CNGD(3)/4H---C,4HHANG,4HED V/,
-C 1 DFLT(1),DFLT(2),DFLT(3)/4HNOND,4HEFAU,4HLT V/
-C/7S
- DATA VARNM(1)/'P'/, VARNM(2)/'P'/, SH(1)/'S'/, SH(2)/'H'/
- DATA CNGD(1),CNGD(2),CNGD(3)/'---C','HANG','ED V'/,
- 1 DFLT(1),DFLT(2),DFLT(3)/'NOND','EFAU','LT V'/
-C/
- DATA IJMP/33/, JLIM(1)/0/, JLIM(2)/24/, JLIM(3)/0/, JLIM(4)/24/,
- 1 NDFLT(1)/32/, NDFLT(2)/25/, NDFLT(3)/32/, NDFLT(4)/25/
- DATA MINIV(1)/82/, MINIV(2)/59/, MINIV(3)/103/, MINIV(4)/103/
-C
-C............................... BODY ................................
-C
- PU = 0
- IF (PRUNIT .LE. LIV) PU = IV(PRUNIT)
- IF (ALGSAV .GT. LIV) GO TO 20
- IF (ALG .EQ. IV(ALGSAV)) GO TO 20
- IF (PU .NE. 0) WRITE(PU,10) ALG, IV(ALGSAV)
- 10 FORMAT(/40H THE FIRST PARAMETER TO IVSET SHOULD BE,I3,
- 1 12H RATHER THAN,I3)
- IV(1) = 67
- GO TO 999
- 20 IF (ALG .LT. 1 .OR. ALG .GT. 4) GO TO 340
- MIV1 = MINIV(ALG)
- IF (IV(1) .EQ. 15) GO TO 360
- ALG1 = MOD(ALG-1,2) + 1
- IF (IV(1) .EQ. 0) CALL IVSET(ALG, IV, LIV, LV, V)
- IV1 = IV(1)
- IF (IV1 .NE. 13 .AND. IV1 .NE. 12) GO TO 30
- IF (PERM .LE. LIV) MIV1 = MAX0(MIV1, IV(PERM) - 1)
- IF (IVNEED .LE. LIV) MIV2 = MIV1 + MAX0(IV(IVNEED), 0)
- IF (LASTIV .LE. LIV) IV(LASTIV) = MIV2
- IF (LIV .LT. MIV1) GO TO 300
- IV(IVNEED) = 0
- IV(LASTV) = MAX0(IV(VNEED), 0) + IV(LMAT) - 1
- IV(VNEED) = 0
- IF (LIV .LT. MIV2) GO TO 300
- IF (LV .LT. IV(LASTV)) GO TO 320
- 30 IF (IV1 .LT. 12 .OR. IV1 .GT. 14) GO TO 60
- IF (N .GE. 1) GO TO 50
- IV(1) = 81
- IF (PU .EQ. 0) GO TO 999
- WRITE(PU,40) VARNM(ALG1), N
- 40 FORMAT(/8H /// BAD,A1,2H =,I5)
- GO TO 999
- 50 IF (IV1 .NE. 14) IV(NEXTIV) = IV(PERM)
- IF (IV1 .NE. 14) IV(NEXTV) = IV(LMAT)
- IF (IV1 .EQ. 13) GO TO 999
- K = IV(PARSAV) - EPSLON
- CALL V7DFL(ALG1, LV-K, V(K+1))
- IV(DTYPE0) = 2 - ALG1
- IV(OLDN) = N
- WHICH(1) = DFLT(1)
- WHICH(2) = DFLT(2)
- WHICH(3) = DFLT(3)
- GO TO 110
- 60 IF (N .EQ. IV(OLDN)) GO TO 80
- IV(1) = 17
- IF (PU .EQ. 0) GO TO 999
- WRITE(PU,70) VARNM(ALG1), IV(OLDN), N
- 70 FORMAT(/5H /// ,1A1,14H CHANGED FROM ,I5,4H TO ,I5)
- GO TO 999
-C
- 80 IF (IV1 .LE. 11 .AND. IV1 .GE. 1) GO TO 100
- IV(1) = 80
- IF (PU .NE. 0) WRITE(PU,90) IV1
- 90 FORMAT(/13H /// IV(1) =,I5,28H SHOULD BE BETWEEN 0 AND 14.)
- GO TO 999
-C
- 100 WHICH(1) = CNGD(1)
- WHICH(2) = CNGD(2)
- WHICH(3) = CNGD(3)
-C
- 110 IF (IV1 .EQ. 14) IV1 = 12
- IF (BIG .GT. TINY) GO TO 120
- TINY = R7MDC(1)
- MACHEP = R7MDC(3)
- BIG = R7MDC(6)
- VM(12) = MACHEP
- VX(12) = BIG
- VX(13) = BIG
- VM(14) = MACHEP
- VM(17) = TINY
- VX(17) = BIG
- VM(18) = TINY
- VX(18) = BIG
- VX(20) = BIG
- VX(21) = BIG
- VX(22) = BIG
- VM(24) = MACHEP
- VM(25) = MACHEP
- VM(26) = MACHEP
- VX(28) = R7MDC(5)
- VM(29) = MACHEP
- VX(30) = BIG
- VM(33) = MACHEP
- 120 M = 0
- I = 1
- J = JLIM(ALG1)
- K = EPSLON
- NDFALT = NDFLT(ALG1)
- DO 150 L = 1, NDFALT
- VK = V(K)
- IF (VK .GE. VM(I) .AND. VK .LE. VX(I)) GO TO 140
- M = K
- IF (PU .NE. 0) WRITE(PU,130) VN(1,I), VN(2,I), K, VK,
- 1 VM(I), VX(I)
- 130 FORMAT(/6H /// ,2A4,5H.. V(,I2,3H) =,E11.3,7H SHOULD,
- 1 11H BE BETWEEN,E11.3,4H AND,E11.3)
- 140 K = K + 1
- I = I + 1
- IF (I .EQ. J) I = IJMP
- 150 CONTINUE
-C
- IF (IV(NVDFLT) .EQ. NDFALT) GO TO 170
- IV(1) = 51
- IF (PU .EQ. 0) GO TO 999
- WRITE(PU,160) IV(NVDFLT), NDFALT
- 160 FORMAT(/13H IV(NVDFLT) =,I5,13H RATHER THAN ,I5)
- GO TO 999
- 170 IF ((IV(DTYPE) .GT. 0 .OR. V(DINIT) .GT. ZERO) .AND. IV1 .EQ. 12)
- 1 GO TO 200
- DO 190 I = 1, N
- IF (D(I) .GT. ZERO) GO TO 190
- M = 18
- IF (PU .NE. 0) WRITE(PU,180) I, D(I)
- 180 FORMAT(/8H /// D(,I3,3H) =,E11.3,19H SHOULD BE POSITIVE)
- 190 CONTINUE
- 200 IF (M .EQ. 0) GO TO 210
- IV(1) = M
- GO TO 999
-C
- 210 IF (PU .EQ. 0 .OR. IV(PARPRT) .EQ. 0) GO TO 999
- IF (IV1 .NE. 12 .OR. IV(INITS) .EQ. ALG1-1) GO TO 230
- M = 1
- WRITE(PU,220) SH(ALG1), IV(INITS)
- 220 FORMAT(/22H NONDEFAULT VALUES..../5H INIT,A1,14H..... IV(25) =,
- 1 I3)
- 230 IF (IV(DTYPE) .EQ. IV(DTYPE0)) GO TO 250
- IF (M .EQ. 0) WRITE(PU,260) WHICH
- M = 1
- WRITE(PU,240) IV(DTYPE)
- 240 FORMAT(20H DTYPE..... IV(16) =,I3)
- 250 I = 1
- J = JLIM(ALG1)
- K = EPSLON
- L = IV(PARSAV)
- NDFALT = NDFLT(ALG1)
- DO 290 II = 1, NDFALT
- IF (V(K) .EQ. V(L)) GO TO 280
- IF (M .EQ. 0) WRITE(PU,260) WHICH
- 260 FORMAT(/1H ,3A4,9HALUES..../)
- M = 1
- WRITE(PU,270) VN(1,I), VN(2,I), K, V(K)
- 270 FORMAT(1X,2A4,5H.. V(,I2,3H) =,E15.7)
- 280 K = K + 1
- L = L + 1
- I = I + 1
- IF (I .EQ. J) I = IJMP
- 290 CONTINUE
-C
- IV(DTYPE0) = IV(DTYPE)
- PARSV1 = IV(PARSAV)
- CALL V7CPY(IV(NVDFLT), V(PARSV1), V(EPSLON))
- GO TO 999
-C
- 300 IV(1) = 15
- IF (PU .EQ. 0) GO TO 999
- WRITE(PU,310) LIV, MIV2
- 310 FORMAT(/10H /// LIV =,I5,17H MUST BE AT LEAST,I5)
- IF (LIV .LT. MIV1) GO TO 999
- IF (LV .LT. IV(LASTV)) GO TO 320
- GO TO 999
-C
- 320 IV(1) = 16
- IF (PU .NE. 0) WRITE(PU,330) LV, IV(LASTV)
- 330 FORMAT(/9H /// LV =,I5,17H MUST BE AT LEAST,I5)
- GO TO 999
-C
- 340 IV(1) = 67
- IF (PU .NE. 0) WRITE(PU,350) ALG
- 350 FORMAT(/10H /// ALG =,I5,21H MUST BE 1 2, 3, OR 4)
- GO TO 999
- 360 IF (PU .NE. 0) WRITE(PU,370) LIV, MIV1
- 370 FORMAT(/10H /// LIV =,I5,17H MUST BE AT LEAST,I5,
- 1 37H TO COMPUTE TRUE MIN. LIV AND MIN. LV)
- IF (LASTIV .LE. LIV) IV(LASTIV) = MIV1
- IF (LASTV .LE. LIV) IV(LASTV) = 0
-C
- 999 RETURN
-C *** LAST LINE OF PARCK FOLLOWS ***
- END
diff --git a/CEP/PyBDSM/src/port3/postx1.f b/CEP/PyBDSM/src/port3/postx1.f
deleted file mode 100644
index eef49562ebcfd567afdf49b759c3024be9502b89..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/postx1.f
+++ /dev/null
@@ -1,105 +0,0 @@
-c main program
- common /cstak/ ds
- double precision ds(1000)
- external handle, bc, af, postd
- integer ndx, k, is(1000), nu, nv, nmesh
- real errpar(2), u(100), v(1), mesh(100), dt, rs(1000)
- real ws(1000), tstop
- logical ls(1000)
- complex cs(500)
- equivalence (ds(1), cs(1), ws(1), rs(1), is(1), ls(1))
-c to test post on
-c u sub t = u sub xx + f on (0,1)
-c where f is chosen so that the solution is
-c u(x,t) = exp(xt).
-c the port library stack and its aliases.
-c initialize the port library stack length.
- call istkin(1000, 4)
- nu = 1
- nv = 0
- errpar(1) = 0
-c absolute error.
- errpar(2) = 1e-2
- tstop = 1
- dt = 1e-2
- k = 4
-c ndx uniform mesh points on (0,1).
- ndx = 4
- call umb(0e0, 1e0, ndx, k, mesh, nmesh)
-c initial conditions for u.
- call setr(nmesh-k, 1e0, u)
- call post(u, nu, k, mesh, nmesh, v, nv, 0e0, tstop, dt, af, bc,
- 1 postd, errpar, handle)
-c check for errors and stack usage statistics.
- call wrapup
- stop
- end
- subroutine af(t, x, nx, u, ux, ut, utx, nu, v, vt, nv, a,
- 1 au, aux, aut, autx, av, avt, f, fu, fux, fut, futx, fv, fvt)
- integer nu, nx
- integer nv
- real t, x(nx), u(nx, nu), ux(nx, nu), ut(nx, nu), utx(nx, nu)
- real v(1), vt(1), a(nx, nu), au(nx, nu, nu), aux(nx, nu, nu), aut(
- 1 nx, nu, nu)
- real autx(nx, nu, nu), av(1), avt(1), f(nx, nu), fu(nx, nu, nu),
- 1 fux(nx, nu, nu)
- real fut(nx, nu, nu), futx(nx, nu, nu), fv(1), fvt(1)
- integer i
- real exp
- do 1 i = 1, nx
- a(i, 1) = -ux(i, 1)
- aux(i, 1, 1) = -1
- f(i, 1) = (x(i)-t**2)*exp(x(i)*t)-ut(i, 1)
- fut(i, 1, 1) = -1
- 1 continue
- return
- end
- subroutine bc(t, l, r, u, ux, ut, utx, nu, v, vt, nv, b, bu,
- 1 bux, but, butx, bv, bvt)
- integer nu
- integer nv
- real t, l, r, u(nu, 2), ux(nu, 2), ut(nu, 2)
- real utx(nu, 2), v(1), vt(1), b(nu, 2), bu(nu, nu, 2), bux(nu, nu,
- 1 2)
- real but(nu, nu, 2), butx(nu, nu, 2), bv(1), bvt(1)
- real exp
- b(1, 1) = u(1, 1)-1.
- b(1, 2) = u(1, 2)-exp(t)
- bu(1, 1, 1) = 1
- bu(1, 1, 2) = 1
- return
- end
- subroutine handle(t0, u0, v0, t, u, v, nu, nxmk, nv, k, x,
- 1 nx, dt, tstop)
- integer nxmk, nu, nx
- integer nv, k
- real t0, u0(nxmk, nu), v0(1), t, u(nxmk, nu), v(1)
- real x(nx), dt, tstop
- common /time/ tt
- real tt
- external uofx
- integer i1mach
- real eu, eesff
- integer temp
-c output and checking routine.
- if (t0 .eq. t) return
-c uofx needs time.
- tt = t
- eu = eesff(k, x, nx, u, uofx)
- temp = i1mach(2)
- write (temp, 1) t, eu
- 1 format (14h error in u(x,, 1pe10.2, 4h ) =, 1pe10.2)
- return
- end
- subroutine uofx(x, nx, u, w)
- integer nx
- real x(nx), u(nx), w(nx)
- common /time/ t
- real t
- integer i
- real exp
- do 1 i = 1, nx
- u(i) = exp(x(i)*t)
- 1 continue
- return
- end
diff --git a/CEP/PyBDSM/src/port3/postx10.f b/CEP/PyBDSM/src/port3/postx10.f
deleted file mode 100644
index 5752f2f9afc4da7712f3c3812940dfc0a0809341..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/postx10.f
+++ /dev/null
@@ -1,148 +0,0 @@
-c main program
- common /cstak/ ds
- double precision ds(2000)
- external handle, bc, af, postd
- integer ndx, nxh, i, k, is(1000), nu
- integer nv, nx, i1mach
- real abs, err, errpar(2), u(100), v(1), x(100)
- real amax1, dt, ue(100), eebsf, uh(100), xh(100)
- real rs(1000), ws(1000), tstop
- logical ls(1000)
- complex cs(500)
- integer temp
- equivalence (ds(1), cs(1), ws(1), rs(1), is(1), ls(1))
-c to estimate x and t error as sum.
-c u sub t = u sub xx + f on (0,1)
-c where f is chosen so that the solution is
-c u(x,t) = exp(xt).
-c the port library stack and its aliases.
-c initialize the port library stack length.
- call istkin(2000, 4)
- nu = 1
- nv = 0
- errpar(1) = 0
- errpar(2) = 1e-2
- k = 4
- ndx = 4
- tstop = 1
- dt = 1e-2
-c crude mesh.
- call umb(0e0, 1e0, ndx, k, x, nx)
-c initial conditions for u.
- call setr(nx-k, 1e0, u)
- temp = i1mach(2)
- write (temp, 1)
- 1 format (36h solving on crude mesh using errpar.)
- call post(u, nu, k, x, nx, v, nv, 0e0, tstop, dt, af, bc, postd,
- 1 errpar, handle)
-c get run-time statistics.
- call postx
-c halve the mesh spacing.
- call umb(0e0, 1e0, 2*ndx-1, k, xh, nxh)
-c initial conditions for uh.
- call setr(nxh-k, 1e0, uh)
- dt = 1e-2
- temp = i1mach(2)
- write (temp, 2)
- 2 format (38h solving on refined mesh using errpar.)
- call post(uh, nu, k, xh, nxh, v, nv, 0e0, tstop, dt, af, bc,
- 1 postd, errpar, handle)
-c get run-time statistics.
- call postx
-c estimate u error.
- err = eebsf(k, x, nx, u, xh, nxh, uh)
- write (6, 3) err
- 3 format (24h u error from u and uh =, 1pe10.2)
-c initial conditions for ue.
- call setr(nx-k, 1e0, ue)
- dt = 1e-2
- errpar(1) = errpar(1)/10.
- errpar(2) = errpar(2)/10.
- temp = i1mach(2)
- write (temp, 4)
- 4 format (39h solving on crude mesh using errpar/10.)
- call post(ue, nu, k, x, nx, v, nv, 0e0, tstop, dt, af, bc, postd
- 1 , errpar, handle)
-c get run-time statistics.
- call postx
- err = 0
- temp = nx-k
- do 5 i = 1, temp
- err = amax1(err, abs(u(i)-ue(i)))
- 5 continue
- write (6, 6) err
- 6 format (24h u error from u and ue =, 1pe10.2)
- stop
- end
- subroutine af(t, x, nx, u, ux, ut, utx, nu, v, vt, nv, a,
- 1 au, aux, aut, autx, av, avt, f, fu, fux, fut, futx, fv, fvt)
- integer nu, nx
- integer nv
- real t, x(nx), u(nx, nu), ux(nx, nu), ut(nx, nu), utx(nx, nu)
- real v(1), vt(1), a(nx, nu), au(nx, nu, nu), aux(nx, nu, nu), aut(
- 1 nx, nu, nu)
- real autx(nx, nu, nu), av(1), avt(1), f(nx, nu), fu(nx, nu, nu),
- 1 fux(nx, nu, nu)
- real fut(nx, nu, nu), futx(nx, nu, nu), fv(1), fvt(1)
- integer i
- real exp
- do 1 i = 1, nx
- a(i, 1) = -ux(i, 1)
- aux(i, 1, 1) = -1
- f(i, 1) = (x(i)-t**2)*exp(x(i)*t)-ut(i, 1)
- fut(i, 1, 1) = -1
- 1 continue
- return
- end
- subroutine bc(t, l, r, u, ux, ut, utx, nu, v, vt, nv, b, bu,
- 1 bux, but, butx, bv, bvt)
- integer nu
- integer nv
- real t, l, r, u(nu, 2), ux(nu, 2), ut(nu, 2)
- real utx(nu, 2), v(1), vt(1), b(nu, 2), bu(nu, nu, 2), bux(nu, nu,
- 1 2)
- real but(nu, nu, 2), butx(nu, nu, 2), bv(1), bvt(1)
- real exp
- b(1, 1) = u(1, 1)-1.
- b(1, 2) = u(1, 2)-exp(t)
- bu(1, 1, 1) = 1
- bu(1, 1, 2) = 1
- return
- end
- subroutine handle(t0, u0, v0, t, u, v, nu, nxmk, nv, k, x,
- 1 nx, dt, tstop)
- integer nxmk, nu, nx
- integer nv, k
- real t0, u0(nxmk, nu), v0(1), t, u(nxmk, nu), v(1)
- real x(nx), dt, tstop
- common /time/ tt
- real tt
- external uofx
- integer i1mach
- real eu, eesff
- integer temp
-c output and checking routine.
- if (t0 .ne. t) goto 2
- temp = i1mach(2)
- write (temp, 1) t
- 1 format (16h restart for t =, 1pe10.2)
- return
- 2 tt = t
- eu = eesff(k, x, nx, u, uofx)
- temp = i1mach(2)
- write (temp, 3) t, eu
- 3 format (14h error in u(x,, 1pe10.2, 4h ) =, 1pe10.2)
- return
- end
- subroutine uofx(x, nx, u, w)
- integer nx
- real x(nx), u(nx), w(nx)
- common /time/ t
- real t
- integer i
- real exp
- do 1 i = 1, nx
- u(i) = exp(x(i)*t)
- 1 continue
- return
- end
diff --git a/CEP/PyBDSM/src/port3/postx2.f b/CEP/PyBDSM/src/port3/postx2.f
deleted file mode 100644
index 6607ea40328bcffe7fb30656e80f38a22936e38e..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/postx2.f
+++ /dev/null
@@ -1,130 +0,0 @@
-c main program
- common /cstak/ ds
- double precision ds(1100)
- external handle, bc, af, postd
- integer ndx, k, is(1000), nu, nv, nmesh
- real errpar(2), u(200), v(1), mesh(100), dt, rs(1000)
- real ws(1000), tstop
- logical ls(1000)
- complex cs(500)
- integer temp
- equivalence (ds(1), cs(1), ws(1), rs(1), is(1), ls(1))
-c to test post on
-c u sub t = u sub xx + f on (0,1)
-c by setting u1 = u and u2 = u1 sub x and solving
-c u1 sub t = u1 sub xx + f
-c on (0,1)
-c u1 sub x = u2
-c where f is chosen so that the solution is
-c u(x,t) = exp(xt).
-c the port library stack and its aliases.
-c initialize the port library stack length.
- call istkin(1100, 4)
- nu = 2
- nv = 0
- errpar(1) = 0
-c absolute error.
- errpar(2) = 1e-2
- tstop = 1
- dt = 1e-2
- k = 4
-c ndx uniform mesh points on (0,1).
- ndx = 4
- call umb(0e0, 1e0, ndx, k, mesh, nmesh)
-c initial conditions for u1.
- call setr(nmesh-k, 1e0, u)
-c initial conditions for u2.
- temp = nmesh-k
- call setr(nmesh-k, 0e0, u(temp+1))
- call post(u, nu, k, mesh, nmesh, v, nv, 0e0, tstop, dt, af, bc,
- 1 postd, errpar, handle)
-c check for errors and stack usage statistics.
- call wrapup
- stop
- end
- subroutine af(t, x, nx, u, ux, ut, utx, nu, v, vt, nv, a,
- 1 au, aux, aut, autx, av, avt, f, fu, fux, fut, futx, fv, fvt)
- integer nu, nx
- integer nv
- real t, x(nx), u(nx, nu), ux(nx, nu), ut(nx, nu), utx(nx, nu)
- real v(1), vt(1), a(nx, nu), au(nx, nu, nu), aux(nx, nu, nu), aut(
- 1 nx, nu, nu)
- real autx(nx, nu, nu), av(1), avt(1), f(nx, nu), fu(nx, nu, nu),
- 1 fux(nx, nu, nu)
- real fut(nx, nu, nu), futx(nx, nu, nu), fv(1), fvt(1)
- integer i
- real exp
- do 1 i = 1, nx
- a(i, 1) = -u(i, 2)
- au(i, 1, 2) = -1
- f(i, 1) = (x(i)-t**2)*exp(x(i)*t)-ut(i, 1)
- fut(i, 1, 1) = -1
- a(i, 2) = u(i, 1)
- au(i, 2, 1) = 1
- f(i, 2) = u(i, 2)
- fu(i, 2, 2) = 1
- 1 continue
- return
- end
- subroutine bc(t, l, r, u, ux, ut, utx, nu, v, vt, nv, b, bu,
- 1 bux, but, butx, bv, bvt)
- integer nu
- integer nv
- real t, l, r, u(nu, 2), ux(nu, 2), ut(nu, 2)
- real utx(nu, 2), v(1), vt(1), b(nu, 2), bu(nu, nu, 2), bux(nu, nu,
- 1 2)
- real but(nu, nu, 2), butx(nu, nu, 2), bv(1), bvt(1)
- real exp
- b(1, 1) = u(1, 1)-1.
- b(1, 2) = u(1, 2)-exp(t)
- bu(1, 1, 1) = 1
- bu(1, 1, 2) = 1
- return
- end
- subroutine handle(t0, u0, v0, t, u, v, nu, nxmk, nv, k, x,
- 1 nx, dt, tstop)
- integer nxmk, nu, nx
- integer nv, k
- real t0, u0(nxmk, nu), v0(1), t, u(nxmk, nu), v(1)
- real x(nx), dt, tstop
- common /time/ tt
- real tt
- external u1ofx, u2ofx
- integer i1mach
- real eu(2), eesff
- integer temp
-c output and checking routine.
- if (t0 .eq. t) return
-c u1ofx and u2ofx need time.
- tt = t
- eu(1) = eesff(k, x, nx, u, u1ofx)
- eu(2) = eesff(k, x, nx, u(1, 2), u2ofx)
- temp = i1mach(2)
- write (temp, 1) t, eu
- 1 format (14h error in u(x,, 1pe10.2, 4h ) =, 2(1pe10.2))
- return
- end
- subroutine u1ofx(x, nx, u, w)
- integer nx
- real x(nx), u(nx), w(nx)
- common /time/ t
- real t
- integer i
- real exp
- do 1 i = 1, nx
- u(i) = exp(x(i)*t)
- 1 continue
- return
- end
- subroutine u2ofx(x, nx, u, w)
- integer nx
- real x(nx), u(nx), w(nx)
- common /time/ t
- real t
- integer i
- real exp
- do 1 i = 1, nx
- u(i) = t*exp(x(i)*t)
- 1 continue
- return
- end
diff --git a/CEP/PyBDSM/src/port3/postx3.f b/CEP/PyBDSM/src/port3/postx3.f
deleted file mode 100644
index fbb79d1f9665b367b8fed5dc87c7a8f48fe03e04..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/postx3.f
+++ /dev/null
@@ -1,140 +0,0 @@
-c main program
- common /cstak/ ds
- double precision ds(2000)
- external dee, handle, bc, af
- integer ndx, k, is(1000), nu, nv, nmesh
- real errpar(2), u(100), v(1), mesh(100), dt, rs(1000)
- real ws(1000), tstop
- logical ls(1000)
- complex cs(500)
- equivalence (ds(1), cs(1), ws(1), rs(1), is(1), ls(1))
-c to test post on
-c u sub t = u sub xx + v + f on (0,1)
-c v sub t = u( 1/2, t )
-c where f is chosen so that the solution is
-c u(x,t) = cos(xt) and v(t) = 2 sin(t/2).
-c the port library stack and its aliases.
-c initialize the port library stack length.
- call istkin(2000, 4)
- nu = 1
- nv = 1
- errpar(1) = 1e-2
-c essentially relative error.
- errpar(2) = 1e-6
- tstop = 1
- dt = 1e-6
- k = 4
- ndx = 4
-c ndx uniform mesh points on (0,1).
- call umb(0e0, 1e0, ndx, k, mesh, nmesh)
-c initial conditions for u.
- call setr(nmesh-k, 1e0, u)
-c initial value for v.
- v(1) = 0
- call post(u, nu, k, mesh, nmesh, v, nv, 0e0, tstop, dt, af, bc,
- 1 dee, errpar, handle)
-c check for errors and stack usage statistics.
- call wrapup
- stop
- end
- subroutine af(t, x, nx, u, ux, ut, utx, nu, v, vt, nv, a,
- 1 au, aux, aut, autx, av, avt, f, fu, fux, fut, futx, fv, fvt)
- integer nu, nv, nx
- real t, x(nx), u(nx, nu), ux(nx, nu), ut(nx, nu), utx(nx, nu)
- real v(nv), vt(nv), a(nx, nu), au(nx, nu, nu), aux(nx, nu, nu),
- 1 aut(nx, nu, nu)
- real autx(nx, nu, nu), av(nx, nu, nv), avt(nx, nu, nv), f(nx, nu),
- 1 fu(nx, nu, nu), fux(nx, nu, nu)
- real fut(nx, nu, nu), futx(nx, nu, nu), fv(nx, nu, nv), fvt(nx,
- 1 nu, nv)
- integer i
- real cos, sin
- do 1 i = 1, nx
- a(i, 1) = -ux(i, 1)
- aux(i, 1, 1) = -1
- f(i, 1) = v(1)-ut(i, 1)-x(i)*sin(x(i)*t)+t**2*cos(x(i)*t)-2.*
- 1 sin(t/2.)
- fut(i, 1, 1) = -1
- fv(i, 1, 1) = 1
- 1 continue
- return
- end
- subroutine bc(t, l, r, u, ux, ut, utx, nu, v, vt, nv, b, bu,
- 1 bux, but, butx, bv, bvt)
- integer nu, nv
- real t, l, r, u(nu, 2), ux(nu, 2), ut(nu, 2)
- real utx(nu, 2), v(nv), vt(nv), b(nu, 2), bu(nu, nu, 2), bux(nu,
- 1 nu, 2)
- real but(nu, nu, 2), butx(nu, nu, 2), bv(nu, nv, 2), bvt(nu, nv, 2
- 1 )
- real cos
- b(1, 1) = u(1, 1)-1.
- b(1, 2) = u(1, 2)-cos(t)
- bu(1, 1, 1) = 1
- bu(1, 1, 2) = 1
- return
- end
- subroutine dee(t, k, x, nx, u, ut, nu, nxmk, v, vt, nv, d,
- 1 du, dut, dv, dvt)
- integer nxmk, nu, nv, nx
- integer k
- real t, x(nx), u(nxmk, nu), ut(nxmk, nu), v(nv), vt(nv)
- real d(nv), du(nv, nxmk, nu), dut(nv, nxmk, nu), dv(nv, nv), dvt(
- 1 nv, nv)
- integer intrvr, i, ileft
- real xi(1), basis(10)
- integer temp
- xi(1) = 0.5e0
-c find 0.5 in mesh.
- ileft = intrvr(nx, x, xi(1))
- if (k .gt. 10) call seterr(
- 1 41hdee - k .gt. 10, need more space in basis, 41, 1, 2)
-c b-spline basis at xi(1).
- call bspln(k, x, nx, xi, 1, ileft, basis)
- d(1) = vt(1)
- dvt(1, 1) = 1
-c vt(1) - u(0.5,t) = 0.
- do 1 i = 1, k
- temp = ileft+i-k
- d(1) = d(1)-u(temp, 1)*basis(i)
- temp = ileft+i-k
- du(1, temp, 1) = du(1, temp, 1)-basis(i)
- 1 continue
- return
- end
- subroutine handle(t0, u0, v0, t, u, v, nu, nxmk, nv, k, x,
- 1 nx, dt, tstop)
- integer nxmk, nu, nv, nx
- integer k
- real t0, u0(nxmk, nu), v0(nv), t, u(nxmk, nu), v(nv)
- real x(nx), dt, tstop
- common /time/ tt
- real tt
- external uofx
- integer i1mach
- real abs, sin, eu, ev, eesff
- integer temp
-c output and checking routine.
- if (t0 .eq. t) return
-c uofx needs time.
- tt = t
- eu = eesff(k, x, nx, u, uofx)
- ev = abs(v(1)-2.*sin(t/2.))
- temp = i1mach(2)
- write (temp, 1) t, eu, ev
- 1 format (14h error in u(x,, 1pe10.2, 4h ) =, 1pe10.2, 6h v =, 1p
- 1 e10.2)
- return
- end
- subroutine uofx(x, nx, u, w)
- integer nx
- real x(nx), u(nx), w(nx)
- common /time/ t
- real t
- integer i
- real cos
- do 1 i = 1, nx
- u(i) = cos(x(i)*t)
- 1 continue
- return
- end
diff --git a/CEP/PyBDSM/src/port3/postx4.f b/CEP/PyBDSM/src/port3/postx4.f
deleted file mode 100644
index 8f76526cf2e2efae7ef51c126fb311ac87891bb3..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/postx4.f
+++ /dev/null
@@ -1,129 +0,0 @@
-c main program
- common /cstak/ ds
- double precision ds(2000)
- external dee, handle, bc, af
- integer ndx, k, is(1000), nu, nv, nmesh
- real errpar(2), u(100), v(1), atan, mesh(100), dt
- real rs(1000), ws(1000), tstop
- logical ls(1000)
- complex cs(500)
- equivalence (ds(1), cs(1), ws(1), rs(1), is(1), ls(1))
-c to test post on
-c u sub t = u sub xx - u**3 + f on (-pi,+pi)
-c subject to periodic boundary conditions,
-c where f is chosen so that the solution is
-c u(x,t) = cos(x)*sin(t).
-c the port library stack and its aliases.
-c initialize the port library stack length.
- call istkin(2000, 4)
- nu = 1
- nv = 1
- errpar(1) = 0
-c absolute error.
- errpar(2) = 1e-2
- tstop = 8.*atan(1e0)
- dt = 0.4
-c make a mesh of ndx uniform points on (-pi,+pi).
- k = 4
- ndx = 7
- call umb((-4.)*atan(1e0), 4.*atan(1e0), ndx, k, mesh, nmesh)
-c initial conditions for u.
- call setr(nmesh-k, 0e0, u)
-c initial conditions for v.
- v(1) = 0
- call post(u, nu, k, mesh, nmesh, v, nv, 0e0, tstop, dt, af, bc,
- 1 dee, errpar, handle)
-c check for errors and stack usage statistics.
- call wrapup
- stop
- end
- subroutine af(t, x, nx, u, ux, ut, utx, nu, v, vt, nv, a,
- 1 au, aux, aut, autx, av, avt, f, fu, fux, fut, futx, fv, fvt)
- integer nu, nv, nx
- real t, x(nx), u(nx, nu), ux(nx, nu), ut(nx, nu), utx(nx, nu)
- real v(nv), vt(nv), a(nx, nu), au(nx, nu, nu), aux(nx, nu, nu),
- 1 aut(nx, nu, nu)
- real autx(nx, nu, nu), av(nx, nu, nv), avt(nx, nu, nv), f(nx, nu),
- 1 fu(nx, nu, nu), fux(nx, nu, nu)
- real fut(nx, nu, nu), futx(nx, nu, nu), fv(nx, nu, nv), fvt(nx,
- 1 nu, nv)
- integer i
- real cos, sin
- do 1 i = 1, nx
- a(i, 1) = -ux(i, 1)
- aux(i, 1, 1) = -1
- f(i, 1) = (-ut(i, 1))-u(i, 1)**3+cos(x(i))*(cos(t)+sin(t)+cos(x
- 1 (i))**2*sin(t)**3)
- fut(i, 1, 1) = -1
- fu(i, 1, 1) = (-3.)*u(i, 1)**2
- 1 continue
- return
- end
- subroutine bc(t, l, r, u, ux, ut, utx, nu, v, vt, nv, b, bu,
- 1 bux, but, butx, bv, bvt)
- integer nu, nv
- real t, l, r, u(nu, 2), ux(nu, 2), ut(nu, 2)
- real utx(nu, 2), v(nv), vt(nv), b(nu, 2), bu(nu, nu, 2), bux(nu,
- 1 nu, 2)
- real but(nu, nu, 2), butx(nu, nu, 2), bv(nu, nv, 2), bvt(nu, nv, 2
- 1 )
- b(1, 1) = ux(1, 1)-v(1)
- b(1, 2) = ux(1, 2)-v(1)
- bux(1, 1, 1) = 1
- bv(1, 1, 1) = -1
- bux(1, 1, 2) = 1
- bv(1, 1, 2) = -1
- return
- end
- subroutine dee(t, k, x, nx, u, ut, nu, nxmk, v, vt, nv, d,
- 1 du, dut, dv, dvt)
- integer nxmk, nu, nv, nx
- integer k
- real t, x(nx), u(nxmk, nu), ut(nxmk, nu), v(nv), vt(nv)
- real d(nv), du(nv, nxmk, nu), dut(nv, nxmk, nu), dv(nv, nv), dvt(
- 1 nv, nv)
- integer temp
-c u(-pi,t) - u(+pi,t) = 0.
- temp = nx-k
- d(1) = u(1, 1)-u(temp, 1)
- du(1, 1, 1) = 1
- temp = nx-k
- du(1, temp, 1) = -1
- return
- end
- subroutine handle(t0, u0, v0, t, u, v, nu, nxmk, nv, k, x,
- 1 nx, dt, tstop)
- integer nxmk, nu, nv, nx
- integer k
- real t0, u0(nxmk, nu), v0(nv), t, u(nxmk, nu), v(nv)
- real x(nx), dt, tstop
- common /time/ tt
- real tt
- external uofx
- integer i1mach
- real eu, eesff, ev
- integer temp
-c output and checking routine.
- if (t0 .eq. t) return
-c uofx needs time.
- tt = t
- eu = eesff(k, x, nx, u, uofx)
- ev = v(1)
- temp = i1mach(2)
- write (temp, 1) t, eu, ev
- 1 format (14h error in u(x,, 1pe10.2, 4h ) =, 1pe10.2, 6h v =, 1p
- 1 e10.2)
- return
- end
- subroutine uofx(x, nx, u, w)
- integer nx
- real x(nx), u(nx), w(nx)
- common /time/ t
- real t
- integer i
- real cos, sin
- do 1 i = 1, nx
- u(i) = cos(x(i))*sin(t)
- 1 continue
- return
- end
diff --git a/CEP/PyBDSM/src/port3/postx5.f b/CEP/PyBDSM/src/port3/postx5.f
deleted file mode 100644
index 3f25dfd67c2e6957537fccc7d65fbed42c8a5ce8..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/postx5.f
+++ /dev/null
@@ -1,239 +0,0 @@
-c main program
- common /cstak/ ds
- double precision ds(4000)
- common /time/ t
- real t
- common /param/ vc, x
- real vc(3), x(3)
- external dee, handle, uofx, bc, af
- integer ndx, istkgt, k, immm, iu, is(1000)
- integer nu, nv, imesh, ilumb, nmesh
- real errpar(2), tstart, v(3), dt, xb(3), rs(1000)
- real ws(1000), tstop
- logical ls(1000)
- complex cs(500)
- equivalence (ds(1), cs(1), ws(1), rs(1), is(1), ls(1))
-c to test post on
-c u sub t = ( k(t,x) * u sub x ) sub x + g on (-1,+2) * (0,+1)
-c with a moving front x(t) characterized by u(x(t),t) == 1 and
-c jump across x(t) of k(t,x) u sub x = - 3 * x'(t).
-c where k(t,x) is piecewise constant, say
-c 1 for x < x(t)
-c k(t,x) =
-c 2 for x > x(t)
-c and g is chosen so that the solution is
-c exp(x-x(t)) for x < x(t)
-c u(x,t) =
-c exp(x(t)-x) for x > x(t)
-c and x(1,t) = t. the moving front is tracked
-c implicitly by forcing u(x(1,t),t) = 1 as a pseudo-rankine-heugoniot re
-clation.
-c v(1,2,3) gives the moving mesh.
-c the port library stack and its aliases.
-c initialize the port library stack length.
- call istkin(4000, 4)
- call enter(1)
- nu = 1
- nv = 3
- errpar(1) = 0
-c absolute error.
- errpar(2) = 1e-2
- tstart = 0
- tstop = 1
- dt = 0.1
- k = 4
-c ndx uniform mesh points on each interval of xb array.
- ndx = 6
- xb(1) = 0
- xb(2) = 1
- xb(3) = 2
-c get mesh on port stack.
- imesh = ilumb(xb, 3, ndx, k, nmesh)
-c make 1 of multiplicity k-1.
- imesh = immm(imesh, nmesh, 1e0, k-1)
- x(1) = -1
- x(2) = 0
- x(3) = 2
-c initial values for v.
- call lplmg(3, x, vc)
-c get u on the port stack.
- iu = istkgt(nmesh-k, 3)
-c uofx needs time.
- t = tstart
-c uofx needs v for mapping.
- call movefr(nv, vc, v)
-c initial conditions for u.
- call l2sff(uofx, k, ws(imesh), nmesh, ws(iu))
-c output the ics.
- call handle(t-1., ws(iu), v, t, ws(iu), v, nu, nmesh-k, nv, k, ws(
- 1 imesh), nmesh, dt, tstop)
- call post(ws(iu), nu, k, ws(imesh), nmesh, v, nv, tstart, tstop,
- 1 dt, af, bc, dee, errpar, handle)
- call leave
- call wrapup
- stop
- end
- subroutine af(t, xi, nx, u, ux, ut, utx, nu, v, vt, nv, a,
- 1 au, aux, aut, autx, av, avt, f, fu, fux, fut, futx, fv, fvt)
- integer nu, nv, nx
- real t, xi(nx), u(nx, nu), ux(nx, nu), ut(nx, nu), utx(nx, nu)
- real v(nv), vt(nv), a(nx, nu), au(nx, nu, nu), aux(nx, nu, nu),
- 1 aut(nx, nu, nu)
- real autx(nx, nu, nu), av(nx, nu, nv), avt(nx, nu, nv), f(nx, nu),
- 1 fu(nx, nu, nu), fux(nx, nu, nu)
- real fut(nx, nu, nu), futx(nx, nu, nu), fv(nx, nu, nv), fvt(nx,
- 1 nu, nv)
- common /postf/ failed
- logical failed
- integer i
- real kay, exp, xxi(99), xtv(99), xvv(99), x(99)
- real xxiv(99), ax(99), fx(99), xt(99), xv(99)
- logical temp
- temp = v(2) .le. v(1)
- if (.not. temp) temp = v(2) .ge. v(3)
- if (.not. temp) goto 1
- failed = .true.
- return
-c map xi into x.
- 1 call lplm(xi, nx, v, 3, x, xxi, xxiv, xv, xvv, xt, xtv)
-c map u into x system.
- call postu(xi, x, xt, xxi, xv, vt, nx, 3, ux, ut, nu, ax, fx)
- do 7 i = 1, nx
- if (xi(i) .gt. 1.) goto 2
- kay = 1
- goto 3
- 2 kay = 2
- 3 a(i, 1) = kay*ux(i, 1)
- aux(i, 1, 1) = kay
- if (xi(i) .gt. 1.) goto 4
- a(i, 1) = a(i, 1)-3.*vt(2)
- avt(i, 1, 2) = -3
- 4 f(i, 1) = ut(i, 1)
- fut(i, 1, 1) = 1
- if (xi(i) .gt. 1.) goto 5
- f(i, 1) = f(i, 1)+2.*exp(x(i)-t)
- fx(i) = 2.*exp(x(i)-t)
- goto 6
- 5 f(i, 1) = f(i, 1)+exp(t-x(i))
- fx(i) = -exp(t-x(i))
- 6 continue
- 7 continue
-c map a and f into xi system.
- call posti(xi, x, xt, xxi, xv, xtv, xxiv, xvv, nx, ux, ut, nu, v
- 1 , vt, nv, 1, 3, a, ax, au, aux, aut, autx, av, avt, f, fx, fu
- 2 , fux, fut, futx, fv, fvt)
- return
- end
- subroutine bc(t, l, r, u, ux, ut, utx, nu, v, vt, nv, b, bu,
- 1 bux, but, butx, bv, bvt)
- integer nu, nv
- real t, l, r, u(nu, 2), ux(nu, 2), ut(nu, 2)
- real utx(nu, 2), v(nv), vt(nv), b(nu, 2), bu(nu, nu, 2), bux(nu,
- 1 nu, 2)
- real but(nu, nu, 2), butx(nu, nu, 2), bv(nu, nv, 2), bvt(nu, nv, 2
- 1 )
- real exp
- b(1, 1) = u(1, 1)-exp((-1.)-t)
- b(1, 2) = u(1, 2)-exp(t-2.)
- bu(1, 1, 1) = 1
- bu(1, 1, 2) = 1
- return
- end
- subroutine dee(t, k, x, nx, u, ut, nu, nxmk, v, vt, nv, d,
- 1 du, dut, dv, dvt)
- integer nxmk, nu, nv, nx
- integer k
- real t, x(nx), u(nxmk, nu), ut(nxmk, nu), v(nv), vt(nv)
- real d(nv), du(nv, nxmk, nu), dut(nv, nxmk, nu), dv(nv, nv), dvt(
- 1 nv, nv)
- integer intrvr, i, ileft
- real bx(10), xx(1)
- integer temp
- d(1) = v(1)+1.
-c x(0,v) = -1.
- dv(1, 1) = 1
- xx(1) = 1
-c find 1 in the mesh.
- ileft = intrvr(nx, x, xx(1))
-c get the b-spline basis at xx.
- call bspln(k, x, nx, xx, 1, ileft, bx)
-c u(x(1,v),t) = 1.
- d(2) = -1
- do 1 i = 1, k
- temp = ileft+i-k
- d(2) = d(2)+u(temp, 1)*bx(i)
- temp = ileft+i-k
- du(2, temp, 1) = bx(i)
- 1 continue
- d(3) = v(3)-2.
-c x(2,v) = +2.
- dv(3, 3) = 1
- return
- end
- subroutine handle(t0, u0, v0, t, u, v, nu, nxmk, nv, k, x,
- 1 nx, dt, tstop)
- integer nxmk, nu, nv, nx
- integer k
- real t0, u0(nxmk, nu), v0(nv), t, u(nxmk, nu), v(nv)
- real x(nx), dt, tstop
- common /param/ vc, xx
- real vc(3), xx(3)
- common /time/ tt
- real tt
- external uofx
- integer i1mach
- real eu, eesff, ev(3)
- integer temp
-c output and checking routine.
- if (t0 .ne. t) goto 2
- temp = i1mach(2)
- write (temp, 1) t
- 1 format (16h restart for t =, 1pe10.2)
- return
- 2 tt = t
-c uofx needs v for mapping.
- call movefr(nv, v, vc)
- eu = eesff(k, x, nx, u, uofx)
- ev(1) = v(1)+1.
- ev(2) = v(2)-t
- ev(3) = v(3)-2.
- temp = i1mach(2)
- write (temp, 3) t, eu, ev
- 3 format (14h error in u(x,, 1pe10.2, 4h ) =, 1pe10.2, 6h v =, 3(
- 1 1pe10.2))
- return
- end
- subroutine uofx(xi, nx, u, w)
- integer nx
- real xi(nx), u(nx), w(nx)
- common /cstak/ ds
- double precision ds(500)
- common /param/ vc, x
- real vc(3), x(3)
- common /time/ t
- real t
- integer ixv, ixx, istkgt, i, is(1000)
- real exp, rs(1000), ws(1000), xofxi
- logical ls(1000)
- complex cs(500)
- integer temp
- equivalence (ds(1), cs(1), ws(1), rs(1), is(1), ls(1))
-c the port library stack and its aliases.
- call enter(1)
- ixx = istkgt(nx, 3)
-c space for x and xv.
- ixv = istkgt(3*nx, 3)
-c map into user system.
- call lplmx(xi, nx, vc, 3, ws(ixx), ws(ixv))
- do 3 i = 1, nx
- temp = ixx+i
- xofxi = ws(temp-1)
- if (xi(i) .gt. 1.) goto 1
- u(i) = exp(xofxi-t)
- goto 2
- 1 u(i) = exp(t-xofxi)
- 2 continue
- 3 continue
- call leave
- return
- end
diff --git a/CEP/PyBDSM/src/port3/postx6.f b/CEP/PyBDSM/src/port3/postx6.f
deleted file mode 100644
index 8e69eb124f830548f8509de365171646755cb671..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/postx6.f
+++ /dev/null
@@ -1,245 +0,0 @@
-c main program
- common /cstak/ ds
- double precision ds(4000)
- common /time/ t
- real t
- common /param/ vc, x
- real vc(4), x(3)
- external dee, handle, uofx, bc, af
- integer ndx, istkgt, k, immm, iu, is(1000)
- integer nu, nv, imesh, ilumb, nmesh
- real errpar(2), tstart, v(4), dt, xb(3), rs(1000)
- real ws(1000), tstop
- logical ls(1000)
- complex cs(500)
- equivalence (ds(1), cs(1), ws(1), rs(1), is(1), ls(1))
-c to test post on the hyperbolic problem
-c u sub t = - u sub x + g on (-pi,+pi) * (0,pi)
-c with a moving shock x(t) characterized by
-c u(x(t)+,t) = 0 and
-c u(x(t)+,t) - u(x(t)-,t) = x'(t)
-c where g is chosen so that the solution is
-c sin(x+t) for x < x(t)
-c u(x,t) =
-c cos(x+t) for x > x(t)
-c with x(t) = pi/2 -t .
-c v(1,2,3) gives the moving mesh and v(4) is the height of the jump.
-c the port library stack and its aliases.
-c initialize the port library stack length.
- call istkin(4000, 4)
- call enter(1)
- nu = 1
- nv = 4
- errpar(1) = 0
-c absolute error.
- errpar(2) = 1e-2
- tstart = 0
- tstop = 3.14
- dt = 0.4
- k = 4
-c ndx uniform mesh points on each interval of xb.
- ndx = 6
- xb(1) = 0
- xb(2) = 1
- xb(3) = 2
-c get mesh on port stack.
- imesh = ilumb(xb, 3, ndx, k, nmesh)
-c make 1 of multiplicity k-1.
- imesh = immm(imesh, nmesh, 1e0, k-1)
- x(1) = -3.14
- x(2) = 3.14/2.
- x(3) = 3.14
-c initial values for v.
- call lplmg(3, x, vc)
-c get u on the port stack.
- iu = istkgt(nmesh-k, 3)
-c uofx needs time.
- t = tstart
-c the initial height of the jump.
- vc(4) = 1
-c uofx needs v for mapping.
- call movefr(nv, vc, v)
-c initial conditions for u.
- call l2sff(uofx, k, ws(imesh), nmesh, ws(iu))
-c output ics.
- call handle(t-1., ws(iu), v, t, ws(iu), v, nu, nmesh-k, nv, k, ws(
- 1 imesh), nmesh, dt, tstop)
- call post(ws(iu), nu, k, ws(imesh), nmesh, v, nv, tstart, tstop,
- 1 dt, af, bc, dee, errpar, handle)
- call leave
- call wrapup
- stop
- end
- subroutine af(t, xi, nx, u, ux, ut, utx, nu, v, vt, nv, a,
- 1 au, aux, aut, autx, av, avt, f, fu, fux, fut, futx, fv, fvt)
- integer nu, nv, nx
- real t, xi(nx), u(nx, nu), ux(nx, nu), ut(nx, nu), utx(nx, nu)
- real v(nv), vt(nv), a(nx, nu), au(nx, nu, nu), aux(nx, nu, nu),
- 1 aut(nx, nu, nu)
- real autx(nx, nu, nu), av(nx, nu, nv), avt(nx, nu, nv), f(nx, nu),
- 1 fu(nx, nu, nu), fux(nx, nu, nu)
- real fut(nx, nu, nu), futx(nx, nu, nu), fv(nx, nu, nv), fvt(nx,
- 1 nu, nv)
- common /postf/ failed
- logical failed
- integer i
- real cos, sin, xxi(99), xtv(99), xvv(99), x(99)
- real xxiv(99), ax(99), fx(99), xt(99), xv(99)
- logical temp
- temp = v(2) .le. v(1)
- if (.not. temp) temp = v(2) .ge. v(3)
- if (.not. temp) goto 1
- failed = .true.
- return
-c map xi into x.
- 1 call lplm(xi, nx, v, 3, x, xxi, xxiv, xv, xvv, xt, xtv)
-c map u into x system.
- call postu(xi, x, xt, xxi, xv, vt, nx, 3, ux, ut, nu, ax, fx)
- do 4 i = 1, nx
- a(i, 1) = -u(i, 1)
- au(i, 1, 1) = -1
- f(i, 1) = ut(i, 1)
- fut(i, 1, 1) = 1
- if (xi(i) .gt. 1.) goto 2
- f(i, 1) = f(i, 1)-2.*cos(x(i)+t)
- fx(i) = 2.*sin(x(i)+t)
- goto 3
- 2 f(i, 1) = f(i, 1)-vt(4)
- fvt(i, 1, 4) = -1
- f(i, 1) = f(i, 1)+2.*sin(x(i)+t)
- fx(i) = 2.*cos(x(i)+t)
- 3 continue
- 4 continue
-c map a and f into xi system.
- call posti(xi, x, xt, xxi, xv, xtv, xxiv, xvv, nx, ux, ut, nu, v
- 1 , vt, nv, 1, 3, a, ax, au, aux, aut, autx, av, avt, f, fx, fu
- 2 , fux, fut, futx, fv, fvt)
- return
- end
- subroutine bc(t, l, r, u, ux, ut, utx, nu, v, vt, nv, b, bu,
- 1 bux, but, butx, bv, bvt)
- integer nu, nv
- real t, l, r, u(nu, 2), ux(nu, 2), ut(nu, 2)
- real utx(nu, 2), v(nv), vt(nv), b(nu, 2), bu(nu, nu, 2), bux(nu,
- 1 nu, 2)
- real but(nu, nu, 2), butx(nu, nu, 2), bv(nu, nv, 2), bvt(nu, nv, 2
- 1 )
- real sin
- b(1, 1) = u(1, 1)-sin(t-3.14)
-c u(-pi,t) = sin(-pi+t).
- bu(1, 1, 1) = 1
- return
- end
- subroutine dee(t, k, x, nx, u, ut, nu, nxmk, v, vt, nv, d,
- 1 du, dut, dv, dvt)
- integer nxmk, nu, nv, nx
- integer k
- real t, x(nx), u(nxmk, nu), ut(nxmk, nu), v(nv), vt(nv)
- real d(nv), du(nv, nxmk, nu), dut(nv, nxmk, nu), dv(nv, nv), dvt(
- 1 nv, nv)
- integer intrvr, i, ileft
- real bx(10), xx(1), r1mach
- integer temp
- d(1) = v(1)+3.14
-c x(0,v) = -pi.
- dv(1, 1) = 1
-c xx(1) = 1 + a rounding error.
- xx(1) = r1mach(4)+1.
- ileft = intrvr(nx, x, xx(1))
-c get the b-spline basis at xx.
- call bspln(k, x, nx, xx, 1, ileft, bx)
- d(2) = -v(4)
-c u(x(t)+,t) - jump = 0.
- dv(2, 4) = -1
- do 1 i = 1, k
- temp = ileft+i-k
- d(2) = d(2)+u(temp, 1)*bx(i)
- temp = ileft+i-k
- du(2, temp, 1) = bx(i)
- 1 continue
- d(3) = v(3)-3.14
-c x(2,v) = +pi.
- dv(3, 3) = 1
-c jump + d( x(1,v(t)) )/dt = 0.
- d(4) = vt(2)+v(4)
- dvt(4, 2) = 1
- dv(4, 4) = 1
- return
- end
- subroutine handle(t0, u0, v0, t, u, v, nu, nxmk, nv, k, x,
- 1 nx, dt, tstop)
- integer nxmk, nu, nv, nx
- integer k
- real t0, u0(nxmk, nu), v0(nv), t, u(nxmk, nu), v(nv)
- real x(nx), dt, tstop
- common /param/ vc, xx
- real vc(4), xx(3)
- common /time/ tt
- real tt
- external uofx
- integer i1mach
- real eu, eesff, ev(2)
- integer temp
-c output and checking routine.
- if (t0 .ne. t) goto 2
- temp = i1mach(2)
- write (temp, 1) t, dt
- 1 format (16h restart for t =, 1pe10.2, 7h dt =, 1pe10.2)
- return
- 2 tt = t
-c uofx needs v for mapping.
- call movefr(nv, v, vc)
- eu = eesff(k, x, nx, u, uofx)
-c error in position of shock.
- ev(1) = v(2)-(3.14/2.-t)
-c error in height of shock.
- ev(2) = v(4)-1.
- temp = i1mach(2)
- write (temp, 3) t, eu, ev
- 3 format (14h error in u(x,, 1pe10.2, 4h ) =, 1pe10.2, 6h v =, 2(
- 1 1pe10.2))
- return
- end
- subroutine uofx(xi, nx, u, w)
- integer nx
- real xi(nx), u(nx), w(nx)
- common /cstak/ ds
- double precision ds(500)
- common /param/ vc, x
- real vc(4), x(3)
- common /time/ t
- real t
- integer ixv, ixx, istkgt, i, is(1000)
- real ewe, rs(1000), ws(1000)
- logical ls(1000)
- complex cs(500)
- integer temp
- equivalence (ds(1), cs(1), ws(1), rs(1), is(1), ls(1))
-c the port library stack and its aliases.
- call enter(1)
- ixx = istkgt(nx, 3)
-c space for x and xv.
- ixv = istkgt(3*nx, 3)
-c map into user system.
- call lplmx(xi, nx, vc, 3, ws(ixx), ws(ixv))
- do 1 i = 1, nx
- temp = ixx+i
- u(i) = ewe(t, ws(temp-1), vc(2))
- if (xi(i) .gt. 1.) u(i) = u(i)+1.
- 1 continue
- call leave
- return
- end
- real function ewe(t, x, xbreak)
- real t, x, xbreak
- real cos, sin
- if (x .ge. xbreak) goto 1
- ewe = sin(x+t)
- return
- 1 if (x .le. xbreak) goto 2
- ewe = cos(x+t)
- return
- 2 call seterr(17hewe - x == xbreak, 17, 1, 2)
- 3 continue
- 4 stop
- end
diff --git a/CEP/PyBDSM/src/port3/postx7.f b/CEP/PyBDSM/src/port3/postx7.f
deleted file mode 100644
index 650bdf9103922ba69a80bfdea847c06be8667e28..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/postx7.f
+++ /dev/null
@@ -1,227 +0,0 @@
-c main program
- common /cstak/ ds
- double precision ds(4000)
- common /time/ t
- real t
- common /param/ vc, x, xi0
- real vc(4), x(3), xi0
- external dee, handle, uofx, bc, af
- integer ndx, istkgt, k, immm, iu, is(1000)
- integer nu, nv, imesh, ilumb, nmesh
- real errpar(2), tstart, d, v(4), dt, xb(3)
- real rs(1000), ws(1000), tstop
- logical ls(1000)
- complex cs(500)
- equivalence (ds(1), cs(1), ws(1), rs(1), is(1), ls(1))
-c to test post on
-c u sub t = u sub xx + f on (20,10**6)
-c where f is chosen so that the solution is
-c u(x,t) = exp(-x*t),
-c and x(1,t) is chosen so that the boundary-layer is tracked
-c implicitly by forcing u(x(1,t)/2.3/d,t) = 1/e.
-c this is the same as requiring the exact solution to have
-c u(x(1,t),t) = 10 ** -d.
-c v(1,2,3) gives the moving mesh, v(4) is time.
-c the port library stack and its aliases.
-c initialize the port library stack length.
- call istkin(4000, 4)
- call enter(1)
- nu = 1
- nv = 4
- errpar(1) = 1e-2
-c mixed relative and absolute error.
- errpar(2) = 1e-2
- d = 3
-c w(xi0,t) = 1/e.
- xi0 = 1./2.3/d
- tstart = 20
- tstop = 1e+6
- dt = 1e-2
- k = 4
-c ndx uniform mesh points on each interval of xb.
- ndx = 6
- xb(1) = 0
- xb(2) = 1
- xb(3) = 2
-c get mesh on port stack.
- imesh = ilumb(xb, 3, ndx, k, nmesh)
-c make 1d0 of multiplicity k-1.
- imesh = immm(imesh, nmesh, 1e0, k-1)
- x(1) = 0
- x(2) = 2.3*d/tstart
- x(3) = 1
-c initial values for v.
- call lplmg(3, x, vc)
-c get u on port stack.
- iu = istkgt(nmesh-k, 3)
-c uofx needs time.
- t = tstart
- vc(4) = tstart
-c uofx needs v for mapping.
- call movefr(nv, vc, v)
-c initial conditions for u.
- call l2sff(uofx, k, ws(imesh), nmesh, ws(iu))
-c output ics.
- call handle(t-1., ws(iu), v, t, ws(iu), v, nu, nmesh-k, nv, k, ws(
- 1 imesh), nmesh, dt, tstop)
- call post(ws(iu), nu, k, ws(imesh), nmesh, v, nv, tstart, tstop,
- 1 dt, af, bc, dee, errpar, handle)
- call leave
- call wrapup
- stop
- end
- subroutine af(t, xi, nx, u, ux, ut, utx, nu, v, vt, nv, a,
- 1 au, aux, aut, autx, av, avt, f, fu, fux, fut, futx, fv, fvt)
- integer nu, nv, nx
- real t, xi(nx), u(nx, nu), ux(nx, nu), ut(nx, nu), utx(nx, nu)
- real v(nv), vt(nv), a(nx, nu), au(nx, nu, nu), aux(nx, nu, nu),
- 1 aut(nx, nu, nu)
- real autx(nx, nu, nu), av(nx, nu, nv), avt(nx, nu, nv), f(nx, nu),
- 1 fu(nx, nu, nu), fux(nx, nu, nu)
- real fut(nx, nu, nu), futx(nx, nu, nu), fv(nx, nu, nv), fvt(nx,
- 1 nu, nv)
- common /postf/ failed
- logical failed
- integer i
- real xxi(99), xtv(99), xvv(99), x(99), expl, xxiv(99)
- real ax(99), fx(99), xt(99), xv(99)
- logical temp
- temp = v(2) .le. v(1)
- if (.not. temp) temp = v(2) .ge. v(3)
- if (.not. temp) goto 1
- failed = .true.
- return
-c map xi into x.
- 1 call lplm(xi, nx, v, 3, x, xxi, xxiv, xv, xvv, xt, xtv)
-c map u into x system.
- call postu(xi, x, xt, xxi, xv, vt, nx, 3, ux, ut, nu, ax, fx)
- do 2 i = 1, nx
- a(i, 1) = -ux(i, 1)
- aux(i, 1, 1) = -1
- f(i, 1) = (-ut(i, 1))-expl((-x(i))*v(4))*(x(i)+v(4)**2)
- fut(i, 1, 1) = -1
- fv(i, 1, 4) = (-expl((-x(i))*v(4)))*(2.*v(4)+(x(i)+v(4)**2)*(-x
- 1 (i)))
- fx(i) = (-expl((-x(i))*v(4)))*(1.-v(4)*x(i)-v(4)**3)
- 2 continue
-c map a and f into xi system.
- call posti(xi, x, xt, xxi, xv, xtv, xxiv, xvv, nx, ux, ut, nu, v
- 1 , vt, nv, 1, 3, a, ax, au, aux, aut, autx, av, avt, f, fx, fu
- 2 , fux, fut, futx, fv, fvt)
- return
- end
- subroutine bc(t, l, r, u, ux, ut, utx, nu, v, vt, nv, b, bu,
- 1 bux, but, butx, bv, bvt)
- integer nu, nv
- real t, l, r, u(nu, 2), ux(nu, 2), ut(nu, 2)
- real utx(nu, 2), v(nv), vt(nv), b(nu, 2), bu(nu, nu, 2), bux(nu,
- 1 nu, 2)
- real but(nu, nu, 2), butx(nu, nu, 2), bv(nu, nv, 2), bvt(nu, nv, 2
- 1 )
- real expl
-c u(0,t) = 1
- b(1, 1) = u(1, 1)-1.
-c u(1,t) = exp(-t)
- b(1, 2) = u(1, 2)-expl(-v(4))
- bu(1, 1, 1) = 1
- bu(1, 1, 2) = 1
- bv(1, 4, 2) = expl(-v(4))
- return
- end
- subroutine dee(t, k, x, nx, u, ut, nu, nxmk, v, vt, nv, d,
- 1 du, dut, dv, dvt)
- integer nxmk, nu, nv, nx
- integer k
- real t, x(nx), u(nxmk, nu), ut(nxmk, nu), v(nv), vt(nv)
- real d(nv), du(nv, nxmk, nu), dut(nv, nxmk, nu), dv(nv, nv), dvt(
- 1 nv, nv)
- common /param/ vc, xc, xi0
- real vc(4), xc(3), xi0
- integer intrvr, i, ileft
- real exp, bx(10), xx(1)
- integer temp
- d(1) = v(1)
-c x(0,v) = 0.
- dv(1, 1) = 1
- xx(1) = xi0
- ileft = intrvr(nx, x, xx(1))
-c get the b-spline basis at xx.
- call bspln(k, x, nx, xx, 1, ileft, bx)
- d(2) = -exp(-1e0)
-c d(2) = w(xi0,t) - exp(-1).
- do 1 i = 1, k
- temp = ileft+i-k
- d(2) = d(2)+u(temp, 1)*bx(i)
- temp = ileft+i-k
- du(2, temp, 1) = bx(i)
- 1 continue
- d(3) = v(3)-1.
-c x(2,v) = 1.
- dv(3, 3) = 1
- d(4) = vt(4)-1.
- dvt(4, 4) = 1
- return
- end
- subroutine handle(t0, u0, v0, t, u, v, nu, nxmk, nv, k, x,
- 1 nx, dt, tstop)
- integer nxmk, nu, nv, nx
- integer k
- real t0, u0(nxmk, nu), v0(nv), t, u(nxmk, nu), v(nv)
- real x(nx), dt, tstop
- common /param/ vc, xx, xi0
- real vc(4), xx(3), xi0
- common /time/ tt
- real tt
- external uofx
- integer i1mach
- real eu, eesff, ev, lplmt
- integer temp
-c output and checking routine.
- if (t0 .ne. t) goto 2
- temp = i1mach(2)
- write (temp, 1) t, dt
- 1 format (16h restart for t =, 1pe10.2, 7h dt =, 1pe10.2)
- return
-c let dt carry v(2) down by no more than a factor of 10.
- 2 dt = lplmt(t, v, nv, t0, v0, 1e-1, dt)
- tt = t
-c uofx needs v for mapping.
- call movefr(nv, v, vc)
- eu = eesff(k, x, nx, u, uofx)
-c error in position of boundary layer.
- ev = v(2)-1./xi0/t
- temp = i1mach(2)
- write (temp, 3) t, eu, ev
- 3 format (14h error in u(x,, 1pe10.2, 4h ) =, 1pe10.2, 6h v =, 1p
- 1 e10.2)
- return
- end
- subroutine uofx(xi, nx, u, w)
- integer nx
- real xi(nx), u(nx), w(nx)
- common /cstak/ ds
- double precision ds(500)
- common /param/ vc, x, xi0
- real vc(4), x(3), xi0
- common /time/ t
- real t
- integer ixv, ixx, istkgt, i, is(1000)
- real expl, rs(1000), ws(1000)
- logical ls(1000)
- complex cs(500)
- integer temp
- equivalence (ds(1), cs(1), ws(1), rs(1), is(1), ls(1))
-c the port library stack and its aliases.
- call enter(1)
- ixx = istkgt(nx, 3)
-c space for x and xv.
- ixv = istkgt(3*nx, 3)
-c map into user system.
- call lplmx(xi, nx, vc, 3, ws(ixx), ws(ixv))
- do 1 i = 1, nx
- temp = ixx+i
- u(i) = expl((-ws(temp-1))*t)
- 1 continue
- call leave
- return
- end
diff --git a/CEP/PyBDSM/src/port3/postx8.f b/CEP/PyBDSM/src/port3/postx8.f
deleted file mode 100644
index 56c23382bca6cf187744bbea168ebc0e306a55e1..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/postx8.f
+++ /dev/null
@@ -1,210 +0,0 @@
-c main program
- common /cstak/ ds
- double precision ds(5000)
- common /time/ t
- real t
- common /kmesh/ k, nmesh
- integer k, nmesh
- common /cmesh/ mesh
- real mesh(100)
- external dee, handle, uofx, bc, af
- integer ndx, i, is(1000), nu, nv
- real errpar(2), u(100), v(100), dt, rs(1000), ws(1000)
- real tstop
- logical ls(1000)
- complex cs(500)
- integer temp
- equivalence (ds(1), cs(1), ws(1), rs(1), is(1), ls(1))
-c to test post on the integro-pde
-c u sub t = 2 * u sub xx - int(0,1) exp(x-y)*u(y) dy on (0,1)
-c subject to given dirichlet bcs, chosen so that the solution is
-c u(x,t) = exp(t+x).
-c the port library stack and its aliases.
-c initialize the port library stack length.
- call istkin(5000, 4)
- nu = 1
- errpar(1) = 0
-c absolute error.
- errpar(2) = 1e-2
- tstop = 1
- dt = 1e-2
- k = 4
-c ndx uniform mesh points on (0,1).
- ndx = 7
- call umb(0e0, 1e0, ndx, k, mesh, nmesh)
- nv = nmesh-k
-c uofx needs t.
- t = 0
-c ics for u.
- call l2sff(uofx, k, mesh, nmesh, u)
- temp = nmesh-k
- do 1 i = 1, temp
- v(i) = u(i)
- 1 continue
-c ics for v.
- call post(u, nu, k, mesh, nmesh, v, nv, 0e0, tstop, dt, af, bc,
- 1 dee, errpar, handle)
- call wrapup
- stop
- end
- subroutine af(t, x, nx, u, ux, ut, utx, nu, v, vt, nv, a,
- 1 au, aux, aut, autx, av, avt, f, fu, fux, fut, futx, fv, fvt)
- integer nu, nv, nx
- real t, x(nx), u(nx, nu), ux(nx, nu), ut(nx, nu), utx(nx, nu)
- real v(nv), vt(nv), a(nx, nu), au(nx, nu, nu), aux(nx, nu, nu),
- 1 aut(nx, nu, nu)
- real autx(nx, nu, nu), av(nx, nu, nv), avt(nx, nu, nv), f(nx, nu),
- 1 fu(nx, nu, nu), fux(nx, nu, nu)
- real fut(nx, nu, nu), futx(nx, nu, nu), fv(nx, nu, nv), fvt(nx,
- 1 nu, nv)
- common /kmesh/ k, nmesh
- integer k, nmesh
- common /cmesh/ mesh
- real mesh(100)
- integer i
- do 1 i = 1, nx
- a(i, 1) = 2.*ux(i, 1)
- aux(i, 1, 1) = 2
- f(i, 1) = ut(i, 1)
- fut(i, 1, 1) = 1
- 1 continue
-c get the integral.
- call intgrl(k, mesh, nmesh, v, x, nx, f, fv)
- return
- end
- subroutine bc(t, l, r, u, ux, ut, utx, nu, v, vt, nv, b, bu,
- 1 bux, but, butx, bv, bvt)
- integer nu, nv
- real t, l, r, u(nu, 2), ux(nu, 2), ut(nu, 2)
- real utx(nu, 2), v(nv), vt(nv), b(nu, 2), bu(nu, nu, 2), bux(nu,
- 1 nu, 2)
- real but(nu, nu, 2), butx(nu, nu, 2), bv(nu, nv, 2), bvt(nu, nv, 2
- 1 )
- real exp
- b(1, 1) = u(1, 1)-exp(t)
- b(1, 2) = u(1, 2)-exp(t+1.)
- bu(1, 1, 1) = 1
- bu(1, 1, 2) = 1
- return
- end
- subroutine dee(t, k, x, nx, u, ut, nu, nxmk, v, vt, nv, d,
- 1 du, dut, dv, dvt)
- integer nxmk, nu, nv, nx
- integer k
- real t, x(nx), u(nxmk, nu), ut(nxmk, nu), v(nv), vt(nv)
- real d(nv), du(nv, nxmk, nu), dut(nv, nxmk, nu), dv(nv, nv), dvt(
- 1 nv, nv)
- integer i
- do 1 i = 1, nxmk
- d(i) = u(i, 1)-v(i)
- du(i, i, 1) = 1
- dv(i, i) = -1
- 1 continue
- return
- end
- subroutine handle(t0, u0, v0, t, u, v, nu, nxmk, nv, k, x,
- 1 nx, dt, tstop)
- integer nxmk, nu, nv, nx
- integer k
- real t0, u0(nxmk, nu), v0(nv), t, u(nxmk, nu), v(nv)
- real x(nx), dt, tstop
- common /time/ tt
- real tt
- external uofx
- integer i1mach
- real eu, eesff
- integer temp
-c output and checking routine.
- if (t0 .ne. t) goto 2
- temp = i1mach(2)
- write (temp, 1) t0, dt
- 1 format (16h restart for t =, 1pe10.2, 7h dt =, 1pe10.2)
- return
- 2 tt = t
- eu = eesff(k, x, nx, u, uofx)
- temp = i1mach(2)
- write (temp, 3) t, eu
- 3 format (14h error in u(x,, 1pe10.2, 4h ) =, 1pe10.2)
- return
- end
- subroutine uofx(x, nx, u, w)
- integer nx
- real x(nx), u(nx), w(nx)
- common /time/ t
- real t
- integer i
- real exp
- do 1 i = 1, nx
- u(i) = exp(t+x(i))
- 1 continue
- return
- end
- subroutine intgrl(k, mesh, nmesh, v, x, nx, f, fv)
- integer nx, nmesh
- integer k
- real mesh(nmesh), v(1), x(nx), f(nx), fv(nx, 1)
- integer mgq, i, j, l, ix
- real ewe, ker, wgq(3), xgq(3), b(3, 4, 200), keru
- real xx(3)
- logical first
- integer temp, temp1
- data first/.true./
-c to compute
-c f = integral from mesh(1) to mesh(nmesh)
-c kernel(x,y,sum(i=1,...,nmesh-k) v(i)*b(i,y)) dy
-c and
-c fv = d(f)/d(v).
-c assume that call kernel(x,y,u,ker,keru) returns
-c ker = kernel(x,y,u) and
-c keru = partial kernel / partial u.
-c v(nmesh-k),fv(nx,nmesh-k)
-c the following declaration is specific to k = 4 splines.
- if (nmesh-k .gt. 200) call seterr(27hintgrl - nmesh-k .gt. nxmax
- 1 , 27, 1, 2)
-c need more local space.
- if (k .ne. 4) call seterr(17hintgrl - k .ne. 4, 17, 2, 2)
-c use k-1 point gaussian-quadrature rule on each interval.
- mgq = k-1
- if (first) call gqm11(mgq, xgq, wgq)
-c only get gq rule once, its expensive.
-c the gaussian quadrature rule.
-c do integral interval by interval.
- temp = nmesh-k
- do 6 i = k, temp
-c g.q. points on (mesh(i), mesh(i+1)).
- do 1 j = 1, mgq
- xx(j) = 0.5*(mesh(i+1)+mesh(i))+0.5*(mesh(i+1)-mesh(i))*xgq(
- 1 j)
- 1 continue
- if (first) call bspln(k, mesh, nmesh, xx, mgq, i, b(1, 1, i))
-c only get b-spline basis once, its expensive.
- do 5 j = 1, mgq
-c get sum() v()*b()(xx).
- ewe = 0
- do 2 l = 1, k
- temp1 = i+l-k
- ewe = ewe+v(temp1)*b(j, l, i)
- 2 continue
- do 4 ix = 1, nx
-c get kernel and partial.
- call kernel(x(ix), xx(j), ewe, ker, keru)
- f(ix) = f(ix)+0.5*ker*(mesh(i+1)-mesh(i))*wgq(j)
- do 3 l = 1, k
- temp1 = i+l-k
- fv(ix, temp1) = fv(ix, temp1)+0.5*b(j, l, i)*keru*(
- 1 mesh(i+1)-mesh(i))*wgq(j)
- 3 continue
- 4 continue
- 5 continue
- 6 continue
- first = .false.
- return
- end
- subroutine kernel(x, y, u, ker, keru)
- real x, y, u, ker, keru
- real exp
-c to evaluate the kernel exp(x-y)*u(y) and its partial wrt. u.
- keru = exp(x-y)
- ker = keru*u
- return
- end
diff --git a/CEP/PyBDSM/src/port3/postx9.f b/CEP/PyBDSM/src/port3/postx9.f
deleted file mode 100644
index 7b2bc50fb240a0ad26c68b17304a1002841b8a2e..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/postx9.f
+++ /dev/null
@@ -1,150 +0,0 @@
-c main program
- common /cstak/ ds
- double precision ds(2000)
- common /param/ c
- real c
- external handle, bc, af, postd
- integer ndx, nxc, nxx, i, k, is(1000)
- integer nu, nv, nx, i1mach
- real ewe(1000), err, errpar(2), u(100), v(1), x(100)
- real errr, dt, xc(100), uc(100), eebsf, rs(1000)
- real ws(1000), xx(1000), tstop, r1mach
- logical ls(1000)
- complex cs(500)
- integer temp
- equivalence (ds(1), cs(1), ws(1), rs(1), is(1), ls(1))
-c to test post on automatic, static mesh refinement.
-c u sub t = u sub xx + c * u sub x on (0,1)
-c the solution is
-c u(x,t) = exp(-c*x).
-c the port library stack and its aliases.
-c initialize the port library stack length.
- call istkin(2000, 4)
- c = 50
- nu = 1
- nv = 0
- errpar(1) = 1e-1
- errpar(2) = 1e-1
- k = 4
- ndx = 8
- call umb(0e0, 1e0, ndx, k, xc, nxc)
-c initial conditions for uc.
- call setr(nxc-k, 0e0, uc)
-c infinity.
- err = r1mach(2)
- 1 if (err .le. 1e-2) goto 6
-c halve the crude x.
- call lumb(xc, nxc, 3, k, x, nx)
-c fitting points for refinement.
- call lumd(x, nx, k, xx, nxx)
-c uc on xx.
- call splne(k, xc, nxc, uc, xx, nxx, ewe)
-c fit u to uc on mesh.
- call dl2sf(xx, ewe, nxx, k, x, nx, u)
- tstop = 1./r1mach(4)
- dt = 1e-6
- i = nx-2*(k-1)
- temp = i1mach(2)
- write (temp, 2) i
- 2 format (18h solving for ndx =, i3)
- call post(u, nu, k, x, nx, v, nv, 0e0, tstop, dt, af, bc,
- 1 postd, errpar, handle)
-c get run-time statistics.
- call postx
-c error estimate for uc.
- err = eebsf(k, xc, nxc, uc, x, nx, u)
-c error estimate for u.
- errr = err/16.
- temp = i1mach(2)
- write (temp, 3) err, errr
- 3 format (21h error estimates uc =, 1pe10.2, 9h and u =, 1p
- 1 e10.2)
- nxc = nx
- do 4 i = 1, nx
- xc(i) = x(i)
- 4 continue
- temp = nx-k
- do 5 i = 1, temp
- uc(i) = u(i)
- 5 continue
- goto 1
- 6 stop
- end
- subroutine af(t, x, nx, u, ux, ut, utx, nu, v, vt, nv, a,
- 1 au, aux, aut, autx, av, avt, f, fu, fux, fut, futx, fv, fvt)
- integer nu, nx
- integer nv
- real t, x(nx), u(nx, nu), ux(nx, nu), ut(nx, nu), utx(nx, nu)
- real v(1), vt(1), a(nx, nu), au(nx, nu, nu), aux(nx, nu, nu), aut(
- 1 nx, nu, nu)
- real autx(nx, nu, nu), av(1), avt(1), f(nx, nu), fu(nx, nu, nu),
- 1 fux(nx, nu, nu)
- real fut(nx, nu, nu), futx(nx, nu, nu), fv(1), fvt(1)
- common /param/ c
- real c
- integer i
- do 1 i = 1, nx
- a(i, 1) = ux(i, 1)+c*u(i, 1)
- aux(i, 1, 1) = 1
- au(i, 1, 1) = c
- f(i, 1) = ut(i, 1)
- fut(i, 1, 1) = 1
- 1 continue
- return
- end
- subroutine bc(t, l, r, u, ux, ut, utx, nu, v, vt, nv, b, bu,
- 1 bux, but, butx, bv, bvt)
- integer nu
- integer nv
- real t, l, r, u(nu, 2), ux(nu, 2), ut(nu, 2)
- real utx(nu, 2), v(1), vt(1), b(nu, 2), bu(nu, nu, 2), bux(nu, nu,
- 1 2)
- real but(nu, nu, 2), butx(nu, nu, 2), bv(1), bvt(1)
- common /param/ c
- real c
- real exp
- b(1, 1) = u(1, 1)-1.
- b(1, 2) = u(1, 2)-exp(-c)
- bu(1, 1, 1) = 1
- bu(1, 1, 2) = 1
- return
- end
- subroutine handle(t0, u0, v0, t, u, v, nu, nxmk, nv, k, x,
- 1 nx, dt, tstop)
- integer nxmk, nu, nx
- integer nv, k
- real t0, u0(nxmk, nu), v0(1), t, u(nxmk, nu), v(1)
- real x(nx), dt, tstop
- common /time/ tt
- real tt
- external uofx
- integer i1mach
- real eu, eesff
- integer temp
-c output and checking routine.
- if (t0 .ne. t) goto 2
- temp = i1mach(2)
- write (temp, 1) t
- 1 format (16h restart for t =, 1pe10.2)
- return
- 2 tt = t
- eu = eesff(k, x, nx, u, uofx)
- temp = i1mach(2)
- write (temp, 3) t, eu
- 3 format (15h error in u(x, , 1pe10.2, 4h ) =, 1pe10.2)
- return
- end
- subroutine uofx(x, nx, u, w)
- integer nx
- real x(nx), u(nx), w(nx)
- common /param/ c
- real c
- common /time/ t
- real t
- integer i
- real exp
- do 1 i = 1, nx
- u(i) = exp((-c)*x(i))
- 1 continue
- return
- end
diff --git a/CEP/PyBDSM/src/port3/q7apl.f b/CEP/PyBDSM/src/port3/q7apl.f
deleted file mode 100644
index 7ea7e3029677975a4302c78a06a3e0455cb5148e..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/q7apl.f
+++ /dev/null
@@ -1,87 +0,0 @@
- SUBROUTINE Q7APL(NN, N, P, J, R, IERR)
-C *****PARAMETERS.
- INTEGER NN, N, P, IERR
- REAL J(NN,P), R(N)
-C
-C ..................................................................
-C ..................................................................
-C
-C *****PURPOSE.
-C THIS SUBROUTINE APPLIES TO R THE ORTHOGONAL TRANSFORMATIONS
-C STORED IN J BY QRFACT
-C
-C *****PARAMETER DESCRIPTION.
-C ON INPUT.
-C
-C NN IS THE ROW DIMENSION OF THE MATRIX J AS DECLARED IN
-C THE CALLING PROGRAM DIMENSION STATEMENT
-C
-C N IS THE NUMBER OF ROWS OF J AND THE SIZE OF THE VECTOR R
-C
-C P IS THE NUMBER OF COLUMNS OF J AND THE SIZE OF SIGMA
-C
-C J CONTAINS ON AND BELOW ITS DIAGONAL THE COLUMN VECTORS
-C U WHICH DETERMINE THE HOUSEHOLDER TRANSFORMATIONS
-C IDENT - U*U.TRANSPOSE
-C
-C R IS THE RIGHT HAND SIDE VECTOR TO WHICH THE ORTHOGONAL
-C TRANSFORMATIONS WILL BE APPLIED
-C
-C IERR IF NON-ZERO INDICATES THAT NOT ALL THE TRANSFORMATIONS
-C WERE SUCCESSFULLY DETERMINED AND ONLY THE FIRST
-C ABS(IERR) - 1 TRANSFORMATIONS WILL BE USED
-C
-C ON OUTPUT.
-C
-C R HAS BEEN OVERWRITTEN BY ITS TRANSFORMED IMAGE
-C
-C *****APPLICATION AND USAGE RESTRICTIONS.
-C NONE
-C
-C *****ALGORITHM NOTES.
-C THE VECTORS U WHICH DETERMINE THE HOUSEHOLDER TRANSFORMATIONS
-C ARE NORMALIZED SO THAT THEIR 2-NORM SQUARED IS 2. THE _USE_ OF
-C THESE TRANSFORMATIONS HERE IS IN THE SPIRIT OF (1).
-C
-C *****SUBROUTINES AND FUNCTIONS CALLED.
-C
-C D7TPR - FUNCTION, RETURNS THE INNER PRODUCT OF VECTORS
-C
-C *****REFERENCES.
-C (1) BUSINGER, P. A., AND GOLUB, G. H. (1965), LINEAR LEAST SQUARES
-C SOLUTIONS BY HOUSEHOLDER TRANSFORMATIONS, NUMER. MATH. 7,
-C PP. 269-276.
-C
-C *****HISTORY.
-C DESIGNED BY DAVID M. GAY, CODED BY STEPHEN C. PETERS (WINTER 1977)
-C CALL ON V2AXY SUBSTITUTED FOR DO LOOP, FALL 1983.
-C
-C *****GENERAL.
-C
-C THIS SUBROUTINE WAS WRITTEN IN CONNECTION WITH RESEARCH
-C SUPPORTED BY THE NATIONAL SCIENCE FOUNDATION UNDER GRANTS
-C MCS-7600324, DCR75-10143, 76-14311DSS, AND MCS76-11989.
-C
-C ..................................................................
-C ..................................................................
-C
-C *****LOCAL VARIABLES.
- INTEGER K, L, NL1
-C *****FUNCTIONS.
- REAL D7TPR
- EXTERNAL D7TPR, V2AXY
-C
-C *** BODY ***
-C
- K = P
- IF (IERR .NE. 0) K = IABS(IERR) - 1
- IF ( K .EQ. 0) GO TO 999
-C
- DO 20 L = 1, K
- NL1 = N - L + 1
- CALL V2AXY(NL1, R(L), - D7TPR(NL1,J(L,L),R(L)), J(L,L), R(L))
- 20 CONTINUE
-C
- 999 RETURN
-C *** LAST LINE OF Q7APL FOLLOWS ***
- END
diff --git a/CEP/PyBDSM/src/port3/q7rad.f b/CEP/PyBDSM/src/port3/q7rad.f
deleted file mode 100644
index 496bedf10aebd75b6f96f8825f816e1beb103b42..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/q7rad.f
+++ /dev/null
@@ -1,136 +0,0 @@
- SUBROUTINE Q7RAD(N, NN, P, QTR, QTRSET, RMAT, W, Y)
-C
-C *** ADD ROWS W TO QR FACTORIZATION WITH R MATRIX RMAT AND
-C *** Q**T * RESIDUAL = QTR. Y = NEW COMPONENTS OF RESIDUAL
-C *** CORRESPONDING TO W. QTR, Y REFERENCED ONLY IF QTRSET = .TRUE.
-C
- LOGICAL QTRSET
- INTEGER N, NN, P
- REAL QTR(P), RMAT(1), W(NN,P), Y(N)
-C DIMENSION RMAT(P*(P+1)/2)
-C/+
- REAL SQRT
-C/
- REAL D7TPR, R7MDC, V2NRM
- EXTERNAL D7TPR, R7MDC, V2AXY, V7SCL, V2NRM
-C
-C *** LOCAL VARIABLES ***
-C
- INTEGER I, II, IJ, IP1, J, K, NK
- REAL ARI, QRI, RI, S, T, WI
- REAL BIG, BIGRT, ONE, TINY, TINYRT, ZERO
-C/7
- SAVE BIGRT, TINY, TINYRT
-C/
- DATA BIG/-1.E+0/, BIGRT/-1.E+0/, ONE/1.E+0/, TINY/0.E+0/,
- 1 TINYRT/0.E+0/, ZERO/0.E+0/
-C
-C------------------------------ BODY -----------------------------------
-C
- IF (TINY .GT. ZERO) GO TO 10
- TINY = R7MDC(1)
- BIG = R7MDC(6)
- IF (TINY*BIG .LT. ONE) TINY = ONE / BIG
- 10 K = 1
- NK = N
- II = 0
- DO 180 I = 1, P
- II = II + I
- IP1 = I + 1
- IJ = II + I
- IF (NK .LE. 1) T = ABS(W(K,I))
- IF (NK .GT. 1) T = V2NRM(NK, W(K,I))
- IF (T .LT. TINY) GOTO 180
- RI = RMAT(II)
- IF (RI .NE. ZERO) GO TO 100
- IF (NK .GT. 1) GO TO 30
- IJ = II
- DO 20 J = I, P
- RMAT(IJ) = W(K,J)
- IJ = IJ + J
- 20 CONTINUE
- IF (QTRSET) QTR(I) = Y(K)
- W(K,I) = ZERO
- GO TO 999
- 30 WI = W(K,I)
- IF (BIGRT .GT. ZERO) GO TO 40
- BIGRT = R7MDC(5)
- TINYRT = R7MDC(2)
- 40 IF (T .LE. TINYRT) GO TO 50
- IF (T .GE. BIGRT) GO TO 50
- IF (WI .LT. ZERO) T = -T
- WI = WI + T
- S = SQRT(T * WI)
- GO TO 70
- 50 S = SQRT(T)
- IF (WI .LT. ZERO) GO TO 60
- WI = WI + T
- S = S * SQRT(WI)
- GO TO 70
- 60 T = -T
- WI = WI + T
- S = S * SQRT(-WI)
- 70 W(K,I) = WI
- CALL V7SCL(NK, W(K,I), ONE/S, W(K,I))
- RMAT(II) = -T
- IF (.NOT. QTRSET) GO TO 80
- CALL V2AXY(NK, Y(K), - D7TPR(NK,Y(K),W(K,I)), W(K,I), Y(K))
- QTR(I) = Y(K)
- 80 IF (IP1 .GT. P) GO TO 999
- DO 90 J = IP1, P
- CALL V2AXY(NK, W(K,J), - D7TPR(NK,W(K,J),W(K,I)),
- 1 W(K,I), W(K,J))
- RMAT(IJ) = W(K,J)
- IJ = IJ + J
- 90 CONTINUE
- IF (NK .LE. 1) GO TO 999
- K = K + 1
- NK = NK - 1
- GO TO 180
-C
- 100 ARI = ABS(RI)
- IF (ARI .GT. T) GO TO 110
- T = T * SQRT(ONE + (ARI/T)**2)
- GO TO 120
- 110 T = ARI * SQRT(ONE + (T/ARI)**2)
- 120 IF (RI .LT. ZERO) T = -T
- RI = RI + T
- RMAT(II) = -T
- S = -RI / T
- IF (NK .LE. 1) GO TO 150
- CALL V7SCL(NK, W(K,I), ONE/RI, W(K,I))
- IF (.NOT. QTRSET) GO TO 130
- QRI = QTR(I)
- T = S * ( QRI + D7TPR(NK, Y(K), W(K,I)) )
- QTR(I) = QRI + T
- 130 IF (IP1 .GT. P) GO TO 999
- IF (QTRSET) CALL V2AXY(NK, Y(K), T, W(K,I), Y(K))
- DO 140 J = IP1, P
- RI = RMAT(IJ)
- T = S * ( RI + D7TPR(NK, W(K,J), W(K,I)) )
- CALL V2AXY(NK, W(K,J), T, W(K,I), W(K,J))
- RMAT(IJ) = RI + T
- IJ = IJ + J
- 140 CONTINUE
- GO TO 180
-C
- 150 WI = W(K,I) / RI
- W(K,I) = WI
- IF (.NOT. QTRSET) GO TO 160
- QRI = QTR(I)
- T = S * ( QRI + Y(K)*WI )
- QTR(I) = QRI + T
- 160 IF (IP1 .GT. P) GO TO 999
- IF (QTRSET) Y(K) = T*WI + Y(K)
- DO 170 J = IP1, P
- RI = RMAT(IJ)
- T = S * (RI + W(K,J)*WI)
- W(K,J) = W(K,J) + T*WI
- RMAT(IJ) = RI + T
- IJ = IJ + J
- 170 CONTINUE
- 180 CONTINUE
-C
- 999 RETURN
-C *** LAST LINE OF Q7RAD FOLLOWS ***
- END
diff --git a/CEP/PyBDSM/src/port3/q7rfh.f b/CEP/PyBDSM/src/port3/q7rfh.f
deleted file mode 100644
index 3c70218bbe4e7f8364e13e8f29f256e2c14d7758..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/q7rfh.f
+++ /dev/null
@@ -1,198 +0,0 @@
- SUBROUTINE Q7RFH(IERR, IPIVOT, N, NN, NOPIVK, P, Q, R, RLEN, W)
-C
-C *** COMPUTE QR FACTORIZATION VIA HOUSEHOLDER TRANSFORMATIONS
-C *** WITH COLUMN PIVOTING ***
-C
-C *** PARAMETER DECLARATIONS ***
-C
- INTEGER IERR, N, NN, NOPIVK, P, RLEN
- INTEGER IPIVOT(P)
- REAL Q(NN,P), R(RLEN), W(P)
-C DIMENSION R(P*(P+1)/2)
-C
-C---------------------------- DESCRIPTION ----------------------------
-C
-C THIS ROUTINE COMPUTES A QR FACTORIZATION (VIA HOUSEHOLDER TRANS-
-C FORMATIONS) OF THE MATRIX A THAT ON INPUT IS STORED IN Q.
-C IF NOPIVK ALLOWS IT, THIS ROUTINE DOES COLUMN PIVOTING -- IF
-C K .GT. NOPIVK, THEN ORIGINAL COLUMN K IS ELIGIBLE FOR PIVOTING.
-C THE Q AND R RETURNED ARE SUCH THAT COLUMN I OF Q*R EQUALS
-C COLUMN IPIVOT(I) OF THE ORIGINAL MATRIX A. THE UPPER TRIANGULAR
-C MATRIX R IS STORED COMPACTLY BY COLUMNS, I.E., THE OUTPUT VECTOR R
-C CONTAINS R(1,1), R(1,2), R(2,2), R(1,3), R(2,3), ..., R(P,P) (IN
-C THAT ORDER). IF ALL GOES WELL, THEN THIS ROUTINE SETS IERR = 0.
-C BUT IF (PERMUTED) COLUMN K OF A IS LINEARLY DEPENDENT ON
-C (PERMUTED) COLUMNS 1,2,...,K-1, THEN IERR IS SET TO K AND THE R
-C MATRIX RETURNED HAS R(I,J) = 0 FOR I .GE. K AND J .GE. K.
-C THE ORIGINAL MATRIX A IS AN N BY P MATRIX. NN IS THE LEAD
-C DIMENSION OF THE ARRAY Q AND MUST SATISFY NN .GE. N. NO
-C PARAMETER CHECKING IS DONE.
-C PIVOTING IS DONE AS THOUGH ALL COLUMNS OF Q WERE FIRST
-C SCALED TO HAVE THE SAME NORM. IF COLUMN K IS ELIGIBLE FOR
-C PIVOTING AND ITS (SCALED) NORM**2 LOSS IS MORE THAN THE
-C MINIMUM SUCH LOSS (OVER COLUMNS K THRU P), THEN COLUMN K IS
-C SWAPPED WITH THE COLUMN OF LEAST NORM**2 LOSS.
-C
-C CODED BY DAVID M. GAY (FALL 1979, SPRING 1984).
-C
-C-------------------------- LOCAL VARIABLES --------------------------
-C
- INTEGER I, II, J, K, KK, KM1, KP1, NK1
- REAL AK, QKK, S, SINGTL, T, T1, WK
- REAL D7TPR, R7MDC, V2NRM
- EXTERNAL D7TPR, R7MDC, V2AXY, V7SCL, V7SCP, V7SWP, V2NRM
-C/+
- REAL SQRT
-C/
- REAL BIG, BIGRT, MEPS10, ONE, TEN, TINY, TINYRT,
- 1 WTOL, ZERO
-C/6
-C DATA ONE/1.0E+0/, TEN/1.E+1/, WTOL/0.75E+0/, ZERO/0.0E+0/
-C/7
- PARAMETER (ONE=1.0E+0, TEN=1.E+1, WTOL=0.75E+0, ZERO=0.0E+0)
- SAVE BIGRT, MEPS10, TINY, TINYRT
-C/
- DATA BIGRT/0.0E+0/, MEPS10/0.0E+0/, TINY/0.E+0/, TINYRT/0.E+0/
-C
-C+++++++++++++++++++++++++++++++ BODY ++++++++++++++++++++++++++++++++
-C
- IERR = 0
- IF (MEPS10 .GT. ZERO) GO TO 10
- BIGRT = R7MDC(5)
- MEPS10 = TEN * R7MDC(3)
- TINYRT = R7MDC(2)
- TINY = R7MDC(1)
- BIG = R7MDC(6)
- IF (TINY*BIG .LT. ONE) TINY = ONE / BIG
- 10 SINGTL = FLOAT(MAX0(N,P)) * MEPS10
-C
-C *** INITIALIZE W, IPIVOT, AND DIAG(R) ***
-C
- J = 0
- DO 40 I = 1, P
- IPIVOT(I) = I
- T = V2NRM(N, Q(1,I))
- IF (T .GT. ZERO) GO TO 20
- W(I) = ONE
- GO TO 30
- 20 W(I) = ZERO
- 30 J = J + I
- R(J) = T
- 40 CONTINUE
-C
-C *** MAIN LOOP ***
-C
- KK = 0
- NK1 = N + 1
- DO 130 K = 1, P
- IF (NK1 .LE. 1) GO TO 999
- NK1 = NK1 - 1
- KK = KK + K
- KP1 = K + 1
- IF (K .LE. NOPIVK) GO TO 60
- IF (K .GE. P) GO TO 60
-C
-C *** FIND COLUMN WITH MINIMUM WEIGHT LOSS ***
-C
- T = W(K)
- IF (T .LE. ZERO) GO TO 60
- J = K
- DO 50 I = KP1, P
- IF (W(I) .GE. T) GO TO 50
- T = W(I)
- J = I
- 50 CONTINUE
- IF (J .EQ. K) GO TO 60
-C
-C *** INTERCHANGE COLUMNS K AND J ***
-C
- I = IPIVOT(K)
- IPIVOT(K) = IPIVOT(J)
- IPIVOT(J) = I
- W(J) = W(K)
- W(K) = T
- I = J*(J+1)/2
- T1 = R(I)
- R(I) = R(KK)
- R(KK) = T1
- CALL V7SWP(N, Q(1,K), Q(1,J))
- IF (K .LE. 1) GO TO 60
- I = I - J + 1
- J = KK - K + 1
- CALL V7SWP(K-1, R(I), R(J))
-C
-C *** COLUMN K OF Q SHOULD BE NEARLY ORTHOGONAL TO THE PREVIOUS
-C *** COLUMNS. NORMALIZE IT, TEST FOR SINGULARITY, AND DECIDE
-C *** WHETHER TO REORTHOGONALIZE IT.
-C
- 60 AK = R(KK)
- IF (AK .LE. ZERO) GO TO 140
- WK = W(K)
-C
-C *** SET T TO THE NORM OF (Q(K,K),...,Q(N,K))
-C *** AND CHECK FOR SINGULARITY.
-C
- IF (WK .LT. WTOL) GO TO 70
- T = V2NRM(NK1, Q(K,K))
- IF (T / AK .LE. SINGTL) GO TO 140
- GO TO 80
- 70 T = SQRT(ONE - WK)
- IF (T .LE. SINGTL) GO TO 140
- T = T * AK
-C
-C *** DETERMINE HOUSEHOLDER TRANSFORMATION ***
-C
- 80 QKK = Q(K,K)
- IF (T .LE. TINYRT) GO TO 90
- IF (T .GE. BIGRT) GO TO 90
- IF (QKK .LT. ZERO) T = -T
- QKK = QKK + T
- S = SQRT(T * QKK)
- GO TO 110
- 90 S = SQRT(T)
- IF (QKK .LT. ZERO) GO TO 100
- QKK = QKK + T
- S = S * SQRT(QKK)
- GO TO 110
- 100 T = -T
- QKK = QKK + T
- S = S * SQRT(-QKK)
- 110 Q(K,K) = QKK
-C
-C *** SCALE (Q(K,K),...,Q(N,K)) TO HAVE NORM SQRT(2) ***
-C
- IF (S .LE. TINY) GO TO 140
- CALL V7SCL(NK1, Q(K,K), ONE/S, Q(K,K))
-C
- R(KK) = -T
-C
-C *** COMPUTE R(K,I) FOR I = K+1,...,P AND UPDATE Q ***
-C
- IF (K .GE. P) GO TO 999
- J = KK + K
- II = KK
- DO 120 I = KP1, P
- II = II + I
- CALL V2AXY(NK1, Q(K,I), - D7TPR(NK1,Q(K,K),Q(K,I)),
- 1 Q(K,K), Q(K,I))
- T = Q(K,I)
- R(J) = T
- J = J + I
- T1 = R(II)
- IF (T1 .GT. ZERO) W(I) = W(I) + (T/T1)**2
- 120 CONTINUE
- 130 CONTINUE
-C
-C *** SINGULAR Q ***
-C
- 140 IERR = K
- KM1 = K - 1
- J = KK
- DO 150 I = K, P
- CALL V7SCP(I-KM1, R(J), ZERO)
- J = J + I
- 150 CONTINUE
-C
- 999 RETURN
-C *** LAST CARD OF Q7RFH FOLLOWS ***
- END
diff --git a/CEP/PyBDSM/src/port3/q7rsh.f b/CEP/PyBDSM/src/port3/q7rsh.f
deleted file mode 100644
index a35074d2df7b4c5f52975140be8d88c6e1746346..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/q7rsh.f
+++ /dev/null
@@ -1,57 +0,0 @@
- SUBROUTINE Q7RSH(K, P, HAVQTR, QTR, R, W)
-C
-C *** PERMUTE COLUMN K OF R TO COLUMN P, MODIFY QTR ACCORDINGLY ***
-C
- LOGICAL HAVQTR
- INTEGER K, P
- REAL QTR(P), R(1), W(P)
-C DIMSNSION R(P*(P+1)/2)
-C
- REAL H2RFG
- EXTERNAL H2RFA, H2RFG, V7CPY
-C
-C *** LOCAL VARIABLES ***
-C
- INTEGER I, I1, J, JM1, JP1, J1, KM1, K1, PM1
- REAL A, B, T, WJ, X, Y, Z, ZERO
-C
- DATA ZERO/0.0E+0/
-C
-C+++++++++++++++++++++++++++++++ BODY ++++++++++++++++++++++++++++++++
-C
- IF (K .GE. P) GO TO 999
- KM1 = K - 1
- K1 = K * KM1 / 2
- CALL V7CPY(K, W, R(K1+1))
- WJ = W(K)
- PM1 = P - 1
- J1 = K1 + KM1
- DO 50 J = K, PM1
- JM1 = J - 1
- JP1 = J + 1
- IF (JM1 .GT. 0) CALL V7CPY(JM1, R(K1+1), R(J1+2))
- J1 = J1 + JP1
- K1 = K1 + J
- A = R(J1)
- B = R(J1+1)
- IF (B .NE. ZERO) GO TO 10
- R(K1) = A
- X = ZERO
- Z = ZERO
- GO TO 40
- 10 R(K1) = H2RFG(A, B, X, Y, Z)
- IF (J .EQ. PM1) GO TO 30
- I1 = J1
- DO 20 I = JP1, PM1
- I1 = I1 + I
- CALL H2RFA(1, R(I1), R(I1+1), X, Y, Z)
- 20 CONTINUE
- 30 IF (HAVQTR) CALL H2RFA(1, QTR(J), QTR(JP1), X, Y, Z)
- 40 T = X * WJ
- W(J) = WJ + T
- WJ = T * Z
- 50 CONTINUE
- W(P) = WJ
- CALL V7CPY(P, R(K1+1), W)
- 999 RETURN
- END
diff --git a/CEP/PyBDSM/src/port3/r1mach.f b/CEP/PyBDSM/src/port3/r1mach.f
deleted file mode 100644
index 91776e8ff791c6d401c2913354f1bd2d488f3fb7..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/r1mach.f
+++ /dev/null
@@ -1,222 +0,0 @@
- REAL FUNCTION R1MACH(I)
- INTEGER I
-C
-C SINGLE-PRECISION MACHINE CONSTANTS
-C R1MACH(1) = B**(EMIN-1), THE SMALLEST POSITIVE MAGNITUDE.
-C R1MACH(2) = B**EMAX*(1 - B**(-T)), THE LARGEST MAGNITUDE.
-C R1MACH(3) = B**(-T), THE SMALLEST RELATIVE SPACING.
-C R1MACH(4) = B**(1-T), THE LARGEST RELATIVE SPACING.
-C R1MACH(5) = LOG10(B)
-C
- INTEGER SMALL(2)
- INTEGER LARGE(2)
- INTEGER RIGHT(2)
- INTEGER DIVER(2)
- INTEGER LOG10(2)
-C needs to be (2) for AUTODOUBLE, HARRIS SLASH 6, ...
- INTEGER SC
- SAVE SMALL, LARGE, RIGHT, DIVER, LOG10, SC
- REAL RMACH(5)
- EQUIVALENCE (RMACH(1),SMALL(1))
- EQUIVALENCE (RMACH(2),LARGE(1))
- EQUIVALENCE (RMACH(3),RIGHT(1))
- EQUIVALENCE (RMACH(4),DIVER(1))
- EQUIVALENCE (RMACH(5),LOG10(1))
- INTEGER J, K, L, T3E(3)
- DATA T3E(1) / 9777664 /
- DATA T3E(2) / 5323660 /
- DATA T3E(3) / 46980 /
-C THIS VERSION ADAPTS AUTOMATICALLY TO MOST CURRENT MACHINES,
-C INCLUDING AUTO-DOUBLE COMPILERS.
-C TO COMPILE ON OLDER MACHINES, ADD A C IN COLUMN 1
-C ON THE NEXT LINE
- DATA SC/0/
-C AND REMOVE THE C FROM COLUMN 1 IN ONE OF THE SECTIONS BELOW.
-C CONSTANTS FOR EVEN OLDER MACHINES CAN BE OBTAINED BY
-C mail netlib@research.bell-labs.com
-C send old1mach from blas
-C PLEASE SEND CORRECTIONS TO dmg OR ehg@bell-labs.com.
-C
-C MACHINE CONSTANTS FOR THE HONEYWELL DPS 8/70 SERIES.
-C DATA RMACH(1) / O402400000000 /
-C DATA RMACH(2) / O376777777777 /
-C DATA RMACH(3) / O714400000000 /
-C DATA RMACH(4) / O716400000000 /
-C DATA RMACH(5) / O776464202324 /, SC/987/
-C
-C MACHINE CONSTANTS FOR PDP-11 FORTRANS SUPPORTING
-C 32-BIT INTEGERS (EXPRESSED IN INTEGER AND OCTAL).
-C DATA SMALL(1) / 8388608 /
-C DATA LARGE(1) / 2147483647 /
-C DATA RIGHT(1) / 880803840 /
-C DATA DIVER(1) / 889192448 /
-C DATA LOG10(1) / 1067065499 /, SC/987/
-C DATA RMACH(1) / O00040000000 /
-C DATA RMACH(2) / O17777777777 /
-C DATA RMACH(3) / O06440000000 /
-C DATA RMACH(4) / O06500000000 /
-C DATA RMACH(5) / O07746420233 /, SC/987/
-C
-C MACHINE CONSTANTS FOR THE UNIVAC 1100 SERIES.
-C DATA RMACH(1) / O000400000000 /
-C DATA RMACH(2) / O377777777777 /
-C DATA RMACH(3) / O146400000000 /
-C DATA RMACH(4) / O147400000000 /
-C DATA RMACH(5) / O177464202324 /, SC/987/
-C
- IF (SC .NE. 987) THEN
-* *** CHECK FOR AUTODOUBLE ***
- SMALL(2) = 0
- RMACH(1) = 1E13
- IF (SMALL(2) .NE. 0) THEN
-* *** AUTODOUBLED ***
- IF ( SMALL(1) .EQ. 1117925532
- * .AND. SMALL(2) .EQ. -448790528) THEN
-* *** IEEE BIG ENDIAN ***
- SMALL(1) = 1048576
- SMALL(2) = 0
- LARGE(1) = 2146435071
- LARGE(2) = -1
- RIGHT(1) = 1017118720
- RIGHT(2) = 0
- DIVER(1) = 1018167296
- DIVER(2) = 0
- LOG10(1) = 1070810131
- LOG10(2) = 1352628735
- ELSE IF ( SMALL(2) .EQ. 1117925532
- * .AND. SMALL(1) .EQ. -448790528) THEN
-* *** IEEE LITTLE ENDIAN ***
- SMALL(2) = 1048576
- SMALL(1) = 0
- LARGE(2) = 2146435071
- LARGE(1) = -1
- RIGHT(2) = 1017118720
- RIGHT(1) = 0
- DIVER(2) = 1018167296
- DIVER(1) = 0
- LOG10(2) = 1070810131
- LOG10(1) = 1352628735
- ELSE IF ( SMALL(1) .EQ. -2065213935
- * .AND. SMALL(2) .EQ. 10752) THEN
-* *** VAX WITH D_FLOATING ***
- SMALL(1) = 128
- SMALL(2) = 0
- LARGE(1) = -32769
- LARGE(2) = -1
- RIGHT(1) = 9344
- RIGHT(2) = 0
- DIVER(1) = 9472
- DIVER(2) = 0
- LOG10(1) = 546979738
- LOG10(2) = -805796613
- ELSE IF ( SMALL(1) .EQ. 1267827943
- * .AND. SMALL(2) .EQ. 704643072) THEN
-* *** IBM MAINFRAME ***
- SMALL(1) = 1048576
- SMALL(2) = 0
- LARGE(1) = 2147483647
- LARGE(2) = -1
- RIGHT(1) = 856686592
- RIGHT(2) = 0
- DIVER(1) = 873463808
- DIVER(2) = 0
- LOG10(1) = 1091781651
- LOG10(2) = 1352628735
- ELSE
- WRITE(*,9010)
- STOP 777
- END IF
- ELSE
- RMACH(1) = 1234567.
- IF (SMALL(1) .EQ. 1234613304) THEN
-* *** IEEE ***
- SMALL(1) = 8388608
- LARGE(1) = 2139095039
- RIGHT(1) = 864026624
- DIVER(1) = 872415232
- LOG10(1) = 1050288283
- ELSE IF (SMALL(1) .EQ. -1271379306) THEN
-* *** VAX ***
- SMALL(1) = 128
- LARGE(1) = -32769
- RIGHT(1) = 13440
- DIVER(1) = 13568
- LOG10(1) = 547045274
- ELSE IF (SMALL(1) .EQ. 1175639687) THEN
-* *** IBM MAINFRAME ***
- SMALL(1) = 1048576
- LARGE(1) = 2147483647
- RIGHT(1) = 990904320
- DIVER(1) = 1007681536
- LOG10(1) = 1091781651
- ELSE IF (SMALL(1) .EQ. 1251390520) THEN
-* *** CONVEX C-1 ***
- SMALL(1) = 8388608
- LARGE(1) = 2147483647
- RIGHT(1) = 880803840
- DIVER(1) = 889192448
- LOG10(1) = 1067065499
- ELSE
- DO 10 L = 1, 3
- J = SMALL(1) / 10000000
- K = SMALL(1) - 10000000*J
- IF (K .NE. T3E(L)) GO TO 20
- SMALL(1) = J
- 10 CONTINUE
-* *** CRAY T3E ***
- CALL I1MCRA(SMALL, K, 16, 0, 0)
- CALL I1MCRA(LARGE, K, 32751, 16777215, 16777215)
- CALL I1MCRA(RIGHT, K, 15520, 0, 0)
- CALL I1MCRA(DIVER, K, 15536, 0, 0)
- CALL I1MCRA(LOG10, K, 16339, 4461392, 10451455)
- GO TO 30
- 20 CALL I1MCRA(J, K, 16405, 9876536, 0)
- IF (SMALL(1) .NE. J) THEN
- WRITE(*,9020)
- STOP 777
- END IF
-* *** CRAY 1, XMP, 2, AND 3 ***
- CALL I1MCRA(SMALL(1), K, 8195, 8388608, 1)
- CALL I1MCRA(LARGE(1), K, 24574, 16777215, 16777214)
- CALL I1MCRA(RIGHT(1), K, 16338, 8388608, 0)
- CALL I1MCRA(DIVER(1), K, 16339, 8388608, 0)
- CALL I1MCRA(LOG10(1), K, 16383, 10100890, 8715216)
- END IF
- END IF
- 30 SC = 987
- END IF
-* SANITY CHECK
- IF (RMACH(4) .GE. 1.0) STOP 776
- IF (I .LT. 1 .OR. I .GT. 5) THEN
- WRITE(*,*) 'R1MACH(I): I =',I,' is out of bounds.'
- STOP
- END IF
- R1MACH = RMACH(I)
- RETURN
- 9010 FORMAT(/' Adjust autodoubled R1MACH by getting data'/
- *' appropriate for your machine from D1MACH.')
- 9020 FORMAT(/' Adjust R1MACH by uncommenting data statements'/
- *' appropriate for your machine.')
-* /* C source for R1MACH -- remove the * in column 1 */
-*#include <stdio.h>
-*#include <float.h>
-*#include <math.h>
-*float r1mach_(long *i)
-*{
-* switch(*i){
-* case 1: return FLT_MIN;
-* case 2: return FLT_MAX;
-* case 3: return FLT_EPSILON/FLT_RADIX;
-* case 4: return FLT_EPSILON;
-* case 5: return log10((double)FLT_RADIX);
-* }
-* fprintf(stderr, "invalid argument: r1mach(%ld)\n", *i);
-* exit(1); return 0; /* else complaint of missing return value */
-*}
- END
- SUBROUTINE I1MCRA(A, A1, B, C, D)
-**** SPECIAL COMPUTATION FOR CRAY MACHINES ****
- INTEGER A, A1, B, C, D
- A1 = 16777216*B + C
- A = 16777216*A1 + D
- END
diff --git a/CEP/PyBDSM/src/port3/r7mdc.f b/CEP/PyBDSM/src/port3/r7mdc.f
deleted file mode 100644
index d6e0282dc91652c7221d9b64fbfe052368b8705b..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/r7mdc.f
+++ /dev/null
@@ -1,53 +0,0 @@
- REAL FUNCTION R7MDC(K)
-C
-C *** RETURN MACHINE DEPENDENT CONSTANTS USED BY NL2SOL ***
-C
- INTEGER K
-C
-C *** THE CONSTANT RETURNED DEPENDS ON K...
-C
-C *** K = 1... SMALLEST POS. ETA SUCH THAT -ETA EXISTS.
-C *** K = 2... SQUARE ROOT OF ETA.
-C *** K = 3... UNIT ROUNDOFF = SMALLEST POS. NO. MACHEP SUCH
-C *** THAT 1 + MACHEP .GT. 1 .AND. 1 - MACHEP .LT. 1.
-C *** K = 4... SQUARE ROOT OF MACHEP.
-C *** K = 5... SQUARE ROOT OF BIG (SEE K = 6).
-C *** K = 6... LARGEST MACHINE NO. BIG SUCH THAT -BIG EXISTS.
-C
- REAL BIG, ETA, MACHEP
-C/+
- REAL SQRT
-C/
- REAL R1MACH, ZERO
- EXTERNAL R1MACH
- DATA BIG/0.E+0/, ETA/0.E+0/, MACHEP/0.E+0/, ZERO/0.E+0/
- IF (BIG .GT. ZERO) GO TO 1
- BIG = R1MACH(2)
- ETA = R1MACH(1)
- MACHEP = R1MACH(4)
- 1 CONTINUE
-C
-C------------------------------- BODY --------------------------------
-C
- GO TO (10, 20, 30, 40, 50, 60), K
-C
- 10 R7MDC = ETA
- GO TO 999
-C
- 20 R7MDC = SQRT(256.E+0*ETA)/16.E+0
- GO TO 999
-C
- 30 R7MDC = MACHEP
- GO TO 999
-C
- 40 R7MDC = SQRT(MACHEP)
- GO TO 999
-C
- 50 R7MDC = SQRT(BIG/256.E+0)*16.E+0
- GO TO 999
-C
- 60 R7MDC = BIG
-C
- 999 RETURN
-C *** LAST CARD OF R7MDC FOLLOWS ***
- END
diff --git a/CEP/PyBDSM/src/port3/r7tvm.f b/CEP/PyBDSM/src/port3/r7tvm.f
deleted file mode 100644
index 219c2076bb1258b39de55b9cf012dde3dc9a5b12..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/r7tvm.f
+++ /dev/null
@@ -1,31 +0,0 @@
- SUBROUTINE R7TVM(N, P, Y, D, U, X)
-C
-C *** SET Y TO R*X, WHERE R IS THE UPPER TRIANGULAR MATRIX WHOSE
-C *** DIAGONAL IS IN D AND WHOSE STRICT UPPER TRIANGLE IS IN U.
-C
-C *** X AND Y MAY SHARE STORAGE.
-C
- INTEGER N, P
- REAL Y(P), D(P), U(N,P), X(P)
-C
- REAL D7TPR
- EXTERNAL D7TPR
-C
-C *** LOCAL VARIABLES ***
-C
- INTEGER I, II, PL, PP1
- REAL T
-C
-C *** BODY ***
-C
- PL = MIN0(N, P)
- PP1 = PL + 1
- DO 10 II = 1, PL
- I = PP1 - II
- T = X(I) * D(I)
- IF (I .GT. 1) T = T + D7TPR(I-1, U(1,I), X)
- Y(I) = T
- 10 CONTINUE
- 999 RETURN
-C *** LAST LINE OF R7TVM FOLLOWS ***
- END
diff --git a/CEP/PyBDSM/src/port3/retsrc.f b/CEP/PyBDSM/src/port3/retsrc.f
deleted file mode 100644
index 3460bbf5a88279305e1136e324b0bd702616a53c..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/retsrc.f
+++ /dev/null
@@ -1,29 +0,0 @@
- SUBROUTINE RETSRC(IROLD)
-C
-C THIS ROUTINE SETS LRECOV = IROLD.
-C
-C IF THE CURRENT ERROR BECOMES UNRECOVERABLE,
-C THE MESSAGE IS PRINTED AND EXECUTION STOPS.
-C
-C ERROR STATES -
-C
-C 1 - ILLEGAL VALUE OF IROLD.
-C
-C/6S
-C IF (IROLD.LT.1 .OR. IROLD.GT.2)
-C 1 CALL SETERR(31HRETSRC - ILLEGAL VALUE OF IROLD,31,1,2)
-C/7S
- IF (IROLD.LT.1 .OR. IROLD.GT.2)
- 1 CALL SETERR('RETSRC - ILLEGAL VALUE OF IROLD',31,1,2)
-C/
-C
- ITEMP=I8SAVE(2,IROLD,.TRUE.)
-C
-C IF THE CURRENT ERROR IS NOW UNRECOVERABLE, PRINT AND STOP.
-C
- IF (IROLD.EQ.1 .OR. I8SAVE(1,0,.FALSE.).EQ.0) RETURN
-C
- CALL EPRINT
- STOP
-C
- END
diff --git a/CEP/PyBDSM/src/port3/rldst.f b/CEP/PyBDSM/src/port3/rldst.f
deleted file mode 100644
index 4cd8206636915cd5b4592eb4f0c111d804118a7b..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/rldst.f
+++ /dev/null
@@ -1,31 +0,0 @@
- REAL FUNCTION RLDST(P, D, X, X0)
-C
-C *** COMPUTE AND RETURN RELATIVE DIFFERENCE BETWEEN X AND X0 ***
-C *** NL2SOL VERSION 2.2 ***
-C
- INTEGER P
- REAL D(P), X(P), X0(P)
-C
- INTEGER I
- REAL EMAX, T, XMAX, ZERO
-C/6
-C DATA ZERO/0.E+0/
-C/7
- PARAMETER (ZERO=0.E+0)
-C/
-C
-C *** BODY ***
-C
- EMAX = ZERO
- XMAX = ZERO
- DO 10 I = 1, P
- T = ABS(D(I) * (X(I) - X0(I)))
- IF (EMAX .LT. T) EMAX = T
- T = D(I) * ( ABS(X(I)) + ABS(X0(I)))
- IF (XMAX .LT. T) XMAX = T
- 10 CONTINUE
- RLDST = ZERO
- IF (XMAX .GT. ZERO) RLDST = EMAX / XMAX
- 999 RETURN
-C *** LAST CARD OF RLDST FOLLOWS ***
- END
diff --git a/CEP/PyBDSM/src/port3/rmnf.f b/CEP/PyBDSM/src/port3/rmnf.f
deleted file mode 100644
index b0280aaaa4e32498635834080dcd0b738256f4b5..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/rmnf.f
+++ /dev/null
@@ -1,149 +0,0 @@
- SUBROUTINE RMNF(D, FX, IV, LIV, LV, N, V, X)
-C
-C *** ITERATION DRIVER FOR MNF...
-C *** MINIMIZE GENERAL UNCONSTRAINED OBJECTIVE FUNCTION USING
-C *** FINITE-DIFFERENCE GRADIENTS AND SECANT HESSIAN APPROXIMATIONS.
-C
- INTEGER LIV, LV, N
- INTEGER IV(LIV)
- REAL D(N), FX, X(N), V(LV)
-C DIMENSION V(77 + N*(N+17)/2)
-C
-C *** PURPOSE ***
-C
-C THIS ROUTINE INTERACTS WITH SUBROUTINE RMNG IN AN ATTEMPT
-C TO FIND AN N-VECTOR X* THAT MINIMIZES THE (UNCONSTRAINED)
-C OBJECTIVE FUNCTION FX = F(X) COMPUTED BY THE CALLER. (OFTEN
-C THE X* FOUND IS A LOCAL MINIMIZER RATHER THAN A GLOBAL ONE.)
-C
-C *** PARAMETERS ***
-C
-C THE PARAMETERS FOR RMNF ARE THE SAME AS THOSE FOR MNG
-C (WHICH SEE), EXCEPT THAT CALCF, CALCG, UIPARM, URPARM, AND UFPARM
-C ARE OMITTED, AND A PARAMETER FX FOR THE OBJECTIVE FUNCTION
-C VALUE AT X IS ADDED. INSTEAD OF CALLING CALCG TO OBTAIN THE
-C GRADIENT OF THE OBJECTIVE FUNCTION AT X, RMNF CALLS S7GRD,
-C WHICH COMPUTES AN APPROXIMATION TO THE GRADIENT BY FINITE
-C (FORWARD AND CENTRAL) DIFFERENCES USING THE METHOD OF REF. 1.
-C THE FOLLOWING INPUT COMPONENT IS OF INTEREST IN THIS REGARD
-C (AND IS NOT DESCRIBED IN MNG).
-C
-C V(ETA0)..... V(42) IS AN ESTIMATED BOUND ON THE RELATIVE ERROR IN THE
-C OBJECTIVE FUNCTION VALUE COMPUTED BY CALCF...
-C (TRUE VALUE) = (COMPUTED VALUE) * (1 + E),
-C WHERE ABS(E) .LE. V(ETA0). DEFAULT = MACHEP * 10**3,
-C WHERE MACHEP IS THE UNIT ROUNDOFF.
-C
-C THE OUTPUT VALUES IV(NFCALL) AND IV(NGCALL) HAVE DIFFERENT
-C MEANINGS FOR MNF THAN FOR MNG...
-C
-C IV(NFCALL)... IV(6) IS THE NUMBER OF CALLS SO FAR MADE ON CALCF (I.E.,
-C FUNCTION EVALUATIONS) EXCLUDING THOSE MADE ONLY FOR
-C COMPUTING GRADIENTS. THE INPUT VALUE IV(MXFCAL) IS A
-C LIMIT ON IV(NFCALL).
-C IV(NGCALL)... IV(30) IS THE NUMBER OF FUNCTION EVALUATIONS MADE ONLY
-C FOR COMPUTING GRADIENTS. THE TOTAL NUMBER OF FUNCTION
-C EVALUATIONS IS THUS IV(NFCALL) + IV(NGCALL).
-C
-C *** REFERENCES ***
-C
-C 1. STEWART, G.W. (1967), A MODIFICATION OF DAVIDON*S MINIMIZATION
-C METHOD TO ACCEPT DIFFERENCE APPROXIMATIONS OF DERIVATIVES,
-C J. ASSOC. COMPUT. MACH. 14, PP. 72-83.
-C.
-C *** GENERAL ***
-C
-C CODED BY DAVID M. GAY (AUGUST 1982).
-C
-C---------------------------- DECLARATIONS ---------------------------
-C
- REAL D7TPR
- EXTERNAL IVSET, D7TPR, S7GRD, RMNG, V7SCP
-C
-C IVSET.... SUPPLIES DEFAULT PARAMETER VALUES.
-C D7TPR... RETURNS INNER PRODUCT OF TWO VECTORS.
-C S7GRD... COMPUTES FINITE-DIFFERENCE GRADIENT APPROXIMATION.
-C RMNG.... REVERSE-COMMUNICATION ROUTINE THAT DOES MNG ALGORITHM.
-C V7SCP... SETS ALL ELEMENTS OF A VECTOR TO A SCALAR.
-C
- INTEGER ALPHA, G1, I, IV1, J, K, W
- REAL ZERO
-C
-C *** SUBSCRIPTS FOR IV ***
-C
- INTEGER ETA0, F, G, LMAT, NEXTV, NGCALL, NITER, SGIRC, TOOBIG,
- 1 VNEED
-C
-C/6
-C DATA ETA0/42/, F/10/, G/28/, LMAT/42/, NEXTV/47/, NGCALL/30/,
-C 1 NITER/31/, SGIRC/57/, TOOBIG/2/, VNEED/4/
-C/7
- PARAMETER (ETA0=42, F=10, G=28, LMAT=42, NEXTV=47, NGCALL=30,
- 1 NITER=31, SGIRC=57, TOOBIG=2, VNEED=4)
-C/
-C/6
-C DATA ZERO/0.E+0/
-C/7
- PARAMETER (ZERO=0.E+0)
-C/
-C
-C+++++++++++++++++++++++++++++++ BODY ++++++++++++++++++++++++++++++++
-C
- IV1 = IV(1)
- IF (IV1 .EQ. 1) GO TO 10
- IF (IV1 .EQ. 2) GO TO 50
- IF (IV(1) .EQ. 0) CALL IVSET(2, IV, LIV, LV, V)
- IV1 = IV(1)
- IF (IV1 .EQ. 12 .OR. IV1 .EQ. 13) IV(VNEED) = IV(VNEED) + 2*N + 6
- IF (IV1 .EQ. 14) GO TO 10
- IF (IV1 .GT. 2 .AND. IV1 .LT. 12) GO TO 10
- G1 = 1
- IF (IV1 .EQ. 12) IV(1) = 13
- GO TO 20
-C
- 10 G1 = IV(G)
-C
- 20 CALL RMNG(D, FX, V(G1), IV, LIV, LV, N, V, X)
- IF (IV(1) - 2) 999, 30, 70
-C
-C *** COMPUTE GRADIENT ***
-C
- 30 IF (IV(NITER) .EQ. 0) CALL V7SCP(N, V(G1), ZERO)
- J = IV(LMAT)
- K = G1 - N
- DO 40 I = 1, N
- V(K) = D7TPR(I, V(J), V(J))
- K = K + 1
- J = J + I
- 40 CONTINUE
-C *** UNDO INCREMENT OF IV(NGCALL) DONE BY RMNG ***
- IV(NGCALL) = IV(NGCALL) - 1
-C *** STORE RETURN CODE FROM S7GRD IN IV(SGIRC) ***
- IV(SGIRC) = 0
-C *** X MAY HAVE BEEN RESTORED, SO COPY BACK FX... ***
- FX = V(F)
- GO TO 60
-C
-C *** GRADIENT LOOP ***
-C
- 50 IF (IV(TOOBIG) .NE. 0) GO TO 10
-C
- 60 G1 = IV(G)
- ALPHA = G1 - N
- W = ALPHA - 6
- CALL S7GRD(V(ALPHA), D, V(ETA0), FX, V(G1), IV(SGIRC), N, V(W),X)
- IF (IV(SGIRC) .EQ. 0) GO TO 10
- IV(NGCALL) = IV(NGCALL) + 1
- GO TO 999
-C
- 70 IF (IV(1) .NE. 14) GO TO 999
-C
-C *** STORAGE ALLOCATION ***
-C
- IV(G) = IV(NEXTV) + N + 6
- IV(NEXTV) = IV(G) + N
- IF (IV1 .NE. 13) GO TO 10
-C
- 999 RETURN
-C *** LAST CARD OF RMNF FOLLOWS ***
- END
diff --git a/CEP/PyBDSM/src/port3/rmnfb.f b/CEP/PyBDSM/src/port3/rmnfb.f
deleted file mode 100644
index 3069737e44afd1c5d729721b4421ebfbbc7f5da1..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/rmnfb.f
+++ /dev/null
@@ -1,157 +0,0 @@
- SUBROUTINE RMNFB(B, D, FX, IV, LIV, LV, P, V, X)
-C
-C *** ITERATION DRIVER FOR MNF...
-C *** MINIMIZE GENERAL UNCONSTRAINED OBJECTIVE FUNCTION USING
-C *** FINITE-DIFFERENCE GRADIENTS AND SECANT HESSIAN APPROXIMATIONS.
-C
- INTEGER LIV, LV, P
- INTEGER IV(LIV)
- REAL B(2,P), D(P), FX, X(P), V(LV)
-C DIMENSION IV(59 + P), V(77 + P*(P+23)/2)
-C
-C *** PURPOSE ***
-C
-C THIS ROUTINE INTERACTS WITH SUBROUTINE RMNGB IN AN ATTEMPT
-C TO FIND AN P-VECTOR X* THAT MINIMIZES THE (UNCONSTRAINED)
-C OBJECTIVE FUNCTION FX = F(X) COMPUTED BY THE CALLER. (OFTEN
-C THE X* FOUND IS A LOCAL MINIMIZER RATHER THAN A GLOBAL ONE.)
-C
-C *** PARAMETERS ***
-C
-C THE PARAMETERS FOR RMNFB ARE THE SAME AS THOSE FOR MNG
-C (WHICH SEE), EXCEPT THAT CALCF, CALCG, UIPARM, URPARM, AND UFPARM
-C ARE OMITTED, AND A PARAMETER FX FOR THE OBJECTIVE FUNCTION
-C VALUE AT X IS ADDED. INSTEAD OF CALLING CALCG TO OBTAIN THE
-C GRADIENT OF THE OBJECTIVE FUNCTION AT X, RMNFB CALLS S3GRD,
-C WHICH COMPUTES AN APPROXIMATION TO THE GRADIENT BY FINITE
-C (FORWARD AND CENTRAL) DIFFERENCES USING THE METHOD OF REF. 1.
-C THE FOLLOWING INPUT COMPONENT IS OF INTEREST IN THIS REGARD
-C (AND IS NOT DESCRIBED IN MNG).
-C
-C V(ETA0)..... V(42) IS AN ESTIMATED BOUND ON THE RELATIVE ERROR IN THE
-C OBJECTIVE FUNCTION VALUE COMPUTED BY CALCF...
-C (TRUE VALUE) = (COMPUTED VALUE) * (1 + E),
-C WHERE ABS(E) .LE. V(ETA0). DEFAULT = MACHEP * 10**3,
-C WHERE MACHEP IS THE UNIT ROUNDOFF.
-C
-C THE OUTPUT VALUES IV(NFCALL) AND IV(NGCALL) HAVE DIFFERENT
-C MEANINGS FOR MNF THAN FOR MNG...
-C
-C IV(NFCALL)... IV(6) IS THE NUMBER OF CALLS SO FAR MADE ON CALCF (I.E.,
-C FUNCTION EVALUATIONS) EXCLUDING THOSE MADE ONLY FOR
-C COMPUTING GRADIENTS. THE INPUT VALUE IV(MXFCAL) IS A
-C LIMIT ON IV(NFCALL).
-C IV(NGCALL)... IV(30) IS THE NUMBER OF FUNCTION EVALUATIONS MADE ONLY
-C FOR COMPUTING GRADIENTS. THE TOTAL NUMBER OF FUNCTION
-C EVALUATIONS IS THUS IV(NFCALL) + IV(NGCALL).
-C
-C *** REFERENCES ***
-C
-C 1. STEWART, G.W. (1967), A MODIFICATION OF DAVIDON*S MINIMIZATION
-C METHOD TO ACCEPT DIFFERENCE APPROXIMATIONS OF DERIVATIVES,
-C J. ASSOC. COMPUT. MACH. 14, PP. 72-83.
-C.
-C *** GENERAL ***
-C
-C CODED BY DAVID M. GAY (AUGUST 1982).
-C
-C---------------------------- DECLARATIONS ---------------------------
-C
- REAL D7TPR
- EXTERNAL IVSET, D7TPR, S3GRD, RMNGB, V7SCP
-C
-C IVSET.... SUPPLIES DEFAULT PARAMETER VALUES.
-C D7TPR... RETURNS INNER PRODUCT OF TWO VECTORS.
-C S3GRD... COMPUTES FINITE-DIFFERENCE GRADIENT APPROXIMATION.
-C RMNGB... REVERSE-COMMUNICATION ROUTINE THAT DOES MNGB ALGORITHM.
-C V7SCP... SETS ALL ELEMENTS OF A VECTOR TO A SCALAR.
-C
- INTEGER ALPHA, ALPHA0, G1, I, IPI, IV1, J, K, W
- REAL ZERO
-C
-C *** SUBSCRIPTS FOR IV ***
-C
- INTEGER ETA0, F, G, LMAT, NEXTV, NGCALL,
- 1 NITER, PERM, SGIRC, TOOBIG, VNEED
-C
-C/6
-C DATA ETA0/42/, F/10/, G/28/, LMAT/42/, NEXTV/47/, NGCALL/30/,
-C 1 NITER/31/, PERM/58/, SGIRC/57/, TOOBIG/2/, VNEED/4/
-C/7
- PARAMETER (ETA0=42, F=10, G=28, LMAT=42, NEXTV=47, NGCALL=30,
- 1 NITER=31, PERM=58, SGIRC=57, TOOBIG=2, VNEED=4)
-C/
-C/6
-C DATA ZERO/0.E+0/
-C/7
- PARAMETER (ZERO=0.E+0)
-C/
-C
-C+++++++++++++++++++++++++++++++ BODY ++++++++++++++++++++++++++++++++
-C
- IV1 = IV(1)
- IF (IV1 .EQ. 1) GO TO 10
- IF (IV1 .EQ. 2) GO TO 50
- IF (IV(1) .EQ. 0) CALL IVSET(2, IV, LIV, LV, V)
- IV1 = IV(1)
- IF (IV1 .EQ. 12 .OR. IV1 .EQ. 13) IV(VNEED) = IV(VNEED) + 2*P + 6
- IF (IV1 .EQ. 14) GO TO 10
- IF (IV1 .GT. 2 .AND. IV1 .LT. 12) GO TO 10
- G1 = 1
- IF (IV1 .EQ. 12) IV(1) = 13
- GO TO 20
-C
- 10 G1 = IV(G)
-C
- 20 CALL RMNGB(B, D, FX, V(G1), IV, LIV, LV, P, V, X)
- IF (IV(1) - 2) 999, 30, 80
-C
-C *** COMPUTE GRADIENT ***
-C
- 30 IF (IV(NITER) .EQ. 0) CALL V7SCP(P, V(G1), ZERO)
- J = IV(LMAT)
- ALPHA0 = G1 - P - 1
- IPI = IV(PERM)
- DO 40 I = 1, P
- K = ALPHA0 + IV(IPI)
- V(K) = D7TPR(I, V(J), V(J))
- IPI = IPI + 1
- J = J + I
- 40 CONTINUE
-C *** UNDO INCREMENT OF IV(NGCALL) DONE BY RMNGB ***
- IV(NGCALL) = IV(NGCALL) - 1
-C *** STORE RETURN CODE FROM S3GRD IN IV(SGIRC) ***
- IV(SGIRC) = 0
-C *** X MAY HAVE BEEN RESTORED, SO COPY BACK FX... ***
- FX = V(F)
- GO TO 60
-C
-C *** GRADIENT LOOP ***
-C
- 50 IF (IV(TOOBIG) .NE. 0) GO TO 10
-C
- 60 G1 = IV(G)
- ALPHA = G1 - P
- W = ALPHA - 6
- CALL S3GRD(V(ALPHA), B, D, V(ETA0), FX, V(G1), IV(SGIRC), P,
- 1 V(W), X)
- I = IV(SGIRC)
- IF (I .EQ. 0) GO TO 10
- IF (I .LE. P) GO TO 70
- IV(TOOBIG) = 1
- GO TO 10
-C
- 70 IV(NGCALL) = IV(NGCALL) + 1
- GO TO 999
-C
- 80 IF (IV(1) .NE. 14) GO TO 999
-C
-C *** STORAGE ALLOCATION ***
-C
- IV(G) = IV(NEXTV) + P + 6
- IV(NEXTV) = IV(G) + P
- IF (IV1 .NE. 13) GO TO 10
-C
- 999 RETURN
-C *** LAST CARD OF RMNFB FOLLOWS ***
- END
diff --git a/CEP/PyBDSM/src/port3/rmng.f b/CEP/PyBDSM/src/port3/rmng.f
deleted file mode 100644
index ebb1435489a308a5680ead215b5c4df860434328..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/rmng.f
+++ /dev/null
@@ -1,447 +0,0 @@
- SUBROUTINE RMNG(D, FX, G, IV, LIV, LV, N, V, X)
-C
-C *** CARRY OUT MNG (UNCONSTRAINED MINIMIZATION) ITERATIONS, USING
-C *** DOUBLE-DOGLEG/BFGS STEPS.
-C
-C *** PARAMETER DECLARATIONS ***
-C
- INTEGER LIV, LV, N
- INTEGER IV(LIV)
- REAL D(N), FX, G(N), V(LV), X(N)
-C
-C-------------------------- PARAMETER USAGE --------------------------
-C
-C D.... SCALE VECTOR.
-C FX... FUNCTION VALUE.
-C G.... GRADIENT VECTOR.
-C IV... INTEGER VALUE ARRAY.
-C LIV.. LENGTH OF IV (AT LEAST 60).
-C LV... LENGTH OF V (AT LEAST 71 + N*(N+13)/2).
-C N.... NUMBER OF VARIABLES (COMPONENTS IN X AND G).
-C V.... FLOATING-POINT VALUE ARRAY.
-C X.... VECTOR OF PARAMETERS TO BE OPTIMIZED.
-C
-C *** DISCUSSION ***
-C
-C PARAMETERS IV, N, V, AND X ARE THE SAME AS THE CORRESPONDING
-C ONES TO MNG (WHICH SEE), EXCEPT THAT V CAN BE SHORTER (SINCE
-C THE PART OF V THAT MNG USES FOR STORING G IS NOT NEEDED).
-C MOREOVER, COMPARED WITH MNG, IV(1) MAY HAVE THE TWO ADDITIONAL
-C OUTPUT VALUES 1 AND 2, WHICH ARE EXPLAINED BELOW, AS IS THE USE
-C OF IV(TOOBIG) AND IV(NFGCAL). THE VALUE IV(G), WHICH IS AN
-C OUTPUT VALUE FROM MNG (AND MNF), IS NOT REFERENCED BY
-C RMNG OR THE SUBROUTINES IT CALLS.
-C FX AND G NEED NOT HAVE BEEN INITIALIZED WHEN RMNG IS CALLED
-C WITH IV(1) = 12, 13, OR 14.
-C
-C IV(1) = 1 MEANS THE CALLER SHOULD SET FX TO F(X), THE FUNCTION VALUE
-C AT X, AND CALL RMNG AGAIN, HAVING CHANGED NONE OF THE
-C OTHER PARAMETERS. AN EXCEPTION OCCURS IF F(X) CANNOT BE
-C (E.G. IF OVERFLOW WOULD OCCUR), WHICH MAY HAPPEN BECAUSE
-C OF AN OVERSIZED STEP. IN THIS CASE THE CALLER SHOULD SET
-C IV(TOOBIG) = IV(2) TO 1, WHICH WILL CAUSE RMNG TO IG-
-C NORE FX AND TRY A SMALLER STEP. THE PARAMETER NF THAT
-C MNG PASSES TO CALCF (FOR POSSIBLE _USE_ BY CALCG) IS A
-C COPY OF IV(NFCALL) = IV(6).
-C IV(1) = 2 MEANS THE CALLER SHOULD SET G TO G(X), THE GRADIENT VECTOR
-C OF F AT X, AND CALL RMNG AGAIN, HAVING CHANGED NONE OF
-C THE OTHER PARAMETERS EXCEPT POSSIBLY THE SCALE VECTOR D
-C WHEN IV(DTYPE) = 0. THE PARAMETER NF THAT MNG PASSES
-C TO CALCG IS IV(NFGCAL) = IV(7). IF G(X) CANNOT BE
-C EVALUATED, THEN THE CALLER MAY SET IV(TOOBIG) TO 0, IN
-C WHICH CASE RMNG WILL RETURN WITH IV(1) = 65.
-C.
-C *** GENERAL ***
-C
-C CODED BY DAVID M. GAY (DECEMBER 1979). REVISED SEPT. 1982.
-C THIS SUBROUTINE WAS WRITTEN IN CONNECTION WITH RESEARCH SUPPORTED
-C IN PART BY THE NATIONAL SCIENCE FOUNDATION UNDER GRANTS
-C MCS-7600324 AND MCS-7906671.
-C
-C (SEE MNG FOR REFERENCES.)
-C
-C+++++++++++++++++++++++++++ DECLARATIONS ++++++++++++++++++++++++++++
-C
-C *** LOCAL VARIABLES ***
-C
- INTEGER DG1, DUMMY, G01, I, K, L, LSTGST, NWTST1, RSTRST, STEP1,
- 1 TEMP1, W, X01, Z
- REAL T
-C
-C *** CONSTANTS ***
-C
- REAL HALF, NEGONE, ONE, ONEP2, ZERO
-C
-C *** NO INTRINSIC FUNCTIONS ***
-C
-C *** EXTERNAL FUNCTIONS AND SUBROUTINES ***
-C
- LOGICAL STOPX
- REAL D7TPR, RLDST, V2NRM
- EXTERNAL A7SST, D7DOG, IVSET, D7TPR, ITSUM, L7ITV, L7IVM,
- 1 L7TVM, L7UPD, L7VML, PARCK, RLDST, STOPX, V2AXY,
- 2 V7CPY, V7SCP, V7VMP, V2NRM, W7ZBF
-C
-C A7SST.... ASSESSES CANDIDATE STEP.
-C D7DOG.... COMPUTES DOUBLE-DOGLEG (CANDIDATE) STEP.
-C IVSET.... SUPPLIES DEFAULT IV AND V INPUT COMPONENTS.
-C D7TPR... RETURNS INNER PRODUCT OF TWO VECTORS.
-C ITSUM.... PRINTS ITERATION SUMMARY AND INFO ON INITIAL AND FINAL X.
-C L7ITV... MULTIPLIES INVERSE TRANSPOSE OF LOWER TRIANGLE TIMES VECTOR.
-C L7IVM... MULTIPLIES INVERSE OF LOWER TRIANGLE TIMES VECTOR.
-C L7TVM... MULTIPLIES TRANSPOSE OF LOWER TRIANGLE TIMES VECTOR.
-C LUPDT.... UPDATES CHOLESKY FACTOR OF HESSIAN APPROXIMATION.
-C L7VML.... MULTIPLIES LOWER TRIANGLE TIMES VECTOR.
-C PARCK.... CHECKS VALIDITY OF INPUT IV AND V VALUES.
-C RLDST... COMPUTES V(RELDX) = RELATIVE STEP SIZE.
-C STOPX.... RETURNS .TRUE. IF THE BREAK KEY HAS BEEN PRESSED.
-C V2AXY.... COMPUTES SCALAR TIMES ONE VECTOR PLUS ANOTHER.
-C V7CPY.... COPIES ONE VECTOR TO ANOTHER.
-C V7SCP... SETS ALL ELEMENTS OF A VECTOR TO A SCALAR.
-C V7VMP... MULTIPLIES VECTOR BY VECTOR RAISED TO POWER (COMPONENTWISE).
-C V2NRM... RETURNS THE 2-NORM OF A VECTOR.
-C W7ZBF... COMPUTES W AND Z FOR L7UPD CORRESPONDING TO BFGS UPDATE.
-C
-C *** SUBSCRIPTS FOR IV AND V ***
-C
- INTEGER CNVCOD, DG, DGNORM, DINIT, DSTNRM, DST0, F, F0, FDIF,
- 1 GTHG, GTSTEP, G0, INCFAC, INITH, IRC, KAGQT, LMAT, LMAX0,
- 2 LMAXS, MODE, MODEL, MXFCAL, MXITER, NEXTV, NFCALL, NFGCAL,
- 3 NGCALL, NITER, NREDUC, NWTSTP, PREDUC, RADFAC, RADINC,
- 4 RADIUS, RAD0, RELDX, RESTOR, STEP, STGLIM, STLSTG, TOOBIG,
- 5 TUNER4, TUNER5, VNEED, XIRC, X0
-C
-C *** IV SUBSCRIPT VALUES ***
-C
-C/6
-C DATA CNVCOD/55/, DG/37/, G0/48/, INITH/25/, IRC/29/, KAGQT/33/,
-C 1 MODE/35/, MODEL/5/, MXFCAL/17/, MXITER/18/, NFCALL/6/,
-C 2 NFGCAL/7/, NGCALL/30/, NITER/31/, NWTSTP/34/, RADINC/8/,
-C 3 RESTOR/9/, STEP/40/, STGLIM/11/, STLSTG/41/, TOOBIG/2/,
-C 4 VNEED/4/, XIRC/13/, X0/43/
-C/7
- PARAMETER (CNVCOD=55, DG=37, G0=48, INITH=25, IRC=29, KAGQT=33,
- 1 MODE=35, MODEL=5, MXFCAL=17, MXITER=18, NFCALL=6,
- 2 NFGCAL=7, NGCALL=30, NITER=31, NWTSTP=34, RADINC=8,
- 3 RESTOR=9, STEP=40, STGLIM=11, STLSTG=41, TOOBIG=2,
- 4 VNEED=4, XIRC=13, X0=43)
-C/
-C
-C *** V SUBSCRIPT VALUES ***
-C
-C/6
-C DATA DGNORM/1/, DINIT/38/, DSTNRM/2/, DST0/3/, F/10/, F0/13/,
-C 1 FDIF/11/, GTHG/44/, GTSTEP/4/, INCFAC/23/, LMAT/42/,
-C 2 LMAX0/35/, LMAXS/36/, NEXTV/47/, NREDUC/6/, PREDUC/7/,
-C 3 RADFAC/16/, RADIUS/8/, RAD0/9/, RELDX/17/, TUNER4/29/,
-C 4 TUNER5/30/
-C/7
- PARAMETER (DGNORM=1, DINIT=38, DSTNRM=2, DST0=3, F=10, F0=13,
- 1 FDIF=11, GTHG=44, GTSTEP=4, INCFAC=23, LMAT=42,
- 2 LMAX0=35, LMAXS=36, NEXTV=47, NREDUC=6, PREDUC=7,
- 3 RADFAC=16, RADIUS=8, RAD0=9, RELDX=17, TUNER4=29,
- 4 TUNER5=30)
-C/
-C
-C/6
-C DATA HALF/0.5E+0/, NEGONE/-1.E+0/, ONE/1.E+0/, ONEP2/1.2E+0/,
-C 1 ZERO/0.E+0/
-C/7
- PARAMETER (HALF=0.5E+0, NEGONE=-1.E+0, ONE=1.E+0, ONEP2=1.2E+0,
- 1 ZERO=0.E+0)
-C/
-C
-C+++++++++++++++++++++++++++++++ BODY ++++++++++++++++++++++++++++++++
-C
- I = IV(1)
- IF (I .EQ. 1) GO TO 50
- IF (I .EQ. 2) GO TO 60
-C
-C *** CHECK VALIDITY OF IV AND V INPUT VALUES ***
-C
- IF (IV(1) .EQ. 0) CALL IVSET(2, IV, LIV, LV, V)
- IF (IV(1) .EQ. 12 .OR. IV(1) .EQ. 13)
- 1 IV(VNEED) = IV(VNEED) + N*(N+13)/2
- CALL PARCK(2, D, IV, LIV, LV, N, V)
- I = IV(1) - 2
- IF (I .GT. 12) GO TO 999
- GO TO (190, 190, 190, 190, 190, 190, 120, 90, 120, 10, 10, 20), I
-C
-C *** STORAGE ALLOCATION ***
-C
- 10 L = IV(LMAT)
- IV(X0) = L + N*(N+1)/2
- IV(STEP) = IV(X0) + N
- IV(STLSTG) = IV(STEP) + N
- IV(G0) = IV(STLSTG) + N
- IV(NWTSTP) = IV(G0) + N
- IV(DG) = IV(NWTSTP) + N
- IV(NEXTV) = IV(DG) + N
- IF (IV(1) .NE. 13) GO TO 20
- IV(1) = 14
- GO TO 999
-C
-C *** INITIALIZATION ***
-C
- 20 IV(NITER) = 0
- IV(NFCALL) = 1
- IV(NGCALL) = 1
- IV(NFGCAL) = 1
- IV(MODE) = -1
- IV(MODEL) = 1
- IV(STGLIM) = 1
- IV(TOOBIG) = 0
- IV(CNVCOD) = 0
- IV(RADINC) = 0
- V(RAD0) = ZERO
- IF (V(DINIT) .GE. ZERO) CALL V7SCP(N, D, V(DINIT))
- IF (IV(INITH) .NE. 1) GO TO 40
-C
-C *** SET THE INITIAL HESSIAN APPROXIMATION TO DIAG(D)**-2 ***
-C
- L = IV(LMAT)
- CALL V7SCP(N*(N+1)/2, V(L), ZERO)
- K = L - 1
- DO 30 I = 1, N
- K = K + I
- T = D(I)
- IF (T .LE. ZERO) T = ONE
- V(K) = T
- 30 CONTINUE
-C
-C *** COMPUTE INITIAL FUNCTION VALUE ***
-C
- 40 IV(1) = 1
- GO TO 999
-C
- 50 V(F) = FX
- IF (IV(MODE) .GE. 0) GO TO 190
- V(F0) = FX
- IV(1) = 2
- IF (IV(TOOBIG) .EQ. 0) GO TO 999
- IV(1) = 63
- GO TO 350
-C
-C *** MAKE SURE GRADIENT COULD BE COMPUTED ***
-C
- 60 IF (IV(TOOBIG) .EQ. 0) GO TO 70
- IV(1) = 65
- GO TO 350
-C
- 70 DG1 = IV(DG)
- CALL V7VMP(N, V(DG1), G, D, -1)
- V(DGNORM) = V2NRM(N, V(DG1))
-C
- IF (IV(CNVCOD) .NE. 0) GO TO 340
- IF (IV(MODE) .EQ. 0) GO TO 300
-C
-C *** ALLOW FIRST STEP TO HAVE SCALED 2-NORM AT MOST V(LMAX0) ***
-C
- V(RADIUS) = V(LMAX0)
-C
- IV(MODE) = 0
-C
-C
-C----------------------------- MAIN LOOP -----------------------------
-C
-C
-C *** PRINT ITERATION SUMMARY, CHECK ITERATION LIMIT ***
-C
- 80 CALL ITSUM(D, G, IV, LIV, LV, N, V, X)
- 90 K = IV(NITER)
- IF (K .LT. IV(MXITER)) GO TO 100
- IV(1) = 10
- GO TO 350
-C
-C *** UPDATE RADIUS ***
-C
- 100 IV(NITER) = K + 1
- IF (K .GT. 0) V(RADIUS) = V(RADFAC) * V(DSTNRM)
-C
-C *** INITIALIZE FOR START OF NEXT ITERATION ***
-C
- G01 = IV(G0)
- X01 = IV(X0)
- V(F0) = V(F)
- IV(IRC) = 4
- IV(KAGQT) = -1
-C
-C *** COPY X TO X0, G TO G0 ***
-C
- CALL V7CPY(N, V(X01), X)
- CALL V7CPY(N, V(G01), G)
-C
-C *** CHECK STOPX AND FUNCTION EVALUATION LIMIT ***
-C
- 110 IF (.NOT. STOPX(DUMMY)) GO TO 130
- IV(1) = 11
- GO TO 140
-C
-C *** COME HERE WHEN RESTARTING AFTER FUNC. EVAL. LIMIT OR STOPX.
-C
- 120 IF (V(F) .GE. V(F0)) GO TO 130
- V(RADFAC) = ONE
- K = IV(NITER)
- GO TO 100
-C
- 130 IF (IV(NFCALL) .LT. IV(MXFCAL)) GO TO 150
- IV(1) = 9
- 140 IF (V(F) .GE. V(F0)) GO TO 350
-C
-C *** IN CASE OF STOPX OR FUNCTION EVALUATION LIMIT WITH
-C *** IMPROVED V(F), EVALUATE THE GRADIENT AT X.
-C
- IV(CNVCOD) = IV(1)
- GO TO 290
-C
-C. . . . . . . . . . . . . COMPUTE CANDIDATE STEP . . . . . . . . . .
-C
- 150 STEP1 = IV(STEP)
- DG1 = IV(DG)
- NWTST1 = IV(NWTSTP)
- IF (IV(KAGQT) .GE. 0) GO TO 160
- L = IV(LMAT)
- CALL L7IVM(N, V(NWTST1), V(L), G)
- V(NREDUC) = HALF * D7TPR(N, V(NWTST1), V(NWTST1))
- CALL L7ITV(N, V(NWTST1), V(L), V(NWTST1))
- CALL V7VMP(N, V(STEP1), V(NWTST1), D, 1)
- V(DST0) = V2NRM(N, V(STEP1))
- CALL V7VMP(N, V(DG1), V(DG1), D, -1)
- CALL L7TVM(N, V(STEP1), V(L), V(DG1))
- V(GTHG) = V2NRM(N, V(STEP1))
- IV(KAGQT) = 0
- 160 CALL D7DOG(V(DG1), LV, N, V(NWTST1), V(STEP1), V)
- IF (IV(IRC) .NE. 6) GO TO 170
- IF (IV(RESTOR) .NE. 2) GO TO 190
- RSTRST = 2
- GO TO 200
-C
-C *** CHECK WHETHER EVALUATING F(X0 + STEP) LOOKS WORTHWHILE ***
-C
- 170 IV(TOOBIG) = 0
- IF (V(DSTNRM) .LE. ZERO) GO TO 190
- IF (IV(IRC) .NE. 5) GO TO 180
- IF (V(RADFAC) .LE. ONE) GO TO 180
- IF (V(PREDUC) .GT. ONEP2 * V(FDIF)) GO TO 180
- IF (IV(RESTOR) .NE. 2) GO TO 190
- RSTRST = 0
- GO TO 200
-C
-C *** COMPUTE F(X0 + STEP) ***
-C
- 180 X01 = IV(X0)
- STEP1 = IV(STEP)
- CALL V2AXY(N, X, ONE, V(STEP1), V(X01))
- IV(NFCALL) = IV(NFCALL) + 1
- IV(1) = 1
- GO TO 999
-C
-C. . . . . . . . . . . . . ASSESS CANDIDATE STEP . . . . . . . . . . .
-C
- 190 RSTRST = 3
- 200 X01 = IV(X0)
- V(RELDX) = RLDST(N, D, X, V(X01))
- CALL A7SST(IV, LIV, LV, V)
- STEP1 = IV(STEP)
- LSTGST = IV(STLSTG)
- I = IV(RESTOR) + 1
- GO TO (240, 210, 220, 230), I
- 210 CALL V7CPY(N, X, V(X01))
- GO TO 240
- 220 CALL V7CPY(N, V(LSTGST), V(STEP1))
- GO TO 240
- 230 CALL V7CPY(N, V(STEP1), V(LSTGST))
- CALL V2AXY(N, X, ONE, V(STEP1), V(X01))
- V(RELDX) = RLDST(N, D, X, V(X01))
- IV(RESTOR) = RSTRST
-C
- 240 K = IV(IRC)
- GO TO (250,280,280,280,250,260,270,270,270,270,270,270,330,300), K
-C
-C *** RECOMPUTE STEP WITH CHANGED RADIUS ***
-C
- 250 V(RADIUS) = V(RADFAC) * V(DSTNRM)
- GO TO 110
-C
-C *** COMPUTE STEP OF LENGTH V(LMAXS) FOR SINGULAR CONVERGENCE TEST.
-C
- 260 V(RADIUS) = V(LMAXS)
- GO TO 150
-C
-C *** CONVERGENCE OR FALSE CONVERGENCE ***
-C
- 270 IV(CNVCOD) = K - 4
- IF (V(F) .GE. V(F0)) GO TO 340
- IF (IV(XIRC) .EQ. 14) GO TO 340
- IV(XIRC) = 14
-C
-C. . . . . . . . . . . . PROCESS ACCEPTABLE STEP . . . . . . . . . . .
-C
- 280 IF (IV(IRC) .NE. 3) GO TO 290
- STEP1 = IV(STEP)
- TEMP1 = IV(STLSTG)
-C
-C *** SET TEMP1 = HESSIAN * STEP FOR _USE_ IN GRADIENT TESTS ***
-C
- L = IV(LMAT)
- CALL L7TVM(N, V(TEMP1), V(L), V(STEP1))
- CALL L7VML(N, V(TEMP1), V(L), V(TEMP1))
-C
-C *** COMPUTE GRADIENT ***
-C
- 290 IV(NGCALL) = IV(NGCALL) + 1
- IV(1) = 2
- GO TO 999
-C
-C *** INITIALIZATIONS -- G0 = G - G0, ETC. ***
-C
- 300 G01 = IV(G0)
- CALL V2AXY(N, V(G01), NEGONE, V(G01), G)
- STEP1 = IV(STEP)
- TEMP1 = IV(STLSTG)
- IF (IV(IRC) .NE. 3) GO TO 320
-C
-C *** SET V(RADFAC) BY GRADIENT TESTS ***
-C
-C *** SET TEMP1 = DIAG(D)**-1 * (HESSIAN*STEP + (G(X0)-G(X))) ***
-C
- CALL V2AXY(N, V(TEMP1), NEGONE, V(G01), V(TEMP1))
- CALL V7VMP(N, V(TEMP1), V(TEMP1), D, -1)
-C
-C *** DO GRADIENT TESTS ***
-C
- IF ( V2NRM(N, V(TEMP1)) .LE. V(DGNORM) * V(TUNER4))
- 1 GO TO 310
- IF ( D7TPR(N, G, V(STEP1))
- 1 .GE. V(GTSTEP) * V(TUNER5)) GO TO 320
- 310 V(RADFAC) = V(INCFAC)
-C
-C *** UPDATE H, LOOP ***
-C
- 320 W = IV(NWTSTP)
- Z = IV(X0)
- L = IV(LMAT)
- CALL W7ZBF(V(L), N, V(STEP1), V(W), V(G01), V(Z))
-C
-C ** _USE_ THE N-VECTORS STARTING AT V(STEP1) AND V(G01) FOR SCRATCH..
- CALL L7UPD(V(TEMP1), V(STEP1), V(L), V(G01), V(L), N, V(W), V(Z))
- IV(1) = 2
- GO TO 80
-C
-C. . . . . . . . . . . . . . MISC. DETAILS . . . . . . . . . . . . . .
-C
-C *** BAD PARAMETERS TO ASSESS ***
-C
- 330 IV(1) = 64
- GO TO 350
-C
-C *** PRINT SUMMARY OF FINAL ITERATION AND OTHER REQUESTED ITEMS ***
-C
- 340 IV(1) = IV(CNVCOD)
- IV(CNVCOD) = 0
- 350 CALL ITSUM(D, G, IV, LIV, LV, N, V, X)
-C
- 999 RETURN
-C
-C *** LAST LINE OF RMNG FOLLOWS ***
- END
diff --git a/CEP/PyBDSM/src/port3/rmngb.f b/CEP/PyBDSM/src/port3/rmngb.f
deleted file mode 100644
index becaa3c613f9cb0251b6941df54e8c497d137988..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/rmngb.f
+++ /dev/null
@@ -1,526 +0,0 @@
- SUBROUTINE RMNGB(B, D, FX, G, IV, LIV, LV, N, V, X)
-C
-C *** CARRY OUT MNGB (SIMPLY BOUNDED MINIMIZATION) ITERATIONS,
-C *** USING DOUBLE-DOGLEG/BFGS STEPS.
-C
-C *** PARAMETER DECLARATIONS ***
-C
- INTEGER LIV, LV, N
- INTEGER IV(LIV)
- REAL B(2,N), D(N), FX, G(N), V(LV), X(N)
-C
-C-------------------------- PARAMETER USAGE --------------------------
-C
-C B.... VECTOR OF LOWER AND UPPER BOUNDS ON X.
-C D.... SCALE VECTOR.
-C FX... FUNCTION VALUE.
-C G.... GRADIENT VECTOR.
-C IV... INTEGER VALUE ARRAY.
-C LIV.. LENGTH OF IV (AT LEAST 59) + N.
-C LV... LENGTH OF V (AT LEAST 71 + N*(N+19)/2).
-C N.... NUMBER OF VARIABLES (COMPONENTS IN X AND G).
-C V.... FLOATING-POINT VALUE ARRAY.
-C X.... VECTOR OF PARAMETERS TO BE OPTIMIZED.
-C
-C *** DISCUSSION ***
-C
-C PARAMETERS IV, N, V, AND X ARE THE SAME AS THE CORRESPONDING
-C ONES TO MNGB (WHICH SEE), EXCEPT THAT V CAN BE SHORTER (SINCE
-C THE PART OF V THAT MNGB USES FOR STORING G IS NOT NEEDED).
-C MOREOVER, COMPARED WITH MNGB, IV(1) MAY HAVE THE TWO ADDITIONAL
-C OUTPUT VALUES 1 AND 2, WHICH ARE EXPLAINED BELOW, AS IS THE USE
-C OF IV(TOOBIG) AND IV(NFGCAL). THE VALUE IV(G), WHICH IS AN
-C OUTPUT VALUE FROM MNGB (AND SMSNOB), IS NOT REFERENCED BY
-C RMNGB OR THE SUBROUTINES IT CALLS.
-C FX AND G NEED NOT HAVE BEEN INITIALIZED WHEN RMNGB IS CALLED
-C WITH IV(1) = 12, 13, OR 14.
-C
-C IV(1) = 1 MEANS THE CALLER SHOULD SET FX TO F(X), THE FUNCTION VALUE
-C AT X, AND CALL RMNGB AGAIN, HAVING CHANGED NONE OF THE
-C OTHER PARAMETERS. AN EXCEPTION OCCURS IF F(X) CANNOT BE
-C (E.G. IF OVERFLOW WOULD OCCUR), WHICH MAY HAPPEN BECAUSE
-C OF AN OVERSIZED STEP. IN THIS CASE THE CALLER SHOULD SET
-C IV(TOOBIG) = IV(2) TO 1, WHICH WILL CAUSE RMNGB TO IG-
-C NORE FX AND TRY A SMALLER STEP. THE PARAMETER NF THAT
-C MNGB PASSES TO CALCF (FOR POSSIBLE _USE_ BY CALCG) IS A
-C COPY OF IV(NFCALL) = IV(6).
-C IV(1) = 2 MEANS THE CALLER SHOULD SET G TO G(X), THE GRADIENT VECTOR
-C OF F AT X, AND CALL RMNGB AGAIN, HAVING CHANGED NONE OF
-C THE OTHER PARAMETERS EXCEPT POSSIBLY THE SCALE VECTOR D
-C WHEN IV(DTYPE) = 0. THE PARAMETER NF THAT MNGB PASSES
-C TO CALCG IS IV(NFGCAL) = IV(7). IF G(X) CANNOT BE
-C EVALUATED, THEN THE CALLER MAY SET IV(NFGCAL) TO 0, IN
-C WHICH CASE RMNGB WILL RETURN WITH IV(1) = 65.
-C.
-C *** GENERAL ***
-C
-C CODED BY DAVID M. GAY (DECEMBER 1979). REVISED SEPT. 1982.
-C THIS SUBROUTINE WAS WRITTEN IN CONNECTION WITH RESEARCH SUPPORTED
-C IN PART BY THE NATIONAL SCIENCE FOUNDATION UNDER GRANTS
-C MCS-7600324 AND MCS-7906671.
-C
-C (SEE MNG FOR REFERENCES.)
-C
-C+++++++++++++++++++++++++++ DECLARATIONS ++++++++++++++++++++++++++++
-C
-C *** LOCAL VARIABLES ***
-C
- INTEGER DG1, DSTEP1, DUMMY, G01, I, I1, IPI, IPN, J, K, L, LSTGST,
- 1 N1, NP1, NWTST1, RSTRST, STEP1, TEMP0, TEMP1, TD1, TG1,
- 2 W1, X01, Z
- REAL GI, T, XI
-C
-C *** CONSTANTS ***
-C
- REAL NEGONE, ONE, ONEP2, ZERO
-C
-C *** NO INTRINSIC FUNCTIONS ***
-C
-C *** EXTERNAL FUNCTIONS AND SUBROUTINES ***
-C
- LOGICAL STOPX
- REAL D7TPR, RLDST, V2NRM
- EXTERNAL A7SST, D7DGB, IVSET, D7TPR, I7SHFT, ITSUM, L7TVM,
- 1 L7UPD, L7VML, PARCK, Q7RSH, RLDST, STOPX, V2NRM,
- 2 V2AXY, V7CPY, V7IPR, V7SCP, V7VMP, W7ZBF
-C
-C A7SST.... ASSESSES CANDIDATE STEP.
-C D7DGB... COMPUTES SIMPLY BOUNDED DOUBLE-DOGLEG (CANDIDATE) STEP.
-C IVSET.... SUPPLIES DEFAULT IV AND V INPUT COMPONENTS.
-C D7TPR... RETURNS INNER PRODUCT OF TWO VECTORS.
-C I7SHFT... CYCLICALLLY SHIFTS AN ARRAY OF INTEGERS.
-C ITSUM.... PRINTS ITERATION SUMMARY AND INFO ON INITIAL AND FINAL X.
-C L7TVM... MULTIPLIES TRANSPOSE OF LOWER TRIANGLE TIMES VECTOR.
-C LUPDT.... UPDATES CHOLESKY FACTOR OF HESSIAN APPROXIMATION.
-C L7VML.... MULTIPLIES LOWER TRIANGLE TIMES VECTOR.
-C PARCK.... CHECKS VALIDITY OF INPUT IV AND V VALUES.
-C Q7RSH... CYCLICALLY SHIFTS CHOLESKY FACTOR.
-C RLDST... COMPUTES V(RELDX) = RELATIVE STEP SIZE.
-C STOPX.... RETURNS .TRUE. IF THE BREAK KEY HAS BEEN PRESSED.
-C V2NRM... RETURNS THE 2-NORM OF A VECTOR.
-C V2AXY.... COMPUTES SCALAR TIMES ONE VECTOR PLUS ANOTHER.
-C V7CPY.... COPIES ONE VECTOR TO ANOTHER.
-C V7IPR... CYCLICALLY SHIFTS A FLOATING-POINT ARRAY.
-C V7SCP... SETS ALL ELEMENTS OF A VECTOR TO A SCALAR.
-C V7VMP... MULTIPLIES VECTOR BY VECTOR RAISED TO POWER (COMPONENTWISE).
-C W7ZBF... COMPUTES W AND Z FOR L7UPD CORRESPONDING TO BFGS UPDATE.
-C
-C *** SUBSCRIPTS FOR IV AND V ***
-C
- INTEGER CNVCOD, DG, DGNORM, DINIT, DSTNRM, F, F0, FDIF,
- 1 GTSTEP, INCFAC, INITH, IRC, IVNEED, KAGQT, LMAT,
- 2 LMAX0, LMAXS, MODE, MODEL, MXFCAL, MXITER, NC, NEXTIV,
- 3 NEXTV, NFCALL, NFGCAL, NGCALL, NITER, NWTSTP, PERM,
- 4 PREDUC, RADFAC, RADINC, RADIUS, RAD0, RELDX, RESTOR, STEP,
- 4 STGLIM, STLSTG, TOOBIG, TUNER4, TUNER5, VNEED, XIRC, X0
-C
-C *** IV SUBSCRIPT VALUES ***
-C
-C *** (NOTE THAT NC IS STORED IN IV(G0)) ***
-C
-C/6
-C DATA CNVCOD/55/, DG/37/, INITH/25/, IRC/29/, IVNEED/3/, KAGQT/33/,
-C 1 MODE/35/, MODEL/5/, MXFCAL/17/, MXITER/18/, NC/48/,
-C 2 NEXTIV/46/, NEXTV/47/, NFCALL/6/, NFGCAL/7/, NGCALL/30/,
-C 3 NITER/31/, NWTSTP/34/, PERM/58/, RADINC/8/, RESTOR/9/,
-C 4 STEP/40/, STGLIM/11/, STLSTG/41/, TOOBIG/2/, XIRC/13/, X0/43/
-C/7
- PARAMETER (CNVCOD=55, DG=37, INITH=25, IRC=29, IVNEED=3, KAGQT=33,
- 1 MODE=35, MODEL=5, MXFCAL=17, MXITER=18, NC=48,
- 2 NEXTIV=46, NEXTV=47, NFCALL=6, NFGCAL=7, NGCALL=30,
- 3 NITER=31, NWTSTP=34, PERM=58, RADINC=8, RESTOR=9,
- 4 STEP=40, STGLIM=11, STLSTG=41, TOOBIG=2, XIRC=13,
- 5 X0=43)
-C/
-C
-C *** V SUBSCRIPT VALUES ***
-C
-C/6
-C DATA DGNORM/1/, DINIT/38/, DSTNRM/2/, F/10/, F0/13/, FDIF/11/,
-C 1 GTSTEP/4/, INCFAC/23/, LMAT/42/, LMAX0/35/, LMAXS/36/,
-C 2 PREDUC/7/, RADFAC/16/, RADIUS/8/, RAD0/9/, RELDX/17/,
-C 3 TUNER4/29/, TUNER5/30/, VNEED/4/
-C/7
- PARAMETER (DGNORM=1, DINIT=38, DSTNRM=2, F=10, F0=13, FDIF=11,
- 1 GTSTEP=4, INCFAC=23, LMAT=42, LMAX0=35, LMAXS=36,
- 2 PREDUC=7, RADFAC=16, RADIUS=8, RAD0=9, RELDX=17,
- 3 TUNER4=29, TUNER5=30, VNEED=4)
-C/
-C
-C/6
-C DATA NEGONE/-1.E+0/, ONE/1.E+0/, ONEP2/1.2E+0/, ZERO/0.E+0/
-C/7
- PARAMETER (NEGONE=-1.E+0, ONE=1.E+0, ONEP2=1.2E+0, ZERO=0.E+0)
-C/
-C
-C+++++++++++++++++++++++++++++++ BODY ++++++++++++++++++++++++++++++++
-C
- I = IV(1)
- IF (I .EQ. 1) GO TO 70
- IF (I .EQ. 2) GO TO 80
-C
-C *** CHECK VALIDITY OF IV AND V INPUT VALUES ***
-C
- IF (IV(1) .EQ. 0) CALL IVSET(2, IV, LIV, LV, V)
- IF (IV(1) .LT. 12) GO TO 10
- IF (IV(1) .GT. 13) GO TO 10
- IV(VNEED) = IV(VNEED) + N*(N+19)/2
- IV(IVNEED) = IV(IVNEED) + N
- 10 CALL PARCK(2, D, IV, LIV, LV, N, V)
- I = IV(1) - 2
- IF (I .GT. 12) GO TO 999
- GO TO (250, 250, 250, 250, 250, 250, 190, 150, 190, 20, 20, 30), I
-C
-C *** STORAGE ALLOCATION ***
-C
- 20 L = IV(LMAT)
- IV(X0) = L + N*(N+1)/2
- IV(STEP) = IV(X0) + 2*N
- IV(STLSTG) = IV(STEP) + 2*N
- IV(NWTSTP) = IV(STLSTG) + N
- IV(DG) = IV(NWTSTP) + 2*N
- IV(NEXTV) = IV(DG) + 2*N
- IV(NEXTIV) = IV(PERM) + N
- IF (IV(1) .NE. 13) GO TO 30
- IV(1) = 14
- GO TO 999
-C
-C *** INITIALIZATION ***
-C
- 30 IV(NITER) = 0
- IV(NFCALL) = 1
- IV(NGCALL) = 1
- IV(NFGCAL) = 1
- IV(MODE) = -1
- IV(MODEL) = 1
- IV(STGLIM) = 1
- IV(TOOBIG) = 0
- IV(CNVCOD) = 0
- IV(RADINC) = 0
- IV(NC) = N
- V(RAD0) = ZERO
-C
-C *** CHECK CONSISTENCY OF B AND INITIALIZE IP ARRAY ***
-C
- IPI = IV(PERM)
- DO 40 I = 1, N
- IV(IPI) = I
- IPI = IPI + 1
- IF (B(1,I) .GT. B(2,I)) GO TO 410
- 40 CONTINUE
-C
- IF (V(DINIT) .GE. ZERO) CALL V7SCP(N, D, V(DINIT))
- IF (IV(INITH) .NE. 1) GO TO 60
-C
-C *** SET THE INITIAL HESSIAN APPROXIMATION TO DIAG(D)**-2 ***
-C
- L = IV(LMAT)
- CALL V7SCP(N*(N+1)/2, V(L), ZERO)
- K = L - 1
- DO 50 I = 1, N
- K = K + I
- T = D(I)
- IF (T .LE. ZERO) T = ONE
- V(K) = T
- 50 CONTINUE
-C
-C *** GET INITIAL FUNCTION VALUE ***
-C
- 60 IV(1) = 1
- GO TO 440
-C
- 70 V(F) = FX
- IF (IV(MODE) .GE. 0) GO TO 250
- V(F0) = FX
- IV(1) = 2
- IF (IV(TOOBIG) .EQ. 0) GO TO 999
- IV(1) = 63
- GO TO 430
-C
-C *** MAKE SURE GRADIENT COULD BE COMPUTED ***
-C
- 80 IF (IV(TOOBIG) .EQ. 0) GO TO 90
- IV(1) = 65
- GO TO 430
-C
-C *** CHOOSE INITIAL PERMUTATION ***
-C
- 90 IPI = IV(PERM)
- IPN = IPI + N
- N1 = N
- NP1 = N + 1
- L = IV(LMAT)
- W1 = IV(NWTSTP) + N
- K = N - IV(NC)
- DO 120 I = 1, N
- IPN = IPN - 1
- J = IV(IPN)
- IF (B(1,J) .GE. B(2,J)) GO TO 100
- XI = X(J)
- GI = G(J)
- IF (XI .LE. B(1,J) .AND. GI .GT. ZERO) GO TO 100
- IF (XI .GE. B(2,J) .AND. GI .LT. ZERO) GO TO 100
-C *** DISALLOW CONVERGENCE IF X(J) HAS JUST BEEN FREED ***
- IF (I .LE. K) IV(CNVCOD) = 0
- GO TO 120
- 100 I1 = NP1 - I
- IF (I1 .GE. N1) GO TO 110
- CALL I7SHFT(N1, I1, IV(IPI))
- CALL Q7RSH(I1, N1, .FALSE., G, V(L), V(W1))
- 110 N1 = N1 - 1
- 120 CONTINUE
-C
- IV(NC) = N1
- V(DGNORM) = ZERO
- IF (N1 .LE. 0) GO TO 130
- DG1 = IV(DG)
- CALL V7VMP(N, V(DG1), G, D, -1)
- CALL V7IPR(N, IV(IPI), V(DG1))
- V(DGNORM) = V2NRM(N1, V(DG1))
- 130 IF (IV(CNVCOD) .NE. 0) GO TO 420
- IF (IV(MODE) .EQ. 0) GO TO 370
-C
-C *** ALLOW FIRST STEP TO HAVE SCALED 2-NORM AT MOST V(LMAX0) ***
-C
- V(RADIUS) = V(LMAX0)
-C
- IV(MODE) = 0
-C
-C
-C----------------------------- MAIN LOOP -----------------------------
-C
-C
-C *** PRINT ITERATION SUMMARY, CHECK ITERATION LIMIT ***
-C
- 140 CALL ITSUM(D, G, IV, LIV, LV, N, V, X)
- 150 K = IV(NITER)
- IF (K .LT. IV(MXITER)) GO TO 160
- IV(1) = 10
- GO TO 430
-C
-C *** UPDATE RADIUS ***
-C
- 160 IV(NITER) = K + 1
- IF (K .EQ. 0) GO TO 170
- T = V(RADFAC) * V(DSTNRM)
- IF (V(RADFAC) .LT. ONE .OR. T .GT. V(RADIUS)) V(RADIUS) = T
-C
-C *** INITIALIZE FOR START OF NEXT ITERATION ***
-C
- 170 X01 = IV(X0)
- V(F0) = V(F)
- IV(IRC) = 4
- IV(KAGQT) = -1
-C
-C *** COPY X TO X0 ***
-C
- CALL V7CPY(N, V(X01), X)
-C
-C *** CHECK STOPX AND FUNCTION EVALUATION LIMIT ***
-C
- 180 IF (.NOT. STOPX(DUMMY)) GO TO 200
- IV(1) = 11
- GO TO 210
-C
-C *** COME HERE WHEN RESTARTING AFTER FUNC. EVAL. LIMIT OR STOPX.
-C
- 190 IF (V(F) .GE. V(F0)) GO TO 200
- V(RADFAC) = ONE
- K = IV(NITER)
- GO TO 160
-C
- 200 IF (IV(NFCALL) .LT. IV(MXFCAL)) GO TO 220
- IV(1) = 9
- 210 IF (V(F) .GE. V(F0)) GO TO 430
-C
-C *** IN CASE OF STOPX OR FUNCTION EVALUATION LIMIT WITH
-C *** IMPROVED V(F), EVALUATE THE GRADIENT AT X.
-C
- IV(CNVCOD) = IV(1)
- GO TO 360
-C
-C. . . . . . . . . . . . . COMPUTE CANDIDATE STEP . . . . . . . . . .
-C
- 220 STEP1 = IV(STEP)
- DG1 = IV(DG)
- NWTST1 = IV(NWTSTP)
- W1 = NWTST1 + N
- DSTEP1 = STEP1 + N
- IPI = IV(PERM)
- L = IV(LMAT)
- TG1 = DG1 + N
- X01 = IV(X0)
- TD1 = X01 + N
- CALL D7DGB(B, D, V(DG1), V(DSTEP1), G, IV(IPI), IV(KAGQT),
- 1 V(L), LV, N, IV(NC), V(NWTST1), V(STEP1), V(TD1),
- 2 V(TG1), V, V(W1), V(X01))
- IF (IV(IRC) .NE. 6) GO TO 230
- IF (IV(RESTOR) .NE. 2) GO TO 250
- RSTRST = 2
- GO TO 260
-C
-C *** CHECK WHETHER EVALUATING F(X0 + STEP) LOOKS WORTHWHILE ***
-C
- 230 IV(TOOBIG) = 0
- IF (V(DSTNRM) .LE. ZERO) GO TO 250
- IF (IV(IRC) .NE. 5) GO TO 240
- IF (V(RADFAC) .LE. ONE) GO TO 240
- IF (V(PREDUC) .GT. ONEP2 * V(FDIF)) GO TO 240
- IF (IV(RESTOR) .NE. 2) GO TO 250
- RSTRST = 0
- GO TO 260
-C
-C *** COMPUTE F(X0 + STEP) ***
-C
- 240 CALL V2AXY(N, X, ONE, V(STEP1), V(X01))
- IV(NFCALL) = IV(NFCALL) + 1
- IV(1) = 1
- GO TO 440
-C
-C. . . . . . . . . . . . . ASSESS CANDIDATE STEP . . . . . . . . . . .
-C
- 250 RSTRST = 3
- 260 X01 = IV(X0)
- V(RELDX) = RLDST(N, D, X, V(X01))
- CALL A7SST(IV, LIV, LV, V)
- STEP1 = IV(STEP)
- LSTGST = IV(STLSTG)
- I = IV(RESTOR) + 1
- GO TO (300, 270, 280, 290), I
- 270 CALL V7CPY(N, X, V(X01))
- GO TO 300
- 280 CALL V7CPY(N, V(LSTGST), X)
- GO TO 300
- 290 CALL V7CPY(N, X, V(LSTGST))
- CALL V2AXY(N, V(STEP1), NEGONE, V(X01), X)
- V(RELDX) = RLDST(N, D, X, V(X01))
- IV(RESTOR) = RSTRST
-C
- 300 K = IV(IRC)
- GO TO (310,340,340,340,310,320,330,330,330,330,330,330,400,370), K
-C
-C *** RECOMPUTE STEP WITH CHANGED RADIUS ***
-C
- 310 V(RADIUS) = V(RADFAC) * V(DSTNRM)
- GO TO 180
-C
-C *** COMPUTE STEP OF LENGTH V(LMAXS) FOR SINGULAR CONVERGENCE TEST.
-C
- 320 V(RADIUS) = V(LMAXS)
- GO TO 220
-C
-C *** CONVERGENCE OR FALSE CONVERGENCE ***
-C
- 330 IV(CNVCOD) = K - 4
- IF (V(F) .GE. V(F0)) GO TO 420
- IF (IV(XIRC) .EQ. 14) GO TO 420
- IV(XIRC) = 14
-C
-C. . . . . . . . . . . . PROCESS ACCEPTABLE STEP . . . . . . . . . . .
-C
- 340 X01 = IV(X0)
- STEP1 = IV(STEP)
- CALL V2AXY(N, V(STEP1), NEGONE, V(X01), X)
- IF (IV(IRC) .NE. 3) GO TO 360
-C
-C *** SET TEMP1 = HESSIAN * STEP FOR _USE_ IN GRADIENT TESTS ***
-C
-C *** _USE_ X0 AS TEMPORARY...
-C
- IPI = IV(PERM)
- CALL V7CPY(N, V(X01), V(STEP1))
- CALL V7IPR(N, IV(IPI), V(X01))
- L = IV(LMAT)
- CALL L7TVM(N, V(X01), V(L), V(X01))
- CALL L7VML(N, V(X01), V(L), V(X01))
-C
-C *** UNPERMUTE X0 INTO TEMP1 ***
-C
- TEMP1 = IV(STLSTG)
- TEMP0 = TEMP1 - 1
- DO 350 I = 1, N
- J = IV(IPI)
- IPI = IPI + 1
- K = TEMP0 + J
- V(K) = V(X01)
- X01 = X01 + 1
- 350 CONTINUE
-C
-C *** SAVE OLD GRADIENT, COMPUTE NEW ONE ***
-C
- 360 G01 = IV(NWTSTP) + N
- CALL V7CPY(N, V(G01), G)
- IV(NGCALL) = IV(NGCALL) + 1
- IV(TOOBIG) = 0
- IV(1) = 2
- GO TO 999
-C
-C *** INITIALIZATIONS -- G0 = G - G0, ETC. ***
-C
- 370 G01 = IV(NWTSTP) + N
- CALL V2AXY(N, V(G01), NEGONE, V(G01), G)
- STEP1 = IV(STEP)
- TEMP1 = IV(STLSTG)
- IF (IV(IRC) .NE. 3) GO TO 390
-C
-C *** SET V(RADFAC) BY GRADIENT TESTS ***
-C
-C *** SET TEMP1 = DIAG(D)**-1 * (HESSIAN*STEP + (G(X0)-G(X))) ***
-C
- CALL V2AXY(N, V(TEMP1), NEGONE, V(G01), V(TEMP1))
- CALL V7VMP(N, V(TEMP1), V(TEMP1), D, -1)
-C
-C *** DO GRADIENT TESTS ***
-C
- IF ( V2NRM(N, V(TEMP1)) .LE. V(DGNORM) * V(TUNER4))
- 1 GO TO 380
- IF ( D7TPR(N, G, V(STEP1))
- 1 .GE. V(GTSTEP) * V(TUNER5)) GO TO 390
- 380 V(RADFAC) = V(INCFAC)
-C
-C *** UPDATE H, LOOP ***
-C
- 390 W1 = IV(NWTSTP)
- Z = IV(X0)
- L = IV(LMAT)
- IPI = IV(PERM)
- CALL V7IPR(N, IV(IPI), V(STEP1))
- CALL V7IPR(N, IV(IPI), V(G01))
- CALL W7ZBF(V(L), N, V(STEP1), V(W1), V(G01), V(Z))
-C
-C ** _USE_ THE N-VECTORS STARTING AT V(STEP1) AND V(G01) FOR SCRATCH..
- CALL L7UPD(V(TEMP1), V(STEP1), V(L), V(G01), V(L), N, V(W1),
- 1 V(Z))
- IV(1) = 2
- GO TO 140
-C
-C. . . . . . . . . . . . . . MISC. DETAILS . . . . . . . . . . . . . .
-C
-C *** BAD PARAMETERS TO ASSESS ***
-C
- 400 IV(1) = 64
- GO TO 430
-C
-C *** INCONSISTENT B ***
-C
- 410 IV(1) = 82
- GO TO 430
-C
-C *** PRINT SUMMARY OF FINAL ITERATION AND OTHER REQUESTED ITEMS ***
-C
- 420 IV(1) = IV(CNVCOD)
- IV(CNVCOD) = 0
- 430 CALL ITSUM(D, G, IV, LIV, LV, N, V, X)
- GO TO 999
-C
-C *** PROJECT X INTO FEASIBLE REGION (PRIOR TO COMPUTING F OR G) ***
-C
- 440 DO 450 I = 1, N
- IF (X(I) .LT. B(1,I)) X(I) = B(1,I)
- IF (X(I) .GT. B(2,I)) X(I) = B(2,I)
- 450 CONTINUE
-C
- 999 RETURN
-C
-C *** LAST CARD OF RMNGB FOLLOWS ***
- END
diff --git a/CEP/PyBDSM/src/port3/rmnh.f b/CEP/PyBDSM/src/port3/rmnh.f
deleted file mode 100644
index 28b70fa26000d061cca0ee7f19701593057e6993..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/rmnh.f
+++ /dev/null
@@ -1,460 +0,0 @@
- SUBROUTINE RMNH(D, FX, G, H, IV, LH, LIV, LV, N, V, X)
-C
-C *** CARRY OUT MNH (UNCONSTRAINED MINIMIZATION) ITERATIONS, USING
-C *** HESSIAN MATRIX PROVIDED BY THE CALLER.
-C
-C *** PARAMETER DECLARATIONS ***
-C
- INTEGER LH, LIV, LV, N
- INTEGER IV(LIV)
- REAL D(N), FX, G(N), H(LH), V(LV), X(N)
-C
-C-------------------------- PARAMETER USAGE --------------------------
-C
-C D.... SCALE VECTOR.
-C FX... FUNCTION VALUE.
-C G.... GRADIENT VECTOR.
-C H.... LOWER TRIANGLE OF THE HESSIAN, STORED ROWWISE.
-C IV... INTEGER VALUE ARRAY.
-C LH... LENGTH OF H = P*(P+1)/2.
-C LIV.. LENGTH OF IV (AT LEAST 60).
-C LV... LENGTH OF V (AT LEAST 78 + N*(N+21)/2).
-C N.... NUMBER OF VARIABLES (COMPONENTS IN X AND G).
-C V.... FLOATING-POINT VALUE ARRAY.
-C X.... PARAMETER VECTOR.
-C
-C *** DISCUSSION ***
-C
-C PARAMETERS IV, N, V, AND X ARE THE SAME AS THE CORRESPONDING
-C ONES TO MNH (WHICH SEE), EXCEPT THAT V CAN BE SHORTER (SINCE
-C THE PART OF V THAT MNH USES FOR STORING G AND H IS NOT NEEDED).
-C MOREOVER, COMPARED WITH MNH, IV(1) MAY HAVE THE TWO ADDITIONAL
-C OUTPUT VALUES 1 AND 2, WHICH ARE EXPLAINED BELOW, AS IS THE USE
-C OF IV(TOOBIG) AND IV(NFGCAL). THE VALUE IV(G), WHICH IS AN
-C OUTPUT VALUE FROM MNH, IS NOT REFERENCED BY RMNH OR THE
-C SUBROUTINES IT CALLS.
-C
-C IV(1) = 1 MEANS THE CALLER SHOULD SET FX TO F(X), THE FUNCTION VALUE
-C AT X, AND CALL RMNH AGAIN, HAVING CHANGED NONE OF THE
-C OTHER PARAMETERS. AN EXCEPTION OCCURS IF F(X) CANNOT BE
-C COMPUTED (E.G. IF OVERFLOW WOULD OCCUR), WHICH MAY HAPPEN
-C BECAUSE OF AN OVERSIZED STEP. IN THIS CASE THE CALLER
-C SHOULD SET IV(TOOBIG) = IV(2) TO 1, WHICH WILL CAUSE
-C RMNH TO IGNORE FX AND TRY A SMALLER STEP. THE PARA-
-C METER NF THAT MNH PASSES TO CALCF (FOR POSSIBLE _USE_ BY
-C CALCGH) IS A COPY OF IV(NFCALL) = IV(6).
-C IV(1) = 2 MEANS THE CALLER SHOULD SET G TO G(X), THE GRADIENT OF F AT
-C X, AND H TO THE LOWER TRIANGLE OF H(X), THE HESSIAN OF F
-C AT X, AND CALL RMNH AGAIN, HAVING CHANGED NONE OF THE
-C OTHER PARAMETERS EXCEPT PERHAPS THE SCALE VECTOR D.
-C THE PARAMETER NF THAT MNH PASSES TO CALCG IS
-C IV(NFGCAL) = IV(7). IF G(X) AND H(X) CANNOT BE EVALUATED,
-C THEN THE CALLER MAY SET IV(TOOBIG) TO 0, IN WHICH CASE
-C RMNH WILL RETURN WITH IV(1) = 65.
-C NOTE -- RMNH OVERWRITES H WITH THE LOWER TRIANGLE
-C OF DIAG(D)**-1 * H(X) * DIAG(D)**-1.
-C.
-C *** GENERAL ***
-C
-C CODED BY DAVID M. GAY (WINTER 1980). REVISED SEPT. 1982.
-C THIS SUBROUTINE WAS WRITTEN IN CONNECTION WITH RESEARCH SUPPORTED
-C IN PART BY THE NATIONAL SCIENCE FOUNDATION UNDER GRANTS
-C MCS-7600324 AND MCS-7906671.
-C
-C (SEE MNG AND MNH FOR REFERENCES.)
-C
-C+++++++++++++++++++++++++++ DECLARATIONS ++++++++++++++++++++++++++++
-C
-C *** LOCAL VARIABLES ***
-C
- INTEGER DG1, DUMMY, I, J, K, L, LSTGST, NN1O2, RSTRST, STEP1,
- 1 TEMP1, W1, X01
- REAL T
-C
-C *** CONSTANTS ***
-C
- REAL ONE, ONEP2, ZERO
-C
-C *** NO INTRINSIC FUNCTIONS ***
-C
-C *** EXTERNAL FUNCTIONS AND SUBROUTINES ***
-C
- LOGICAL STOPX
- REAL D7TPR, RLDST, V2NRM
- EXTERNAL A7SST, IVSET, D7TPR, D7DUP, G7QTS, ITSUM, PARCK,
- 1 RLDST, S7LVM, STOPX, V2AXY, V7CPY, V7SCP, V2NRM
-C
-C A7SST.... ASSESSES CANDIDATE STEP.
-C IVSET.... PROVIDES DEFAULT IV AND V INPUT VALUES.
-C D7TPR... RETURNS INNER PRODUCT OF TWO VECTORS.
-C D7DUP.... UPDATES SCALE VECTOR D.
-C G7QTS.... COMPUTES OPTIMALLY LOCALLY CONSTRAINED STEP.
-C ITSUM.... PRINTS ITERATION SUMMARY AND INFO ON INITIAL AND FINAL X.
-C PARCK.... CHECKS VALIDITY OF INPUT IV AND V VALUES.
-C RLDST... COMPUTES V(RELDX) = RELATIVE STEP SIZE.
-C S7LVM... MULTIPLIES SYMMETRIC MATRIX TIMES VECTOR, GIVEN THE LOWER
-C TRIANGLE OF THE MATRIX.
-C STOPX.... RETURNS .TRUE. IF THE BREAK KEY HAS BEEN PRESSED.
-C V2AXY.... COMPUTES SCALAR TIMES ONE VECTOR PLUS ANOTHER.
-C V7CPY.... COPIES ONE VECTOR TO ANOTHER.
-C V7SCP... SETS ALL ELEMENTS OF A VECTOR TO A SCALAR.
-C V2NRM... RETURNS THE 2-NORM OF A VECTOR.
-C
-C *** SUBSCRIPTS FOR IV AND V ***
-C
- INTEGER CNVCOD, DG, DGNORM, DINIT, DSTNRM, DTINIT, DTOL,
- 1 DTYPE, D0INIT, F, F0, FDIF, GTSTEP, INCFAC, IRC, KAGQT,
- 2 LMAT, LMAX0, LMAXS, MODE, MODEL, MXFCAL, MXITER, NEXTV,
- 3 NFCALL, NFGCAL, NGCALL, NITER, PHMXFC, PREDUC, RADFAC,
- 4 RADINC, RADIUS, RAD0, RELDX, RESTOR, STEP, STGLIM, STLSTG,
- 5 STPPAR, TOOBIG, TUNER4, TUNER5, VNEED, W, XIRC, X0
-C
-C *** IV SUBSCRIPT VALUES ***
-C
-C/6
-C DATA CNVCOD/55/, DG/37/, DTOL/59/, DTYPE/16/, IRC/29/, KAGQT/33/,
-C 1 LMAT/42/, MODE/35/, MODEL/5/, MXFCAL/17/, MXITER/18/,
-C 2 NEXTV/47/, NFCALL/6/, NFGCAL/7/, NGCALL/30/, NITER/31/,
-C 3 RADINC/8/, RESTOR/9/, STEP/40/, STGLIM/11/, STLSTG/41/,
-C 4 TOOBIG/2/, VNEED/4/, W/34/, XIRC/13/, X0/43/
-C/7
- PARAMETER (CNVCOD=55, DG=37, DTOL=59, DTYPE=16, IRC=29, KAGQT=33,
- 1 LMAT=42, MODE=35, MODEL=5, MXFCAL=17, MXITER=18,
- 2 NEXTV=47, NFCALL=6, NFGCAL=7, NGCALL=30, NITER=31,
- 3 RADINC=8, RESTOR=9, STEP=40, STGLIM=11, STLSTG=41,
- 4 TOOBIG=2, VNEED=4, W=34, XIRC=13, X0=43)
-C/
-C
-C *** V SUBSCRIPT VALUES ***
-C
-C/6
-C DATA DGNORM/1/, DINIT/38/, DSTNRM/2/, DTINIT/39/, D0INIT/40/,
-C 1 F/10/, F0/13/, FDIF/11/, GTSTEP/4/, INCFAC/23/, LMAX0/35/,
-C 2 LMAXS/36/, PHMXFC/21/, PREDUC/7/, RADFAC/16/, RADIUS/8/,
-C 3 RAD0/9/, RELDX/17/, STPPAR/5/, TUNER4/29/, TUNER5/30/
-C/7
- PARAMETER (DGNORM=1, DINIT=38, DSTNRM=2, DTINIT=39, D0INIT=40,
- 1 F=10, F0=13, FDIF=11, GTSTEP=4, INCFAC=23, LMAX0=35,
- 2 LMAXS=36, PHMXFC=21, PREDUC=7, RADFAC=16, RADIUS=8,
- 3 RAD0=9, RELDX=17, STPPAR=5, TUNER4=29, TUNER5=30)
-C/
-C
-C/6
-C DATA ONE/1.E+0/, ONEP2/1.2E+0/, ZERO/0.E+0/
-C/7
- PARAMETER (ONE=1.E+0, ONEP2=1.2E+0, ZERO=0.E+0)
-C/
-C
-C+++++++++++++++++++++++++++++++ BODY ++++++++++++++++++++++++++++++++
-C
- I = IV(1)
- IF (I .EQ. 1) GO TO 30
- IF (I .EQ. 2) GO TO 40
-C
-C *** CHECK VALIDITY OF IV AND V INPUT VALUES ***
-C
- IF (IV(1) .EQ. 0) CALL IVSET(2, IV, LIV, LV, V)
- IF (IV(1) .EQ. 12 .OR. IV(1) .EQ. 13)
- 1 IV(VNEED) = IV(VNEED) + N*(N+21)/2 + 7
- CALL PARCK(2, D, IV, LIV, LV, N, V)
- I = IV(1) - 2
- IF (I .GT. 12) GO TO 999
- NN1O2 = N * (N + 1) / 2
- IF (LH .GE. NN1O2) GO TO (220,220,220,220,220,220,160,120,160,
- 1 10,10,20), I
- IV(1) = 66
- GO TO 400
-C
-C *** STORAGE ALLOCATION ***
-C
- 10 IV(DTOL) = IV(LMAT) + NN1O2
- IV(X0) = IV(DTOL) + 2*N
- IV(STEP) = IV(X0) + N
- IV(STLSTG) = IV(STEP) + N
- IV(DG) = IV(STLSTG) + N
- IV(W) = IV(DG) + N
- IV(NEXTV) = IV(W) + 4*N + 7
- IF (IV(1) .NE. 13) GO TO 20
- IV(1) = 14
- GO TO 999
-C
-C *** INITIALIZATION ***
-C
- 20 IV(NITER) = 0
- IV(NFCALL) = 1
- IV(NGCALL) = 1
- IV(NFGCAL) = 1
- IV(MODE) = -1
- IV(MODEL) = 1
- IV(STGLIM) = 1
- IV(TOOBIG) = 0
- IV(CNVCOD) = 0
- IV(RADINC) = 0
- V(RAD0) = ZERO
- V(STPPAR) = ZERO
- IF (V(DINIT) .GE. ZERO) CALL V7SCP(N, D, V(DINIT))
- K = IV(DTOL)
- IF (V(DTINIT) .GT. ZERO) CALL V7SCP(N, V(K), V(DTINIT))
- K = K + N
- IF (V(D0INIT) .GT. ZERO) CALL V7SCP(N, V(K), V(D0INIT))
- IV(1) = 1
- GO TO 999
-C
- 30 V(F) = FX
- IF (IV(MODE) .GE. 0) GO TO 220
- V(F0) = FX
- IV(1) = 2
- IF (IV(TOOBIG) .EQ. 0) GO TO 999
- IV(1) = 63
- GO TO 400
-C
-C *** MAKE SURE GRADIENT COULD BE COMPUTED ***
-C
- 40 IF (IV(TOOBIG) .EQ. 0) GO TO 50
- IV(1) = 65
- GO TO 400
-C
-C *** UPDATE THE SCALE VECTOR D ***
-C
- 50 DG1 = IV(DG)
- IF (IV(DTYPE) .LE. 0) GO TO 70
- K = DG1
- J = 0
- DO 60 I = 1, N
- J = J + I
- V(K) = H(J)
- K = K + 1
- 60 CONTINUE
- CALL D7DUP(D, V(DG1), IV, LIV, LV, N, V)
-C
-C *** COMPUTE SCALED GRADIENT AND ITS NORM ***
-C
- 70 DG1 = IV(DG)
- K = DG1
- DO 80 I = 1, N
- V(K) = G(I) / D(I)
- K = K + 1
- 80 CONTINUE
- V(DGNORM) = V2NRM(N, V(DG1))
-C
-C *** COMPUTE SCALED HESSIAN ***
-C
- K = 1
- DO 100 I = 1, N
- T = ONE / D(I)
- DO 90 J = 1, I
- H(K) = T * H(K) / D(J)
- K = K + 1
- 90 CONTINUE
- 100 CONTINUE
-C
- IF (IV(CNVCOD) .NE. 0) GO TO 390
- IF (IV(MODE) .EQ. 0) GO TO 350
-C
-C *** ALLOW FIRST STEP TO HAVE SCALED 2-NORM AT MOST V(LMAX0) ***
-C
- V(RADIUS) = V(LMAX0) / (ONE + V(PHMXFC))
-C
- IV(MODE) = 0
-C
-C
-C----------------------------- MAIN LOOP -----------------------------
-C
-C
-C *** PRINT ITERATION SUMMARY, CHECK ITERATION LIMIT ***
-C
- 110 CALL ITSUM(D, G, IV, LIV, LV, N, V, X)
- 120 K = IV(NITER)
- IF (K .LT. IV(MXITER)) GO TO 130
- IV(1) = 10
- GO TO 400
-C
- 130 IV(NITER) = K + 1
-C
-C *** INITIALIZE FOR START OF NEXT ITERATION ***
-C
- DG1 = IV(DG)
- X01 = IV(X0)
- V(F0) = V(F)
- IV(IRC) = 4
- IV(KAGQT) = -1
-C
-C *** COPY X TO X0 ***
-C
- CALL V7CPY(N, V(X01), X)
-C
-C *** UPDATE RADIUS ***
-C
- IF (K .EQ. 0) GO TO 150
- STEP1 = IV(STEP)
- K = STEP1
- DO 140 I = 1, N
- V(K) = D(I) * V(K)
- K = K + 1
- 140 CONTINUE
- V(RADIUS) = V(RADFAC) * V2NRM(N, V(STEP1))
-C
-C *** CHECK STOPX AND FUNCTION EVALUATION LIMIT ***
-C
- 150 IF (.NOT. STOPX(DUMMY)) GO TO 170
- IV(1) = 11
- GO TO 180
-C
-C *** COME HERE WHEN RESTARTING AFTER FUNC. EVAL. LIMIT OR STOPX.
-C
- 160 IF (V(F) .GE. V(F0)) GO TO 170
- V(RADFAC) = ONE
- K = IV(NITER)
- GO TO 130
-C
- 170 IF (IV(NFCALL) .LT. IV(MXFCAL)) GO TO 190
- IV(1) = 9
- 180 IF (V(F) .GE. V(F0)) GO TO 400
-C
-C *** IN CASE OF STOPX OR FUNCTION EVALUATION LIMIT WITH
-C *** IMPROVED V(F), EVALUATE THE GRADIENT AT X.
-C
- IV(CNVCOD) = IV(1)
- GO TO 340
-C
-C. . . . . . . . . . . . . COMPUTE CANDIDATE STEP . . . . . . . . . .
-C
- 190 STEP1 = IV(STEP)
- DG1 = IV(DG)
- L = IV(LMAT)
- W1 = IV(W)
- CALL G7QTS(D, V(DG1), H, IV(KAGQT), V(L), N, V(STEP1), V, V(W1))
- IF (IV(IRC) .NE. 6) GO TO 200
- IF (IV(RESTOR) .NE. 2) GO TO 220
- RSTRST = 2
- GO TO 230
-C
-C *** CHECK WHETHER EVALUATING F(X0 + STEP) LOOKS WORTHWHILE ***
-C
- 200 IV(TOOBIG) = 0
- IF (V(DSTNRM) .LE. ZERO) GO TO 220
- IF (IV(IRC) .NE. 5) GO TO 210
- IF (V(RADFAC) .LE. ONE) GO TO 210
- IF (V(PREDUC) .GT. ONEP2 * V(FDIF)) GO TO 210
- IF (IV(RESTOR) .NE. 2) GO TO 220
- RSTRST = 0
- GO TO 230
-C
-C *** COMPUTE F(X0 + STEP) ***
-C
- 210 X01 = IV(X0)
- STEP1 = IV(STEP)
- CALL V2AXY(N, X, ONE, V(STEP1), V(X01))
- IV(NFCALL) = IV(NFCALL) + 1
- IV(1) = 1
- GO TO 999
-C
-C. . . . . . . . . . . . . ASSESS CANDIDATE STEP . . . . . . . . . . .
-C
- 220 RSTRST = 3
- 230 X01 = IV(X0)
- V(RELDX) = RLDST(N, D, X, V(X01))
- CALL A7SST(IV, LIV, LV, V)
- STEP1 = IV(STEP)
- LSTGST = IV(STLSTG)
- I = IV(RESTOR) + 1
- GO TO (270, 240, 250, 260), I
- 240 CALL V7CPY(N, X, V(X01))
- GO TO 270
- 250 CALL V7CPY(N, V(LSTGST), V(STEP1))
- GO TO 270
- 260 CALL V7CPY(N, V(STEP1), V(LSTGST))
- CALL V2AXY(N, X, ONE, V(STEP1), V(X01))
- V(RELDX) = RLDST(N, D, X, V(X01))
- IV(RESTOR) = RSTRST
-C
- 270 K = IV(IRC)
- GO TO (280,310,310,310,280,290,300,300,300,300,300,300,380,350), K
-C
-C *** RECOMPUTE STEP WITH NEW RADIUS ***
-C
- 280 V(RADIUS) = V(RADFAC) * V(DSTNRM)
- GO TO 150
-C
-C *** COMPUTE STEP OF LENGTH V(LMAXS) FOR SINGULAR CONVERGENCE TEST.
-C
- 290 V(RADIUS) = V(LMAXS)
- GO TO 190
-C
-C *** CONVERGENCE OR FALSE CONVERGENCE ***
-C
- 300 IV(CNVCOD) = K - 4
- IF (V(F) .GE. V(F0)) GO TO 390
- IF (IV(XIRC) .EQ. 14) GO TO 390
- IV(XIRC) = 14
-C
-C. . . . . . . . . . . . PROCESS ACCEPTABLE STEP . . . . . . . . . . .
-C
- 310 IF (IV(IRC) .NE. 3) GO TO 340
- TEMP1 = LSTGST
-C
-C *** PREPARE FOR GRADIENT TESTS ***
-C *** SET TEMP1 = HESSIAN * STEP + G(X0)
-C *** = DIAG(D) * (H * STEP + G(X0))
-C
-C _USE_ X0 VECTOR AS TEMPORARY.
- K = X01
- DO 320 I = 1, N
- V(K) = D(I) * V(STEP1)
- K = K + 1
- STEP1 = STEP1 + 1
- 320 CONTINUE
- CALL S7LVM(N, V(TEMP1), H, V(X01))
- DO 330 I = 1, N
- V(TEMP1) = D(I) * V(TEMP1) + G(I)
- TEMP1 = TEMP1 + 1
- 330 CONTINUE
-C
-C *** COMPUTE GRADIENT AND HESSIAN ***
-C
- 340 IV(NGCALL) = IV(NGCALL) + 1
- IV(TOOBIG) = 0
- IV(1) = 2
- GO TO 999
-C
- 350 IV(1) = 2
- IF (IV(IRC) .NE. 3) GO TO 110
-C
-C *** SET V(RADFAC) BY GRADIENT TESTS ***
-C
- TEMP1 = IV(STLSTG)
- STEP1 = IV(STEP)
-C
-C *** SET TEMP1 = DIAG(D)**-1 * (HESSIAN*STEP + (G(X0)-G(X))) ***
-C
- K = TEMP1
- DO 360 I = 1, N
- V(K) = (V(K) - G(I)) / D(I)
- K = K + 1
- 360 CONTINUE
-C
-C *** DO GRADIENT TESTS ***
-C
- IF ( V2NRM(N, V(TEMP1)) .LE. V(DGNORM) * V(TUNER4)) GO TO 370
- IF ( D7TPR(N, G, V(STEP1))
- 1 .GE. V(GTSTEP) * V(TUNER5)) GO TO 110
- 370 V(RADFAC) = V(INCFAC)
- GO TO 110
-C
-C. . . . . . . . . . . . . . MISC. DETAILS . . . . . . . . . . . . . .
-C
-C *** BAD PARAMETERS TO ASSESS ***
-C
- 380 IV(1) = 64
- GO TO 400
-C
-C *** PRINT SUMMARY OF FINAL ITERATION AND OTHER REQUESTED ITEMS ***
-C
- 390 IV(1) = IV(CNVCOD)
- IV(CNVCOD) = 0
- 400 CALL ITSUM(D, G, IV, LIV, LV, N, V, X)
-C
- 999 RETURN
-C
-C *** LAST CARD OF RMNH FOLLOWS ***
- END
diff --git a/CEP/PyBDSM/src/port3/rmnhb.f b/CEP/PyBDSM/src/port3/rmnhb.f
deleted file mode 100644
index c9e7c3f133be228de0105125a309cfebe465c9c6..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/rmnhb.f
+++ /dev/null
@@ -1,539 +0,0 @@
- SUBROUTINE RMNHB(B, D, FX, G, H, IV, LH, LIV, LV, N, V, X)
-C
-C *** CARRY OUT MNHB (SIMPLY BOUNDED MINIMIZATION) ITERATIONS,
-C *** USING HESSIAN MATRIX PROVIDED BY THE CALLER.
-C
-C *** PARAMETER DECLARATIONS ***
-C
- INTEGER LH, LIV, LV, N
- INTEGER IV(LIV)
- REAL B(2,N), D(N), FX, G(N), H(LH), V(LV), X(N)
-C
-C-------------------------- PARAMETER USAGE --------------------------
-C
-C D.... SCALE VECTOR.
-C FX... FUNCTION VALUE.
-C G.... GRADIENT VECTOR.
-C H.... LOWER TRIANGLE OF THE HESSIAN, STORED ROWWISE.
-C IV... INTEGER VALUE ARRAY.
-C LH... LENGTH OF H = P*(P+1)/2.
-C LIV.. LENGTH OF IV (AT LEAST 59 + 3*N).
-C LV... LENGTH OF V (AT LEAST 78 + N*(N+27)/2).
-C N.... NUMBER OF VARIABLES (COMPONENTS IN X AND G).
-C V.... FLOATING-POINT VALUE ARRAY.
-C X.... PARAMETER VECTOR.
-C
-C *** DISCUSSION ***
-C
-C PARAMETERS IV, N, V, AND X ARE THE SAME AS THE CORRESPONDING
-C ONES TO MNHB (WHICH SEE), EXCEPT THAT V CAN BE SHORTER (SINCE
-C THE PART OF V THAT MNHB USES FOR STORING G AND H IS NOT NEEDED).
-C MOREOVER, COMPARED WITH MNHB, IV(1) MAY HAVE THE TWO ADDITIONAL
-C OUTPUT VALUES 1 AND 2, WHICH ARE EXPLAINED BELOW, AS IS THE USE
-C OF IV(TOOBIG) AND IV(NFGCAL). THE VALUE IV(G), WHICH IS AN
-C OUTPUT VALUE FROM MNHB, IS NOT REFERENCED BY RMNHB OR THE
-C SUBROUTINES IT CALLS.
-C
-C IV(1) = 1 MEANS THE CALLER SHOULD SET FX TO F(X), THE FUNCTION VALUE
-C AT X, AND CALL RMNHB AGAIN, HAVING CHANGED NONE OF THE
-C OTHER PARAMETERS. AN EXCEPTION OCCURS IF F(X) CANNOT BE
-C COMPUTED (E.G. IF OVERFLOW WOULD OCCUR), WHICH MAY HAPPEN
-C BECAUSE OF AN OVERSIZED STEP. IN THIS CASE THE CALLER
-C SHOULD SET IV(TOOBIG) = IV(2) TO 1, WHICH WILL CAUSE
-C RMNHB TO IGNORE FX AND TRY A SMALLER STEP. THE PARA-
-C METER NF THAT MNH PASSES TO CALCF (FOR POSSIBLE _USE_ BY
-C CALCGH) IS A COPY OF IV(NFCALL) = IV(6).
-C IV(1) = 2 MEANS THE CALLER SHOULD SET G TO G(X), THE GRADIENT OF F AT
-C X, AND H TO THE LOWER TRIANGLE OF H(X), THE HESSIAN OF F
-C AT X, AND CALL RMNHB AGAIN, HAVING CHANGED NONE OF THE
-C OTHER PARAMETERS EXCEPT PERHAPS THE SCALE VECTOR D.
-C THE PARAMETER NF THAT MNHB PASSES TO CALCG IS
-C IV(NFGCAL) = IV(7). IF G(X) AND H(X) CANNOT BE EVALUATED,
-C THEN THE CALLER MAY SET IV(NFGCAL) TO 0, IN WHICH CASE
-C RMNHB WILL RETURN WITH IV(1) = 65.
-C NOTE -- RMNHB OVERWRITES H WITH THE LOWER TRIANGLE
-C OF DIAG(D)**-1 * H(X) * DIAG(D)**-1.
-C.
-C *** GENERAL ***
-C
-C CODED BY DAVID M. GAY (WINTER, SPRING 1983).
-C
-C (SEE MNG AND MNH FOR REFERENCES.)
-C
-C+++++++++++++++++++++++++++ DECLARATIONS ++++++++++++++++++++++++++++
-C
-C *** LOCAL VARIABLES ***
-C
- INTEGER DG1, DUMMY, I, IPI, IPIV2, IPN, J, K, L, LSTGST, NN1O2,
- 1 RSTRST, STEP0, STEP1, TD1, TEMP0, TEMP1, TG1, W1, X01, X11
- REAL GI, T, XI
-C
-C *** CONSTANTS ***
-C
- REAL NEGONE, ONE, ONEP2, ZERO
-C
-C *** NO INTRINSIC FUNCTIONS ***
-C
-C *** EXTERNAL FUNCTIONS AND SUBROUTINES ***
-C
- LOGICAL STOPX
- REAL D7TPR, RLDST, V2NRM
- EXTERNAL A7SST, IVSET, D7TPR, D7DUP, G7QSB, I7PNVR, ITSUM,
- 1 PARCK, RLDST, S7IPR, S7LVM, STOPX, V2NRM, V2AXY,
- 2 V7CPY, V7IPR, V7SCP, V7VMP
-C
-C A7SST.... ASSESSES CANDIDATE STEP.
-C IVSET.... PROVIDES DEFAULT IV AND V INPUT VALUES.
-C D7TPR... RETURNS INNER PRODUCT OF TWO VECTORS.
-C D7DUP.... UPDATES SCALE VECTOR D.
-C G7QSB... COMPUTES APPROXIMATE OPTIMAL BOUNDED STEP.
-C I7PNVR... INVERTS PERMUTATION ARRAY.
-C ITSUM.... PRINTS ITERATION SUMMARY AND INFO ON INITIAL AND FINAL X.
-C PARCK.... CHECKS VALIDITY OF INPUT IV AND V VALUES.
-C RLDST... COMPUTES V(RELDX) = RELATIVE STEP SIZE.
-C S7IPR... APPLIES PERMUTATION TO LOWER TRIANG. OF SYM. MATRIX.
-C S7LVM... MULTIPLIES SYMMETRIC MATRIX TIMES VECTOR, GIVEN THE LOWER
-C TRIANGLE OF THE MATRIX.
-C STOPX.... RETURNS .TRUE. IF THE BREAK KEY HAS BEEN PRESSED.
-C V2NRM... RETURNS THE 2-NORM OF A VECTOR.
-C V2AXY.... COMPUTES SCALAR TIMES ONE VECTOR PLUS ANOTHER.
-C V7CPY.... COPIES ONE VECTOR TO ANOTHER.
-C V7IPR... APPLIES PERMUTATION TO VECTOR.
-C V7SCP... SETS ALL ELEMENTS OF A VECTOR TO A SCALAR.
-C V7VMP... MULTIPLIES (OR DIVIDES) TWO VECTORS COMPONENTWISE.
-C
-C *** SUBSCRIPTS FOR IV AND V ***
-C
- INTEGER CNVCOD, DG, DGNORM, DINIT, DSTNRM, DTINIT, DTOL, DTYPE,
- 1 D0INIT, F, F0, FDIF, GTSTEP, INCFAC, IVNEED, IRC, KAGQT,
- 2 LMAT, LMAX0, LMAXS, MODE, MODEL, MXFCAL, MXITER, N0, NC,
- 3 NEXTIV, NEXTV, NFCALL, NFGCAL, NGCALL, NITER, PERM,
- 4 PHMXFC, PREDUC, RADFAC, RADINC, RADIUS, RAD0, RELDX,
- 5 RESTOR, STEP, STGLIM, STPPAR, TOOBIG, TUNER4, TUNER5,
- 6 VNEED, W, XIRC, X0
-C
-C *** IV SUBSCRIPT VALUES ***
-C
-C *** (NOTE THAT NC AND N0 ARE STORED IN IV(G0) AND IV(STLSTG) RESP.)
-C
-C/6
-C DATA CNVCOD/55/, DG/37/, DTOL/59/, DTYPE/16/, IRC/29/, IVNEED/3/,
-C 1 KAGQT/33/, LMAT/42/, MODE/35/, MODEL/5/, MXFCAL/17/,
-C 2 MXITER/18/, N0/41/, NC/48/, NEXTIV/46/, NEXTV/47/, NFCALL/6/,
-C 3 NFGCAL/7/, NGCALL/30/, NITER/31/, PERM/58/, RADINC/8/,
-C 4 RESTOR/9/, STEP/40/, STGLIM/11/, TOOBIG/2/, VNEED/4/, W/34/,
-C 5 XIRC/13/, X0/43/
-C/7
- PARAMETER (CNVCOD=55, DG=37, DTOL=59, DTYPE=16, IRC=29, IVNEED=3,
- 1 KAGQT=33, LMAT=42, MODE=35, MODEL=5, MXFCAL=17,
- 2 MXITER=18, N0=41, NC=48, NEXTIV=46, NEXTV=47, NFCALL=6,
- 3 NFGCAL=7, NGCALL=30, NITER=31, PERM=58, RADINC=8,
- 4 RESTOR=9, STEP=40, STGLIM=11, TOOBIG=2, VNEED=4, W=34,
- 5 XIRC=13, X0=43)
-C/
-C
-C *** V SUBSCRIPT VALUES ***
-C
-C/6
-C DATA DGNORM/1/, DINIT/38/, DSTNRM/2/, DTINIT/39/, D0INIT/40/,
-C 1 F/10/, F0/13/, FDIF/11/, GTSTEP/4/, INCFAC/23/, LMAX0/35/,
-C 2 LMAXS/36/, PHMXFC/21/, PREDUC/7/, RADFAC/16/, RADIUS/8/,
-C 3 RAD0/9/, RELDX/17/, STPPAR/5/, TUNER4/29/, TUNER5/30/
-C/7
- PARAMETER (DGNORM=1, DINIT=38, DSTNRM=2, DTINIT=39, D0INIT=40,
- 1 F=10, F0=13, FDIF=11, GTSTEP=4, INCFAC=23, LMAX0=35,
- 2 LMAXS=36, PHMXFC=21, PREDUC=7, RADFAC=16, RADIUS=8,
- 3 RAD0=9, RELDX=17, STPPAR=5, TUNER4=29, TUNER5=30)
-C/
-C
-C/6
-C DATA NEGONE/-1.E+0/, ONE/1.E+0/, ONEP2/1.2E+0/, ZERO/0.E+0/
-C/7
- PARAMETER (NEGONE=-1.E+0, ONE=1.E+0, ONEP2=1.2E+0, ZERO=0.E+0)
-C/
-C
-C+++++++++++++++++++++++++++++++ BODY ++++++++++++++++++++++++++++++++
-C
- I = IV(1)
- IF (I .EQ. 1) GO TO 50
- IF (I .EQ. 2) GO TO 60
-C
-C *** CHECK VALIDITY OF IV AND V INPUT VALUES ***
-C
- IF (IV(1) .EQ. 0) CALL IVSET(2, IV, LIV, LV, V)
- IF (IV(1) .LT. 12) GO TO 10
- IF (IV(1) .GT. 13) GO TO 10
- IV(VNEED) = IV(VNEED) + N*(N+27)/2 + 7
- IV(IVNEED) = IV(IVNEED) + 3*N
- 10 CALL PARCK(2, D, IV, LIV, LV, N, V)
- I = IV(1) - 2
- IF (I .GT. 12) GO TO 999
- NN1O2 = N * (N + 1) / 2
- IF (LH .GE. NN1O2) GO TO (250,250,250,250,250,250,190,150,190,
- 1 20,20,30), I
- IV(1) = 81
- GO TO 440
-C
-C *** STORAGE ALLOCATION ***
-C
- 20 IV(DTOL) = IV(LMAT) + NN1O2
- IV(X0) = IV(DTOL) + 2*N
- IV(STEP) = IV(X0) + 2*N
- IV(DG) = IV(STEP) + 3*N
- IV(W) = IV(DG) + 2*N
- IV(NEXTV) = IV(W) + 4*N + 7
- IV(NEXTIV) = IV(PERM) + 3*N
- IF (IV(1) .NE. 13) GO TO 30
- IV(1) = 14
- GO TO 999
-C
-C *** INITIALIZATION ***
-C
- 30 IV(NITER) = 0
- IV(NFCALL) = 1
- IV(NGCALL) = 1
- IV(NFGCAL) = 1
- IV(MODE) = -1
- IV(MODEL) = 1
- IV(STGLIM) = 1
- IV(TOOBIG) = 0
- IV(CNVCOD) = 0
- IV(RADINC) = 0
- IV(NC) = N
- V(RAD0) = ZERO
- V(STPPAR) = ZERO
- IF (V(DINIT) .GE. ZERO) CALL V7SCP(N, D, V(DINIT))
- K = IV(DTOL)
- IF (V(DTINIT) .GT. ZERO) CALL V7SCP(N, V(K), V(DTINIT))
- K = K + N
- IF (V(D0INIT) .GT. ZERO) CALL V7SCP(N, V(K), V(D0INIT))
-C
-C *** CHECK CONSISTENCY OF B AND INITIALIZE IP ARRAY ***
-C
- IPI = IV(PERM)
- DO 40 I = 1, N
- IV(IPI) = I
- IPI = IPI + 1
- IF (B(1,I) .GT. B(2,I)) GO TO 420
- 40 CONTINUE
-C
-C *** GET INITIAL FUNCTION VALUE ***
-C
- IV(1) = 1
- GO TO 450
-C
- 50 V(F) = FX
- IF (IV(MODE) .GE. 0) GO TO 250
- V(F0) = FX
- IV(1) = 2
- IF (IV(TOOBIG) .EQ. 0) GO TO 999
- IV(1) = 63
- GO TO 440
-C
-C *** MAKE SURE GRADIENT COULD BE COMPUTED ***
-C
- 60 IF (IV(TOOBIG) .EQ. 0) GO TO 70
- IV(1) = 65
- GO TO 440
-C
-C *** UPDATE THE SCALE VECTOR D ***
-C
- 70 DG1 = IV(DG)
- IF (IV(DTYPE) .LE. 0) GO TO 90
- K = DG1
- J = 0
- DO 80 I = 1, N
- J = J + I
- V(K) = H(J)
- K = K + 1
- 80 CONTINUE
- CALL D7DUP(D, V(DG1), IV, LIV, LV, N, V)
-C
-C *** COMPUTE SCALED GRADIENT AND ITS NORM ***
-C
- 90 DG1 = IV(DG)
- CALL V7VMP(N, V(DG1), G, D, -1)
-C
-C *** COMPUTE SCALED HESSIAN ***
-C
- K = 1
- DO 110 I = 1, N
- T = ONE / D(I)
- DO 100 J = 1, I
- H(K) = T * H(K) / D(J)
- K = K + 1
- 100 CONTINUE
- 110 CONTINUE
-C
-C *** CHOOSE INITIAL PERMUTATION ***
-C
- IPI = IV(PERM)
- IPN = IPI + N
- IPIV2 = IPN - 1
-C *** INVERT OLD PERMUTATION ARRAY ***
- CALL I7PNVR(N, IV(IPN), IV(IPI))
- K = IV(NC)
- DO 130 I = 1, N
- IF (B(1,I) .GE. B(2,I)) GO TO 120
- XI = X(I)
- GI = G(I)
- IF (XI .LE. B(1,I) .AND. GI .GT. ZERO) GO TO 120
- IF (XI .GE. B(2,I) .AND. GI .LT. ZERO) GO TO 120
- IV(IPI) = I
- IPI = IPI + 1
- J = IPIV2 + I
-C *** DISALLOW CONVERGENCE IF X(I) HAS JUST BEEN FREED ***
- IF (IV(J) .GT. K) IV(CNVCOD) = 0
- GO TO 130
- 120 IPN = IPN - 1
- IV(IPN) = I
- 130 CONTINUE
- IV(NC) = IPN - IV(PERM)
-C
-C *** PERMUTE SCALED GRADIENT AND HESSIAN ACCORDINGLY ***
-C
- IPI = IV(PERM)
- CALL S7IPR(N, IV(IPI), H)
- CALL V7IPR(N, IV(IPI), V(DG1))
- V(DGNORM) = ZERO
- IF (IV(NC) .GT. 0) V(DGNORM) = V2NRM(IV(NC), V(DG1))
-C
- IF (IV(CNVCOD) .NE. 0) GO TO 430
- IF (IV(MODE) .EQ. 0) GO TO 380
-C
-C *** ALLOW FIRST STEP TO HAVE SCALED 2-NORM AT MOST V(LMAX0) ***
-C
- V(RADIUS) = V(LMAX0) / (ONE + V(PHMXFC))
-C
- IV(MODE) = 0
-C
-C
-C----------------------------- MAIN LOOP -----------------------------
-C
-C
-C *** PRINT ITERATION SUMMARY, CHECK ITERATION LIMIT ***
-C
- 140 CALL ITSUM(D, G, IV, LIV, LV, N, V, X)
- 150 K = IV(NITER)
- IF (K .LT. IV(MXITER)) GO TO 160
- IV(1) = 10
- GO TO 440
-C
- 160 IV(NITER) = K + 1
-C
-C *** INITIALIZE FOR START OF NEXT ITERATION ***
-C
- X01 = IV(X0)
- V(F0) = V(F)
- IV(IRC) = 4
- IV(KAGQT) = -1
-C
-C *** COPY X TO X0 ***
-C
- CALL V7CPY(N, V(X01), X)
-C
-C *** UPDATE RADIUS ***
-C
- IF (K .EQ. 0) GO TO 180
- STEP1 = IV(STEP)
- K = STEP1
- DO 170 I = 1, N
- V(K) = D(I) * V(K)
- K = K + 1
- 170 CONTINUE
- T = V(RADFAC) * V2NRM(N, V(STEP1))
- IF (V(RADFAC) .LT. ONE .OR. T .GT. V(RADIUS)) V(RADIUS) = T
-C
-C *** CHECK STOPX AND FUNCTION EVALUATION LIMIT ***
-C
- 180 IF (.NOT. STOPX(DUMMY)) GO TO 200
- IV(1) = 11
- GO TO 210
-C
-C *** COME HERE WHEN RESTARTING AFTER FUNC. EVAL. LIMIT OR STOPX.
-C
- 190 IF (V(F) .GE. V(F0)) GO TO 200
- V(RADFAC) = ONE
- K = IV(NITER)
- GO TO 160
-C
- 200 IF (IV(NFCALL) .LT. IV(MXFCAL)) GO TO 220
- IV(1) = 9
- 210 IF (V(F) .GE. V(F0)) GO TO 440
-C
-C *** IN CASE OF STOPX OR FUNCTION EVALUATION LIMIT WITH
-C *** IMPROVED V(F), EVALUATE THE GRADIENT AT X.
-C
- IV(CNVCOD) = IV(1)
- GO TO 370
-C
-C. . . . . . . . . . . . . COMPUTE CANDIDATE STEP . . . . . . . . . .
-C
- 220 STEP1 = IV(STEP)
- L = IV(LMAT)
- W1 = IV(W)
- IPI = IV(PERM)
- IPN = IPI + N
- IPIV2 = IPN + N
- TG1 = IV(DG)
- TD1 = TG1 + N
- X01 = IV(X0)
- X11 = X01 + N
- CALL G7QSB(B, D, H, G, IV(IPI), IV(IPN), IV(IPIV2), IV(KAGQT),
- 1 V(L), LV, N, IV(N0), IV(NC), V(STEP1), V(TD1), V(TG1),
- 2 V, V(W1), V(X11), V(X01))
- IF (IV(IRC) .NE. 6) GO TO 230
- IF (IV(RESTOR) .NE. 2) GO TO 250
- RSTRST = 2
- GO TO 260
-C
-C *** CHECK WHETHER EVALUATING F(X0 + STEP) LOOKS WORTHWHILE ***
-C
- 230 IV(TOOBIG) = 0
- IF (V(DSTNRM) .LE. ZERO) GO TO 250
- IF (IV(IRC) .NE. 5) GO TO 240
- IF (V(RADFAC) .LE. ONE) GO TO 240
- IF (V(PREDUC) .GT. ONEP2 * V(FDIF)) GO TO 240
- IF (IV(RESTOR) .NE. 2) GO TO 250
- RSTRST = 0
- GO TO 260
-C
-C *** COMPUTE F(X0 + STEP) ***
-C
- 240 CALL V2AXY(N, X, ONE, V(STEP1), V(X01))
- IV(NFCALL) = IV(NFCALL) + 1
- IV(1) = 1
- GO TO 450
-C
-C. . . . . . . . . . . . . ASSESS CANDIDATE STEP . . . . . . . . . . .
-C
- 250 RSTRST = 3
- 260 X01 = IV(X0)
- V(RELDX) = RLDST(N, D, X, V(X01))
- CALL A7SST(IV, LIV, LV, V)
- STEP1 = IV(STEP)
- LSTGST = STEP1 + 2*N
- I = IV(RESTOR) + 1
- GO TO (300, 270, 280, 290), I
- 270 CALL V7CPY(N, X, V(X01))
- GO TO 300
- 280 CALL V7CPY(N, V(LSTGST), X)
- GO TO 300
- 290 CALL V7CPY(N, X, V(LSTGST))
- CALL V2AXY(N, V(STEP1), NEGONE, V(X01), X)
- V(RELDX) = RLDST(N, D, X, V(X01))
- IV(RESTOR) = RSTRST
-C
- 300 K = IV(IRC)
- GO TO (310,340,340,340,310,320,330,330,330,330,330,330,410,380), K
-C
-C *** RECOMPUTE STEP WITH NEW RADIUS ***
-C
- 310 V(RADIUS) = V(RADFAC) * V(DSTNRM)
- GO TO 180
-C
-C *** COMPUTE STEP OF LENGTH V(LMAXS) FOR SINGULAR CONVERGENCE TEST.
-C
- 320 V(RADIUS) = V(LMAXS)
- GO TO 220
-C
-C *** CONVERGENCE OR FALSE CONVERGENCE ***
-C
- 330 IV(CNVCOD) = K - 4
- IF (V(F) .GE. V(F0)) GO TO 430
- IF (IV(XIRC) .EQ. 14) GO TO 430
- IV(XIRC) = 14
-C
-C. . . . . . . . . . . . PROCESS ACCEPTABLE STEP . . . . . . . . . . .
-C
- 340 IF (IV(IRC) .NE. 3) GO TO 370
- TEMP1 = LSTGST
-C
-C *** PREPARE FOR GRADIENT TESTS ***
-C *** SET TEMP1 = HESSIAN * STEP + G(X0)
-C *** = DIAG(D) * (H * STEP + G(X0))
-C
- K = TEMP1
- STEP0 = STEP1 - 1
- IPI = IV(PERM)
- DO 350 I = 1, N
- J = IV(IPI)
- IPI = IPI + 1
- STEP1 = STEP0 + J
- V(K) = D(J) * V(STEP1)
- K = K + 1
- 350 CONTINUE
-C _USE_ X0 VECTOR AS TEMPORARY.
- CALL S7LVM(N, V(X01), H, V(TEMP1))
- TEMP0 = TEMP1 - 1
- IPI = IV(PERM)
- DO 360 I = 1, N
- J = IV(IPI)
- IPI = IPI + 1
- TEMP1 = TEMP0 + J
- V(TEMP1) = D(J) * V(X01) + G(J)
- X01 = X01 + 1
- 360 CONTINUE
-C
-C *** COMPUTE GRADIENT AND HESSIAN ***
-C
- 370 IV(NGCALL) = IV(NGCALL) + 1
- IV(TOOBIG) = 0
- IV(1) = 2
- GO TO 450
-C
- 380 IV(1) = 2
- IF (IV(IRC) .NE. 3) GO TO 140
-C
-C *** SET V(RADFAC) BY GRADIENT TESTS ***
-C
- STEP1 = IV(STEP)
-C *** TEMP1 = STLSTG ***
- TEMP1 = STEP1 + 2*N
-C
-C *** SET TEMP1 = DIAG(D)**-1 * (HESSIAN*STEP + (G(X0)-G(X))) ***
-C
- K = TEMP1
- DO 390 I = 1, N
- V(K) = (V(K) - G(I)) / D(I)
- K = K + 1
- 390 CONTINUE
-C
-C *** DO GRADIENT TESTS ***
-C
- IF ( V2NRM(N, V(TEMP1)) .LE. V(DGNORM) * V(TUNER4)) GO TO 400
- IF ( D7TPR(N, G, V(STEP1))
- 1 .GE. V(GTSTEP) * V(TUNER5)) GO TO 140
- 400 V(RADFAC) = V(INCFAC)
- GO TO 140
-C
-C. . . . . . . . . . . . . . MISC. DETAILS . . . . . . . . . . . . . .
-C
-C *** BAD PARAMETERS TO ASSESS ***
-C
- 410 IV(1) = 64
- GO TO 440
-C
-C *** INCONSISTENT B ***
-C
- 420 IV(1) = 82
- GO TO 440
-C
-C *** PRINT SUMMARY OF FINAL ITERATION AND OTHER REQUESTED ITEMS ***
-C
- 430 IV(1) = IV(CNVCOD)
- IV(CNVCOD) = 0
- 440 CALL ITSUM(D, G, IV, LIV, LV, N, V, X)
- GO TO 999
-C
-C *** PROJECT X INTO FEASIBLE REGION (PRIOR TO COMPUTING F OR G) ***
-C
- 450 DO 460 I = 1, N
- IF (X(I) .LT. B(1,I)) X(I) = B(1,I)
- IF (X(I) .GT. B(2,I)) X(I) = B(2,I)
- 460 CONTINUE
-C
- 999 RETURN
-C
-C *** LAST CARD OF RMNHB FOLLOWS ***
- END
diff --git a/CEP/PyBDSM/src/port3/rn2g.f b/CEP/PyBDSM/src/port3/rn2g.f
deleted file mode 100644
index f16a6162bc2156e15015a35eeeb396396e140808..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/rn2g.f
+++ /dev/null
@@ -1,461 +0,0 @@
- SUBROUTINE RN2G(D, DR, IV, LIV, LV, N, ND, N1, N2, P, R,
- 1 RD, V, X)
-C
-C *** REVISED ITERATION DRIVER FOR NL2SOL (VERSION 2.3) ***
-C
- INTEGER LIV, LV, N, ND, N1, N2, P
- INTEGER IV(LIV)
- REAL D(P), DR(ND,P), R(ND), RD(ND), V(LV), X(P)
-C
-C-------------------------- PARAMETER USAGE --------------------------
-C
-C D........ SCALE VECTOR.
-C DR....... DERIVATIVES OF R AT X.
-C IV....... INTEGER VALUES ARRAY.
-C LIV...... LENGTH OF IV... LIV MUST BE AT LEAST P + 82.
-C LV....... LENGTH OF V... LV MUST BE AT LEAST 105 + P*(2*P+16).
-C N........ TOTAL NUMBER OF RESIDUALS.
-C ND....... MAX. NO. OF RESIDUALS PASSED ON ONE CALL.
-C N1....... LOWEST ROW INDEX FOR RESIDUALS SUPPLIED THIS TIME.
-C N2....... HIGHEST ROW INDEX FOR RESIDUALS SUPPLIED THIS TIME.
-C P........ NUMBER OF PARAMETERS (COMPONENTS OF X) BEING ESTIMATED.
-C R........ RESIDUALS.
-C RD....... RD(I) = SQRT(G(I)**T * H(I)**-1 * G(I)) ON OUTPUT WHEN
-C IV(RDREQ) IS NONZERO. RN2G SETS IV(REGD) = 1 IF RD
-C IS SUCCESSFULLY COMPUTED, TO 0 IF NO ATTEMPT WAS MADE
-C TO COMPUTE IT, AND TO -1 IF H (THE FINITE-DIFFERENCE HESSIAN)
-C WAS INDEFINITE. IF ND .GE. N, THEN RD IS ALSO USED AS
-C TEMPORARY STORAGE.
-C V........ FLOATING-POINT VALUES ARRAY.
-C X........ PARAMETER VECTOR BEING ESTIMATED (INPUT = INITIAL GUESS,
-C OUTPUT = BEST VALUE FOUND).
-C
-C *** DISCUSSION ***
-C
-C NOTE... NL2SOL AND NL2ITR (MENTIONED BELOW) ARE DESCRIBED IN
-C ACM TRANS. MATH. SOFTWARE, VOL. 7, PP. 369-383 (AN ADAPTIVE
-C NONLINEAR LEAST-SQUARES ALGORITHM, BY J.E. DENNIS, D.M. GAY,
-C AND R.E. WELSCH).
-C
-C THIS ROUTINE CARRIES OUT ITERATIONS FOR SOLVING NONLINEAR
-C LEAST SQUARES PROBLEMS. WHEN ND = N, IT IS SIMILAR TO NL2ITR
-C (WITH J = DR), EXCEPT THAT R(X) AND DR(X) NEED NOT BE INITIALIZED
-C WHEN RN2G IS CALLED WITH IV(1) = 0 OR 12. RN2G ALSO ALLOWS
-C R AND DR TO BE SUPPLIED ROW-WISE -- JUST SET ND = 1 AND CALL
-C RN2G ONCE FOR EACH ROW WHEN PROVIDING RESIDUALS AND JACOBIANS.
-C ANOTHER NEW FEATURE IS THAT CALLING RN2G WITH IV(1) = 13
-C CAUSES STORAGE ALLOCATION ONLY TO BE PERFORMED -- ON RETURN, SUCH
-C COMPONENTS AS IV(G) (THE FIRST SUBSCRIPT IN G OF THE GRADIENT)
-C AND IV(S) (THE FIRST SUBSCRIPT IN V OF THE S LOWER TRIANGLE OF
-C THE S MATRIX) WILL HAVE BEEN SET (UNLESS LIV OR LV IS TOO SMALL),
-C AND IV(1) WILL HAVE BEEN SET TO 14. CALLING RN2G WITH IV(1) = 14
-C CAUSES EXECUTION OF THE ALGORITHM TO BEGIN UNDER THE ASSUMPTION
-C THAT STORAGE HAS BEEN ALLOCATED.
-C
-C *** SUPPLYING R AND DR ***
-C
-C RN2G USES IV AND V IN THE SAME WAY AS NL2SOL, WITH A SMALL
-C NUMBER OF OBVIOUS CHANGES. ONE DIFFERENCE BETWEEN RN2G AND
-C NL2ITR IS THAT INITIAL FUNCTION AND GRADIENT INFORMATION NEED NOT
-C BE SUPPLIED IN THE VERY FIRST CALL ON RN2G, THE ONE WITH
-C IV(1) = 0 OR 12. ANOTHER DIFFERENCE IS THAT RN2G RETURNS WITH
-C IV(1) = -2 WHEN IT WANTS ANOTHER LOOK AT THE OLD JACOBIAN MATRIX
-C AND THE CURRENT RESIDUAL -- THE ONE CORRESPONDING TO X AND
-C IV(NFGCAL). IT THEN RETURNS WITH IV(1) = -3 WHEN IT WANTS TO SEE
-C BOTH THE NEW RESIDUAL AND THE NEW JACOBIAN MATRIX AT ONCE. NOTE
-C THAT IV(NFGCAL) = IV(7) CONTAINS THE VALUE THAT IV(NFCALL) = IV(6)
-C HAD WHEN THE CURRENT RESIDUAL WAS EVALUATED. ALSO NOTE THAT THE
-C VALUE OF X CORRESPONDING TO THE OLD JACOBIAN MATRIX IS STORED IN
-C V, STARTING AT V(IV(X0)) = V(IV(43)).
-C ANOTHER NEW RETURN... RN2G IV(1) = -1 WHEN IT WANTS BOTH THE
-C RESIDUAL AND THE JACOBIAN TO BE EVALUATED AT X.
-C A NEW RESIDUAL VECTOR MUST BE SUPPLIED WHEN RN2G RETURNS WITH
-C IV(1) = 1 OR -1. THIS TAKES THE FORM OF VALUES OF R(I,X) PASSED
-C IN R(I-N1+1), I = N1(1)N2. YOU MAY PASS ALL THESE VALUES AT ONCE
-C (I.E., N1 = 1 AND N2 = N) OR IN PIECES BY MAKING SEVERAL CALLS ON
-C RN2G. EACH TIME RN2G RETURNS WITH IV(1) = 1, N1 WILL HAVE
-C BEEN SET TO THE INDEX OF THE NEXT RESIDUAL THAT RN2G EXPECTS TO
-C SEE, AND N2 WILL BE SET TO THE INDEX OF THE HIGHEST RESIDUAL THAT
-C COULD BE GIVEN ON THE NEXT CALL, I.E., N2 = N1 + ND - 1. (THUS
-C WHEN RN2G FIRST RETURNS WITH IV(1) = 1 FOR A NEW X, IT WILL
-C HAVE SET N1 TO 1 AND N2 TO MIN(ND,N).) THE CALLER MAY PROVIDE
-C FEWER THAN N2-N1+1 RESIDUALS ON THE NEXT CALL BY SETTING N2 TO
-C A SMALLER VALUE. RN2G ASSUMES IT HAS SEEN ALL THE RESIDUALS
-C FOR THE CURRENT X WHEN IT IS CALLED WITH N2 .GE. N.
-C EXAMPLE... SUPPOSE N = 80 AND THAT R IS TO BE PASSED IN 8
-C BLOCKS OF SIZE 10. THE FOLLOWING CODE WOULD DO THE JOB.
-C
-C N = 80
-C ND = 10
-C ...
-C DO 10 K = 1, 8
-C *** COMPUTE R(I,X) FOR I = 10*K-9 TO 10*K ***
-C *** AND STORE THEM IN R(1),...,R(10) ***
-C CALL RN2G(..., R, ...)
-C 10 CONTINUE
-C
-C THE SITUATION IS SIMILAR WHEN GRADIENT INFORMATION IS
-C REQUIRED, I.E., WHEN RN2G RETURNS WITH IV(1) = 2, -1, OR -2.
-C NOTE THAT RN2G OVERWRITES R, BUT THAT IN THE SPECIAL CASE OF
-C N1 = 1 AND N2 = N ON PREVIOUS CALLS, RN2G NEVER RETURNS WITH
-C IV(1) = -2. IT SHOULD BE CLEAR THAT THE PARTIAL DERIVATIVE OF
-C R(I,X) WITH RESPECT TO X(L) IS TO BE STORED IN DR(I-N1+1,L),
-C L = 1(1)P, I = N1(1)N2. IT IS ESSENTIAL THAT R(I) AND DR(I,L)
-C ALL CORRESPOND TO THE SAME RESIDUALS WHEN IV(1) = -1 OR -2.
-C
-C *** COVARIANCE MATRIX ***
-C
-C IV(RDREQ) = IV(57) TELLS WHETHER TO COMPUTE A COVARIANCE
-C MATRIX AND/OR REGRESSION DIAGNOSTICS... 0 MEANS NEITHER,
-C 1 MEANS COVARIANCE MATRIX ONLY, 2 MEANS REG. DIAGNOSTICS ONLY,
-C 3 MEANS BOTH. AS WITH NL2SOL, IV(COVREQ) = IV(15) TELLS WHAT
-C HESSIAN APPROXIMATION TO _USE_ IN THIS COMPUTING.
-C
-C *** REGRESSION DIAGNOSTICS ***
-C
-C SEE THE COMMENTS IN SUBROUTINE N2G.
-C
-C *** GENERAL ***
-C
-C CODED BY DAVID M. GAY.
-C
-C+++++++++++++++++++++++++++++ DECLARATIONS ++++++++++++++++++++++++++
-C
-C *** INTRINSIC FUNCTIONS ***
-C/+
- INTEGER IABS, MOD
-C/
-C *** EXTERNAL FUNCTIONS AND SUBROUTINES ***
-C
- REAL D7TPR, V2NRM
- EXTERNAL C7VFN, IVSET, D7TPR, D7UPD, G7LIT, ITSUM, L7VML,
- 1 N2CVP, N2LRD, Q7APL, Q7RAD, V7CPY, V7SCP, V2NRM
-C
-C C7VFN... FINISHES COVARIANCE COMPUTATION.
-C IVSET.... PROVIDES DEFAULT IV AND V INPUT COMPONENTS.
-C D7TPR... COMPUTES INNER PRODUCT OF TWO VECTORS.
-C D7UPD... UPDATES SCALE VECTOR D.
-C G7LIT.... PERFORMS BASIC MINIMIZATION ALGORITHM.
-C ITSUM.... PRINTS ITERATION SUMMARY, INFO ABOUT INITIAL AND FINAL X.
-C L7VML.... COMPUTES L * V, V = VECTOR, L = LOWER TRIANGULAR MATRIX.
-C N2CVP... PRINTS COVARIANCE MATRIX.
-C N2LRD... COMPUTES REGRESSION DIAGNOSTICS.
-C Q7APL... APPLIES QR TRANSFORMATIONS STORED BY Q7RAD.
-C Q7RAD.... ADDS A NEW BLOCK OF ROWS TO QR DECOMPOSITION.
-C V7CPY.... COPIES ONE VECTOR TO ANOTHER.
-C V7SCP... SETS ALL ELEMENTS OF A VECTOR TO A SCALAR.
-C
-C *** LOCAL VARIABLES ***
-C
- INTEGER G1, GI, I, IV1, IVMODE, JTOL1, K, L, LH, NN, QTR1,
- 1 RMAT1, YI, Y1
- REAL T
-C
- REAL HALF, ZERO
-C
-C *** SUBSCRIPTS FOR IV AND V ***
-C
- INTEGER CNVCOD, COVMAT, COVREQ, DINIT, DTYPE, DTINIT, D0INIT, F,
- 1 FDH, G, H, IPIVOT, IVNEED, JCN, JTOL, LMAT, MODE,
- 2 NEXTIV, NEXTV, NF0, NF00, NF1, NFCALL, NFCOV, NFGCAL,
- 3 NGCALL, NGCOV, QTR, RDREQ, REGD, RESTOR, RLIMIT, RMAT,
- 4 TOOBIG, VNEED, Y
-C
-C *** IV SUBSCRIPT VALUES ***
-C
-C/6
-C DATA CNVCOD/55/, COVMAT/26/, COVREQ/15/, DTYPE/16/, FDH/74/,
-C 1 G/28/, H/56/, IPIVOT/76/, IVNEED/3/, JCN/66/, JTOL/59/,
-C 2 LMAT/42/, MODE/35/, NEXTIV/46/, NEXTV/47/, NFCALL/6/,
-C 3 NFCOV/52/, NF0/68/, NF00/81/, NF1/69/, NFGCAL/7/, NGCALL/30/,
-C 4 NGCOV/53/, QTR/77/, RESTOR/9/, RMAT/78/, RDREQ/57/, REGD/67/,
-C 5 TOOBIG/2/, VNEED/4/, Y/48/
-C/7
- PARAMETER (CNVCOD=55, COVMAT=26, COVREQ=15, DTYPE=16, FDH=74,
- 1 G=28, H=56, IPIVOT=76, IVNEED=3, JCN=66, JTOL=59,
- 2 LMAT=42, MODE=35, NEXTIV=46, NEXTV=47, NFCALL=6,
- 3 NFCOV=52, NF0=68, NF00=81, NF1=69, NFGCAL=7, NGCALL=30,
- 4 NGCOV=53, QTR=77, RESTOR=9, RMAT=78, RDREQ=57, REGD=67,
- 5 TOOBIG=2, VNEED=4, Y=48)
-C/
-C
-C *** V SUBSCRIPT VALUES ***
-C
-C/6
-C DATA DINIT/38/, DTINIT/39/, D0INIT/40/, F/10/, RLIMIT/46/
-C/7
- PARAMETER (DINIT=38, DTINIT=39, D0INIT=40, F=10, RLIMIT=46)
-C/
-C/6
-C DATA HALF/0.5E+0/, ZERO/0.E+0/
-C/7
- PARAMETER (HALF=0.5E+0, ZERO=0.E+0)
-C/
-C
-C+++++++++++++++++++++++++++++++ BODY ++++++++++++++++++++++++++++++++
-C
- LH = P * (P+1) / 2
- IF (IV(1) .EQ. 0) CALL IVSET(1, IV, LIV, LV, V)
- IV1 = IV(1)
- IF (IV1 .GT. 2) GO TO 10
- NN = N2 - N1 + 1
- IV(RESTOR) = 0
- I = IV1 + 4
- IF (IV(TOOBIG) .EQ. 0) GO TO (150, 130, 150, 120, 120, 150), I
- IF (I .NE. 5) IV(1) = 2
- GO TO 40
-C
-C *** FRESH START OR RESTART -- CHECK INPUT INTEGERS ***
-C
- 10 IF (ND .LE. 0) GO TO 210
- IF (P .LE. 0) GO TO 210
- IF (N .LE. 0) GO TO 210
- IF (IV1 .EQ. 14) GO TO 30
- IF (IV1 .GT. 16) GO TO 300
- IF (IV1 .LT. 12) GO TO 40
- IF (IV1 .EQ. 12) IV(1) = 13
- IF (IV(1) .NE. 13) GO TO 20
- IV(IVNEED) = IV(IVNEED) + P
- IV(VNEED) = IV(VNEED) + P*(P+13)/2
- 20 CALL G7LIT(D, X, IV, LIV, LV, P, P, V, X, X)
- IF (IV(1) .NE. 14) GO TO 999
-C
-C *** STORAGE ALLOCATION ***
-C
- IV(IPIVOT) = IV(NEXTIV)
- IV(NEXTIV) = IV(IPIVOT) + P
- IV(Y) = IV(NEXTV)
- IV(G) = IV(Y) + P
- IV(JCN) = IV(G) + P
- IV(RMAT) = IV(JCN) + P
- IV(QTR) = IV(RMAT) + LH
- IV(JTOL) = IV(QTR) + P
- IV(NEXTV) = IV(JTOL) + 2*P
- IF (IV1 .EQ. 13) GO TO 999
-C
- 30 JTOL1 = IV(JTOL)
- IF (V(DINIT) .GE. ZERO) CALL V7SCP(P, D, V(DINIT))
- IF (V(DTINIT) .GT. ZERO) CALL V7SCP(P, V(JTOL1), V(DTINIT))
- I = JTOL1 + P
- IF (V(D0INIT) .GT. ZERO) CALL V7SCP(P, V(I), V(D0INIT))
- IV(NF0) = 0
- IV(NF1) = 0
- IF (ND .GE. N) GO TO 40
-C
-C *** SPECIAL CASE HANDLING OF FIRST FUNCTION AND GRADIENT EVALUATION
-C *** -- ASK FOR BOTH RESIDUAL AND JACOBIAN AT ONCE
-C
- G1 = IV(G)
- Y1 = IV(Y)
- CALL G7LIT(D, V(G1), IV, LIV, LV, P, P, V, X, V(Y1))
- IF (IV(1) .NE. 1) GO TO 220
- V(F) = ZERO
- CALL V7SCP(P, V(G1), ZERO)
- IV(1) = -1
- QTR1 = IV(QTR)
- CALL V7SCP(P, V(QTR1), ZERO)
- IV(REGD) = 0
- RMAT1 = IV(RMAT)
- GO TO 100
-C
- 40 G1 = IV(G)
- Y1 = IV(Y)
- CALL G7LIT(D, V(G1), IV, LIV, LV, P, P, V, X, V(Y1))
- IF (IV(1) - 2) 50, 60, 220
-C
- 50 V(F) = ZERO
- IF (IV(NF1) .EQ. 0) GO TO 260
- IF (IV(RESTOR) .NE. 2) GO TO 260
- IV(NF0) = IV(NF1)
- CALL V7CPY(N, RD, R)
- IV(REGD) = 0
- GO TO 260
-C
- 60 CALL V7SCP(P, V(G1), ZERO)
- IF (IV(MODE) .GT. 0) GO TO 230
- RMAT1 = IV(RMAT)
- QTR1 = IV(QTR)
- CALL V7SCP(P, V(QTR1), ZERO)
- IV(REGD) = 0
- IF (ND .LT. N) GO TO 90
- IF (N1 .NE. 1) GO TO 90
- IF (IV(MODE) .LT. 0) GO TO 100
- IF (IV(NF1) .EQ. IV(NFGCAL)) GO TO 70
- IF (IV(NF0) .NE. IV(NFGCAL)) GO TO 90
- CALL V7CPY(N, R, RD)
- GO TO 80
- 70 CALL V7CPY(N, RD, R)
- 80 CALL Q7APL(ND, N, P, DR, RD, 0)
- CALL L7VML(P, V(Y1), V(RMAT1), RD)
- GO TO 110
-C
- 90 IV(1) = -2
- IF (IV(MODE) .LT. 0) IV(1) = -1
- 100 CALL V7SCP(P, V(Y1), ZERO)
- 110 CALL V7SCP(LH, V(RMAT1), ZERO)
- GO TO 260
-C
-C *** COMPUTE F(X) ***
-C
- 120 T = V2NRM(NN, R)
- IF (T .GT. V(RLIMIT)) GO TO 200
- V(F) = V(F) + HALF * T**2
- IF (N2 .LT. N) GO TO 270
- IF (N1 .EQ. 1) IV(NF1) = IV(NFCALL)
- GO TO 40
-C
-C *** COMPUTE Y ***
-C
- 130 Y1 = IV(Y)
- YI = Y1
- DO 140 L = 1, P
- V(YI) = V(YI) + D7TPR(NN, DR(1,L), R)
- YI = YI + 1
- 140 CONTINUE
- IF (N2 .LT. N) GO TO 270
- IV(1) = 2
- IF (N1 .GT. 1) IV(1) = -3
- GO TO 260
-C
-C *** COMPUTE GRADIENT INFORMATION ***
-C
- 150 IF (IV(MODE) .GT. P) GO TO 240
- G1 = IV(G)
- IVMODE = IV(MODE)
- IF (IVMODE .LT. 0) GO TO 170
- IF (IVMODE .EQ. 0) GO TO 180
- IV(1) = 2
-C
-C *** COMPUTE GRADIENT ONLY (FOR _USE_ IN COVARIANCE COMPUTATION) ***
-C
- GI = G1
- DO 160 L = 1, P
- V(GI) = V(GI) + D7TPR(NN, R, DR(1,L))
- GI = GI + 1
- 160 CONTINUE
- GO TO 190
-C
-C *** COMPUTE INITIAL FUNCTION VALUE WHEN ND .LT. N ***
-C
- 170 IF (N .LE. ND) GO TO 180
- T = V2NRM(NN, R)
- IF (T .GT. V(RLIMIT)) GO TO 200
- V(F) = V(F) + HALF * T**2
-C
-C *** UPDATE D IF DESIRED ***
-C
- 180 IF (IV(DTYPE) .GT. 0)
- 1 CALL D7UPD(D, DR, IV, LIV, LV, N, ND, NN, N2, P, V)
-C
-C *** COMPUTE RMAT AND QTR ***
-C
- QTR1 = IV(QTR)
- RMAT1 = IV(RMAT)
- CALL Q7RAD(NN, ND, P, V(QTR1), .TRUE., V(RMAT1), DR, R)
- IV(NF1) = 0
-C
- 190 IF (N2 .LT. N) GO TO 270
- IF (IVMODE .GT. 0) GO TO 40
- IV(NF00) = IV(NFGCAL)
-C
-C *** COMPUTE G FROM RMAT AND QTR ***
-C
- CALL L7VML(P, V(G1), V(RMAT1), V(QTR1))
- IV(1) = 2
- IF (IVMODE .EQ. 0) GO TO 40
- IF (N .LE. ND) GO TO 40
-C
-C *** FINISH SPECIAL CASE HANDLING OF FIRST FUNCTION AND GRADIENT
-C
- Y1 = IV(Y)
- IV(1) = 1
- CALL G7LIT(D, V(G1), IV, LIV, LV, P, P, V, X, V(Y1))
- IF (IV(1) .NE. 2) GO TO 220
- GO TO 40
-C
-C *** MISC. DETAILS ***
-C
-C *** X IS OUT OF RANGE (OVERSIZE STEP) ***
-C
- 200 IV(TOOBIG) = 1
- GO TO 40
-C
-C *** BAD N, ND, OR P ***
-C
- 210 IV(1) = 66
- GO TO 300
-C
-C *** CONVERGENCE OBTAINED -- SEE WHETHER TO COMPUTE COVARIANCE ***
-C
- 220 IF (IV(COVMAT) .NE. 0) GO TO 290
- IF (IV(REGD) .NE. 0) GO TO 290
-C
-C *** SEE IF CHOLESKY FACTOR OF HESSIAN IS AVAILABLE ***
-C
- K = IV(FDH)
- IF (K .LE. 0) GO TO 280
- IF (IV(RDREQ) .LE. 0) GO TO 290
-C
-C *** COMPUTE REGRESSION DIAGNOSTICS AND DEFAULT COVARIANCE IF
-C DESIRED ***
-C
- I = 0
- IF (MOD(IV(RDREQ),4) .GE. 2) I = 1
- IF (MOD(IV(RDREQ),2) .EQ. 1 .AND. IABS(IV(COVREQ)) .LE. 1) I = I+2
- IF (I .EQ. 0) GO TO 250
- IV(MODE) = P + I
- IV(NGCALL) = IV(NGCALL) + 1
- IV(NGCOV) = IV(NGCOV) + 1
- IV(CNVCOD) = IV(1)
- IF (I .LT. 2) GO TO 230
- L = IABS(IV(H))
- CALL V7SCP(LH, V(L), ZERO)
- 230 IV(NFCOV) = IV(NFCOV) + 1
- IV(NFCALL) = IV(NFCALL) + 1
- IV(NFGCAL) = IV(NFCALL)
- IV(1) = -1
- GO TO 260
-C
- 240 L = IV(LMAT)
- CALL N2LRD(DR, IV, V(L), LH, LIV, LV, ND, NN, P, R, RD, V)
- IF (N2 .LT. N) GO TO 270
- IF (N1 .GT. 1) GO TO 250
-C
-C *** ENSURE WE CAN RESTART -- AND MAKE RETURN STATE OF DR
-C *** INDEPENDENT OF WHETHER REGRESSION DIAGNOSTICS ARE COMPUTED.
-C *** _USE_ STEP VECTOR (ALLOCATED BY G7LIT) FOR SCRATCH.
-C
- RMAT1 = IV(RMAT)
- CALL V7SCP(LH, V(RMAT1), ZERO)
- CALL Q7RAD(NN, ND, P, R, .FALSE., V(RMAT1), DR, R)
- IV(NF1) = 0
-C
-C *** FINISH COMPUTING COVARIANCE ***
-C
- 250 L = IV(LMAT)
- CALL C7VFN(IV, V(L), LH, LIV, LV, N, P, V)
- GO TO 290
-C
-C *** RETURN FOR MORE FUNCTION OR GRADIENT INFORMATION ***
-C
- 260 N2 = 0
- 270 N1 = N2 + 1
- N2 = N2 + ND
- IF (N2 .GT. N) N2 = N
- GO TO 999
-C
-C *** COME HERE FOR INDEFINITE FINITE-DIFFERENCE HESSIAN ***
-C
- 280 IV(COVMAT) = K
- IV(REGD) = K
-C
-C *** PRINT SUMMARY OF FINAL ITERATION AND OTHER REQUESTED ITEMS ***
-C
- 290 G1 = IV(G)
- 300 CALL ITSUM(D, V(G1), IV, LIV, LV, P, V, X)
- IF (IV(1) .LE. 6 .AND. IV(RDREQ) .GT. 0)
- 1 CALL N2CVP(IV, LIV, LV, P, V)
-C
- 999 RETURN
-C *** LAST LINE OF RN2G FOLLOWS ***
- END
diff --git a/CEP/PyBDSM/src/port3/rn2gb.f b/CEP/PyBDSM/src/port3/rn2gb.f
deleted file mode 100644
index 20b29993d0174c658455390ab512a143cdcd45b7..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/rn2gb.f
+++ /dev/null
@@ -1,329 +0,0 @@
- SUBROUTINE RN2GB(B, D, DR, IV, LIV, LV, N, ND, N1, N2, P, R,
- 1 RD, V, X)
-C
-C *** REVISED ITERATION DRIVER FOR NL2SOL WITH SIMPLE BOUNDS ***
-C
- INTEGER LIV, LV, N, ND, N1, N2, P
- INTEGER IV(LIV)
- REAL B(2,P), D(P), DR(ND,P), R(ND), RD(ND), V(LV),
- 1 X(P)
-C
-C-------------------------- PARAMETER USAGE --------------------------
-C
-C B........ BOUNDS ON X.
-C D........ SCALE VECTOR.
-C DR....... DERIVATIVES OF R AT X.
-C IV....... INTEGER VALUES ARRAY.
-C LIV...... LENGTH OF IV... LIV MUST BE AT LEAST 4*P + 82.
-C LV....... LENGTH OF V... LV MUST BE AT LEAST 105 + P*(2*P+20).
-C N........ TOTAL NUMBER OF RESIDUALS.
-C ND....... MAX. NO. OF RESIDUALS PASSED ON ONE CALL.
-C N1....... LOWEST ROW INDEX FOR RESIDUALS SUPPLIED THIS TIME.
-C N2....... HIGHEST ROW INDEX FOR RESIDUALS SUPPLIED THIS TIME.
-C P........ NUMBER OF PARAMETERS (COMPONENTS OF X) BEING ESTIMATED.
-C R........ RESIDUALS.
-C V........ FLOATING-POINT VALUES ARRAY.
-C X........ PARAMETER VECTOR BEING ESTIMATED (INPUT = INITIAL GUESS,
-C OUTPUT = BEST VALUE FOUND).
-C
-C *** DISCUSSION ***
-C
-C THIS ROUTINE CARRIES OUT ITERATIONS FOR SOLVING NONLINEAR
-C LEAST SQUARES PROBLEMS. IT IS SIMILAR TO RN2G, EXCEPT THAT
-C THIS ROUTINE ENFORCES THE BOUNDS B(1,I) .LE. X(I) .LE. B(2,I),
-C I = 1(1)P.
-C
-C *** GENERAL ***
-C
-C CODED BY DAVID M. GAY.
-C
-C+++++++++++++++++++++++++++++ DECLARATIONS ++++++++++++++++++++++++++
-C
-C *** EXTERNAL FUNCTIONS AND SUBROUTINES ***
-C
- REAL D7TPR, V2NRM
- EXTERNAL IVSET, D7TPR, D7UPD, G7ITB, ITSUM, L7VML, Q7APL,
- 1 Q7RAD, R7TVM, V7CPY, V7SCP, V2NRM
-C
-C IVSET.... PROVIDES DEFAULT IV AND V INPUT COMPONENTS.
-C D7TPR... COMPUTES INNER PRODUCT OF TWO VECTORS.
-C D7UPD... UPDATES SCALE VECTOR D.
-C G7ITB... PERFORMS BASIC MINIMIZATION ALGORITHM.
-C ITSUM.... PRINTS ITERATION SUMMARY, INFO ABOUT INITIAL AND FINAL X.
-C L7VML.... COMPUTES L * V, V = VECTOR, L = LOWER TRIANGULAR MATRIX.
-C Q7APL... APPLIES QR TRANSFORMATIONS STORED BY Q7RAD.
-C Q7RAD.... ADDS A NEW BLOCK OF ROWS TO QR DECOMPOSITION.
-C R7TVM... MULT. VECTOR BY TRANS. OF UPPER TRIANG. MATRIX FROM QR FACT.
-C V7CPY.... COPIES ONE VECTOR TO ANOTHER.
-C V7SCP... SETS ALL ELEMENTS OF A VECTOR TO A SCALAR.
-C V2NRM... RETURNS THE 2-NORM OF A VECTOR.
-C
-C
-C *** LOCAL VARIABLES ***
-C
- INTEGER G1, GI, I, IV1, IVMODE, JTOL1, L, LH, NN, QTR1,
- 1 RD1, RMAT1, YI, Y1
- REAL T
-C
- REAL HALF, ZERO
-C
-C *** SUBSCRIPTS FOR IV AND V ***
-C
- INTEGER DINIT, DTYPE, DTINIT, D0INIT, F, G, JCN, JTOL, MODE,
- 1 NEXTV, NF0, NF00, NF1, NFCALL, NFCOV, NFGCAL, QTR, RDREQ,
- 1 REGD, RESTOR, RLIMIT, RMAT, TOOBIG, VNEED
-C
-C *** IV SUBSCRIPT VALUES ***
-C
-C/6
-C DATA DTYPE/16/, G/28/, JCN/66/, JTOL/59/, MODE/35/, NEXTV/47/,
-C 1 NF0/68/, NF00/81/, NF1/69/, NFCALL/6/, NFCOV/52/, NFGCAL/7/,
-C 2 QTR/77/, RDREQ/57/, RESTOR/9/, REGD/67/, RMAT/78/, TOOBIG/2/,
-C 3 VNEED/4/
-C/7
- PARAMETER (DTYPE=16, G=28, JCN=66, JTOL=59, MODE=35, NEXTV=47,
- 1 NF0=68, NF00=81, NF1=69, NFCALL=6, NFCOV=52, NFGCAL=7,
- 2 QTR=77, RDREQ=57, RESTOR=9, REGD=67, RMAT=78, TOOBIG=2,
- 3 VNEED=4)
-C/
-C
-C *** V SUBSCRIPT VALUES ***
-C
-C/6
-C DATA DINIT/38/, DTINIT/39/, D0INIT/40/, F/10/, RLIMIT/46/
-C/7
- PARAMETER (DINIT=38, DTINIT=39, D0INIT=40, F=10, RLIMIT=46)
-C/
-C/6
-C DATA HALF/0.5E+0/, ZERO/0.E+0/
-C/7
- PARAMETER (HALF=0.5E+0, ZERO=0.E+0)
-C/
-C
-C+++++++++++++++++++++++++++++++ BODY ++++++++++++++++++++++++++++++++
-C
- LH = P * (P+1) / 2
- IF (IV(1) .EQ. 0) CALL IVSET(1, IV, LIV, LV, V)
- IV1 = IV(1)
- IF (IV1 .GT. 2) GO TO 10
- NN = N2 - N1 + 1
- IV(RESTOR) = 0
- I = IV1 + 4
- IF (IV(TOOBIG) .EQ. 0) GO TO (150, 130, 150, 120, 120, 150), I
- IF (I .NE. 5) IV(1) = 2
- GO TO 40
-C
-C *** FRESH START OR RESTART -- CHECK INPUT INTEGERS ***
-C
- 10 IF (ND .LE. 0) GO TO 220
- IF (P .LE. 0) GO TO 220
- IF (N .LE. 0) GO TO 220
- IF (IV1 .EQ. 14) GO TO 30
- IF (IV1 .GT. 16) GO TO 270
- IF (IV1 .LT. 12) GO TO 40
- IF (IV1 .EQ. 12) IV(1) = 13
- IF (IV(1) .NE. 13) GO TO 20
- IV(VNEED) = IV(VNEED) + P*(P+15)/2
- 20 CALL G7ITB(B, D, X, IV, LIV, LV, P, P, V, X, X)
- IF (IV(1) .NE. 14) GO TO 999
-C
-C *** STORAGE ALLOCATION ***
-C
- IV(G) = IV(NEXTV)
- IV(JCN) = IV(G) + 2*P
- IV(RMAT) = IV(JCN) + P
- IV(QTR) = IV(RMAT) + LH
- IV(JTOL) = IV(QTR) + 2*P
- IV(NEXTV) = IV(JTOL) + 2*P
-C *** TURN OFF COVARIANCE COMPUTATION ***
- IV(RDREQ) = 0
- IF (IV1 .EQ. 13) GO TO 999
-C
- 30 JTOL1 = IV(JTOL)
- IF (V(DINIT) .GE. ZERO) CALL V7SCP(P, D, V(DINIT))
- IF (V(DTINIT) .GT. ZERO) CALL V7SCP(P, V(JTOL1), V(DTINIT))
- I = JTOL1 + P
- IF (V(D0INIT) .GT. ZERO) CALL V7SCP(P, V(I), V(D0INIT))
- IV(NF0) = 0
- IV(NF1) = 0
- IF (ND .GE. N) GO TO 40
-C
-C *** SPECIAL CASE HANDLING OF FIRST FUNCTION AND GRADIENT EVALUATION
-C *** -- ASK FOR BOTH RESIDUAL AND JACOBIAN AT ONCE
-C
- G1 = IV(G)
- Y1 = G1 + P
- CALL G7ITB(B, D, V(G1), IV, LIV, LV, P, P, V, X, V(Y1))
- IF (IV(1) .NE. 1) GO TO 260
- V(F) = ZERO
- CALL V7SCP(P, V(G1), ZERO)
- IV(1) = -1
- QTR1 = IV(QTR)
- CALL V7SCP(P, V(QTR1), ZERO)
- IV(REGD) = 0
- RMAT1 = IV(RMAT)
- GO TO 100
-C
- 40 G1 = IV(G)
- Y1 = G1 + P
- CALL G7ITB(B, D, V(G1), IV, LIV, LV, P, P, V, X, V(Y1))
- IF (IV(1) - 2) 50, 60, 260
-C
- 50 V(F) = ZERO
- IF (IV(NF1) .EQ. 0) GO TO 240
- IF (IV(RESTOR) .NE. 2) GO TO 240
- IV(NF0) = IV(NF1)
- CALL V7CPY(N, RD, R)
- IV(REGD) = 0
- GO TO 240
-C
- 60 CALL V7SCP(P, V(G1), ZERO)
- IF (IV(MODE) .GT. 0) GO TO 230
- RMAT1 = IV(RMAT)
- QTR1 = IV(QTR)
- RD1 = QTR1 + P
- CALL V7SCP(P, V(QTR1), ZERO)
- IV(REGD) = 0
- IF (ND .LT. N) GO TO 90
- IF (N1 .NE. 1) GO TO 90
- IF (IV(MODE) .LT. 0) GO TO 100
- IF (IV(NF1) .EQ. IV(NFGCAL)) GO TO 70
- IF (IV(NF0) .NE. IV(NFGCAL)) GO TO 90
- CALL V7CPY(N, R, RD)
- GO TO 80
- 70 CALL V7CPY(N, RD, R)
- 80 CALL Q7APL(ND, N, P, DR, RD, 0)
- CALL R7TVM(ND, MIN0(N,P), V(Y1), V(RD1), DR, RD)
- IV(REGD) = 0
- GO TO 110
-C
- 90 IV(1) = -2
- IF (IV(MODE) .LT. 0) IV(1) = -3
- 100 CALL V7SCP(P, V(Y1), ZERO)
- 110 CALL V7SCP(LH, V(RMAT1), ZERO)
- GO TO 240
-C
-C *** COMPUTE F(X) ***
-C
- 120 T = V2NRM(NN, R)
- IF (T .GT. V(RLIMIT)) GO TO 210
- V(F) = V(F) + HALF * T**2
- IF (N2 .LT. N) GO TO 250
- IF (N1 .EQ. 1) IV(NF1) = IV(NFCALL)
- GO TO 40
-C
-C *** COMPUTE Y ***
-C
- 130 Y1 = IV(G) + P
- YI = Y1
- DO 140 L = 1, P
- V(YI) = V(YI) + D7TPR(NN, DR(1,L), R)
- YI = YI + 1
- 140 CONTINUE
- IF (N2 .LT. N) GO TO 250
- IV(1) = 2
- IF (N1 .GT. 1) IV(1) = -3
- GO TO 240
-C
-C *** COMPUTE GRADIENT INFORMATION ***
-C
- 150 G1 = IV(G)
- IVMODE = IV(MODE)
- IF (IVMODE .LT. 0) GO TO 170
- IF (IVMODE .EQ. 0) GO TO 180
- IV(1) = 2
-C
-C *** COMPUTE GRADIENT ONLY (FOR _USE_ IN COVARIANCE COMPUTATION) ***
-C
- GI = G1
- DO 160 L = 1, P
- V(GI) = V(GI) + D7TPR(NN, R, DR(1,L))
- GI = GI + 1
- 160 CONTINUE
- GO TO 200
-C
-C *** COMPUTE INITIAL FUNCTION VALUE WHEN ND .LT. N ***
-C
- 170 IF (N .LE. ND) GO TO 180
- T = V2NRM(NN, R)
- IF (T .GT. V(RLIMIT)) GO TO 210
- V(F) = V(F) + HALF * T**2
-C
-C *** UPDATE D IF DESIRED ***
-C
- 180 IF (IV(DTYPE) .GT. 0)
- 1 CALL D7UPD(D, DR, IV, LIV, LV, N, ND, NN, N2, P, V)
-C
-C *** COMPUTE RMAT AND QTR ***
-C
- QTR1 = IV(QTR)
- RMAT1 = IV(RMAT)
- CALL Q7RAD(NN, ND, P, V(QTR1), .TRUE., V(RMAT1), DR, R)
- IV(NF1) = 0
- IF (N1 .GT. 1) GO TO 200
- IF (N2 .LT. N) GO TO 250
-C
-C *** SAVE DIAGONAL OF R FOR COMPUTING Y LATER ***
-C
- RD1 = QTR1 + P
- L = RMAT1 - 1
- DO 190 I = 1, P
- L = L + I
- V(RD1) = V(L)
- RD1 = RD1 + 1
- 190 CONTINUE
-C
- 200 IF (N2 .LT. N) GO TO 250
- IF (IVMODE .GT. 0) GO TO 40
- IV(NF00) = IV(NFGCAL)
-C
-C *** COMPUTE G FROM RMAT AND QTR ***
-C
- CALL L7VML(P, V(G1), V(RMAT1), V(QTR1))
- IV(1) = 2
- IF (IVMODE .EQ. 0) GO TO 40
- IF (N .LE. ND) GO TO 40
-C
-C *** FINISH SPECIAL CASE HANDLING OF FIRST FUNCTION AND GRADIENT
-C
- Y1 = G1 + P
- IV(1) = 1
- CALL G7ITB(B, D, V(G1), IV, LIV, LV, P, P, V, X, V(Y1))
- IF (IV(1) .NE. 2) GO TO 260
- GO TO 40
-C
-C *** MISC. DETAILS ***
-C
-C *** X IS OUT OF RANGE (OVERSIZE STEP) ***
-C
- 210 IV(TOOBIG) = 1
- GO TO 40
-C
-C *** BAD N, ND, OR P ***
-C
- 220 IV(1) = 66
- GO TO 270
-C
-C *** RECORD EXTRA EVALUATIONS FOR FINITE-DIFFERENCE HESSIAN ***
-C
- 230 IV(NFCOV) = IV(NFCOV) + 1
- IV(NFCALL) = IV(NFCALL) + 1
- IV(NFGCAL) = IV(NFCALL)
- IV(1) = -1
-C
-C *** RETURN FOR MORE FUNCTION OR GRADIENT INFORMATION ***
-C
- 240 N2 = 0
- 250 N1 = N2 + 1
- N2 = N2 + ND
- IF (N2 .GT. N) N2 = N
- GO TO 999
-C
-C *** PRINT SUMMARY OF FINAL ITERATION AND OTHER REQUESTED ITEMS ***
-C
- 260 G1 = IV(G)
- 270 CALL ITSUM(D, V(G1), IV, LIV, LV, P, V, X)
-C
- 999 RETURN
-C *** LAST CARD OF RN2GB FOLLOWS ***
- END
diff --git a/CEP/PyBDSM/src/port3/rnsg.f b/CEP/PyBDSM/src/port3/rnsg.f
deleted file mode 100644
index 1603ca584ceb6383dc6c65dc2822d5a0b7daa37e..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/rnsg.f
+++ /dev/null
@@ -1,455 +0,0 @@
- SUBROUTINE RNSG(A, ALF, C, DA, IN, IV, L, L1, LA, LIV, LV,
- 1 N, NDA, P, V, Y)
-C
-C *** ITERATION DRIVER FOR SEPARABLE NONLINEAR LEAST SQUARES.
-C
-C *** PARAMETER DECLARATIONS ***
-C
- INTEGER L, L1, LA, LIV, LV, N, NDA, P
- INTEGER IN(2,NDA), IV(LIV)
-C DIMENSION UIPARM(*)
- REAL A(LA,L1), ALF(P), C(L), DA(LA,NDA), V(LV), Y(N)
-C
-C *** PURPOSE ***
-C
-C GIVEN A SET OF N OBSERVATIONS Y(1)....Y(N) OF A DEPENDENT VARIABLE
-C T(1)...T(N), RNSG ATTEMPTS TO COMPUTE A LEAST SQUARES FIT
-C TO A FUNCTION ETA (THE MODEL) WHICH IS A LINEAR COMBINATION
-C
-C L
-C ETA(C,ALF,T) = SUM C * PHI(ALF,T) +PHI (ALF,T)
-C J=1 J J L+1
-C
-C OF NONLINEAR FUNCTIONS PHI(J) DEPENDENT ON T AND ALF(1),...,ALF(P)
-C (.E.G. A SUM OF EXPONENTIALS OR GAUSSIANS). THAT IS, IT DETERMINES
-C NONLINEAR PARAMETERS ALF WHICH MINIMIZE
-C
-C 2 N 2
-C NORM(RESIDUAL) = SUM (Y - ETA(C,ALF,T )).
-C I=1 I I
-C
-C THE (L+1)ST TERM IS OPTIONAL.
-C
-C
-C *** PARAMETERS ***
-C
-C A (IN) MATRIX PHI(ALF,T) OF THE MODEL.
-C ALF (I/O) NONLINEAR PARAMETERS.
-C INPUT = INITIAL GUESS,
-C OUTPUT = BEST ESTIMATE FOUND.
-C C (OUT) LINEAR PARAMETERS (ESTIMATED).
-C DA (IN) DERIVATIVES OF COLUMNS OF A WITH RESPECT TO COMPONENTS
-C OF ALF, AS SPECIFIED BY THE IN ARRAY...
-C IN (IN) WHEN RNSG IS CALLED WITH IV(1) = 2 OR -2, THEN FOR
-C I = 1(1)NDA, COLUMN I OF DA IS THE PARTIAL
-C DERIVATIVE WITH RESPECT TO ALF(IN(1,I)) OF COLUMN
-C IN(2,I) OF A, UNLESS IV(1,I) IS NOT POSITIVE (IN
-C WHICH CASE COLUMN I OF DA IS IGNORED. IV(1) = -2
-C MEANS THERE ARE MORE COLUMNS OF DA TO COME AND
-C RNSG SHOULD RETURN FOR THEM.
-C IV (I/O) INTEGER PARAMETER AND SCRATCH VECTOR. RNSG RETURNS
-C WITH IV(1) = 1 WHEN IT WANTS A TO BE EVALUATED AT
-C ALF AND WITH IV(1) = 2 WHEN IT WANTS DA TO BE
-C EVALUATED AT ALF. WHEN CALLED WITH IV(1) = -2
-C (AFTER A RETURN WITH IV(1) = 2), RNSG RETURNS
-C WITH IV(1) = -2 TO GET MORE COLUMNS OF DA.
-C L (IN) NUMBER OF LINEAR PARAMETERS TO BE ESTIMATED.
-C L1 (IN) L+1 IF PHI(L+1) IS IN THE MODEL, L IF NOT.
-C LA (IN) LEAD DIMENSION OF A. MUST BE AT LEAST N.
-C LIV (IN) LENGTH OF IV. MUST BE AT LEAST 110 + L + P.
-C LV (IN) LENGTH OF V. MUST BE AT LEAST
-C 105 + 2*N + JLEN + L*(L+3)/2 + P*(2*P + 17),
-C WHERE JLEN = (L+P)*(N+L+P+1), UNLESS NEITHER A
-C COVARIANCE MATRIX NOR REGRESSION DIAGNOSTICS ARE
-C REQUESTED, IN WHICH CASE JLEN = N*P.
-C N (IN) NUMBER OF OBSERVATIONS.
-C NDA (IN) NUMBER OF COLUMNS IN DA AND IN.
-C P (IN) NUMBER OF NONLINEAR PARAMETERS TO BE ESTIMATED.
-C V (I/O) FLOATING-POINT PARAMETER AND SCRATCH VECTOR.
-C IF A COVARIANCE ESTIMATE IS REQUESTED, IT IS FOR
-C (ALF,C) -- NONLINEAR PARAMETERS ORDERED FIRST,
-C FOLLOWED BY LINEAR PARAMETERS.
-C Y (IN) RIGHT-HAND SIDE VECTOR.
-C
-C
-C *** EXTERNAL SUBROUTINES ***
-C
- REAL D7TPR, L7SVX, L7SVN, R7MDC
- EXTERNAL C7VFN, IVSET, D7TPR, ITSUM, L7ITV, L7SRT, L7SVX,
- 1 L7SVN, N2CVP, N2LRD, N2RDP, RN2G, Q7APL, Q7RAD,
- 2 Q7RFH, R7MDC, S7CPR, V2AXY, V7CPY, V7PRM, V7SCL,
- 3 V7SCP
-C
-C C7VFN... FINISHES COVARIANCE COMPUTATION.
-C IVSET.... SUPPLIES DEFAULT PARAMETER VALUES.
-C D7TPR... RETURNS INNER PRODUCT OF TWO VECTORS.
-C ITSUM.... PRINTS ITERATION SUMMARY, INITIAL AND FINAL ALF.
-C L7ITV... APPLIES INVERSE-TRANSPOSE OF COMPACT LOWER TRIANG. MATRIX.
-C L7SRT.... COMPUTES (PARTIAL) CHOLESKY FACTORIZATION.
-C L7SVX... ESTIMATES LARGEST SING. VALUE OF LOWER TRIANG. MATRIX.
-C L7SVN... ESTIMATES SMALLEST SING. VALUE OF LOWER TRIANG. MATRIX.
-C N2CVP... PRINTS COVARIANCE MATRIX.
-C N2LRD... COMPUTES COVARIANCE AND REGRESSION DIAGNOSTICS.
-C N2RDP... PRINTS REGRESSION DIAGNOSTICS.
-C RN2G... UNDERLYING NONLINEAR LEAST-SQUARES SOLVER.
-C Q7APL... APPLIES HOUSEHOLDER TRANSFORMS STORED BY Q7RFH.
-C Q7RFH.... COMPUTES QR FACT. VIA HOUSEHOLDER TRANSFORMS WITH PIVOTING.
-C Q7RAD.... QR FACT., NO PIVOTING.
-C R7MDC... RETURNS MACHINE-DEP. CONSTANTS.
-C S7CPR... PRINTS LINEAR PARAMETERS AT SOLUTION.
-C V2AXY.... ADDS MULTIPLE OF ONE VECTOR TO ANOTHER.
-C V7CPY.... COPIES ONE VECTOR TO ANOTHER.
-C V7PRM.... PERMUTES A VECTOR.
-C V7SCL... SCALES AND COPIES ONE VECTOR TO ANOTHER.
-C V7SCP... SETS ALL COMPONENTS OF A VECTOR TO A SCALAR.
-C
-C *** LOCAL VARIABLES ***
-C
- LOGICAL NOCOV
- INTEGER AR1, CSAVE1, D1, DR1, DR1L, DRI, DRI1, FDH0, HSAVE, I, I1,
- 1 IPIV1, IER, IV1, J1, JLEN, K, LH, LI, LL1O2, MD, N1, N2,
- 2 NML, NRAN, PP, PP1, R1, R1L, RD1, TEMP1
- REAL SINGTL, T
- REAL MACHEP, NEGONE, SNGFAC, ZERO
-C
-C *** SUBSCRIPTS FOR IV AND V ***
-C
- INTEGER AR, CNVCOD, COVMAT, COVREQ, CSAVE, CVRQSV, D, FDH, H,
- 1 IERS, IPIVS, IV1SAV, IVNEED, J, LMAT, MODE, NEXTIV, NEXTV,
- 2 NFCALL, NFCOV, NFGCAL, NGCALL, NGCOV, PERM, R, RCOND,
- 3 RDREQ, RDRQSV, REGD, REGD0, RESTOR, TOOBIG, VNEED
-C
-C *** IV SUBSCRIPT VALUES ***
-C
-C/6
-C DATA AR/110/, CNVCOD/55/, COVMAT/26/, COVREQ/15/, CSAVE/105/,
-C 1 CVRQSV/106/, D/27/, FDH/74/, H/56/, IERS/108/, IPIVS/109/,
-C 2 IV1SAV/104/, IVNEED/3/, J/70/, LMAT/42/, MODE/35/,
-C 3 NEXTIV/46/, NEXTV/47/, NFCALL/6/, NFCOV/52/, NFGCAL/7/,
-C 4 NGCALL/30/, NGCOV/53/, PERM/58/, R/61/, RCOND/53/, RDREQ/57/,
-C 5 RDRQSV/107/, REGD/67/, REGD0/82/, RESTOR/9/, TOOBIG/2/,
-C 6 VNEED/4/
-C/7
- PARAMETER (AR=110, CNVCOD=55, COVMAT=26, COVREQ=15, CSAVE=105,
- 1 CVRQSV=106, D=27, FDH=74, H=56, IERS=108, IPIVS=109,
- 2 IV1SAV=104, IVNEED=3, J=70, LMAT=42, MODE=35,
- 3 NEXTIV=46, NEXTV=47, NFCALL=6, NFCOV=52, NFGCAL=7,
- 4 NGCALL=30, NGCOV=53, PERM=58, R=61, RCOND=53, RDREQ=57,
- 5 RDRQSV=107, REGD=67, REGD0=82, RESTOR=9, TOOBIG=2,
- 6 VNEED=4)
-C/
- DATA MACHEP/-1.E+0/, NEGONE/-1.E+0/, SNGFAC/1.E+2/, ZERO/0.E+0/
-C
-C++++++++++++++++++++++++++++++++ BODY ++++++++++++++++++++++++++++++
-C
-C
- IF (IV(1) .EQ. 0) CALL IVSET(1, IV, LIV, LV, V)
- N1 = 1
- NML = N
- IV1 = IV(1)
- IF (IV1 .LE. 2) GO TO 20
-C
-C *** CHECK INPUT INTEGERS ***
-C
- IF (P .LE. 0) GO TO 370
- IF (L .LT. 0) GO TO 370
- IF (N .LE. L) GO TO 370
- IF (LA .LT. N) GO TO 370
- IF (IV1 .LT. 12) GO TO 20
- IF (IV1 .EQ. 14) GO TO 20
- IF (IV1 .EQ. 12) IV(1) = 13
-C
-C *** FRESH START -- COMPUTE STORAGE REQUIREMENTS ***
-C
- IF (IV(1) .GT. 16) GO TO 370
- LL1O2 = L*(L+1)/2
- JLEN = N*P
- I = L + P
- IF (IV(RDREQ) .GT. 0 .AND. IV(COVREQ) .NE. 0) JLEN = I*(N + I + 1)
- IF (IV(1) .NE. 13) GO TO 10
- IV(IVNEED) = IV(IVNEED) + L
- IV(VNEED) = IV(VNEED) + P + 2*N + JLEN + LL1O2 + L
- 10 IF (IV(PERM) .LE. AR) IV(PERM) = AR + 1
- CALL RN2G(V, V, IV, LIV, LV, N, N, N1, NML, P, V, V, V, ALF)
- IF (IV(1) .NE. 14) GO TO 999
-C
-C *** STORAGE ALLOCATION ***
-C
- IV(IPIVS) = IV(NEXTIV)
- IV(NEXTIV) = IV(NEXTIV) + L
- IV(D) = IV(NEXTV)
- IV(REGD0) = IV(D) + P
- IV(AR) = IV(REGD0) + N
- IV(CSAVE) = IV(AR) + LL1O2
- IV(J) = IV(CSAVE) + L
- IV(R) = IV(J) + JLEN
- IV(NEXTV) = IV(R) + N
- IV(IERS) = 0
- IF (IV1 .EQ. 13) GO TO 999
-C
-C *** SET POINTERS INTO IV AND V ***
-C
- 20 AR1 = IV(AR)
- D1 = IV(D)
- DR1 = IV(J)
- DR1L = DR1 + L
- R1 = IV(R)
- R1L = R1 + L
- RD1 = IV(REGD0)
- CSAVE1 = IV(CSAVE)
- NML = N - L
- IF (IV1 .LE. 2) GO TO 50
-C
-C *** IF F.D. HESSIAN WILL BE NEEDED (FOR COVARIANCE OR REG.
-C *** DIAGNOSTICS), HAVE RN2G COMPUTE ONLY THE PART CORRESP.
-C *** TO ALF WITH C FIXED...
-C
- IF (L .LE. 0) GO TO 30
- IV(CVRQSV) = IV(COVREQ)
- IF (IABS(IV(COVREQ)) .GE. 3) IV(COVREQ) = 0
- IV(RDRQSV) = IV(RDREQ)
- IF (IV(RDREQ) .GT. 0) IV(RDREQ) = -1
-C
- 30 N2 = NML
- CALL RN2G(V(D1), V(DR1L), IV, LIV, LV, NML, N, N1, N2, P,
- 1 V(R1L), V(RD1), V, ALF)
- IF (IABS(IV(RESTOR)-2) .EQ. 1 .AND. L .GT. 0)
- 1 CALL V7CPY(L, C, V(CSAVE1))
- IV1 = IV(1)
- IF (IV1-2) 40, 150, 230
-C
-C *** NEW FUNCTION VALUE (RESIDUAL) NEEDED ***
-C
- 40 IV(IV1SAV) = IV(1)
- IV(1) = IABS(IV1)
- IF (IV(RESTOR) .EQ. 2 .AND. L .GT. 0) CALL V7CPY(L, V(CSAVE1), C)
- GO TO 999
-C
-C *** COMPUTE NEW RESIDUAL OR GRADIENT ***
-C
- 50 IV(1) = IV(IV1SAV)
- MD = IV(MODE)
- IF (MD .LE. 0) GO TO 60
- NML = N
- DR1L = DR1
- R1L = R1
- 60 IF (IV(TOOBIG) .NE. 0) GO TO 30
- IF (IABS(IV1) .EQ. 2) GO TO 170
-C
-C *** COMPUTE NEW RESIDUAL ***
-C
- IF (L1 .LE. L) CALL V7CPY(N, V(R1), Y)
- IF (L1 .GT. L) CALL V2AXY(N, V(R1), NEGONE, A(1,L1), Y)
- IF (MD .GT. 0) GO TO 120
- IER = 0
- IF (L .LE. 0) GO TO 110
- LL1O2 = L * (L + 1) / 2
- IPIV1 = IV(IPIVS)
- CALL Q7RFH(IER, IV(IPIV1), N, LA, 0, L, A, V(AR1), LL1O2, C)
-C
-C *** DETERMINE NUMERICAL RANK OF A ***
-C
- IF (MACHEP .LE. ZERO) MACHEP = R7MDC(3)
- SINGTL = SNGFAC * FLOAT(MAX0(L,N)) * MACHEP
- K = L
- IF (IER .NE. 0) K = IER - 1
- 70 IF (K .LE. 0) GO TO 90
- T = L7SVX(K, V(AR1), C, C)
- IF (T .GT. ZERO) T = L7SVN(K, V(AR1), C, C) / T
- IF (T .GT. SINGTL) GO TO 80
- K = K - 1
- GO TO 70
-C
-C *** RECORD RANK IN IV(IERS)... IV(IERS) = 0 MEANS FULL RANK,
-C *** IV(IERS) .GT. 0 MEANS RANK IV(IERS) - 1.
-C
- 80 IF (K .GE. L) GO TO 100
- 90 IER = K + 1
- CALL V7SCP(L-K, C(K+1), ZERO)
- 100 IV(IERS) = IER
- IF (K .LE. 0) GO TO 110
-C
-C *** APPLY HOUSEHOLDER TRANSFORMATONS TO RESIDUALS...
-C
- CALL Q7APL(LA, N, K, A, V(R1), IER)
-C
-C *** COMPUTING C NOW MAY SAVE A FUNCTION EVALUATION AT
-C *** THE LAST ITERATION.
-C
- CALL L7ITV(K, C, V(AR1), V(R1))
- CALL V7PRM(L, IV(IPIV1), C)
-C
- 110 IF(IV(1) .LT. 2) GO TO 220
- GO TO 999
-C
-C
-C *** RESIDUAL COMPUTATION FOR F.D. HESSIAN ***
-C
- 120 IF (L .LE. 0) GO TO 140
- DO 130 I = 1, L
- 130 CALL V2AXY(N, V(R1), -C(I), A(1,I), V(R1))
- 140 IF (IV(1) .GT. 0) GO TO 30
- IV(1) = 2
- GO TO 160
-C
-C *** NEW GRADIENT (JACOBIAN) NEEDED ***
-C
- 150 IV(IV1SAV) = IV1
- IF (IV(NFGCAL) .NE. IV(NFCALL)) IV(1) = 1
- 160 CALL V7SCP(N*P, V(DR1), ZERO)
- GO TO 999
-C
-C *** COMPUTE NEW JACOBIAN ***
-C
- 170 NOCOV = MD .LE. P .OR. IABS(IV(COVREQ)) .GE. 3
- FDH0 = DR1 + N*(P+L)
- IF (NDA .LE. 0) GO TO 370
- DO 180 I = 1, NDA
- I1 = IN(1,I) - 1
- IF (I1 .LT. 0) GO TO 180
- J1 = IN(2,I)
- K = DR1 + I1*N
- T = NEGONE
- IF (J1 .LE. L) T = -C(J1)
- CALL V2AXY(N, V(K), T, DA(1,I), V(K))
- IF (NOCOV) GO TO 180
- IF (J1 .GT. L) GO TO 180
-C *** ADD IN (L,P) PORTION OF SECOND-ORDER PART OF HESSIAN
-C *** FOR COVARIANCE OR REG. DIAG. COMPUTATIONS...
- J1 = J1 + P
- K = FDH0 + J1*(J1-1)/2 + I1
- V(K) = V(K) - D7TPR(N, V(R1), DA(1,I))
- 180 CONTINUE
- IF (IV1 .EQ. 2) GO TO 190
- IV(1) = IV1
- GO TO 999
- 190 IF (L .LE. 0) GO TO 30
- IF (MD .GT. P) GO TO 240
- IF (MD .GT. 0) GO TO 30
- K = DR1
- IER = IV(IERS)
- NRAN = L
- IF (IER .GT. 0) NRAN = IER - 1
- IF (NRAN .LE. 0) GO TO 210
- DO 200 I = 1, P
- CALL Q7APL(LA, N, NRAN, A, V(K), IER)
- K = K + N
- 200 CONTINUE
- 210 CALL V7CPY(L, V(CSAVE1), C)
- 220 IF (IER .EQ. 0) GO TO 30
-C
-C *** ADJUST SUBSCRIPTS DESCRIBING R AND DR...
-C
- NRAN = IER - 1
- DR1L = DR1 + NRAN
- NML = N - NRAN
- R1L = R1 + NRAN
- GO TO 30
-C
-C *** CONVERGENCE OR LIMIT REACHED ***
-C
- 230 IF (L .LE. 0) GO TO 350
- IV(COVREQ) = IV(CVRQSV)
- IV(RDREQ) = IV(RDRQSV)
- IF (IV(1) .GT. 6) GO TO 360
- IF (MOD(IV(RDREQ),4) .EQ. 0) GO TO 360
- IF (IV(FDH) .LE. 0 .AND. IABS(IV(COVREQ)) .LT. 3) GO TO 360
- IF (IV(REGD) .GT. 0) GO TO 360
- IF (IV(COVMAT) .GT. 0) GO TO 360
-C
-C *** PREPARE TO FINISH COMPUTING COVARIANCE MATRIX AND REG. DIAG. ***
-C
- PP = L + P
- I = 0
- IF (MOD(IV(RDREQ),4) .GE. 2) I = 1
- IF (MOD(IV(RDREQ),2) .EQ. 1 .AND. IABS(IV(COVREQ)) .EQ. 1) I = I+2
- IV(MODE) = PP + I
- I = DR1 + N*PP
- K = P * (P + 1) / 2
- I1 = IV(LMAT)
- CALL V7CPY(K, V(I), V(I1))
- I = I + K
- CALL V7SCP(PP*(PP+1)/2 - K, V(I), ZERO)
- IV(NFCOV) = IV(NFCOV) + 1
- IV(NFCALL) = IV(NFCALL) + 1
- IV(NFGCAL) = IV(NFCALL)
- IV(CNVCOD) = IV(1)
- IV(IV1SAV) = -1
- IV(1) = 1
- IV(NGCALL) = IV(NGCALL) + 1
- IV(NGCOV) = IV(NGCOV) + 1
- GO TO 999
-C
-C *** FINISH COVARIANCE COMPUTATION ***
-C
- 240 I = DR1 + N*P
- DO 250 I1 = 1, L
- CALL V7SCL(N, V(I), NEGONE, A(1,I1))
- I = I + N
- 250 CONTINUE
- PP = L + P
- HSAVE = IV(H)
- K = DR1 + N*PP
- LH = PP * (PP + 1) / 2
- IF (IABS(IV(COVREQ)) .LT. 3) GO TO 270
- I = IV(MODE) - 4
- IF (I .GE. PP) GO TO 260
- CALL V7SCP(LH, V(K), ZERO)
- CALL Q7RAD(N, N, PP, V, .FALSE., V(K), V(DR1), V)
- IV(MODE) = I + 8
- IV(1) = 2
- IV(NGCALL) = IV(NGCALL) + 1
- IV(NGCOV) = IV(NGCOV) + 1
- GO TO 160
-C
- 260 IV(MODE) = I
- GO TO 300
-C
- 270 PP1 = P + 1
- DRI = DR1 + N*P
- LI = K + P*PP1/2
- DO 290 I = PP1, PP
- DRI1 = DR1
- DO 280 I1 = 1, I
- V(LI) = V(LI) + D7TPR(N, V(DRI), V(DRI1))
- LI = LI + 1
- DRI1 = DRI1 + N
- 280 CONTINUE
- DRI = DRI + N
- 290 CONTINUE
- CALL L7SRT(PP1, PP, V(K), V(K), I)
- IF (I .NE. 0) GO TO 310
- 300 TEMP1 = K + LH
- T = L7SVN(PP, V(K), V(TEMP1), V(TEMP1))
- IF (T .LE. ZERO) GO TO 310
- T = T / L7SVX(PP, V(K), V(TEMP1), V(TEMP1))
- V(RCOND) = T
- IF (T .GT. R7MDC(4)) GO TO 320
- 310 IV(REGD) = -1
- IV(COVMAT) = -1
- IV(FDH) = -1
- GO TO 340
- 320 IV(H) = TEMP1
- IV(FDH) = IABS(HSAVE)
- IF (IV(MODE) - PP .LT. 2) GO TO 330
- I = IV(H)
- CALL V7SCP(LH, V(I), ZERO)
- 330 CALL N2LRD(V(DR1), IV, V(K), LH, LIV, LV, N, N, PP, V(R1),
- 1 V(RD1), V)
- 340 CALL C7VFN(IV, V(K), LH, LIV, LV, N, PP, V)
- IV(H) = HSAVE
-C
- 350 IF (IV(REGD) .EQ. 1) IV(REGD) = RD1
- 360 IF (IV(1) .LE. 11) CALL S7CPR(C, IV, L, LIV)
- IF (IV(1) .GT. 6) GO TO 999
- CALL N2CVP(IV, LIV, LV, P+L, V)
- CALL N2RDP(IV, LIV, LV, N, V(RD1), V)
- GO TO 999
-C
- 370 IV(1) = 66
- CALL ITSUM(V, V, IV, LIV, LV, P, V, ALF)
-C
- 999 RETURN
-C
-C *** LAST CARD OF RNSG FOLLOWS ***
- END
diff --git a/CEP/PyBDSM/src/port3/rnsgb.f b/CEP/PyBDSM/src/port3/rnsgb.f
deleted file mode 100644
index 241b61528cb59a5df19896fe05f2a43bd1abef04..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/rnsgb.f
+++ /dev/null
@@ -1,322 +0,0 @@
- SUBROUTINE RNSGB(A, ALF, B, C, DA, IN, IV, L, L1, LA, LIV, LV,
- 1 N, NDA, P, V, Y)
-C
-C *** ITERATION DRIVER FOR SEPARABLE NONLINEAR LEAST SQUARES,
-C *** WITH SIMPLE BOUNDS ON THE NONLINEAR VARIABLES.
-C
-C *** PARAMETER DECLARATIONS ***
-C
- INTEGER L, L1, LA, LIV, LV, N, NDA, P
- INTEGER IN(2,NDA), IV(LIV)
-C DIMENSION UIPARM(*)
- REAL A(LA,L1), ALF(P), B(2,P), C(L), DA(LA,NDA),
- 1 V(LV), Y(N)
-C
-C *** PURPOSE ***
-C
-C GIVEN A SET OF N OBSERVATIONS Y(1)....Y(N) OF A DEPENDENT VARIABLE
-C T(1)...T(N), RNSGB ATTEMPTS TO COMPUTE A LEAST SQUARES FIT
-C TO A FUNCTION ETA (THE MODEL) WHICH IS A LINEAR COMBINATION
-C
-C L
-C ETA(C,ALF,T) = SUM C * PHI(ALF,T) +PHI (ALF,T)
-C J=1 J J L+1
-C
-C OF NONLINEAR FUNCTIONS PHI(J) DEPENDENT ON T AND ALF(1),...,ALF(P)
-C (.E.G. A SUM OF EXPONENTIALS OR GAUSSIANS). THAT IS, IT DETERMINES
-C NONLINEAR PARAMETERS ALF WHICH MINIMIZE
-C
-C 2 N 2
-C NORM(RESIDUAL) = SUM (Y - ETA(C,ALF,T )) ,
-C I=1 I I
-C
-C SUBJECT TO THE SIMPLE BOUND CONSTRAINTS
-C B(1,I) .LE. ALF(I) .LE. B(2,I), I = 1(1)P.
-C
-C THE (L+1)ST TERM IS OPTIONAL.
-C
-C
-C *** PARAMETERS ***
-C
-C A (IN) MATRIX PHI(ALF,T) OF THE MODEL.
-C ALF (I/O) NONLINEAR PARAMETERS.
-C INPUT = INITIAL GUESS,
-C OUTPUT = BEST ESTIMATE FOUND.
-C C (OUT) LINEAR PARAMETERS (ESTIMATED).
-C DA (IN) DERIVATIVES OF COLUMNS OF A WITH RESPECT TO COMPONENTS
-C OF ALF, AS SPECIFIED BY THE IN ARRAY...
-C IN (IN) WHEN RNSGB IS CALLED WITH IV(1) = 2 OR -2, THEN FOR
-C I = 1(1)NDA, COLUMN I OF DA IS THE PARTIAL
-C DERIVATIVE WITH RESPECT TO ALF(IN(1,I)) OF COLUMN
-C IN(2,I) OF A, UNLESS IV(1,I) IS NOT POSITIVE (IN
-C WHICH CASE COLUMN I OF DA IS IGNORED. IV(1) = -2
-C MEANS THERE ARE MORE COLUMNS OF DA TO COME AND
-C RNSGB SHOULD RETURN FOR THEM.
-C IV (I/O) INTEGER PARAMETER AND SCRATCH VECTOR. RNSGB RETURNS
-C WITH IV(1) = 1 WHEN IT WANTS A TO BE EVALUATED AT
-C ALF AND WITH IV(1) = 2 WHEN IT WANTS DA TO BE
-C EVALUATED AT ALF. WHEN CALLED WITH IV(1) = -2
-C (AFTER A RETURN WITH IV(1) = 2), RNSGB RETURNS
-C WITH IV(1) = -2 TO GET MORE COLUMNS OF DA.
-C L (IN) NUMBER OF LINEAR PARAMETERS TO BE ESTIMATED.
-C L1 (IN) L+1 IF PHI(L+1) IS IN THE MODEL, L IF NOT.
-C LA (IN) LEAD DIMENSION OF A. MUST BE AT LEAST N.
-C LIV (IN) LENGTH OF IV. MUST BE AT LEAST 110 + L + 4*P.
-C LV (IN) LENGTH OF V. MUST BE AT LEAST
-C 105 + 2*N + L*(L+3)/2 + P*(2*P + 21 + N).
-C N (IN) NUMBER OF OBSERVATIONS.
-C NDA (IN) NUMBER OF COLUMNS IN DA AND IN.
-C P (IN) NUMBER OF NONLINEAR PARAMETERS TO BE ESTIMATED.
-C V (I/O) FLOATING-POINT PARAMETER AND SCRATCH VECTOR.
-C Y (IN) RIGHT-HAND SIDE VECTOR.
-C
-C
-C *** EXTERNAL SUBROUTINES ***
-C
- REAL L7SVX, L7SVN, R7MDC
- EXTERNAL IVSET, ITSUM, L7ITV, L7SVX, L7SVN, RN2GB, Q7APL,
- 1 Q7RFH, R7MDC, S7CPR, V2AXY, V7CPY, V7PRM, V7SCP
-C
-C IVSET.... SUPPLIES DEFAULT PARAMETER VALUES.
-C ITSUM.... PRINTS ITERATION SUMMARY, INITIAL AND FINAL ALF.
-C L7ITV... APPLIES INVERSE-TRANSPOSE OF COMPACT LOWER TRIANG. MATRIX.
-C L7SVX... ESTIMATES LARGEST SING. VALUE OF LOWER TRIANG. MATRIX.
-C L7SVN... ESTIMATES SMALLEST SING. VALUE OF LOWER TRIANG. MATRIX.
-C RN2GB... UNDERLYING NONLINEAR LEAST-SQUARES SOLVER.
-C Q7APL... APPLIES HOUSEHOLDER TRANSFORMS STORED BY Q7RFH.
-C Q7RFH.... COMPUTES QR FACT. VIA HOUSEHOLDER TRANSFORMS WITH PIVOTING.
-C R7MDC... RETURNS MACHINE-DEP. CONSTANTS.
-C S7CPR... PRINTS LINEAR PARAMETERS AT SOLUTION.
-C V2AXY.... ADDS MULTIPLE OF ONE VECTOR TO ANOTHER.
-C V7CPY.... COPIES ONE VECTOR TO ANOTHER.
-C V7PRM.... PERMUTES VECTOR.
-C V7SCL... SCALES AND COPIES ONE VECTOR TO ANOTHER.
-C
-C *** LOCAL VARIABLES ***
-C
- INTEGER AR1, CSAVE1, D1, DR1, DR1L, I, I1,
- 1 IPIV1, IER, IV1, J1, JLEN, K, LL1O2, MD, N1, N2,
- 2 NML, NRAN, R1, R1L, RD1
- REAL SINGTL, T
- REAL MACHEP, NEGONE, SNGFAC, ZERO
-C
-C *** SUBSCRIPTS FOR IV AND V ***
-C
- INTEGER AR, CSAVE, D, IERS, IPIVS, IV1SAV,
- 2 IVNEED, J, MODE, NEXTIV, NEXTV,
- 2 NFCALL, NFGCAL, PERM, R,
- 3 REGD, REGD0, RESTOR, TOOBIG, VNEED
-C
-C *** IV SUBSCRIPT VALUES ***
-C
-C/6
-C DATA AR/110/, CSAVE/105/, D/27/, IERS/108/, IPIVS/109/,
-C 1 IV1SAV/104/, IVNEED/3/, J/70/, MODE/35/, NEXTIV/46/,
-C 2 NEXTV/47/, NFCALL/6/, NFGCAL/7/, PERM/58/, R/61/, REGD/67/,
-C 3 REGD0/82/, RESTOR/9/, TOOBIG/2/, VNEED/4/
-C/7
- PARAMETER (AR=110, CSAVE=105, D=27, IERS=108, IPIVS=109,
- 1 IV1SAV=104, IVNEED=3, J=70, MODE=35, NEXTIV=46,
- 2 NEXTV=47, NFCALL=6, NFGCAL=7, PERM=58, R=61, REGD=67,
- 3 REGD0=82, RESTOR=9, TOOBIG=2, VNEED=4)
-C/
- DATA MACHEP/-1.E+0/, NEGONE/-1.E+0/, SNGFAC/1.E+2/, ZERO/0.E+0/
-C
-C++++++++++++++++++++++++++++++++ BODY ++++++++++++++++++++++++++++++
-C
-C
- IF (IV(1) .EQ. 0) CALL IVSET(1, IV, LIV, LV, V)
- N1 = 1
- NML = N
- IV1 = IV(1)
- IF (IV1 .LE. 2) GO TO 20
-C
-C *** CHECK INPUT INTEGERS ***
-C
- IF (P .LE. 0) GO TO 240
- IF (L .LT. 0) GO TO 240
- IF (N .LE. L) GO TO 240
- IF (LA .LT. N) GO TO 240
- IF (IV1 .LT. 12) GO TO 20
- IF (IV1 .EQ. 14) GO TO 20
- IF (IV1 .EQ. 12) IV(1) = 13
-C
-C *** FRESH START -- COMPUTE STORAGE REQUIREMENTS ***
-C
- IF (IV(1) .GT. 16) GO TO 240
- LL1O2 = L*(L+1)/2
- JLEN = N*P
- I = L + P
- IF (IV(1) .NE. 13) GO TO 10
- IV(IVNEED) = IV(IVNEED) + L
- IV(VNEED) = IV(VNEED) + P + 2*N + JLEN + LL1O2 + L
- 10 IF (IV(PERM) .LE. AR) IV(PERM) = AR + 1
- CALL RN2GB(B, V, V, IV, LIV, LV, N, N, N1, NML, P, V, V, V, ALF)
- IF (IV(1) .NE. 14) GO TO 999
-C
-C *** STORAGE ALLOCATION ***
-C
- IV(IPIVS) = IV(NEXTIV)
- IV(NEXTIV) = IV(NEXTIV) + L
- IV(D) = IV(NEXTV)
- IV(REGD0) = IV(D) + P
- IV(AR) = IV(REGD0) + N
- IV(CSAVE) = IV(AR) + LL1O2
- IV(J) = IV(CSAVE) + L
- IV(R) = IV(J) + JLEN
- IV(NEXTV) = IV(R) + N
- IV(IERS) = 0
- IF (IV1 .EQ. 13) GO TO 999
-C
-C *** SET POINTERS INTO IV AND V ***
-C
- 20 AR1 = IV(AR)
- D1 = IV(D)
- DR1 = IV(J)
- DR1L = DR1 + L
- R1 = IV(R)
- R1L = R1 + L
- RD1 = IV(REGD0)
- CSAVE1 = IV(CSAVE)
- NML = N - L
- IF (IV1 .LE. 2) GO TO 50
-C
- 30 N2 = NML
- CALL RN2GB(B, V(D1), V(DR1L), IV, LIV, LV, NML, N, N1, N2, P,
- 1 V(R1L), V(RD1), V, ALF)
- IF (IABS(IV(RESTOR)-2) .EQ. 1 .AND. L .GT. 0)
- 1 CALL V7CPY(L, C, V(CSAVE1))
- IV1 = IV(1)
- IF (IV1-2) 40, 150, 230
-C
-C *** NEW FUNCTION VALUE (RESIDUAL) NEEDED ***
-C
- 40 IV(IV1SAV) = IV(1)
- IV(1) = IABS(IV1)
- IF (IV(RESTOR) .EQ. 2 .AND. L .GT. 0) CALL V7CPY(L, V(CSAVE1), C)
- GO TO 999
-C
-C *** COMPUTE NEW RESIDUAL OR GRADIENT ***
-C
- 50 IV(1) = IV(IV1SAV)
- MD = IV(MODE)
- IF (MD .LE. 0) GO TO 60
- NML = N
- DR1L = DR1
- R1L = R1
- 60 IF (IV(TOOBIG) .NE. 0) GO TO 30
- IF (IABS(IV1) .EQ. 2) GO TO 170
-C
-C *** COMPUTE NEW RESIDUAL ***
-C
- IF (L1 .LE. L) CALL V7CPY(N, V(R1), Y)
- IF (L1 .GT. L) CALL V2AXY(N, V(R1), NEGONE, A(1,L1), Y)
- IF (MD .GT. 0) GO TO 120
- IER = 0
- IF (L .LE. 0) GO TO 110
- LL1O2 = L * (L + 1) / 2
- IPIV1 = IV(IPIVS)
- CALL Q7RFH(IER, IV(IPIV1), N, LA, 0, L, A, V(AR1), LL1O2, C)
-C
-C *** DETERMINE NUMERICAL RANK OF A ***
-C
- IF (MACHEP .LE. ZERO) MACHEP = R7MDC(3)
- SINGTL = SNGFAC * FLOAT(MAX0(L,N)) * MACHEP
- K = L
- IF (IER .NE. 0) K = IER - 1
- 70 IF (K .LE. 0) GO TO 90
- T = L7SVX(K, V(AR1), C, C)
- IF (T .GT. ZERO) T = L7SVN(K, V(AR1), C, C) / T
- IF (T .GT. SINGTL) GO TO 80
- K = K - 1
- GO TO 70
-C
-C *** RECORD RANK IN IV(IERS)... IV(IERS) = 0 MEANS FULL RANK,
-C *** IV(IERS) .GT. 0 MEANS RANK IV(IERS) - 1.
-C
- 80 IF (K .GE. L) GO TO 100
- 90 IER = K + 1
- CALL V7SCP(L-K, C(K+1), ZERO)
- 100 IV(IERS) = IER
- IF (K .LE. 0) GO TO 110
-C
-C *** APPLY HOUSEHOLDER TRANSFORMATONS TO RESIDUALS...
-C
- CALL Q7APL(LA, N, K, A, V(R1), IER)
-C
-C *** COMPUTING C NOW MAY SAVE A FUNCTION EVALUATION AT
-C *** THE LAST ITERATION.
-C
- CALL L7ITV(K, C, V(AR1), V(R1))
- CALL V7PRM(L, IV(IPIV1), C)
-C
- 110 IF(IV(1) .LT. 2) GO TO 220
- GO TO 999
-C
-C
-C *** RESIDUAL COMPUTATION FOR F.D. HESSIAN ***
-C
- 120 IF (L .LE. 0) GO TO 140
- DO 130 I = 1, L
- 130 CALL V2AXY(N, V(R1), -C(I), A(1,I), V(R1))
- 140 IF (IV(1) .GT. 0) GO TO 30
- IV(1) = 2
- GO TO 160
-C
-C *** NEW GRADIENT (JACOBIAN) NEEDED ***
-C
- 150 IV(IV1SAV) = IV1
- IF (IV(NFGCAL) .NE. IV(NFCALL)) IV(1) = 1
- 160 CALL V7SCP(N*P, V(DR1), ZERO)
- GO TO 999
-C
-C *** COMPUTE NEW JACOBIAN ***
-C
- 170 IF (NDA .LE. 0) GO TO 240
- DO 180 I = 1, NDA
- I1 = IN(1,I) - 1
- IF (I1 .LT. 0) GO TO 180
- J1 = IN(2,I)
- K = DR1 + I1*N
- T = NEGONE
- IF (J1 .LE. L) T = -C(J1)
- CALL V2AXY(N, V(K), T, DA(1,I), V(K))
- 180 CONTINUE
- IF (IV1 .EQ. 2) GO TO 190
- IV(1) = IV1
- GO TO 999
- 190 IF (L .LE. 0) GO TO 30
- IF (MD .GT. 0) GO TO 30
- K = DR1
- IER = IV(IERS)
- NRAN = L
- IF (IER .GT. 0) NRAN = IER - 1
- IF (NRAN .LE. 0) GO TO 210
- DO 200 I = 1, P
- CALL Q7APL(LA, N, NRAN, A, V(K), IER)
- K = K + N
- 200 CONTINUE
- 210 CALL V7CPY(L, V(CSAVE1), C)
- 220 IF (IER .EQ. 0) GO TO 30
-C
-C *** ADJUST SUBSCRIPTS DESCRIBING R AND DR...
-C
- NRAN = IER - 1
- DR1L = DR1 + NRAN
- NML = N - NRAN
- R1L = R1 + NRAN
- GO TO 30
-C
-C *** CONVERGENCE OR LIMIT REACHED ***
-C
- 230 IF (IV(REGD) .EQ. 1) IV(REGD) = RD1
- IF (IV(1) .LE. 11) CALL S7CPR(C, IV, L, LIV)
- GO TO 999
-C
- 240 IV(1) = 66
- CALL ITSUM(V, V, IV, LIV, LV, P, V, ALF)
-C
- 999 RETURN
-C
-C *** LAST CARD OF RNSGB FOLLOWS ***
- END
diff --git a/CEP/PyBDSM/src/port3/s1mach.f b/CEP/PyBDSM/src/port3/s1mach.f
deleted file mode 100644
index dbac0ffde701627b1db4afa47db5b0119d66bbb9..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/s1mach.f
+++ /dev/null
@@ -1,673 +0,0 @@
- SUBROUTINE S1MACH
-C
-C S1MACH TESTS THE CONSISTENCY OF THE MACHINE CONSTANTS IN
-C I1MACH, R1MACH AND D1MACH.
-C
- INTEGER IMACH(16),I1MACH
- INTEGER STDOUT
- INTEGER DIGINT, DIGSP, DIGDP
- REAL RMACH(5),R1MACH
- REAL S2MACH, XR, YR
- REAL SBASE, SBASEM
- REAL ALOG10, SQRT
- DOUBLE PRECISION DLOG10, DSQRT
- DOUBLE PRECISION DMACH(5),D1MACH
- DOUBLE PRECISION S3MACH, XD, YD
- DOUBLE PRECISION DBASE, DBASEM
-C
-C/6S
-C INTEGER IFMT(12)
-C INTEGER EFMT(15)
-C INTEGER DFMT(15)
-C INTEGER CCPLUS
-C/7S
- CHARACTER*1 IFMT1(12), EFMT1(15), DFMT1(15), CCPLUS
- CHARACTER*12 IFMT
- CHARACTER*15 EFMT, DFMT
- EQUIVALENCE (IFMT1(1),IFMT), (EFMT1(1),EFMT), (DFMT1(1),DFMT)
-C/
- INTEGER DWIDTH, WWIDTH, EWIDTH
- INTEGER DEMAX, DEMIN
-C
- EQUIVALENCE ( STDOUT, IMACH(2) )
- EQUIVALENCE ( DIGINT, IMACH(8) )
- EQUIVALENCE ( DIGSP, IMACH(11) )
- EQUIVALENCE ( DIGDP, IMACH(14) )
-C
-C/6S
-C DATA CCPLUS / 1H+ /
-C/7S
- DATA CCPLUS / '+' /
-C/
-C
-C/6S
-C DATA IFMT(1 ) / 1H( /
-C DATA IFMT(2 ) / 1HA /
-C DATA IFMT(3 ) / 1H1 /
-C DATA IFMT(4 ) / 1H, /
-C DATA IFMT(5 ) / 1H5 /
-C DATA IFMT(6 ) / 1H1 /
-C DATA IFMT(7 ) / 1HX /
-C DATA IFMT(8 ) / 1H, /
-C DATA IFMT(9 ) / 1HI /
-C DATA IFMT(10) / 1H /
-C DATA IFMT(11) / 1H /
-C DATA IFMT(12) / 1H) /
-C/7S
- DATA IFMT1(1 ) / '(' /
- DATA IFMT1(2 ) / 'A' /
- DATA IFMT1(3 ) / '1' /
- DATA IFMT1(4 ) / ',' /
- DATA IFMT1(5 ) / '5' /
- DATA IFMT1(6 ) / '1' /
- DATA IFMT1(7 ) / 'X' /
- DATA IFMT1(8 ) / ',' /
- DATA IFMT1(9 ) / 'I' /
- DATA IFMT1(10) / ' ' /
- DATA IFMT1(11) / ' ' /
- DATA IFMT1(12) / ')' /
-C/
-C
-C/6S
-C DATA EFMT( 1) / 1H( /, DFMT( 1) / 1H( /
-C DATA EFMT( 2) / 1HA /, DFMT( 2) / 1HA /
-C DATA EFMT( 3) / 1H1 /, DFMT( 3) / 1H1 /
-C DATA EFMT( 4) / 1H, /, DFMT( 4) / 1H, /
-C DATA EFMT( 5) / 1H3 /, DFMT( 5) / 1H3 /
-C DATA EFMT( 6) / 1H2 /, DFMT( 6) / 1H2 /
-C DATA EFMT( 7) / 1HX /, DFMT( 7) / 1HX /
-C DATA EFMT( 8) / 1H, /, DFMT( 8) / 1H, /
-C DATA EFMT( 9) / 1HE /, DFMT( 9) / 1HD /
-C DATA EFMT(10) / 1H /, DFMT(10) / 1H /
-C DATA EFMT(11) / 1H /, DFMT(11) / 1H /
-C DATA EFMT(12) / 1H. /, DFMT(12) / 1H. /
-C DATA EFMT(13) / 1H /, DFMT(13) / 1H /
-C DATA EFMT(14) / 1H /, DFMT(14) / 1H /
-C DATA EFMT(15) / 1H) /, DFMT(15) / 1H) /
-C/7S
- DATA EFMT1( 1) / '(' /, DFMT1( 1) / '(' /
- DATA EFMT1( 2) / 'A' /, DFMT1( 2) / 'A' /
- DATA EFMT1( 3) / '1' /, DFMT1( 3) / '1' /
- DATA EFMT1( 4) / ',' /, DFMT1( 4) / ',' /
- DATA EFMT1( 5) / '3' /, DFMT1( 5) / '3' /
- DATA EFMT1( 6) / '2' /, DFMT1( 6) / '2' /
- DATA EFMT1( 7) / 'X' /, DFMT1( 7) / 'X' /
- DATA EFMT1( 8) / ',' /, DFMT1( 8) / ',' /
- DATA EFMT1( 9) / 'E' /, DFMT1( 9) / 'D' /
- DATA EFMT1(10) / ' ' /, DFMT1(10) / ' ' /
- DATA EFMT1(11) / ' ' /, DFMT1(11) / ' ' /
- DATA EFMT1(12) / '.' /, DFMT1(12) / '.' /
- DATA EFMT1(13) / ' ' /, DFMT1(13) / ' ' /
- DATA EFMT1(14) / ' ' /, DFMT1(14) / ' ' /
- DATA EFMT1(15) / ')' /, DFMT1(15) / ')' /
-C/
-C
-C FETCH ALL CONSTANTS INTO LOCAL ARRAYS
-C
- DO 10 I = 1,16
- IMACH(I) = I1MACH(I)
- 10 CONTINUE
-C
- DO 20 I = 1,5
- RMACH(I) = R1MACH(I)
- DMACH(I) = D1MACH(I)
- 20 CONTINUE
-C
-C COMPUTE NUMBER OF CHARACTER POSITIONS NEEDED FOR WRITING
-C OUT THE LARGEST INTEGER ALLOWING FOR ONE SPACE AND A SIGN
-C AND PLUG THE FIELD WIDTH IN THE FORMAT.
-C
- WWIDTH = ICEIL( ALOG10(FLOAT(IMACH(7)))*FLOAT(IMACH(8)) ) + 2
-C/6S
-C CALL S88FMT( 2, WWIDTH, IFMT(10) )
-C WRITE( STDOUT, 900 ) ( IFMT(I), I = 9, 11 )
-C/7S
- CALL S88FMT( 2, WWIDTH, IFMT1(10) )
- WRITE( STDOUT, 900 ) ( IFMT1(I), I = 9, 11 )
-C/
- 900 FORMAT(//37H FORMAT CONVERSION FOR INTEGERS IS - ,3A1
- 1 / 25H INTEGER CONSTANTS FOLLOW///)
-C
-C NOW WRITE OUT THE INTEGER CONSTANTS
-C
- WRITE( STDOUT, 1001 )
- 1001 FORMAT(24H THE STANDARD INPUT UNIT)
- WRITE( STDOUT, IFMT ) CCPLUS, IMACH(1)
-C
- WRITE( STDOUT, 1002 )
- 1002 FORMAT(25H THE STANDARD OUTPUT UNIT)
- WRITE( STDOUT, IFMT ) CCPLUS, IMACH(2)
-C
- WRITE( STDOUT, 1003 )
- 1003 FORMAT(24H THE STANDARD PUNCH UNIT)
- WRITE( STDOUT, IFMT ) CCPLUS, IMACH(3)
-C
- WRITE( STDOUT, 1004 )
- 1004 FORMAT(32H THE STANDARD ERROR MESSAGE UNIT)
- WRITE( STDOUT, IFMT ) CCPLUS, IMACH(4)
-C
- WRITE( STDOUT, 1005 )
- 1005 FORMAT(28H THE NUMBER OF BITS PER WORD)
- WRITE( STDOUT, IFMT ) CCPLUS, IMACH(5)
-C
- WRITE( STDOUT, 1006 )
- 1006 FORMAT(34H THE NUMBER OF CHARACTERS PER WORD)
- WRITE( STDOUT, IFMT ) CCPLUS, IMACH(6)
-C
- WRITE( STDOUT, 1007 )
- 1007 FORMAT(34H A, THE BASE OF AN S-DIGIT INTEGER)
- WRITE( STDOUT, IFMT ) CCPLUS, IMACH(7)
-C
- WRITE( STDOUT, 1008 )
- 1008 FORMAT(31H S, THE NUMBER OF BASE-A DIGITS)
- WRITE( STDOUT, IFMT ) CCPLUS, IMACH(8)
-C
- WRITE( STDOUT, 1009 )
- 1009 FORMAT(32H A**S - 1, THE LARGEST MAGNITUDE)
- WRITE( STDOUT, IFMT ) CCPLUS, IMACH(9)
-C
- WRITE( STDOUT, 1010 )
- 1010 FORMAT(47H B, THE BASE OF A T-DIGIT FLOATING-POINT NUMBER)
- WRITE( STDOUT, IFMT ) CCPLUS, IMACH(10)
-C
- WRITE( STDOUT, 1011 )
- 1011 FORMAT(51H T, THE NUMBER OF BASE-B DIGITS IN SINGLE-PRECISION)
- WRITE( STDOUT, IFMT ) CCPLUS, IMACH(11)
-C
- WRITE( STDOUT, 1012 )
- 1012 FORMAT(45H EMIN, THE SMALLEST SINGLE-PRECISION EXPONENT)
- WRITE( STDOUT, IFMT ) CCPLUS, IMACH(12)
-C
- WRITE( STDOUT, 1013 )
- 1013 FORMAT(44H EMAX, THE LARGEST SINGLE-PRECISION EXPONENT)
- WRITE( STDOUT, IFMT ) CCPLUS, IMACH(13)
-C
- WRITE( STDOUT, 1014 )
- 1014 FORMAT(51H T, THE NUMBER OF BASE-B DIGITS IN DOUBLE-PRECISION)
- WRITE( STDOUT, IFMT ) CCPLUS, IMACH(14)
-C
- WRITE( STDOUT, 1015 )
- 1015 FORMAT(45H EMIN, THE SMALLEST DOUBLE-PRECISION EXPONENT)
- WRITE( STDOUT, IFMT ) CCPLUS, IMACH(15)
-C
- WRITE( STDOUT, 1016 )
- 1016 FORMAT(44H EMAX, THE LARGEST DOUBLE-PRECISION EXPONENT)
- WRITE( STDOUT, IFMT ) CCPLUS, IMACH(16)
-C
-C COMPUTE THE NUMBER OF CHARACTER POSITIONS NEEDED FOR WRITING
-C OUT A SINGLE-PRECISION NUMBER ALLOWING FOR ONE SPACE AND
-C A SIGN AND PLUG THE FIELDS IN THE FORMAT.
-C
- DWIDTH = ICEIL( ALOG10(FLOAT(IMACH(10)))*FLOAT(IMACH(11)) )
-C/6S
-C CALL S88FMT( 2, DWIDTH, EFMT(13) )
-C/7S
- CALL S88FMT( 2, DWIDTH, EFMT1(13) )
-C/
- DEMIN = IFLR( ALOG10(FLOAT(IMACH(10)))*FLOAT(IMACH(12)-1) ) + 1
- DEMAX = ICEIL( ALOG10(FLOAT(IMACH(10)))*FLOAT(IMACH(13)) )
- EWIDTH = IFLR( ALOG10(FLOAT(MAX0(IABS(DEMIN),IABS(DEMAX)))) ) + 1
- WWIDTH = DWIDTH + EWIDTH + 6
-C/6S
-C CALL S88FMT( 2, WWIDTH, EFMT(10) )
-C WRITE( STDOUT, 1900 ) ( EFMT(I), I = 9, 14 )
-C/7S
- CALL S88FMT( 2, WWIDTH, EFMT1(10) )
- WRITE( STDOUT, 1900 ) ( EFMT1(I), I = 9, 14 )
-C/
- 1900 FORMAT(//45H FORMAT CONVERSION FOR SINGLE-PRECISION IS - ,6A1
- 1 / 34H SINGLE-PRECISION CONSTANTS FOLLOW///)
-C
-C NOW WRITE OUT THE SINGLE-PRECISION CONSTANTS
-C
- WRITE( STDOUT, 2001 )
- 2001 FORMAT(32H THE SMALLEST POSITIVE MAGNITUDE)
- WRITE( STDOUT, EFMT ) CCPLUS, RMACH(1)
-C
- WRITE( STDOUT, 2002 )
- 2002 FORMAT(22H THE LARGEST MAGNITUDE)
- WRITE( STDOUT, EFMT ) CCPLUS, RMACH(2)
-C
- WRITE( STDOUT, 2003 )
- 2003 FORMAT(30H THE SMALLEST RELATIVE SPACING)
- WRITE( STDOUT, EFMT ) CCPLUS, RMACH(3)
-C
- WRITE( STDOUT, 2004 )
- 2004 FORMAT(29H THE LARGEST RELATIVE SPACING)
- WRITE( STDOUT, EFMT ) CCPLUS, RMACH(4)
-C
- WRITE( STDOUT, 2005 )
- 2005 FORMAT(18H LOG10 OF THE BASE)
- WRITE( STDOUT, EFMT ) CCPLUS, RMACH(5)
-C/6S
-C CALL S88FMT( 2, WWIDTH+1, EFMT(10) )
-C CALL S88FMT( 2, DWIDTH+1, EFMT(13) )
-C/7S
- CALL S88FMT( 2, WWIDTH+1, EFMT1(10) )
- CALL S88FMT( 2, DWIDTH+1, EFMT1(13) )
-C/
-C COMPUTE THE NUMBER OF CHARACTER POSITIONS NEEDED FOR WRITING
-C OUT A DOUBLE-PRECISION NUMBER ALLOWING FOR ONE SPACE AND
-C A SIGN AND PLUG THE FIELDS IN THE FORMAT.
-C
- DWIDTH = ICEIL( ALOG10(FLOAT(IMACH(10)))*FLOAT(IMACH(14)) )
-C/6S
-C CALL S88FMT( 2, DWIDTH, DFMT(13) )
-C/7S
- CALL S88FMT( 2, DWIDTH, DFMT1(13) )
-C/
- DEMIN = IFLR( ALOG10(FLOAT(IMACH(10)))*FLOAT(IMACH(15)-1) ) + 1
- DEMAX = ICEIL( ALOG10(FLOAT(IMACH(10)))*FLOAT(IMACH(16)) )
- EWIDTH = IFLR( ALOG10(FLOAT(MAX0(IABS(DEMIN),IABS(DEMAX)))) ) + 1
- WWIDTH = DWIDTH + EWIDTH + 6
-C/6S
-C CALL S88FMT( 2, WWIDTH, DFMT(10) )
-C WRITE( STDOUT, 2900 ) ( DFMT(I), I = 9, 14 )
-C/7S
- CALL S88FMT( 2, WWIDTH, DFMT1(10) )
- WRITE( STDOUT, 2900 ) ( DFMT1(I), I = 9, 14 )
-C/
- 2900 FORMAT(//45H FORMAT CONVERSION FOR DOUBLE-PRECISION IS - ,6A1
- 1 / 34H DOUBLE-PRECISION CONSTANTS FOLLOW///)
-C
-C NOW WRITE OUT THE DOUBLE-PRECISION CONSTANTS
-C
- WRITE( STDOUT, 3001 )
- 3001 FORMAT(32H THE SMALLEST POSITIVE MAGNITUDE)
- WRITE( STDOUT, DFMT ) CCPLUS, DMACH(1)
-C
- WRITE( STDOUT, 3002 )
- 3002 FORMAT(22H THE LARGEST MAGNITUDE)
- WRITE( STDOUT, DFMT ) CCPLUS, DMACH(2)
-C
- WRITE( STDOUT, 3003 )
- 3003 FORMAT(30H THE SMALLEST RELATIVE SPACING)
- WRITE( STDOUT, DFMT ) CCPLUS, DMACH(3)
-C
- WRITE( STDOUT, 3004 )
- 3004 FORMAT(29H THE LARGEST RELATIVE SPACING)
- WRITE( STDOUT, DFMT ) CCPLUS, DMACH(4)
-C
- WRITE( STDOUT, 3005 )
- 3005 FORMAT(18H LOG10 OF THE BASE)
- WRITE( STDOUT, DFMT ) CCPLUS, DMACH(5)
-C/6S
-C CALL S88FMT( 2, WWIDTH+1, DFMT(10) )
-C CALL S88FMT( 2, DWIDTH+1, DFMT(13) )
-C/7S
- CALL S88FMT( 2, WWIDTH+1, DFMT1(10) )
- CALL S88FMT( 2, DWIDTH+1, DFMT1(13) )
-C/
-C NOW CHECK CONSISTENCY OF INTEGER CONSTANTS
-C/6S
-C CALL S88FMT( 2, 14, IFMT(5) )
-C/7S
- CALL S88FMT( 2, 14, IFMT1(5) )
-C/
- IF( IMACH(11) .LE. IMACH(14) ) GOTO 4009
- WRITE( STDOUT, 4001 )
- 4001 FORMAT(30H0I1MACH(11) EXCEEDS I1MACH(14) )
- WRITE( STDOUT, 4002 )
- 4002 FORMAT(13H I1MACH(11) = )
- WRITE( STDOUT, IFMT ) CCPLUS, IMACH(11)
- WRITE( STDOUT, 4003 )
- 4003 FORMAT(13H I1MACH(14) = )
- WRITE( STDOUT, IFMT ) CCPLUS, IMACH(14)
- 4009 CONTINUE
-C
- IF( IMACH(13) .LE. IMACH(16) ) GOTO 4019
- WRITE( STDOUT, 4011 )
- 4011 FORMAT(40H0WARNING - I1MACH(13) EXCEEDS I1MACH(16) )
- WRITE( STDOUT, 4012 )
- 4012 FORMAT(13H I1MACH(13) = )
- WRITE( STDOUT, IFMT ) CCPLUS, IMACH(13)
- WRITE( STDOUT, 4013 )
- 4013 FORMAT(13H I1MACH(16) = )
- WRITE( STDOUT, IFMT ) CCPLUS, IMACH(16)
- 4019 CONTINUE
-C
- IF( IMACH(16)-IMACH(15) .GE. IMACH(13)-IMACH(12) ) GOTO 4029
- WRITE( STDOUT, 4021 )
- 4021 FORMAT(34H0WARNING - I1MACH(13) - I1MACH(12) )
- WRITE( STDOUT, 4022 )
- 4022 FORMAT(32H EXCEEDS I1MACH(16) - I1MACH(15) )
- WRITE( STDOUT, 4023 )
- 4023 FORMAT(13H I1MACH(12) = )
- WRITE( STDOUT, IFMT ) CCPLUS, IMACH(12)
- WRITE( STDOUT, 4024 )
- 4024 FORMAT(13H I1MACH(13) = )
- WRITE( STDOUT, IFMT ) CCPLUS, IMACH(13)
- WRITE( STDOUT, 4025 )
- 4025 FORMAT(13H I1MACH(15) = )
- WRITE( STDOUT, IFMT ) CCPLUS, IMACH(15)
- WRITE( STDOUT, 4026 )
- 4026 FORMAT(13H I1MACH(16) = )
- WRITE( STDOUT, IFMT ) CCPLUS, IMACH(16)
- 4029 CONTINUE
-C
- N = 0
- IBASEM = IMACH(7) - 1
- DO 4030 I = 1, DIGINT
- N = N*IMACH(7) + IBASEM
- 4030 CONTINUE
-C
- IF( IMACH(9) .EQ. N) GOTO 4039
- WRITE( STDOUT, 4031 )
- 4031 FORMAT(39H1IMACH(9) IS NOT IMACH(7)**IMACH(8) - 1 )
- WRITE( STDOUT, 4032 )
- 4032 FORMAT(12H I1MACH(7) = )
- WRITE( STDOUT, IFMT ) CCPLUS, IMACH(7)
- WRITE( STDOUT, 4034 )
- 4034 FORMAT(12H I1MACH(8) = )
- WRITE( STDOUT, IFMT ) CCPLUS, IMACH(8)
- WRITE( STDOUT, 4035 )
- 4035 FORMAT(12H I1MACH(9) = )
- WRITE( STDOUT, IFMT ) CCPLUS, IMACH(9)
- 4039 CONTINUE
-C
-C NOW CHECK CONSISTENCY OF SINGLE-PRECISION CONSTANTS
-C/6S
-C CALL S88FMT( 2, 19, EFMT(5) )
-C/7S
- CALL S88FMT( 2, 19, EFMT1(5) )
-C/
- XR = S2MACH( 1.0, IMACH(10), IMACH(12)-1 )
- IF( XR .EQ. RMACH(1) ) GOTO 5009
- WRITE( STDOUT, 5001 )
- 5001 FORMAT(47H0R1MACH(1) DOES NOT AGREE WITH CALCULATED VALUE)
- WRITE( STDOUT, 5002 )
- 5002 FORMAT(12H R1MACH(1) = )
- WRITE( STDOUT, EFMT ) CCPLUS, RMACH(1)
- WRITE( STDOUT, 5003 )
- 5003 FORMAT(19H CALCULATED VALUE = )
- WRITE( STDOUT, EFMT ) CCPLUS, XR
- WRITE( STDOUT, 5004 )
- 5004 FORMAT(14H DIFFERENCE = )
- XR = RMACH(1) - XR
- WRITE( STDOUT, EFMT ) CCPLUS, XR
- 5009 CONTINUE
-C
- XR = 0.0
- SBASE = FLOAT( IMACH(10) )
- SBASEM = FLOAT( IMACH(10)-1 )
- DO 5010 I = 1, DIGSP
- XR = (XR + SBASEM)/SBASE
- 5010 CONTINUE
-C
- XR = S2MACH( XR, IMACH(10), IMACH(13) )
- IF( XR .EQ. RMACH(2) ) GOTO 5019
- WRITE( STDOUT, 5011 )
- 5011 FORMAT(47H0R1MACH(2) DOES NOT AGREE WITH CALCULATED VALUE)
- WRITE( STDOUT, 5012 )
- 5012 FORMAT(12H R1MACH(2) = )
- WRITE( STDOUT, EFMT ) CCPLUS, RMACH(2)
- WRITE( STDOUT, 5013 )
- 5013 FORMAT(19H CALCULATED VALUE = )
- WRITE( STDOUT, EFMT ) CCPLUS, XR
- WRITE( STDOUT, 5014 )
- 5014 FORMAT(14H DIFFERENCE = )
- XR = RMACH(2) - XR
- WRITE( STDOUT, EFMT ) CCPLUS, XR
- 5019 CONTINUE
-C
- XR = S2MACH( 1.0, IMACH(10), -IMACH(11) )
- IF( XR .EQ. RMACH(3) ) GOTO 5029
- WRITE( STDOUT, 5021 )
- 5021 FORMAT(47H0R1MACH(3) DOES NOT AGREE WITH CALCULATED VALUE)
- WRITE( STDOUT, 5022 )
- 5022 FORMAT(12H R1MACH(3) = )
- WRITE( STDOUT, EFMT ) CCPLUS, RMACH(3)
- WRITE( STDOUT, 5023 )
- 5023 FORMAT(19H CALCULATED VALUE = )
- WRITE( STDOUT, EFMT ) CCPLUS, XR
- WRITE( STDOUT, 5024 )
- 5024 FORMAT(14H DIFFERENCE = )
- XR = RMACH(3) - XR
- WRITE( STDOUT, EFMT ) CCPLUS, XR
- 5029 CONTINUE
-C
- XR = S2MACH( 1.0, IMACH(10), 1-IMACH(11) )
- IF( XR .EQ. RMACH(4) ) GOTO 5039
- WRITE( STDOUT, 5031 )
- 5031 FORMAT(47H0R1MACH(4) DOES NOT AGREE WITH CALCULATED VALUE)
- WRITE( STDOUT, 5032 )
- 5032 FORMAT(12H R1MACH(4) = )
- WRITE( STDOUT, EFMT ) CCPLUS, RMACH(4)
- WRITE( STDOUT, 5033 )
- 5033 FORMAT(19H CALCULATED VALUE = )
- WRITE( STDOUT, EFMT ) CCPLUS, XR
- WRITE( STDOUT, 5034 )
- 5034 FORMAT(14H DIFFERENCE = )
- XR = RMACH(4) - XR
- WRITE( STDOUT, EFMT ) CCPLUS, XR
- 5039 CONTINUE
-C
- XR = ALOG10( FLOAT(IMACH(10)) )
- IF( XR .EQ. RMACH(5) ) GOTO 5049
- WRITE( STDOUT, 5041 )
- 5041 FORMAT(47H0R1MACH(5) DOES NOT AGREE WITH CALCULATED VALUE)
- WRITE( STDOUT, 5042 )
- 5042 FORMAT(12H R1MACH(5) = )
- WRITE( STDOUT, EFMT ) CCPLUS, RMACH(5)
- WRITE( STDOUT, 5043 )
- 5043 FORMAT(19H CALCULATED VALUE = )
- WRITE( STDOUT, EFMT ) CCPLUS, XR
- WRITE( STDOUT, 5044 )
- 5044 FORMAT(14H DIFFERENCE = )
- XR = RMACH(5) - XR
- WRITE( STDOUT, EFMT ) CCPLUS, XR
- 5049 CONTINUE
-C
-C NOW CHECK CONSISTENCY OF DOUBLE-PRECISION CONSTANTS
-C/6S
-C CALL S88FMT( 2, 19, DFMT(5) )
-C/7S
- CALL S88FMT( 2, 19, DFMT1(5) )
-C/
- XD = S3MACH( 1.0D0, IMACH(10), IMACH(15)-1 )
- IF( XD .EQ. DMACH(1) ) GOTO 6009
- WRITE( STDOUT, 6001 )
- 6001 FORMAT(47H0D1MACH(1) DOES NOT AGREE WITH CALCULATED VALUE)
- WRITE( STDOUT, 6002 )
- 6002 FORMAT(12H D1MACH(1) = )
- WRITE( STDOUT, DFMT ) CCPLUS, DMACH(1)
- WRITE( STDOUT, 6003 )
- 6003 FORMAT(19H CALCULATED VALUE = )
- WRITE( STDOUT, DFMT ) CCPLUS, XD
- WRITE( STDOUT, 6004 )
- 6004 FORMAT(14H DIFFERENCE = )
- XD = DMACH(1) - XD
- WRITE( STDOUT, DFMT ) CCPLUS, XD
- 6009 CONTINUE
-C
- XD = 0.0D0
- DBASE = DBLE ( FLOAT( IMACH(10) ) )
- DBASEM = DBLE ( FLOAT( IMACH(10)-1 ) )
- DO 6010 I = 1, DIGDP
- XD = (XD + DBASEM)/DBASE
- 6010 CONTINUE
-C
- XD = S3MACH( XD, IMACH(10), IMACH(16) )
- IF( XD .EQ. DMACH(2) ) GOTO 6019
- WRITE( STDOUT, 6011 )
- 6011 FORMAT(47H0D1MACH(2) DOES NOT AGREE WITH CALCULATED VALUE)
- WRITE( STDOUT, 6012 )
- 6012 FORMAT(12H D1MACH(2) = )
- WRITE( STDOUT, DFMT ) CCPLUS, DMACH(2)
- WRITE( STDOUT, 6013 )
- 6013 FORMAT(19H CALCULATED VALUE = )
- WRITE( STDOUT, DFMT ) CCPLUS, XD
- WRITE( STDOUT, 6014 )
- 6014 FORMAT(14H DIFFERENCE = )
- XD = DMACH(2) - XD
- WRITE( STDOUT, DFMT ) CCPLUS, XD
- 6019 CONTINUE
-C
- XD = S3MACH( 1.0D0, IMACH(10), -IMACH(14) )
- IF( XD .EQ. DMACH(3) ) GOTO 6029
- WRITE( STDOUT, 6021 )
- 6021 FORMAT(47H0D1MACH(3) DOES NOT AGREE WITH CALCULATED VALUE)
- WRITE( STDOUT, 6022 )
- 6022 FORMAT(12H D1MACH(3) = )
- WRITE( STDOUT, DFMT ) CCPLUS, DMACH(3)
- WRITE( STDOUT, 6023 )
- 6023 FORMAT(19H CALCULATED VALUE = )
- WRITE( STDOUT, DFMT ) CCPLUS, XD
- WRITE( STDOUT, 6024 )
- 6024 FORMAT(14H DIFFERENCE = )
- XD = DMACH(3) - XD
- WRITE( STDOUT, DFMT ) CCPLUS, XD
- 6029 CONTINUE
-C
- XD = S3MACH( 1.0D0, IMACH(10), 1-IMACH(14) )
- IF( XD .EQ. DMACH(4) ) GOTO 6039
- WRITE( STDOUT, 6031 )
- 6031 FORMAT(47H0D1MACH(4) DOES NOT AGREE WITH CALCULATED VALUE)
- WRITE( STDOUT, 6032 )
- 6032 FORMAT(12H D1MACH(4) = )
- WRITE( STDOUT, DFMT ) CCPLUS, DMACH(4)
- WRITE( STDOUT, 6033 )
- 6033 FORMAT(19H CALCULATED VALUE = )
- WRITE( STDOUT, DFMT ) CCPLUS, XD
- WRITE( STDOUT, 6034 )
- 6034 FORMAT(14H DIFFERENCE = )
- XD = DMACH(4) - XD
- WRITE( STDOUT, DFMT ) CCPLUS, XD
- 6039 CONTINUE
-C
- XD = DLOG10( DBLE(FLOAT(IMACH(10))) )
- IF( XD .EQ. DMACH(5) ) GOTO 6049
- WRITE( STDOUT, 6041 )
- 6041 FORMAT(47H0D1MACH(5) DOES NOT AGREE WITH CALCULATED VALUE)
- WRITE( STDOUT, 6042 )
- 6042 FORMAT(12H D1MACH(5) = )
- WRITE( STDOUT, DFMT ) CCPLUS, DMACH(5)
- WRITE( STDOUT, 6043 )
- 6043 FORMAT(19H CALCULATED VALUE = )
- WRITE( STDOUT, DFMT ) CCPLUS, XD
- WRITE( STDOUT, 6044 )
- 6044 FORMAT(14H DIFFERENCE = )
- XD = DMACH(5) - XD
- WRITE( STDOUT, DFMT ) CCPLUS, XD
- 6049 CONTINUE
-C
-C NOW SEE IF SINGLE-PRECISION IS CLOSED UNDER NEGATION
-C
- XR = -RMACH(1)
- XR = -XR
- IF( XR .EQ. RMACH(1) ) GOTO 7009
- WRITE( STDOUT, 7001 )
- 7001 FORMAT(29H0-(-R1MACH(1)) .NE. R1MACH(1))
- WRITE( STDOUT, 7002 )
- 7002 FORMAT(16H R1MACH(1) = )
- WRITE( STDOUT, EFMT ) CCPLUS, RMACH(1)
- WRITE( STDOUT, 7003 )
- 7003 FORMAT(16H -(-R1MACH(1)) = )
- WRITE( STDOUT, EFMT ) CCPLUS, XR
- 7009 CONTINUE
-C
- XR = -RMACH(2)
- XR = -XR
- IF( XR .EQ. RMACH(2) ) GOTO 7019
- WRITE( STDOUT, 7011 )
- 7011 FORMAT(29H0-(-R1MACH(2)) .NE. R1MACH(2))
- WRITE( STDOUT, 7012 )
- 7012 FORMAT(16H R1MACH(2) = )
- WRITE( STDOUT, EFMT ) CCPLUS, RMACH(2)
- WRITE( STDOUT, 7013 )
- 7013 FORMAT(16H -(-R1MACH(2)) = )
- WRITE( STDOUT, EFMT ) CCPLUS, XR
- 7019 CONTINUE
-C
-C NOW SEE IF DOUBLE-PRECISION IS CLOSED UNDER NEGATION
-C
- XD = -DMACH(1)
- XD = -XD
- IF( XD .EQ. DMACH(1) ) GOTO 8009
- WRITE( STDOUT, 8001 )
- 8001 FORMAT(29H0-(-D1MACH(1)) .NE. D1MACH(1))
- WRITE( STDOUT, 8002 )
- 8002 FORMAT(16H D1MACH(1) = )
- WRITE( STDOUT, DFMT ) CCPLUS, DMACH(1)
- WRITE( STDOUT, 8003 )
- 8003 FORMAT(16H -(-D1MACH(1)) = )
- WRITE( STDOUT, DFMT ) CCPLUS, XD
- 8009 CONTINUE
-C
- XD = -DMACH(2)
- XD = -XD
- IF( XD .EQ. DMACH(2) ) GOTO 8019
- WRITE( STDOUT, 8011 )
- 8011 FORMAT(29H0-(-D1MACH(2)) .NE. D1MACH(2))
- WRITE( STDOUT, 8012 )
- 8012 FORMAT(16H D1MACH(2) = )
- WRITE( STDOUT, DFMT ) CCPLUS, DMACH(2)
- WRITE( STDOUT, 8013 )
- 8013 FORMAT(16H -(-D1MACH(2)) = )
- WRITE( STDOUT, DFMT ) CCPLUS, XD
- 8019 CONTINUE
-C
-C CHECK THAT SQRT AND DSQRT WORK NEAR OVER- AND UNDERFLOW LIMITS.
-C
- N = IMACH(11)/2 + 1
- XR = SQRT(RMACH(1))
- IF (XR .GT. 0.0) GO TO 9002
- WRITE( STDOUT, 9001 )
- 9001 FORMAT(18H SQRT(R1MACH(1)) =)
- WRITE( STDOUT, EFMT ) CCPLUS, XR
- GO TO 9004
-C SCALE TO AVOID TROUBLE FROM UNDERFLOW...
- 9002 XR = S2MACH( XR, IMACH(10), N)
- YR = S2MACH( RMACH(1), IMACH(10), 2*N)
- YR = ABS(XR*XR - YR) / YR
- IF (YR .LT. 2.*RMACH(4)) GO TO 9004
- WRITE( STDOUT, 9003 )
- 9003 FORMAT(35H EXCESSIVE ERROR IN SQRT(R1MACH(1))/13H REL. ERROR =)
- WRITE( STDOUT, EFMT ) CCPLUS, YR
- 9004 XR = SQRT(RMACH(2))
- IF (XR .GT. 0.0) GO TO 9006
- WRITE( STDOUT, 9005 )
- 9005 FORMAT(18H SQRT(R1MACH(2)) =)
- WRITE( STDOUT, EFMT ) CCPLUS, XR
- GO TO 9008
-C SCALE TO AVOID TROUBLE FROM OVERFLOW...
- 9006 XR = S2MACH( XR, IMACH(10), -N)
- YR = S2MACH( RMACH(2), IMACH(10), -2*N)
- YR = ABS(XR*XR - YR) / YR
- IF (YR .LT. 2.*RMACH(4)) GO TO 9008
- WRITE( STDOUT, 9007 )
- 9007 FORMAT(35H EXCESSIVE ERROR IN SQRT(R1MACH(2))/13H REL. ERROR =)
- WRITE( STDOUT, EFMT ) CCPLUS, YR
-C
- 9008 N = IMACH(14)/2 + 1
- XD = DSQRT(DMACH(1))
- IF (XD .GT. 0.D0) GO TO 9010
- WRITE( STDOUT, 9009 )
- 9009 FORMAT(19H DSQRT(D1MACH(1)) =)
- WRITE( STDOUT, DFMT ) CCPLUS, XD
- GO TO 9012
-C AGAIN SCALE TO AVOID TROUBLE FROM UNDERFLOW...
- 9010 XD = S3MACH( XD, IMACH(10), N)
- YD = S3MACH( DMACH(1), IMACH(10), 2*N)
- YD = DABS(XD*XD - YD) / YD
- IF (YD .LT. 2.D0*DMACH(4)) GO TO 9012
- WRITE( STDOUT, 9011 )
- 9011 FORMAT(36H EXCESSIVE ERROR IN DSQRT(D1MACH(1))/13H REL. ERROR =)
- WRITE( STDOUT, EFMT ) CCPLUS, YD
- 9012 XD = DSQRT(DMACH(2))
- IF (XD .GT. 0.0D0) GO TO 9014
- WRITE( STDOUT, 9013 )
- 9013 FORMAT(19H DSQRT(D1MACH(2)) =)
- WRITE( STDOUT, EFMT ) CCPLUS, XD
- GO TO 9016
-C AGAIN SCALE TO AVOID TROUBLE FROM OVERFLOW...
- 9014 XD = S3MACH( XD, IMACH(10), -N)
- YD = S3MACH( DMACH(2), IMACH(10), -2*N)
- YD = DABS(XD*XD - YD) / YD
- IF (YD .LT. 2.D0*DMACH(4)) GO TO 9016
- WRITE( STDOUT, 9015 )
- 9015 FORMAT(36H EXCESSIVE ERROR IN DSQRT(D1MACH(2))/13H REL. ERROR =)
- WRITE( STDOUT, EFMT ) CCPLUS, YD
- 9016 RETURN
-C
- END
diff --git a/CEP/PyBDSM/src/port3/s2mach.f b/CEP/PyBDSM/src/port3/s2mach.f
deleted file mode 100644
index 0b16d339075bde58badba428821f14b0eda0daa6..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/s2mach.f
+++ /dev/null
@@ -1,27 +0,0 @@
- REAL FUNCTION S2MACH( XR, BASE, EXP )
-C
-C S2MACH = XR * BASE**EXP
-C
-C (17-JUN-85) -- REVISED TO MAKE OVERFLOW LESS LIKELY
- INTEGER BASE, EXP
- REAL TBASE, XR
-C
- TBASE = FLOAT(BASE)
- S2MACH = XR
-C
- N = EXP
- IF( N .GE. 0 ) GO TO 20
-C
- N = -N
- TBASE = 1.0/TBASE
-C
- 20 IF( MOD(N,2) .NE. 0 ) S2MACH = S2MACH*TBASE
- N = N/2
- IF( N .LT. 2 ) GO TO 30
- TBASE = TBASE * TBASE
- GO TO 20
-C
- 30 IF (N .EQ. 1) S2MACH = (S2MACH * TBASE) * TBASE
- RETURN
-C
- END
diff --git a/CEP/PyBDSM/src/port3/s3grd.f b/CEP/PyBDSM/src/port3/s3grd.f
deleted file mode 100644
index 8347f7c4f2928544be84cf621227a4f63ef4b811..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/s3grd.f
+++ /dev/null
@@ -1,282 +0,0 @@
- SUBROUTINE S3GRD(ALPHA, B, D, ETA0, FX, G, IRC, P, W, X)
-C
-C *** COMPUTE FINITE DIFFERENCE GRADIENT BY STWEART*S SCHEME ***
-C
-C *** PARAMETERS ***
-C
- INTEGER IRC, P
- REAL ALPHA(P), B(2,P), D(P), ETA0, FX, G(P), W(6),
- 1 X(P)
-C
-C.......................................................................
-C
-C *** PURPOSE ***
-C
-C THIS SUBROUTINE USES AN EMBELLISHED FORM OF THE FINITE-DIFFER-
-C ENCE SCHEME PROPOSED BY STEWART (REF. 1) TO APPROXIMATE THE
-C GRADIENT OF THE FUNCTION F(X), WHOSE VALUES ARE SUPPLIED BY
-C REVERSE COMMUNICATION.
-C
-C *** PARAMETER DESCRIPTION ***
-C
-C ALPHA IN (APPROXIMATE) DIAGONAL ELEMENTS OF THE HESSIAN OF F(X).
-C B IN ARRAY OF SIMPLE LOWER AND UPPER BOUNDS ON X. X MUST
-C SATISFY B(1,I) .LE. X(I) .LE. B(2,I), I = 1(1)P.
-C FOR ALL I WITH B(1,I) .GE. B(2,I), S3GRD SIMPLY
-C SETS G(I) TO 0.
-C D IN SCALE VECTOR SUCH THAT D(I)*X(I), I = 1,...,P, ARE IN
-C COMPARABLE UNITS.
-C ETA0 IN ESTIMATED BOUND ON RELATIVE ERROR IN THE FUNCTION VALUE...
-C (TRUE VALUE) = (COMPUTED VALUE)*(1+E), WHERE
-C ABS(E) .LE. ETA0.
-C FX I/O ON INPUT, FX MUST BE THE COMPUTED VALUE OF F(X). ON
-C OUTPUT WITH IRC = 0, FX HAS BEEN RESTORED TO ITS ORIGINAL
-C VALUE, THE ONE IT HAD WHEN S3GRD WAS LAST CALLED WITH
-C IRC = 0.
-C G I/O ON INPUT WITH IRC = 0, G SHOULD CONTAIN AN APPROXIMATION
-C TO THE GRADIENT OF F NEAR X, E.G., THE GRADIENT AT THE
-C PREVIOUS ITERATE. WHEN S3GRD RETURNS WITH IRC = 0, G IS
-C THE DESIRED FINITE-DIFFERENCE APPROXIMATION TO THE
-C GRADIENT AT X.
-C IRC I/O INPUT/RETURN CODE... BEFORE THE VERY FIRST CALL ON S3GRD,
-C THE CALLER MUST SET IRC TO 0. WHENEVER S3GRD RETURNS A
-C NONZERO VALUE (OF AT MOST P) FOR IRC, IT HAS PERTURBED
-C SOME COMPONENT OF X... THE CALLER SHOULD EVALUATE F(X)
-C AND CALL S3GRD AGAIN WITH FX = F(X). IF B PREVENTS
-C ESTIMATING G(I) I.E., IF THERE IS AN I WITH
-C B(1,I) .LT. B(2,I) BUT WITH B(1,I) SO CLOSE TO B(2,I)
-C THAT THE FINITE-DIFFERENCING STEPS CANNOT BE CHOSEN,
-C THEN S3GRD RETURNS WITH IRC .GT. P.
-C P IN THE NUMBER OF VARIABLES (COMPONENTS OF X) ON WHICH F
-C DEPENDS.
-C X I/O ON INPUT WITH IRC = 0, X IS THE POINT AT WHICH THE
-C GRADIENT OF F IS DESIRED. ON OUTPUT WITH IRC NONZERO, X
-C IS THE POINT AT WHICH F SHOULD BE EVALUATED. ON OUTPUT
-C WITH IRC = 0, X HAS BEEN RESTORED TO ITS ORIGINAL VALUE
-C (THE ONE IT HAD WHEN S3GRD WAS LAST CALLED WITH IRC = 0)
-C AND G CONTAINS THE DESIRED GRADIENT APPROXIMATION.
-C W I/O WORK VECTOR OF LENGTH 6 IN WHICH S3GRD SAVES CERTAIN
-C QUANTITIES WHILE THE CALLER IS EVALUATING F(X) AT A
-C PERTURBED X.
-C
-C *** APPLICATION AND USAGE RESTRICTIONS ***
-C
-C THIS ROUTINE IS INTENDED FOR _USE_ WITH QUASI-NEWTON ROUTINES
-C FOR UNCONSTRAINED MINIMIZATION (IN WHICH CASE ALPHA COMES FROM
-C THE DIAGONAL OF THE QUASI-NEWTON HESSIAN APPROXIMATION).
-C
-C *** ALGORITHM NOTES ***
-C
-C THIS CODE DEPARTS FROM THE SCHEME PROPOSED BY STEWART (REF. 1)
-C IN ITS GUARDING AGAINST OVERLY LARGE OR SMALL STEP SIZES AND ITS
-C HANDLING OF SPECIAL CASES (SUCH AS ZERO COMPONENTS OF ALPHA OR G).
-C
-C *** REFERENCES ***
-C
-C 1. STEWART, G.W. (1967), A MODIFICATION OF DAVIDON*S MINIMIZATION
-C METHOD TO ACCEPT DIFFERENCE APPROXIMATIONS OF DERIVATIVES,
-C J. ASSOC. COMPUT. MACH. 14, PP. 72-83.
-C
-C *** HISTORY ***
-C
-C DESIGNED AND CODED BY DAVID M. GAY (SUMMER 1977/SUMMER 1980).
-C
-C *** GENERAL ***
-C
-C THIS ROUTINE WAS PREPARED IN CONNECTION WITH WORK SUPPORTED BY
-C THE NATIONAL SCIENCE FOUNDATION UNDER GRANTS MCS76-00324 AND
-C MCS-7906671.
-C
-C.......................................................................
-C
-C ***** EXTERNAL FUNCTION *****
-C
- REAL R7MDC
- EXTERNAL R7MDC
-C R7MDC... RETURNS MACHINE-DEPENDENT CONSTANTS.
-C
-C ***** INTRINSIC FUNCTIONS *****
-C/+
- REAL SQRT
-C/
-C ***** LOCAL VARIABLES *****
-C
- LOGICAL HIT
- INTEGER FH, FX0, HSAVE, I, XISAVE
- REAL AAI, AFX, AFXETA, AGI, ALPHAI, AXI, AXIBAR,
- 1 DISCON, ETA, GI, H, HMIN, XI, XIH
- REAL C2000, FOUR, HMAX0, HMIN0, H0, MACHEP, ONE, P002,
- 1 THREE, TWO, ZERO
-C
-C/6
-C DATA C2000/2.0E+3/, FOUR/4.0E+0/, HMAX0/0.02E+0/, HMIN0/5.0E+1/,
-C 1 ONE/1.0E+0/, P002/0.002E+0/, THREE/3.0E+0/,
-C 2 TWO/2.0E+0/, ZERO/0.0E+0/
-C/7
- PARAMETER (C2000=2.0E+3, FOUR=4.0E+0, HMAX0=0.02E+0, HMIN0=5.0E+1,
- 1 ONE=1.0E+0, P002=0.002E+0, THREE=3.0E+0,
- 2 TWO=2.0E+0, ZERO=0.0E+0)
-C/
-C/6
-C DATA FH/3/, FX0/4/, HSAVE/5/, XISAVE/6/
-C/7
- PARAMETER (FH=3, FX0=4, HSAVE=5, XISAVE=6)
-C/
-C
-C--------------------------------- BODY ------------------------------
-C
- IF (IRC) 80, 10, 210
-C
-C *** FRESH START -- GET MACHINE-DEPENDENT CONSTANTS ***
-C
-C STORE MACHEP IN W(1) AND H0 IN W(2), WHERE MACHEP IS THE UNIT
-C ROUNDOFF (THE SMALLEST POSITIVE NUMBER SUCH THAT
-C 1 + MACHEP .GT. 1 AND 1 - MACHEP .LT. 1), AND H0 IS THE
-C SQUARE-ROOT OF MACHEP.
-C
- 10 W(1) = R7MDC(3)
- W(2) = SQRT(W(1))
-C
- W(FX0) = FX
-C
-C *** INCREMENT I AND START COMPUTING G(I) ***
-C
- 20 I = IABS(IRC) + 1
- IF (I .GT. P) GO TO 220
- IRC = I
- IF (B(1,I) .LT. B(2,I)) GO TO 30
- G(I) = ZERO
- GO TO 20
- 30 AFX = ABS(W(FX0))
- MACHEP = W(1)
- H0 = W(2)
- HMIN = HMIN0 * MACHEP
- XI = X(I)
- W(XISAVE) = XI
- AXI = ABS(XI)
- AXIBAR = AMAX1(AXI, ONE/D(I))
- GI = G(I)
- AGI = ABS(GI)
- ETA = ABS(ETA0)
- IF (AFX .GT. ZERO) ETA = AMAX1(ETA, AGI*AXI*MACHEP/AFX)
- ALPHAI = ALPHA(I)
- IF (ALPHAI .EQ. ZERO) GO TO 130
- IF (GI .EQ. ZERO .OR. FX .EQ. ZERO) GO TO 140
- AFXETA = AFX*ETA
- AAI = ABS(ALPHAI)
-C
-C *** COMPUTE H = STEWART*S FORWARD-DIFFERENCE STEP SIZE.
-C
- IF (GI**2 .LE. AFXETA*AAI) GO TO 40
- H = TWO* SQRT(AFXETA/AAI)
- H = H*(ONE - AAI*H/(THREE*AAI*H + FOUR*AGI))
- GO TO 50
-C40 H = TWO*(AFXETA*AGI/(AAI**2))**(ONE/THREE)
- 40 H = TWO * (AFXETA*AGI)**(ONE/THREE) * AAI**(-TWO/THREE)
- H = H*(ONE - TWO*AGI/(THREE*AAI*H + FOUR*AGI))
-C
-C *** ENSURE THAT H IS NOT INSIGNIFICANTLY SMALL ***
-C
- 50 H = AMAX1(H, HMIN*AXIBAR)
-C
-C *** _USE_ FORWARD DIFFERENCE IF BOUND ON TRUNCATION ERROR IS AT
-C *** MOST 10**-3.
-C
- IF (AAI*H .LE. P002*AGI) GO TO 120
-C
-C *** COMPUTE H = STEWART*S STEP FOR CENTRAL DIFFERENCE.
-C
- DISCON = C2000*AFXETA
- H = DISCON/(AGI + SQRT(GI**2 + AAI*DISCON))
-C
-C *** ENSURE THAT H IS NEITHER TOO SMALL NOR TOO BIG ***
-C
- H = AMAX1(H, HMIN*AXIBAR)
- IF (H .GE. HMAX0*AXIBAR) H = AXIBAR * H0**(TWO/THREE)
-C
-C *** COMPUTE CENTRAL DIFFERENCE ***
-C
- XIH = XI + H
- IF (XI - H .LT. B(1,I)) GO TO 60
- IRC = -I
- IF (XIH .LE. B(2,I)) GO TO 200
- H = -H
- XIH = XI + H
- IF (XI + TWO*H .LT. B(1,I)) GO TO 190
- GO TO 70
- 60 IF (XI + TWO*H .GT. B(2,I)) GO TO 190
-C *** MUST DO OFF-SIDE CENTRAL DIFFERENCE ***
- 70 IRC = -(I + P)
- GO TO 200
-C
- 80 I = -IRC
- IF (I .LE. P) GO TO 100
- I = I - P
- IF (I .GT. P) GO TO 90
- W(FH) = FX
- H = TWO * W(HSAVE)
- XIH = W(XISAVE) + H
- IRC = IRC - P
- GO TO 200
-C
-C *** FINISH OFF-SIDE CENTRAL DIFFERENCE ***
-C
- 90 I = I - P
- G(I) = (FOUR*W(FH) - FX - THREE*W(FX0)) / W(HSAVE)
- IRC = I
- X(I) = W(XISAVE)
- GO TO 20
-C
- 100 H = -W(HSAVE)
- IF (H .GT. ZERO) GO TO 110
- W(FH) = FX
- XIH = W(XISAVE) + H
- GO TO 200
-C
- 110 G(I) = (W(FH) - FX) / (TWO * H)
- X(I) = W(XISAVE)
- GO TO 20
-C
-C *** COMPUTE FORWARD DIFFERENCES IN VARIOUS CASES ***
-C
- 120 IF (H .GE. HMAX0*AXIBAR) H = H0 * AXIBAR
- IF (ALPHAI*GI .LT. ZERO) H = -H
- GO TO 150
- 130 H = AXIBAR
- GO TO 150
- 140 H = H0 * AXIBAR
-C
- 150 HIT = .FALSE.
- 160 XIH = XI + H
- IF (H .GT. ZERO) GO TO 170
- IF (XIH .GE. B(1,I)) GO TO 200
- GO TO 180
- 170 IF (XIH .LE. B(2,I)) GO TO 200
- 180 IF (HIT) GO TO 190
- HIT = .TRUE.
- H = -H
- GO TO 160
-C
-C *** ERROR RETURN...
- 190 IRC = I + P
- GO TO 230
-C
-C *** RETURN FOR NEW FUNCTION VALUE...
- 200 X(I) = XIH
- W(HSAVE) = H
- GO TO 999
-C
-C *** COMPUTE ACTUAL FORWARD DIFFERENCE ***
-C
- 210 G(IRC) = (FX - W(FX0)) / W(HSAVE)
- X(IRC) = W(XISAVE)
- GO TO 20
-C
-C *** RESTORE FX AND INDICATE THAT G HAS BEEN COMPUTED ***
-C
- 220 IRC = 0
- 230 FX = W(FX0)
-C
- 999 RETURN
-C *** LAST LINE OF S3GRD FOLLOWS ***
- END
diff --git a/CEP/PyBDSM/src/port3/s3mach.f b/CEP/PyBDSM/src/port3/s3mach.f
deleted file mode 100644
index 2a611298c30a95a6ea3f7a1d6fda088086fa3870..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/s3mach.f
+++ /dev/null
@@ -1,27 +0,0 @@
- DOUBLE PRECISION FUNCTION S3MACH( XD, BASE, EXP )
-C
-C S3MACH = XD * BASE**EXP
-C
-C (17-JUN-85) -- REVISED TO MAKE OVERFLOW LESS LIKELY
- INTEGER BASE, EXP
- DOUBLE PRECISION TBASE, XD
-C
- TBASE = FLOAT(BASE)
- S3MACH = XD
-C
- N = EXP
- IF( N .GE. 0 ) GO TO 20
-C
- N = -N
- TBASE = 1.0D0/TBASE
-C
- 20 IF( MOD(N,2) .NE. 0 ) S3MACH = S3MACH*TBASE
- N = N/2
- IF( N .LT. 2 ) GO TO 30
- TBASE = TBASE * TBASE
- GO TO 20
-C
- 30 IF (N .EQ. 1) S3MACH = (S3MACH * TBASE) * TBASE
- RETURN
-C
- END
diff --git a/CEP/PyBDSM/src/port3/s7bqn.f b/CEP/PyBDSM/src/port3/s7bqn.f
deleted file mode 100644
index fba6533d1e1b11342323f92688770f9d5474638f..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/s7bqn.f
+++ /dev/null
@@ -1,154 +0,0 @@
- SUBROUTINE S7BQN(B, D, DST, IPIV, IPIV1, IPIV2, KB, L, LV, NS,
- 1 P, P1, STEP, TD, TG, V, W, X, X0)
-C
-C *** COMPUTE BOUNDED MODIFIED NEWTON STEP ***
-C
- INTEGER KB, LV, NS, P, P1
- INTEGER IPIV(P), IPIV1(P), IPIV2(P)
- REAL B(2,P), D(P), DST(P), L(1),
- 1 STEP(P), TD(P), TG(P), V(LV), W(P), X(P),
- 2 X0(P)
-C DIMENSION L(P*(P+1)/2)
-C
- REAL D7TPR, R7MDC, V2NRM
- EXTERNAL D7TPR, I7SHFT, L7ITV, L7IVM, Q7RSH, R7MDC, V2NRM,
- 1 V2AXY, V7CPY, V7IPR, V7SCP, V7SHF
-C
-C *** LOCAL VARIABLES ***
-C
- INTEGER I, J, K, P0, P1M1
- REAL ALPHA, DST0, DST1, DSTMAX, DSTMIN, DX, GTS, T,
- 1 TI, T1, XI
- REAL FUDGE, HALF, MEPS2, ONE, TWO, ZERO
-C
-C *** V SUBSCRIPTS ***
-C
- INTEGER DSTNRM, GTSTEP, PHMNFC, PHMXFC, PREDUC, RADIUS, STPPAR
-C
-C/6
-C DATA DSTNRM/2/, GTSTEP/4/, PHMNFC/20/, PHMXFC/21/, PREDUC/7/,
-C 1 RADIUS/8/, STPPAR/5/
-C/7
- PARAMETER (DSTNRM=2, GTSTEP=4, PHMNFC=20, PHMXFC=21, PREDUC=7,
- 1 RADIUS=8, STPPAR=5)
- SAVE MEPS2
-C/
-C
- DATA FUDGE/1.0001E+0/, HALF/0.5E+0/, MEPS2/0.E+0/,
- 1 ONE/1.0E+0/, TWO/2.E+0/, ZERO/0.E+0/
-C
-C+++++++++++++++++++++++++++++++ BODY ++++++++++++++++++++++++++++++++
-C
- DSTMAX = FUDGE * (ONE + V(PHMXFC)) * V(RADIUS)
- DSTMIN = (ONE + V(PHMNFC)) * V(RADIUS)
- DST1 = ZERO
- IF (MEPS2 .LE. ZERO) MEPS2 = TWO * R7MDC(3)
- P0 = P1
- NS = 0
- DO 10 I = 1, P
- IPIV1(I) = I
- IPIV2(I) = I
- 10 CONTINUE
- DO 20 I = 1, P1
- 20 W(I) = -STEP(I) * TD(I)
- ALPHA = ABS(V(STPPAR))
- V(PREDUC) = ZERO
- GTS = -V(GTSTEP)
- IF (KB .LT. 0) CALL V7SCP(P, DST, ZERO)
- KB = 1
-C
-C *** -W = D TIMES RESTRICTED NEWTON STEP FROM X + DST/D.
-C
-C *** FIND T SUCH THAT X - T*W IS STILL FEASIBLE.
-C
- 30 T = ONE
- K = 0
- DO 60 I = 1, P1
- J = IPIV(I)
- DX = W(I) / D(J)
- XI = X(J) - DX
- IF (XI .LT. B(1,J)) GO TO 40
- IF (XI .LE. B(2,J)) GO TO 60
- TI = ( X(J) - B(2,J) ) / DX
- K = I
- GO TO 50
- 40 TI = ( X(J) - B(1,J) ) / DX
- K = -I
- 50 IF (T .LE. TI) GO TO 60
- T = TI
- 60 CONTINUE
-C
- IF (P .GT. P1) CALL V7CPY(P-P1, STEP(P1+1), DST(P1+1))
- CALL V2AXY(P1, STEP, -T, W, DST)
- DST0 = DST1
- DST1 = V2NRM(P, STEP)
-C
-C *** CHECK FOR OVERSIZE STEP ***
-C
- IF (DST1 .LE. DSTMAX) GO TO 80
- IF (P1 .GE. P0) GO TO 70
- IF (DST0 .LT. DSTMIN) KB = 0
- GO TO 110
-C
- 70 K = 0
-C
-C *** UPDATE DST, TG, AND V(PREDUC) ***
-C
- 80 V(DSTNRM) = DST1
- CALL V7CPY(P1, DST, STEP)
- T1 = ONE - T
- DO 90 I = 1, P1
- 90 TG(I) = T1 * TG(I)
- IF (ALPHA .GT. ZERO) CALL V2AXY(P1, TG, T*ALPHA, W, TG)
- V(PREDUC) = V(PREDUC) + T*((ONE - HALF*T)*GTS +
- 1 HALF*ALPHA*T* D7TPR(P1,W,W))
- IF (K .EQ. 0) GO TO 110
-C
-C *** PERMUTE L, ETC. IF NECESSARY ***
-C
- P1M1 = P1 - 1
- J = IABS(K)
- IF (J .EQ. P1) GO TO 100
- NS = NS + 1
- IPIV2(P1) = J
- CALL Q7RSH(J, P1, .FALSE., TG, L, W)
- CALL I7SHFT(P1, J, IPIV)
- CALL I7SHFT(P1, J, IPIV1)
- CALL V7SHF(P1, J, TG)
- CALL V7SHF(P1, J, DST)
- 100 IF (K .LT. 0) IPIV(P1) = -IPIV(P1)
- P1 = P1M1
- IF (P1 .LE. 0) GO TO 110
- CALL L7IVM(P1, W, L, TG)
- GTS = D7TPR(P1, W, W)
- CALL L7ITV(P1, W, L, W)
- GO TO 30
-C
-C *** UNSCALE STEP ***
-C
- 110 DO 120 I = 1, P
- J = IABS(IPIV(I))
- STEP(J) = DST(I) / D(J)
- 120 CONTINUE
-C
-C *** FUDGE STEP TO ENSURE THAT IT FORCES APPROPRIATE COMPONENTS
-C *** TO THEIR BOUNDS ***
-C
- IF (P1 .GE. P0) GO TO 150
- K = P1 + 1
- DO 140 I = K, P0
- J = IPIV(I)
- T = MEPS2
- IF (J .GT. 0) GO TO 130
- T = -T
- J = -J
- IPIV(I) = J
- 130 T = T * AMAX1( ABS(X(J)), ABS(X0(J)))
- STEP(J) = STEP(J) + T
- 140 CONTINUE
-C
- 150 CALL V2AXY(P, X, ONE, STEP, X0)
- IF (NS .GT. 0) CALL V7IPR(P0, IPIV1, TD)
- 999 RETURN
-C *** LAST LINE OF S7BQN FOLLOWS ***
- END
diff --git a/CEP/PyBDSM/src/port3/s7cpr.f b/CEP/PyBDSM/src/port3/s7cpr.f
deleted file mode 100644
index 69e1bd540461400a44af8a157058e39898910a5c..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/s7cpr.f
+++ /dev/null
@@ -1,29 +0,0 @@
- SUBROUTINE S7CPR(C, IV, L, LIV)
-C
-C *** PRINT C FOR NSG (ETC.) ***
-C
- INTEGER L, LIV
- INTEGER IV(LIV)
- REAL C(L)
-C
- INTEGER I, PU
-C
- INTEGER PRUNIT, SOLPRT
-C
-C/6
-C DATA PRUNIT/21/, SOLPRT/22/
-C/7
- PARAMETER (PRUNIT=21, SOLPRT=22)
-C/
-C *** BODY ***
-C
- IF (IV(1) .GT. 11) GO TO 999
- IF (IV(SOLPRT) .EQ. 0) GO TO 999
- PU = IV(PRUNIT)
- IF (PU .EQ. 0) GO TO 999
- IF (L .GT. 0) WRITE(PU,10) (I, C(I), I = 1, L)
- 10 FORMAT(/21H LINEAR PARAMETERS...//(1X,I5,E16.6))
-C
- 999 RETURN
-C *** LAST LINE OF S7CPR FOLLOWS ***
- END
diff --git a/CEP/PyBDSM/src/port3/s7dmp.f b/CEP/PyBDSM/src/port3/s7dmp.f
deleted file mode 100644
index a43a74e67fd4c8362ad2956ab3b61dd359551321..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/s7dmp.f
+++ /dev/null
@@ -1,37 +0,0 @@
- SUBROUTINE S7DMP(N, X, Y, Z, K)
-C
-C *** SET X = DIAG(Z)**K * Y * DIAG(Z)**K
-C *** FOR X, Y = COMPACTLY STORED LOWER TRIANG. MATRICES
-C *** K = 1 OR -1.
-C
- INTEGER N, K
-C/6S
-C REAL X(1), Y(1), Z(N)
-C/7S
- REAL X(*), Y(*), Z(N)
-C/
- INTEGER I, J, L
- REAL ONE, T
- DATA ONE/1.E+0/
-C
- L = 1
- IF (K .GE. 0) GO TO 30
- DO 20 I = 1, N
- T = ONE / Z(I)
- DO 10 J = 1, I
- X(L) = T * Y(L) / Z(J)
- L = L + 1
- 10 CONTINUE
- 20 CONTINUE
- GO TO 999
-C
- 30 DO 50 I = 1, N
- T = Z(I)
- DO 40 J = 1, I
- X(L) = T * Y(L) * Z(J)
- L = L + 1
- 40 CONTINUE
- 50 CONTINUE
- 999 RETURN
-C *** LAST CARD OF S7DMP FOLLOWS ***
- END
diff --git a/CEP/PyBDSM/src/port3/s7etr.f b/CEP/PyBDSM/src/port3/s7etr.f
deleted file mode 100644
index 58911850497863026e513fcc2e718a9cfe40fc24..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/s7etr.f
+++ /dev/null
@@ -1,97 +0,0 @@
- SUBROUTINE S7ETR(M,N,INDROW,JPNTR,INDCOL,IPNTR,IWA)
- INTEGER M,N
- INTEGER INDROW(1),JPNTR(1),INDCOL(1),IPNTR(1),IWA(M)
-C **********
-C
-C SUBROUTINE S7ETR
-C
-C GIVEN A COLUMN-ORIENTED DEFINITION OF THE SPARSITY PATTERN
-C OF AN M BY N MATRIX A, THIS SUBROUTINE DETERMINES A
-C ROW-ORIENTED DEFINITION OF THE SPARSITY PATTERN OF A.
-C
-C ON INPUT THE COLUMN-ORIENTED DEFINITION IS SPECIFIED BY
-C THE ARRAYS INDROW AND JPNTR. ON OUTPUT THE ROW-ORIENTED
-C DEFINITION IS SPECIFIED BY THE ARRAYS INDCOL AND IPNTR.
-C
-C THE SUBROUTINE STATEMENT IS
-C
-C SUBROUTINE S7ETR(M,N,INDROW,JPNTR,INDCOL,IPNTR,IWA)
-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 INDROW IS AN INTEGER INPUT ARRAY WHICH CONTAINS THE ROW
-C INDICES FOR THE NON-ZEROES IN THE MATRIX A.
-C
-C JPNTR IS AN INTEGER INPUT ARRAY OF LENGTH N + 1 WHICH
-C SPECIFIES THE LOCATIONS OF THE ROW INDICES IN INDROW.
-C THE ROW INDICES FOR COLUMN J ARE
-C
-C INDROW(K), K = JPNTR(J),...,JPNTR(J+1)-1.
-C
-C NOTE THAT JPNTR(N+1)-1 IS THEN THE NUMBER OF NON-ZERO
-C ELEMENTS OF THE MATRIX A.
-C
-C INDCOL IS AN INTEGER OUTPUT ARRAY WHICH CONTAINS THE
-C COLUMN INDICES FOR THE NON-ZEROES IN THE MATRIX A.
-C
-C IPNTR IS AN INTEGER OUTPUT ARRAY OF LENGTH M + 1 WHICH
-C SPECIFIES THE LOCATIONS OF THE COLUMN INDICES IN INDCOL.
-C THE COLUMN INDICES FOR ROW I ARE
-C
-C INDCOL(K), K = IPNTR(I),...,IPNTR(I+1)-1.
-C
-C NOTE THAT IPNTR(1) IS SET TO 1 AND THAT IPNTR(M+1)-1 IS
-C THEN THE NUMBER OF NON-ZERO ELEMENTS OF THE MATRIX A.
-C
-C IWA IS AN INTEGER WORK ARRAY OF LENGTH M.
-C
-C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. JUNE 1982.
-C THOMAS F. COLEMAN, BURTON S. GARBOW, JORGE J. MORE
-C
-C **********
- INTEGER IR,JCOL,JP,JPL,JPU,L,NNZ
-C
-C DETERMINE THE NUMBER OF NON-ZEROES IN THE ROWS.
-C
- DO 10 IR = 1, M
- IWA(IR) = 0
- 10 CONTINUE
- NNZ = JPNTR(N+1) - 1
- DO 20 JP = 1, NNZ
- IR = INDROW(JP)
- IWA(IR) = IWA(IR) + 1
- 20 CONTINUE
-C
-C SET POINTERS TO THE START OF THE ROWS IN INDCOL.
-C
- IPNTR(1) = 1
- DO 30 IR = 1, M
- IPNTR(IR+1) = IPNTR(IR) + IWA(IR)
- IWA(IR) = IPNTR(IR)
- 30 CONTINUE
-C
-C FILL INDCOL.
-C
- DO 60 JCOL = 1, N
- JPL = JPNTR(JCOL)
- JPU = JPNTR(JCOL+1) - 1
- IF (JPU .LT. JPL) GO TO 50
- DO 40 JP = JPL, JPU
- IR = INDROW(JP)
- L = IWA(IR)
- INDCOL(L) = JCOL
- IWA(IR) = IWA(IR) + 1
- 40 CONTINUE
- 50 CONTINUE
- 60 CONTINUE
- RETURN
-C
-C LAST CARD OF SUBROUTINE S7ETR.
-C
- END
diff --git a/CEP/PyBDSM/src/port3/s7grd.f b/CEP/PyBDSM/src/port3/s7grd.f
deleted file mode 100644
index 6597f4c61ec1b5d8488175f03cdafe8cc03febb3..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/s7grd.f
+++ /dev/null
@@ -1,224 +0,0 @@
- SUBROUTINE S7GRD (ALPHA, D, ETA0, FX, G, IRC, N, W, X)
-C
-C *** COMPUTE FINITE DIFFERENCE GRADIENT BY STWEART*S SCHEME ***
-C
-C *** PARAMETERS ***
-C
- INTEGER IRC, N
- REAL ALPHA(N), D(N), ETA0, FX, G(N), W(6), X(N)
-C
-C.......................................................................
-C
-C *** PURPOSE ***
-C
-C THIS SUBROUTINE USES AN EMBELLISHED FORM OF THE FINITE-DIFFER-
-C ENCE SCHEME PROPOSED BY STEWART (REF. 1) TO APPROXIMATE THE
-C GRADIENT OF THE FUNCTION F(X), WHOSE VALUES ARE SUPPLIED BY
-C REVERSE COMMUNICATION.
-C
-C *** PARAMETER DESCRIPTION ***
-C
-C ALPHA IN (APPROXIMATE) DIAGONAL ELEMENTS OF THE HESSIAN OF F(X).
-C D IN SCALE VECTOR SUCH THAT D(I)*X(I), I = 1,...,N, ARE IN
-C COMPARABLE UNITS.
-C ETA0 IN ESTIMATED BOUND ON RELATIVE ERROR IN THE FUNCTION VALUE...
-C (TRUE VALUE) = (COMPUTED VALUE)*(1+E), WHERE
-C ABS(E) .LE. ETA0.
-C FX I/O ON INPUT, FX MUST BE THE COMPUTED VALUE OF F(X). ON
-C OUTPUT WITH IRC = 0, FX HAS BEEN RESTORED TO ITS ORIGINAL
-C VALUE, THE ONE IT HAD WHEN S7GRD WAS LAST CALLED WITH
-C IRC = 0.
-C G I/O ON INPUT WITH IRC = 0, G SHOULD CONTAIN AN APPROXIMATION
-C TO THE GRADIENT OF F NEAR X, E.G., THE GRADIENT AT THE
-C PREVIOUS ITERATE. WHEN S7GRD RETURNS WITH IRC = 0, G IS
-C THE DESIRED FINITE-DIFFERENCE APPROXIMATION TO THE
-C GRADIENT AT X.
-C IRC I/O INPUT/RETURN CODE... BEFORE THE VERY FIRST CALL ON S7GRD,
-C THE CALLER MUST SET IRC TO 0. WHENEVER S7GRD RETURNS A
-C NONZERO VALUE FOR IRC, IT HAS PERTURBED SOME COMPONENT OF
-C X... THE CALLER SHOULD EVALUATE F(X) AND CALL S7GRD
-C AGAIN WITH FX = F(X).
-C N IN THE NUMBER OF VARIABLES (COMPONENTS OF X) ON WHICH F
-C DEPENDS.
-C X I/O ON INPUT WITH IRC = 0, X IS THE POINT AT WHICH THE
-C GRADIENT OF F IS DESIRED. ON OUTPUT WITH IRC NONZERO, X
-C IS THE POINT AT WHICH F SHOULD BE EVALUATED. ON OUTPUT
-C WITH IRC = 0, X HAS BEEN RESTORED TO ITS ORIGINAL VALUE
-C (THE ONE IT HAD WHEN S7GRD WAS LAST CALLED WITH IRC = 0)
-C AND G CONTAINS THE DESIRED GRADIENT APPROXIMATION.
-C W I/O WORK VECTOR OF LENGTH 6 IN WHICH S7GRD SAVES CERTAIN
-C QUANTITIES WHILE THE CALLER IS EVALUATING F(X) AT A
-C PERTURBED X.
-C
-C *** APPLICATION AND USAGE RESTRICTIONS ***
-C
-C THIS ROUTINE IS INTENDED FOR _USE_ WITH QUASI-NEWTON ROUTINES
-C FOR UNCONSTRAINED MINIMIZATION (IN WHICH CASE ALPHA COMES FROM
-C THE DIAGONAL OF THE QUASI-NEWTON HESSIAN APPROXIMATION).
-C
-C *** ALGORITHM NOTES ***
-C
-C THIS CODE DEPARTS FROM THE SCHEME PROPOSED BY STEWART (REF. 1)
-C IN ITS GUARDING AGAINST OVERLY LARGE OR SMALL STEP SIZES AND ITS
-C HANDLING OF SPECIAL CASES (SUCH AS ZERO COMPONENTS OF ALPHA OR G).
-C
-C *** REFERENCES ***
-C
-C 1. STEWART, G.W. (1967), A MODIFICATION OF DAVIDON*S MINIMIZATION
-C METHOD TO ACCEPT DIFFERENCE APPROXIMATIONS OF DERIVATIVES,
-C J. ASSOC. COMPUT. MACH. 14, PP. 72-83.
-C
-C *** HISTORY ***
-C
-C DESIGNED AND CODED BY DAVID M. GAY (SUMMER 1977/SUMMER 1980).
-C
-C *** GENERAL ***
-C
-C THIS ROUTINE WAS PREPARED IN CONNECTION WITH WORK SUPPORTED BY
-C THE NATIONAL SCIENCE FOUNDATION UNDER GRANTS MCS76-00324 AND
-C MCS-7906671.
-C
-C.......................................................................
-C
-C ***** EXTERNAL FUNCTION *****
-C
- REAL R7MDC
- EXTERNAL R7MDC
-C R7MDC... RETURNS MACHINE-DEPENDENT CONSTANTS.
-C
-C ***** INTRINSIC FUNCTIONS *****
-C/+
- REAL SQRT
-C/
-C ***** LOCAL VARIABLES *****
-C
- INTEGER FH, FX0, HSAVE, I, XISAVE
- REAL AAI, AFX, AFXETA, AGI, ALPHAI, AXI, AXIBAR,
- 1 DISCON, ETA, GI, H, HMIN
- REAL C2000, FOUR, HMAX0, HMIN0, H0, MACHEP, ONE, P002,
- 1 THREE, TWO, ZERO
-C
-C/6
-C DATA C2000/2.0E+3/, FOUR/4.0E+0/, HMAX0/0.02E+0/, HMIN0/5.0E+1/,
-C 1 ONE/1.0E+0/, P002/0.002E+0/, THREE/3.0E+0/,
-C 2 TWO/2.0E+0/, ZERO/0.0E+0/
-C/7
- PARAMETER (C2000=2.0E+3, FOUR=4.0E+0, HMAX0=0.02E+0, HMIN0=5.0E+1,
- 1 ONE=1.0E+0, P002=0.002E+0, THREE=3.0E+0,
- 2 TWO=2.0E+0, ZERO=0.0E+0)
-C/
-C/6
-C DATA FH/3/, FX0/4/, HSAVE/5/, XISAVE/6/
-C/7
- PARAMETER (FH=3, FX0=4, HSAVE=5, XISAVE=6)
-C/
-C
-C--------------------------------- BODY ------------------------------
-C
- IF (IRC) 140, 100, 210
-C
-C *** FRESH START -- GET MACHINE-DEPENDENT CONSTANTS ***
-C
-C STORE MACHEP IN W(1) AND H0 IN W(2), WHERE MACHEP IS THE UNIT
-C ROUNDOFF (THE SMALLEST POSITIVE NUMBER SUCH THAT
-C 1 + MACHEP .GT. 1 AND 1 - MACHEP .LT. 1), AND H0 IS THE
-C SQUARE-ROOT OF MACHEP.
-C
- 100 W(1) = R7MDC(3)
- W(2) = SQRT(W(1))
-C
- W(FX0) = FX
-C
-C *** INCREMENT I AND START COMPUTING G(I) ***
-C
- 110 I = IABS(IRC) + 1
- IF (I .GT. N) GO TO 300
- IRC = I
- AFX = ABS(W(FX0))
- MACHEP = W(1)
- H0 = W(2)
- HMIN = HMIN0 * MACHEP
- W(XISAVE) = X(I)
- AXI = ABS(X(I))
- AXIBAR = AMAX1(AXI, ONE/D(I))
- GI = G(I)
- AGI = ABS(GI)
- ETA = ABS(ETA0)
- IF (AFX .GT. ZERO) ETA = AMAX1(ETA, AGI*AXI*MACHEP/AFX)
- ALPHAI = ALPHA(I)
- IF (ALPHAI .EQ. ZERO) GO TO 170
- IF (GI .EQ. ZERO .OR. FX .EQ. ZERO) GO TO 180
- AFXETA = AFX*ETA
- AAI = ABS(ALPHAI)
-C
-C *** COMPUTE H = STEWART*S FORWARD-DIFFERENCE STEP SIZE.
-C
- IF (GI**2 .LE. AFXETA*AAI) GO TO 120
- H = TWO* SQRT(AFXETA/AAI)
- H = H*(ONE - AAI*H/(THREE*AAI*H + FOUR*AGI))
- GO TO 130
-C120 H = TWO*(AFXETA*AGI/(AAI**2))**(ONE/THREE)
- 120 H = TWO * (AFXETA*AGI)**(ONE/THREE) * AAI**(-TWO/THREE)
- H = H*(ONE - TWO*AGI/(THREE*AAI*H + FOUR*AGI))
-C
-C *** ENSURE THAT H IS NOT INSIGNIFICANTLY SMALL ***
-C
- 130 H = AMAX1(H, HMIN*AXIBAR)
-C
-C *** _USE_ FORWARD DIFFERENCE IF BOUND ON TRUNCATION ERROR IS AT
-C *** MOST 10**-3.
-C
- IF (AAI*H .LE. P002*AGI) GO TO 160
-C
-C *** COMPUTE H = STEWART*S STEP FOR CENTRAL DIFFERENCE.
-C
- DISCON = C2000*AFXETA
- H = DISCON/(AGI + SQRT(GI**2 + AAI*DISCON))
-C
-C *** ENSURE THAT H IS NEITHER TOO SMALL NOR TOO BIG ***
-C
- H = AMAX1(H, HMIN*AXIBAR)
- IF (H .GE. HMAX0*AXIBAR) H = AXIBAR * H0**(TWO/THREE)
-C
-C *** COMPUTE CENTRAL DIFFERENCE ***
-C
- IRC = -I
- GO TO 200
-C
- 140 H = -W(HSAVE)
- I = IABS(IRC)
- IF (H .GT. ZERO) GO TO 150
- W(FH) = FX
- GO TO 200
-C
- 150 G(I) = (W(FH) - FX) / (TWO * H)
- X(I) = W(XISAVE)
- GO TO 110
-C
-C *** COMPUTE FORWARD DIFFERENCES IN VARIOUS CASES ***
-C
- 160 IF (H .GE. HMAX0*AXIBAR) H = H0 * AXIBAR
- IF (ALPHAI*GI .LT. ZERO) H = -H
- GO TO 200
- 170 H = AXIBAR
- GO TO 200
- 180 H = H0 * AXIBAR
-C
- 200 X(I) = W(XISAVE) + H
- W(HSAVE) = H
- GO TO 999
-C
-C *** COMPUTE ACTUAL FORWARD DIFFERENCE ***
-C
- 210 G(IRC) = (FX - W(FX0)) / W(HSAVE)
- X(IRC) = W(XISAVE)
- GO TO 110
-C
-C *** RESTORE FX AND INDICATE THAT G HAS BEEN COMPUTED ***
-C
- 300 FX = W(FX0)
- IRC = 0
-C
- 999 RETURN
-C *** LAST CARD OF S7GRD FOLLOWS ***
- END
diff --git a/CEP/PyBDSM/src/port3/s7ipr.f b/CEP/PyBDSM/src/port3/s7ipr.f
deleted file mode 100644
index 5a4fd24b6fce2aeffd2e19ae3b956ebba9eb8f90..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/s7ipr.f
+++ /dev/null
@@ -1,73 +0,0 @@
- SUBROUTINE S7IPR(P, IP, H)
-C
-C APPLY THE PERMUTATION DEFINED BY IP TO THE ROWS AND COLUMNS OF THE
-C P X P SYMMETRIC MATRIX WHOSE LOWER TRIANGLE IS STORED COMPACTLY IN H.
-C THUS H.OUTPUT(I,J) = H.INPUT(IP(I), IP(J)).
-C
- INTEGER P
- INTEGER IP(P)
- REAL H(1)
-C
- INTEGER I, J, J1, JM, K, K1, KK, KM, KMJ, L, M
- REAL T
-C
-C *** BODY ***
-C
- DO 90 I = 1, P
- J = IP(I)
- IF (J .EQ. I) GO TO 90
- IP(I) = IABS(J)
- IF (J .LT. 0) GO TO 90
- K = I
- 10 J1 = J
- K1 = K
- IF (J .LE. K) GO TO 20
- J1 = K
- K1 = J
- 20 KMJ = K1-J1
- L = J1-1
- JM = J1*L/2
- KM = K1*(K1-1)/2
- IF (L .LE. 0) GO TO 40
- DO 30 M = 1, L
- JM = JM+1
- T = H(JM)
- KM = KM+1
- H(JM) = H(KM)
- H(KM) = T
- 30 CONTINUE
- 40 KM = KM+1
- KK = KM+KMJ
- JM = JM+1
- T = H(JM)
- H(JM) = H(KK)
- H(KK) = T
- J1 = L
- L = KMJ-1
- IF (L .LE. 0) GO TO 60
- DO 50 M = 1, L
- JM = JM+J1+M
- T = H(JM)
- KM = KM+1
- H(JM) = H(KM)
- H(KM) = T
- 50 CONTINUE
- 60 IF (K1 .GE. P) GO TO 80
- L = P-K1
- K1 = K1-1
- KM = KK
- DO 70 M = 1, L
- KM = KM+K1+M
- JM = KM-KMJ
- T = H(JM)
- H(JM) = H(KM)
- H(KM) = T
- 70 CONTINUE
- 80 K = J
- J = IP(K)
- IP(K) = -J
- IF (J .GT. I) GO TO 10
- 90 CONTINUE
- 999 RETURN
-C *** LAST LINE OF S7IPR FOLLOWS ***
- END
diff --git a/CEP/PyBDSM/src/port3/s7lup.f b/CEP/PyBDSM/src/port3/s7lup.f
deleted file mode 100644
index 7c17ffc1359529828d03e665ec66d8d4fadad121..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/s7lup.f
+++ /dev/null
@@ -1,62 +0,0 @@
- SUBROUTINE S7LUP(A, COSMIN, P, SIZE, STEP, U, W, WCHMTD, WSCALE,
- 1 Y)
-C
-C *** UPDATE SYMMETRIC A SO THAT A * STEP = Y ***
-C *** (LOWER TRIANGLE OF A STORED ROWWISE ***
-C
-C *** PARAMETER DECLARATIONS ***
-C
- INTEGER P
- REAL A(1), COSMIN, SIZE, STEP(P), U(P), W(P),
- 1 WCHMTD(P), WSCALE, Y(P)
-C DIMENSION A(P*(P+1)/2)
-C
-C *** LOCAL VARIABLES ***
-C
- INTEGER I, J, K
- REAL DENMIN, SDOTWM, T, UI, WI
-C
-C *** CONSTANTS ***
- REAL HALF, ONE, ZERO
-C
-C *** EXTERNAL FUNCTIONS AND SUBROUTINES ***
-C
- REAL D7TPR, V2NRM
- EXTERNAL D7TPR, S7LVM, V2NRM
-C
-C/6
-C DATA HALF/0.5E+0/, ONE/1.E+0/, ZERO/0.E+0/
-C/7
- PARAMETER (HALF=0.5E+0, ONE=1.E+0, ZERO=0.E+0)
-C/
-C
-C-----------------------------------------------------------------------
-C
- SDOTWM = D7TPR(P, STEP, WCHMTD)
- DENMIN = COSMIN * V2NRM(P,STEP) * V2NRM(P,WCHMTD)
- WSCALE = ONE
- IF (DENMIN .NE. ZERO) WSCALE = AMIN1(ONE, ABS(SDOTWM/DENMIN))
- T = ZERO
- IF (SDOTWM .NE. ZERO) T = WSCALE / SDOTWM
- DO 10 I = 1, P
- 10 W(I) = T * WCHMTD(I)
- CALL S7LVM(P, U, A, STEP)
- T = HALF * (SIZE * D7TPR(P, STEP, U) - D7TPR(P, STEP, Y))
- DO 20 I = 1, P
- 20 U(I) = T*W(I) + Y(I) - SIZE*U(I)
-C
-C *** SET A = A + U*(W**T) + W*(U**T) ***
-C
- K = 1
- DO 40 I = 1, P
- UI = U(I)
- WI = W(I)
- DO 30 J = 1, I
- A(K) = SIZE*A(K) + UI*W(J) + WI*U(J)
- K = K + 1
- 30 CONTINUE
- 40 CONTINUE
-C
- 999 RETURN
-C *** LAST CARD OF S7LUP FOLLOWS ***
- END
diff --git a/CEP/PyBDSM/src/port3/s7lvm.f b/CEP/PyBDSM/src/port3/s7lvm.f
deleted file mode 100644
index 3038087674c2a350d0a70e39a3d9cca1df043171..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/s7lvm.f
+++ /dev/null
@@ -1,46 +0,0 @@
- SUBROUTINE S7LVM(P, Y, S, X)
-C
-C *** SET Y = S * X, S = P X P SYMMETRIC MATRIX. ***
-C *** LOWER TRIANGLE OF S STORED ROWWISE. ***
-C
-C *** PARAMETER DECLARATIONS ***
-C
- INTEGER P
- REAL S(1), X(P), Y(P)
-C DIMENSION S(P*(P+1)/2)
-C
-C *** LOCAL VARIABLES ***
-C
- INTEGER I, IM1, J, K
- REAL XI
-C
-C *** NO INTRINSIC FUNCTIONS ***
-C
-C *** EXTERNAL FUNCTION ***
-C
- REAL D7TPR
- EXTERNAL D7TPR
-C
-C-----------------------------------------------------------------------
-C
- J = 1
- DO 10 I = 1, P
- Y(I) = D7TPR(I, S(J), X)
- J = J + I
- 10 CONTINUE
-C
- IF (P .LE. 1) GO TO 999
- J = 1
- DO 40 I = 2, P
- XI = X(I)
- IM1 = I - 1
- J = J + 1
- DO 30 K = 1, IM1
- Y(K) = Y(K) + S(J)*XI
- J = J + 1
- 30 CONTINUE
- 40 CONTINUE
-C
- 999 RETURN
-C *** LAST CARD OF S7LVM FOLLOWS ***
- END
diff --git a/CEP/PyBDSM/src/port3/s7rtdt.f b/CEP/PyBDSM/src/port3/s7rtdt.f
deleted file mode 100644
index bb27b50d85c859e9368539293cbf45803f497c82..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/s7rtdt.f
+++ /dev/null
@@ -1,119 +0,0 @@
- SUBROUTINE S7RTDT(N,NNZ,INDROW,INDCOL,JPNTR,IWA)
- INTEGER N,NNZ
- INTEGER INDROW(NNZ),INDCOL(NNZ),JPNTR(1),IWA(N)
-C **********
-C
-C SUBROUTINE S7RTDT
-C
-C GIVEN THE NON-ZERO ELEMENTS OF AN M BY N MATRIX A IN
-C ARBITRARY ORDER AS SPECIFIED BY THEIR ROW AND COLUMN
-C INDICES, THIS SUBROUTINE PERMUTES THESE ELEMENTS SO
-C THAT THEIR COLUMN INDICES ARE IN NON-DECREASING ORDER.
-C
-C ON INPUT IT IS ASSUMED THAT THE ELEMENTS ARE SPECIFIED IN
-C
-C INDROW(K),INDCOL(K), K = 1,...,NNZ.
-C
-C ON OUTPUT THE ELEMENTS ARE PERMUTED SO THAT INDCOL IS
-C IN NON-DECREASING ORDER. IN ADDITION, THE ARRAY JPNTR
-C IS SET SO THAT THE ROW INDICES FOR COLUMN J ARE
-C
-C INDROW(K), K = JPNTR(J),...,JPNTR(J+1)-1.
-C
-C NOTE THAT THE VALUE OF M IS NOT NEEDED BY S7RTDT AND IS
-C THEREFORE NOT PRESENT IN THE SUBROUTINE STATEMENT.
-C
-C THE SUBROUTINE STATEMENT IS
-C
-C SUBROUTINE S7RTDT(N,NNZ,INDROW,INDCOL,JPNTR,IWA)
-C
-C WHERE
-C
-C N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER
-C OF COLUMNS OF A.
-C
-C NNZ IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER
-C OF NON-ZERO ELEMENTS OF A.
-C
-C INDROW IS AN INTEGER ARRAY OF LENGTH NNZ. ON INPUT INDROW
-C MUST CONTAIN THE ROW INDICES OF THE NON-ZERO ELEMENTS OF A.
-C ON OUTPUT INDROW IS PERMUTED SO THAT THE CORRESPONDING
-C COLUMN INDICES OF INDCOL ARE IN NON-DECREASING ORDER.
-C
-C INDCOL IS AN INTEGER ARRAY OF LENGTH NNZ. ON INPUT INDCOL
-C MUST CONTAIN THE COLUMN INDICES OF THE NON-ZERO ELEMENTS
-C OF A. ON OUTPUT INDCOL IS PERMUTED SO THAT THESE INDICES
-C ARE IN NON-DECREASING ORDER.
-C
-C JPNTR IS AN INTEGER OUTPUT ARRAY OF LENGTH N + 1 WHICH
-C SPECIFIES THE LOCATIONS OF THE ROW INDICES IN THE OUTPUT
-C INDROW. THE ROW INDICES FOR COLUMN J ARE
-C
-C INDROW(K), K = JPNTR(J),...,JPNTR(J+1)-1.
-C
-C NOTE THAT JPNTR(1) IS SET TO 1 AND THAT JPNTR(N+1)-1
-C IS THEN NNZ.
-C
-C IWA IS AN INTEGER WORK ARRAY OF LENGTH N.
-C
-C SUBPROGRAMS CALLED
-C
-C FORTRAN-SUPPLIED ... MAX0
-C
-C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. JUNE 1982.
-C THOMAS F. COLEMAN, BURTON S. GARBOW, JORGE J. MORE
-C
-C **********
- INTEGER I,J,K,L
-C
-C DETERMINE THE NUMBER OF NON-ZEROES IN THE COLUMNS.
-C
- DO 10 J = 1, N
- IWA(J) = 0
- 10 CONTINUE
- DO 20 K = 1, NNZ
- J = INDCOL(K)
- IWA(J) = IWA(J) + 1
- 20 CONTINUE
-C
-C SET POINTERS TO THE START OF THE COLUMNS IN INDROW.
-C
- JPNTR(1) = 1
- DO 30 J = 1, N
- JPNTR(J+1) = JPNTR(J) + IWA(J)
- IWA(J) = JPNTR(J)
- 30 CONTINUE
- K = 1
-C
-C BEGIN IN-PLACE SORT.
-C
- 40 CONTINUE
- J = INDCOL(K)
- IF (K .LT. JPNTR(J) .OR. K .GE. JPNTR(J+1)) GO TO 50
-C
-C CURRENT ELEMENT IS IN POSITION. NOW EXAMINE THE
-C NEXT ELEMENT OR THE FIRST UN-SORTED ELEMENT IN
-C THE J-TH GROUP.
-C
- K = MAX0(K+1,IWA(J))
- GO TO 60
- 50 CONTINUE
-C
-C CURRENT ELEMENT IS NOT IN POSITION. PLACE ELEMENT
-C IN POSITION AND MAKE THE DISPLACED ELEMENT THE
-C CURRENT ELEMENT.
-C
- L = IWA(J)
- IWA(J) = IWA(J) + 1
- I = INDROW(K)
- INDROW(K) = INDROW(L)
- INDCOL(K) = INDCOL(L)
- INDROW(L) = I
- INDCOL(L) = J
- 60 CONTINUE
- IF (K .LE. NNZ) GO TO 40
- RETURN
-C
-C LAST CARD OF SUBROUTINE S7RTDT.
-C
- END
diff --git a/CEP/PyBDSM/src/port3/s88fmt.f b/CEP/PyBDSM/src/port3/s88fmt.f
deleted file mode 100644
index 342c1325ce8d8e24857ff3fe04cbf77003d709e6..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/s88fmt.f
+++ /dev/null
@@ -1,52 +0,0 @@
- SUBROUTINE S88FMT( N, W, IFMT )
-C
-C S88FMT REPLACES IFMT(1), ... , IFMT(N) WITH
-C THE CHARACTERS CORRESPONDING TO THE N LEAST SIGNIFICANT
-C DIGITS OF W.
-C
- INTEGER N,W
-C/6S
-C INTEGER IFMT(N)
-C/7S
- CHARACTER*1 IFMT(N)
-C/
-C
- INTEGER NT,WT
-C
-C/6S
-C INTEGER DIGITS(10)
-C DATA DIGITS( 1) / 1H0 /
-C DATA DIGITS( 2) / 1H1 /
-C DATA DIGITS( 3) / 1H2 /
-C DATA DIGITS( 4) / 1H3 /
-C DATA DIGITS( 5) / 1H4 /
-C DATA DIGITS( 6) / 1H5 /
-C DATA DIGITS( 7) / 1H6 /
-C DATA DIGITS( 8) / 1H7 /
-C DATA DIGITS( 9) / 1H8 /
-C DATA DIGITS(10) / 1H9 /
-C/7S
- CHARACTER*1 DIGITS(10)
- DATA DIGITS( 1) / '0' /
- DATA DIGITS( 2) / '1' /
- DATA DIGITS( 3) / '2' /
- DATA DIGITS( 4) / '3' /
- DATA DIGITS( 5) / '4' /
- DATA DIGITS( 6) / '5' /
- DATA DIGITS( 7) / '6' /
- DATA DIGITS( 8) / '7' /
- DATA DIGITS( 9) / '8' /
- DATA DIGITS(10) / '9' /
-C/
-C
- NT = N
- WT = W
-C
- 10 IF (NT .LE. 0) RETURN
- IDIGIT = MOD( WT, 10 )
- IFMT(NT) = DIGITS(IDIGIT+1)
- WT = WT/10
- NT = NT - 1
- GO TO 10
-C
- END
diff --git a/CEP/PyBDSM/src/port3/sdump.f b/CEP/PyBDSM/src/port3/sdump.f
deleted file mode 100644
index 7d223659153e9fa13bbebb7d1397e43ed7828486..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/sdump.f
+++ /dev/null
@@ -1,8 +0,0 @@
- SUBROUTINE SDUMP
-C THIS IS THE STANDARD DUMP ROUTINE FOR THE PORT LIBRARY.
-C FIRST IT PROVIDES A FORMATTED DUMP OF THE PORT STACK.
-C THEN IT CALLS THE LOCAL (PREFERABLY SYMBOLIC) DUMP ROUTINE.
- CALL STKDMP
- CALL FDUMP
- RETURN
- END
diff --git a/CEP/PyBDSM/src/port3/setc.f b/CEP/PyBDSM/src/port3/setc.f
deleted file mode 100644
index 8b93eceae922c7c8ce4b1a1fd4b891ea373441eb..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/setc.f
+++ /dev/null
@@ -1,25 +0,0 @@
- SUBROUTINE SETC(N,V,B)
-C
-C SETC SETS THE N COMPLEX ITEMS IN B TO V
-C
-C/R
-C REAL B(2,N), V(2), V1, V2
-C V1 = V(1)
-C V2 = V(2)
-C/C
- COMPLEX B(1),V
-C/
-C
- IF(N .LE. 0) RETURN
-C
- DO 10 I = 1, N
-C/R
-C B(1,I) = V1
-C10 B(2,I) = V2
-C/C
- 10 B(I) = V
-C/
-C
- RETURN
-C
- END
diff --git a/CEP/PyBDSM/src/port3/setd.f b/CEP/PyBDSM/src/port3/setd.f
deleted file mode 100644
index b930248bcf1b7c3841bef2641fa548ce10aee6cd..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/setd.f
+++ /dev/null
@@ -1,14 +0,0 @@
- SUBROUTINE SETD(N,V,B)
-C
-C SETD SETS THE N DOUBLE PRECISION ITEMS IN B TO V
-C
- DOUBLE PRECISION B(1),V
-C
- IF(N .LE. 0) RETURN
-C
- DO 10 I = 1, N
- 10 B(I) = V
-C
- RETURN
-C
- END
diff --git a/CEP/PyBDSM/src/port3/seterr.f b/CEP/PyBDSM/src/port3/seterr.f
deleted file mode 100644
index a4a3f76591029c60e626c69a219b07fa147960f1..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/seterr.f
+++ /dev/null
@@ -1,112 +0,0 @@
- SUBROUTINE SETERR(MESSG,NMESSG,NERR,IOPT)
-C
-C SETERR SETS LERROR = NERR, OPTIONALLY PRINTS THE MESSAGE AND DUMPS
-C ACCORDING TO THE FOLLOWING RULES...
-C
-C IF IOPT = 1 AND RECOVERING - JUST REMEMBER THE ERROR.
-C IF IOPT = 1 AND NOT RECOVERING - PRINT AND STOP.
-C IF IOPT = 2 - PRINT, DUMP AND STOP.
-C
-C INPUT
-C
-C MESSG - THE ERROR MESSAGE.
-C NMESSG - THE LENGTH OF THE MESSAGE, IN CHARACTERS.
-C NERR - THE ERROR NUMBER. MUST HAVE NERR NON-ZERO.
-C IOPT - THE OPTION. MUST HAVE IOPT=1 OR 2.
-C
-C ERROR STATES -
-C
-C 1 - MESSAGE LENGTH NOT POSITIVE.
-C 2 - CANNOT HAVE NERR=0.
-C 3 - AN UNRECOVERED ERROR FOLLOWED BY ANOTHER ERROR.
-C 4 - BAD VALUE FOR IOPT.
-C
-C ONLY THE FIRST 72 CHARACTERS OF THE MESSAGE ARE PRINTED.
-C
-C THE ERROR HANDLER CALLS A SUBROUTINE NAMED SDUMP TO PRODUCE A
-C SYMBOLIC DUMP.
-C
-C/6S
-C INTEGER MESSG(1)
-C/7S
- CHARACTER*1 MESSG(NMESSG)
-C/
-C
-C THE UNIT FOR ERROR MESSAGES.
-C
- IWUNIT=I1MACH(4)
-C
- IF (NMESSG.GE.1) GO TO 10
-C
-C A MESSAGE OF NON-POSITIVE LENGTH IS FATAL.
-C
- WRITE(IWUNIT,9000)
- 9000 FORMAT(52H1ERROR 1 IN SETERR - MESSAGE LENGTH NOT POSITIVE.)
- GO TO 60
-C
-C NW IS THE NUMBER OF WORDS THE MESSAGE OCCUPIES.
-C (I1MACH(6) IS THE NUMBER OF CHARACTERS PER WORD.)
-C
-C/6S
-C10 NW=(MIN0(NMESSG,72)-1)/I1MACH(6)+1
-C/7S
- 10 NW= MIN0(NMESSG,72)
-C/
-C
- IF (NERR.NE.0) GO TO 20
-C
-C CANNOT TURN THE ERROR STATE OFF USING SETERR.
-C (I8SAVE SETS A FATAL ERROR HERE.)
-C
- WRITE(IWUNIT,9001)
- 9001 FORMAT(42H1ERROR 2 IN SETERR - CANNOT HAVE NERR=0//
- 1 34H THE CURRENT ERROR MESSAGE FOLLOWS///)
- CALL E9RINT(MESSG,NW,NERR,.TRUE.)
- ITEMP=I8SAVE(1,1,.TRUE.)
- GO TO 50
-C
-C SET LERROR AND TEST FOR A PREVIOUS UNRECOVERED ERROR.
-C
- 20 IF (I8SAVE(1,NERR,.TRUE.).EQ.0) GO TO 30
-C
- WRITE(IWUNIT,9002)
- 9002 FORMAT(23H1ERROR 3 IN SETERR -,
- 1 48H AN UNRECOVERED ERROR FOLLOWED BY ANOTHER ERROR.//
- 2 48H THE PREVIOUS AND CURRENT ERROR MESSAGES FOLLOW.///)
- CALL EPRINT
- CALL E9RINT(MESSG,NW,NERR,.TRUE.)
- GO TO 50
-C
-C SAVE THIS MESSAGE IN CASE IT IS NOT RECOVERED FROM PROPERLY.
-C
- 30 CALL E9RINT(MESSG,NW,NERR,.TRUE.)
-C
- IF (IOPT.EQ.1 .OR. IOPT.EQ.2) GO TO 40
-C
-C MUST HAVE IOPT = 1 OR 2.
-C
- WRITE(IWUNIT,9003)
- 9003 FORMAT(42H1ERROR 4 IN SETERR - BAD VALUE FOR IOPT//
- 1 34H THE CURRENT ERROR MESSAGE FOLLOWS///)
- GO TO 50
-C
-C IF THE ERROR IS FATAL, PRINT, DUMP, AND STOP
-C
- 40 IF (IOPT.EQ.2) GO TO 50
-C
-C HERE THE ERROR IS RECOVERABLE
-C
-C IF THE RECOVERY MODE IS IN EFFECT, OK, JUST RETURN
-C
- IF (I8SAVE(2,0,.FALSE.).EQ.1) RETURN
-C
-C OTHERWISE PRINT AND STOP
-C
- CALL EPRINT
- STOP
-C
- 50 CALL EPRINT
- 60 CALL SDUMP
- STOP
-C
- END
diff --git a/CEP/PyBDSM/src/port3/seti.f b/CEP/PyBDSM/src/port3/seti.f
deleted file mode 100644
index 03fa17f5fc38c93bcd434cb1fde3d51faa1ba16b..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/seti.f
+++ /dev/null
@@ -1,14 +0,0 @@
- SUBROUTINE SETI(N,V,B)
-C
-C SETI SETS THE N INTEGER ITEMS IN B TO V
-C
- INTEGER B(1),V
-C
- IF(N .LE. 0) RETURN
-C
- DO 10 I = 1, N
- 10 B(I) = V
-C
- RETURN
-C
- END
diff --git a/CEP/PyBDSM/src/port3/setl.f b/CEP/PyBDSM/src/port3/setl.f
deleted file mode 100644
index 27abb995b742f7260ffe1988df0f0840c0ce8354..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/setl.f
+++ /dev/null
@@ -1,14 +0,0 @@
- SUBROUTINE SETL(N,V,B)
-C
-C SETL SETS THE N LOGICAL ITEMS IN B TO V
-C
- LOGICAL B(1),V
-C
- IF(N .LE. 0) RETURN
-C
- DO 10 I = 1, N
- 10 B(I) = V
-C
- RETURN
-C
- END
diff --git a/CEP/PyBDSM/src/port3/setr.f b/CEP/PyBDSM/src/port3/setr.f
deleted file mode 100644
index 3ae6104086d1d91b0d9777357c85205cc30859b6..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/setr.f
+++ /dev/null
@@ -1,14 +0,0 @@
- SUBROUTINE SETR(N,V,B)
-C
-C SETR SETS THE N REAL ITEMS IN B TO V
-C
- REAL B(1),V
-C
- IF(N .LE. 0) RETURN
-C
- DO 10 I = 1, N
- 10 B(I) = V
-C
- RETURN
-C
- END
diff --git a/CEP/PyBDSM/src/port3/smnfb.f b/CEP/PyBDSM/src/port3/smnfb.f
deleted file mode 100644
index fa3d9e6b0b6ddb4b66a6ec83fc9a0cf66b5314e5..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/smnfb.f
+++ /dev/null
@@ -1,88 +0,0 @@
- SUBROUTINE SMNFB( P, X,B, CALCF, MXFCAL, ACC )
-C
-C ** SIMPLIED VERSION OF MNF
-C
-C INPUT PARAMETERS
-C P NUMBER OF UNKNOWNS
-C X APPROXIMATE SOLUTION
-C B FIRST ROW OF B GIVES LOWER BOUNDS ON X AND SECOND GIVES UPPER
-C BOUNDS
-C CALCF SUBROUTINE TO EVALUATE FUNCTION
-C MXFCAL MAXIMUM NUMBER OF PERMITTED FUNCTION EVALUATIONS
-C ACC ACCURACY IN X
-C OUTPUT PARAMETERS
-C X SOLUTION
- INTEGER P, MXFCAL
- REAL X(P), ACC ,B(2,P)
- EXTERNAL CALCF, C6LCF
-C
-C
-C
-C *** LOCAL VARIABLES ***
-C
- INTEGER IV, LIV, LV, V1
- INTEGER IDI,IDM1,ID,J
- REAL DSTAK(1000)
- COMMON /CSTAK/ DSTAK
- INTEGER ISTAK(1000)
- EQUIVALENCE (DSTAK(1), ISTAK(1))
-C
-C *** BODY ***
-C
- CALL ENTER(0)
-C/6S
-C IF (P.LT.1)
-C 1CALL SETERR(14H SMNFB- P.LT.1,14,1,2)
-C IF (MXFCAL.LT.1)
-C 1CALL SETERR(19H SMNFB- MXFCAL.LT.1,19,2,2)
-C IF (ACC.LT.0.0)
-C 1CALL SETERR(18H SMNFB-ACC .LT.0.0,18,3,2)
-C/7S
- IF (P.LT.1)
- 1CALL SETERR(' SMNFB- P.LT.1',14,1,2)
- IF (MXFCAL.LT.1)
- 1CALL SETERR(' SMNFB- MXFCAL.LT.1',19,2,2)
- IF (ACC.LT.0.0)
- 1CALL SETERR(' SMNFB-ACC .LT.0.0',18,3,2)
-C/
- LIV =59+P
- LV=77+P*(P+23)/2
- IV=ISTKGT(LIV,2)
- V1=ISTKGT(LV, 3)
- CALL IVSET(2,ISTAK(IV),LIV,LV,DSTAK(V1))
- ISTAK(IV+20)=0
- ISTAK(IV+16)=MXFCAL
- ISTAK(IV+17)=MXFCAL
- DSTAK(V1+32)=ACC
- DSTAK(V1+31)=ACC
- ID=ISTKGT(P, 3)
- IDM1=ID-1
- DO 10 I=1,P
- IDI=IDM1+I
- DSTAK(IDI)=1.0
- IF (X(I).NE.0.0)DSTAK(IDI)=1.0/ABS(X(I))
- 10 CONTINUE
- CALL MNFB( P, DSTAK(ID),X,B, C6LCF, ISTAK(IV), LIV, LV,
- 1 DSTAK(V1), IU, UR, CALCF)
- J=ISTAK(IV)
- IF(J.LT.7) GO TO 20
-C/6S
-C IF (J.EQ.82)CALL SETERR(26H SMNFB-INCONSISTENT BOUNDS,26,4,1)
-C IF (J.EQ.7)CALL SETERR(27H SMNFB-SINGULAR CONVERGENCE,27,5,1)
-C IF(J.EQ.8)CALL SETERR(24H SMNFB-FALSE CONVERGENCE,24,6,1)
-C IF(J.EQ.9)CALL SETERR(32H SMNFB-FUNCTION EVALUATION LIMIT,32,7,1)
-C IF (J.EQ.63)
-C 1CALL SETERR(43H SMNFB-F(X) CANNOT BE COMPUTED AT INITIAL X,43,8,1)
-C/7S
- IF (J.EQ.82)CALL SETERR(' SMNFB-INCONSISTENT BOUNDS',26,4,1)
- IF (J.EQ.7)CALL SETERR(' SMNFB-SINGULAR CONVERGENCE',27,5,1)
- IF(J.EQ.8)CALL SETERR(' SMNFB-FALSE CONVERGENCE',24,6,1)
- IF(J.EQ.9)CALL SETERR(' SMNFB-FUNCTION EVALUATION LIMIT',32,7,1)
- IF (J.EQ.63)
- 1CALL SETERR(' SMNFB-F(X) CANNOT BE COMPUTED AT INITIAL X',43,8,1)
-C/
- 20 CALL LEAVE
-C
- RETURN
-C *** LAST LINE OF SMNFB FOLLOWS ***
- END
diff --git a/CEP/PyBDSM/src/port3/srecap.f b/CEP/PyBDSM/src/port3/srecap.f
deleted file mode 100644
index 11d269ee4af3c78905adbed6f8b1e4f9180893ce..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/srecap.f
+++ /dev/null
@@ -1,30 +0,0 @@
- SUBROUTINE SRECAP(IWUNIT)
-C
-C WRITES LOUT, LNOW, LUSED AND LMAX ON LOGICAL UNIT IWUNIT.
-C
- COMMON /CSTAK/DSTAK
-C
- DOUBLE PRECISION DSTAK(500)
- INTEGER ISTAK(1000)
- INTEGER ISTATS(4)
- LOGICAL INIT
-C
- EQUIVALENCE (DSTAK(1),ISTAK(1))
- EQUIVALENCE (ISTAK(1),ISTATS(1))
-C
- DATA INIT/.TRUE./
-C
- CALL I0TK01
- IF (INIT) CALL I0TK00(INIT,500,4)
-C
- WRITE(IWUNIT,9000) ISTATS
-C
- 9000 FORMAT(20H0STACK STATISTICS...//
- 1 24H OUTSTANDING ALLOCATIONS,I8/
- 1 24H CURRENT ACTIVE LENGTH ,I8/
- 3 24H MAXIMUM LENGTH USED ,I8/
- 4 24H MAXIMUM LENGTH ALLOWED ,I8)
-C
- RETURN
-C
- END
diff --git a/CEP/PyBDSM/src/port3/stinit.f b/CEP/PyBDSM/src/port3/stinit.f
deleted file mode 100644
index a386d0d0186ad716fe9ba8d332470c49dc284d16..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/stinit.f
+++ /dev/null
@@ -1,8 +0,0 @@
- SUBROUTINE STINIT(NITEMS,ISIZE)
-C
- CALL I0TK01
- CALL ISTKIN(NITEMS,ISIZE+2)
-C
- RETURN
-C
- END
diff --git a/CEP/PyBDSM/src/port3/stkdmp.f b/CEP/PyBDSM/src/port3/stkdmp.f
deleted file mode 100644
index 5140ce4def4f9702006ad7a741466d7ef3e429d4..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/stkdmp.f
+++ /dev/null
@@ -1,286 +0,0 @@
- SUBROUTINE STKDMP
-C
-C THIS PROCEDURE PROVIDES A DUMP OF THE PORT STACK.
-C
-C WRITTEN BY D. D. WARNER.
-C
-C MOSTLY REWRITTEN BY P. A. FOX, OCTOBER 13, 1982
-C AND COMMENTS ADDED.
-C
-C ALLOCATED REGIONS OF THE STACK ARE PRINTED OUT IN THE APPROPRIATE
-C FORMAT, EXCEPT IF THE STACK APPEARS TO HAVE BEEN OVERWRITTEN.
-C IF OVERWRITE SEEMS TO HAVE HAPPENED, THE ENTIRE STACK IS PRINTED OUT
-C IN UNSTRUCTURED FORM, ONCE FOR EACH OF THE POSSIBLE
-C (LOGICAL, INTEGER, REAL, DOUBLE PRECISION, OR COMPLEX) FORMATS.
-C
- COMMON /CSTAK/ DSTAK
- DOUBLE PRECISION DSTAK(500)
- REAL RSTAK(1000)
-C/R
-C REAL CMSTAK(2,500)
-C/C
- COMPLEX CMSTAK(500)
-C/
- INTEGER ISTAK(1000)
- LOGICAL LSTAK(1000)
-C
- INTEGER LOUT, LNOW, LUSED, LMAX, LBOOK
- INTEGER LLOUT, BPNTR
- INTEGER IPTR, ERROUT, MCOL, NITEMS
- INTEGER WR, DR, WD, DD, WI
- INTEGER LNG(5), ISIZE(5)
- INTEGER I, LNEXT, ITYPE, I1MACH
-C
- LOGICAL INIT, TRBL1, TRBL2
-C
- EQUIVALENCE (DSTAK(1), ISTAK(1))
- EQUIVALENCE (DSTAK(1), LSTAK(1))
- EQUIVALENCE (DSTAK(1), RSTAK(1))
-C/R
-C EQUIVALENCE (DSTAK(1), CMSTAK(1,1))
-C/C
- EQUIVALENCE (DSTAK(1), CMSTAK(1))
-C/
- EQUIVALENCE (ISTAK(1), LOUT)
- EQUIVALENCE (ISTAK(2), LNOW)
- EQUIVALENCE (ISTAK(3), LUSED)
- EQUIVALENCE (ISTAK(4), LMAX)
- EQUIVALENCE (ISTAK(5), LBOOK)
- EQUIVALENCE (ISTAK(6), ISIZE(1))
-C
- DATA MCOL/132/
- DATA INIT/.TRUE./
-C
-C I0TK00 CHECKS TO SEE IF THE FIRST TEN, BOOKKEEPING, LOCATIONS OF
-C THE STACK HAVE BEEN INITIALIZED (AND DOES IT, IF NEEDED).
-C
- IF (INIT) CALL I0TK00(INIT, 500, 4)
-C
-C
-C I1MACH(4) IS THE STANDARD ERROR MESSAGE WRITE UNIT.
-C
- ERROUT = I1MACH(4)
- WRITE (ERROUT, 9901)
- 9901 FORMAT (11H1STACK DUMP)
-C
-C
-C FIND THE MACHINE-DEPENDENT FORMATS FOR PRINTING - BUT ADD 1 TO
-C THE WIDTH TO GET SEPARATION BETWEEN ITEMS, AND SUBTRACT 1 FROM
-C THE NUMBER OF DIGITS AFTER THE DECIMAL POINT TO ALLOW FOR THE
-C 1P IN THE DUMP FORMAT OF 1PEW.D
-C
-C (NOTE, THAT ALTHOUGH IT IS NOT NECESSARY, 2 HAS BEEN ADDED TO
-C THE INTEGER WIDTH, WI, TO CONFORM WITH DAN WARNERS PREVIOUS
-C USAGE - SO PEOPLE CAN COMPARE DUMPS WITH ONES THEY HAVE HAD
-C AROUND FOR A LONG TIME.)
-C
- CALL FRMATR(WR,DR)
- CALL FRMATD(WD,DD)
- CALL FRMATI(WI)
-C
- WR = WR+1
- WD = WD+1
- WI = WI+2
- DR = DR-1
- DD = DD-1
-C
-C CHECK, IN VARIOUS WAYS, THE BOOKKEEPING PART OF THE STACK TO SEE
-C IF THINGS WERE OVERWRITTEN.
-C
-C LOUT IS THE NUMBER OF CURRENT ALLOCATIONS
-C LNOW IS THE CURRENT ACTIVE LENGTH OF THE STACK
-C LUSED IS THE MAXIMUM VALUE OF LNOW ACHIEVED
-C LMAX IS THE MAXIMUM LENGTH OF THE STACK
-C LBOOK IS THE NUMBER OF WORDS USED FOR BOOK-KEEPING
-C
- TRBL1 = LBOOK .NE. 10
- IF (.NOT. TRBL1) TRBL1 = LMAX .LT. 12
- IF (.NOT. TRBL1) TRBL1 = LMAX .LT. LUSED
- IF (.NOT. TRBL1) TRBL1 = LUSED .LT. LNOW
- IF (.NOT. TRBL1) TRBL1 = LNOW .LT. LBOOK
- IF (.NOT. TRBL1) TRBL1 = LOUT .LT. 0
- IF (.NOT. TRBL1) GO TO 10
-C
- WRITE (ERROUT, 9902)
- 9902 FORMAT (29H0STACK HEADING IS OVERWRITTEN)
- WRITE (ERROUT, 9903)
- 9903 FORMAT (47H UNSTRUCTURED DUMP OF THE DEFAULT STACK FOLLOWS)
-C
-C SINCE INFORMATION IS LOST, SIMPLY SET THE USUAL DEFAULT VALUES FOR
-C THE LENGTH OF THE ENTIRE STACK IN TERMS OF EACH (LOGICAL, INTEGER,
-C ETC.,) TYPE.
-C
- LNG(1) = 1000
- LNG(2) = 1000
- LNG(3) = 1000
- LNG(4) = 500
- LNG(5) = 500
-C
-C
- CALL U9DMP(LNG, MCOL, WI, WR, DR, WD, DD)
- GO TO 110
-C
-C WRITE OUT THE STORAGE UNITS USED BY EACH TYPE OF VARIABLE
-C
- 10 WRITE (ERROUT, 9904)
- 9904 FORMAT (19H0STORAGE PARAMETERS)
- WRITE (ERROUT, 9905) ISIZE(1)
- 9905 FORMAT (18H LOGICAL , I7, 14H STORAGE UNITS)
- WRITE (ERROUT, 9906) ISIZE(2)
- 9906 FORMAT (18H INTEGER , I7, 14H STORAGE UNITS)
- WRITE (ERROUT, 9907) ISIZE(3)
- 9907 FORMAT (18H REAL , I7, 14H STORAGE UNITS)
- WRITE (ERROUT, 9908) ISIZE(4)
- 9908 FORMAT (18H DOUBLE PRECISION , I7, 14H STORAGE UNITS)
- WRITE (ERROUT, 9909) ISIZE(5)
- 9909 FORMAT (18H COMPLEX , I7, 14H STORAGE UNITS)
-C
-C WRITE OUT THE CURRENT STACK STATISTICS (I.E. USAGE)
-C
- WRITE (ERROUT, 9910)
- 9910 FORMAT (17H0STACK STATISTICS)
- WRITE (ERROUT, 9911) LMAX
- 9911 FORMAT (23H STACK SIZE , I7)
- WRITE (ERROUT, 9912) LUSED
- 9912 FORMAT (23H MAXIMUM STACK USED , I7)
- WRITE (ERROUT, 9913) LNOW
- 9913 FORMAT (23H CURRENT STACK USED , I7)
- WRITE (ERROUT, 9914) LOUT
- 9914 FORMAT (23H NUMBER OF ALLOCATIONS , I7)
-C
-C HERE AT LEAST THE BOOKKEEPING PART OF THE STACK HAS NOT BEEN
-C OVERWRITTEN.
-C
-C STACKDUMP WORKS BACKWARDS FROM THE END (MOST RECENT ALLOCATION) OF
-C THE STACK, PRINTING INFORMATION, BUT ALWAYS CHECKING TO SEE IF
-C THE POINTERS FOR AN ALLOCATION HAVE BEEN OVERWRITTEN.
-C
-C LLOUT COUNTS THE NUMBER OF ALLOCATIONS STILL LEFT TO PRINT
-C SO LLOUT IS INITIALLY LOUT OR ISTAK(1).
-C
-C THE STACK ALLOCATION ROUTINE PUTS, AT THE END OF EACH ALLOCATION,
-C TWO EXTRA SPACES - ONE FOR THE TYPE OF THE ALLOCATION AND THE NEXT
-C TO HOLD A BACK POINTER TO THE PREVIOUS ALLOCATION.
-C THE BACK POINTER IS THEREFORE INITIALLY LOCATED AT THE INITIAL END,
-C LNOW, OF THE STACK.
-C CALL THIS LOCATION BPNTR.
-C
- LLOUT = LOUT
- BPNTR = LNOW
-C
-C IF WE ARE DONE, THE BACK POINTER POINTS BACK INTO THE BOOKKEEPING
-C PART OF THE STACK.
-C
-C IF WE ARE NOT DONE, OBTAIN THE NEXT REGION TO PRINT AND GET ITS TYPE.
-C
- 20 IF (BPNTR .LE. LBOOK) GO TO 110
-C
- LNEXT = ISTAK(BPNTR)
- ITYPE = ISTAK(BPNTR-1)
-C
-C SEE IF ANY OF THESE NEW DATA ARE INCONSISTENT - WHICH WOULD SIGNAL
-C AN OVERWRITE.
-C
- TRBL2 = LNEXT .LT. LBOOK
- IF (.NOT. TRBL2) TRBL2 = BPNTR .LE. LNEXT
- IF (.NOT. TRBL2) TRBL2 = ITYPE .LT. 0
- IF (.NOT. TRBL2) TRBL2 = 5 .LT. ITYPE
- IF (.NOT. TRBL2) GO TO 40
-C
-C HERE THERE SEEMS TO HAVE BEEN A PARTIAL OVERWRITE.
-C COMPUTE THE LENGTH OF THE ENTIRE STACK IN TERMS OF THE VALUES GIVEN
-C IN THE BOOKKEEPING PART OF THE STACK (WHICH, AT LEAST, SEEMS NOT TO
-C HAVE BEEN OVERWRITTEN), AND DO AN UNFORMATTED DUMP, AND RETURN.
-C
- WRITE (ERROUT, 9915)
- 9915 FORMAT (28H0STACK PARTIALLY OVERWRITTEN)
- WRITE (ERROUT, 9916)
- 9916 FORMAT (45H UNSTRUCTURED DUMP OF REMAINING STACK FOLLOWS)
-C
- DO 30 I = 1, 5
- LNG(I) = (BPNTR*ISIZE(2)-1)/ISIZE(I)+1
- 30 CONTINUE
-C
- CALL U9DMP(LNG, MCOL, WI, WR, DR, WD, DD)
- GO TO 110
-C
-C
-C COMES HERE EACH TIME TO PRINT NEXT (BACK) ALLOCATION.
-C
-C AT THIS POINT BPNTR POINTS TO THE END OF THE ALLOCATION ABOUT TO
-C BE PRINTED, LNEXT = ISTAK(BPNTR) POINTS BACK TO THE END OF THE
-C PREVIOUS ALLOCATION, AND ITYPE = ISTAK(BPNTR-1) GIVES THE TYPE OF
-C THE ALLOCATION ABOUT TO BE PRINTED.
-C
-C THE PRINTING ROUTINES NEED TO KNOW THE START OF THE ALLOCATION AND
-C THE NUMBER OF ITEMS.
-C THESE ARE COMPUTED FROM THE EQUATIONS USED WHEN THE FUNCTION ISTKGT
-C COMPUTED THE ORIGINAL ALLOCATION - THE POINTER TO THE
-C START OF THE ALLOCATION WAS COMPUTED BY ISTKGT FROM THE (THEN)
-C END OF THE PREVIOUS ALLOCATION VIA THE FORMULA,
-C
-C ISTKGT = (LNOW*ISIZE(2)-1)/ISIZE(ITYPE) + 2
-C
- 40 IPTR = (LNEXT*ISIZE(2)-1)/ISIZE(ITYPE) + 2
-C
-C THE FUNCTION ISTKGT THEN FOUND NEW END OF THE STACK, LNOW, FROM THE
-C FORMULA
-C
-C I = ( (ISTKGT-1+NITEMS)*ISIZE(ITYPE) - 1 )/ISIZE(2) + 3
-C
-C HERE WE SOLVE THIS FOR NITEMS TO DETERMINE THE NUMBER OF LOCATIONS
-C IN THIS ALLOCATION.
-C
- NITEMS = 1-IPTR + ((BPNTR-3)*ISIZE(2)+1)/ISIZE(ITYPE)
-C
-C
-C _USE_ THE TYPE (INTEGER, REAL, ETC.) TO DTERMINE WHICH PRINTING
-C ROUTINE TO USE.
-C
- IF (ITYPE .EQ. 1) GO TO 50
- IF (ITYPE .EQ. 2) GO TO 60
- IF (ITYPE .EQ. 3) GO TO 70
- IF (ITYPE .EQ. 4) GO TO 80
- IF (ITYPE .EQ. 5) GO TO 90
-C
- 50 WRITE (ERROUT, 9917) LLOUT, IPTR
- 9917 FORMAT (13H0ALLOCATION =, I7, 20H, POINTER =,
- 1 I7, 23H, TYPE LOGICAL)
- CALL A9RNTL(LSTAK(IPTR), NITEMS, ERROUT, MCOL)
- GO TO 100
-C
- 60 WRITE (ERROUT, 9918) LLOUT, IPTR
- 9918 FORMAT (13H0ALLOCATION =, I7, 20H, POINTER =,
- 1 I7, 23H, TYPE INTEGER)
- CALL A9RNTI(ISTAK(IPTR), NITEMS, ERROUT, MCOL, WI)
- GO TO 100
-C
- 70 WRITE (ERROUT, 9919) LLOUT, IPTR
- 9919 FORMAT (13H0ALLOCATION =, I7, 20H, POINTER =,
- 1 I7, 20H, TYPE REAL)
- CALL A9RNTR(RSTAK(IPTR), NITEMS, ERROUT, MCOL, WR, DR)
- GO TO 100
-C
- 80 WRITE (ERROUT, 9920) LLOUT, IPTR
- 9920 FORMAT (13H0ALLOCATION =, I7, 20H, POINTER =,
- 1 I7, 32H, TYPE DOUBLE PRECISION)
- CALL A9RNTD(DSTAK(IPTR), NITEMS, ERROUT, MCOL, WD, DD)
- GO TO 100
-C
- 90 WRITE (ERROUT, 9921) LLOUT, IPTR
- 9921 FORMAT (13H0ALLOCATION =, I7, 20H, POINTER =,
- 1 I7, 23H, TYPE COMPLEX)
-C/R
-C CALL A9RNTC(CMSTAK(1,IPTR), NITEMS, ERROUT, MCOL, WR,DR)
-C/C
- CALL A9RNTC(CMSTAK(IPTR), NITEMS, ERROUT, MCOL, WR, DR)
-C/
-C
- 100 BPNTR = LNEXT
- LLOUT = LLOUT-1
- GO TO 20
-C
- 110 WRITE (ERROUT, 9922)
- 9922 FORMAT (18H0END OF STACK DUMP)
- RETURN
- END
diff --git a/CEP/PyBDSM/src/port3/stopx.f b/CEP/PyBDSM/src/port3/stopx.f
deleted file mode 100644
index 122d345833d553d30cf3f738a484985e4da80259..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/stopx.f
+++ /dev/null
@@ -1,23 +0,0 @@
- LOGICAL FUNCTION STOPX(IDUMMY)
-C *****PARAMETERS...
- INTEGER IDUMMY
-C
-C ..................................................................
-C
-C *****PURPOSE...
-C THIS FUNCTION MAY SERVE AS THE STOPX (ASYNCHRONOUS INTERRUPTION)
-C FUNCTION FOR THE NL2SOL (NONLINEAR LEAST-SQUARES) PACKAGE AT
-C THOSE INSTALLATIONS WHICH DO NOT WISH TO IMPLEMENT A
-C DYNAMIC STOPX.
-C
-C *****ALGORITHM NOTES...
-C AT INSTALLATIONS WHERE THE NL2SOL SYSTEM IS USED
-C INTERACTIVELY, THIS DUMMY STOPX SHOULD BE REPLACED BY A
-C FUNCTION THAT RETURNS .TRUE. IF AND ONLY IF THE INTERRUPT
-C (BREAK) KEY HAS BEEN PRESSED SINCE THE LAST CALL ON STOPX.
-C
-C ..................................................................
-C
- STOPX = .FALSE.
- RETURN
- END
diff --git a/CEP/PyBDSM/src/port3/ttgrx1.f b/CEP/PyBDSM/src/port3/ttgrx1.f
deleted file mode 100644
index aa2c1e0ecf2318a49eda74177e2abd8af13e8e01..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ttgrx1.f
+++ /dev/null
@@ -1,188 +0,0 @@
-C$TEST TTGR1
-c main program
- common /cstak/ ds
- double precision ds(350000)
- external handle, bc, af
- integer ndx, ndy, istkgt, iumb, is(1000), iu
- integer ix, iy, nu, kx, nx, ky
- integer ny
- real errpar(2), tstart, dt, lx, ly, rx
- real ry, ws(1000), rs(1000), tstop
- logical ls(1000)
- complex cs(500)
- equivalence (ds(1), cs(1), ws(1), rs(1), is(1), ls(1))
-c to solve the heat equation with solution u == t*x*y,
-c grad . ( u + ux + .1 * uy, u + uy + .1 * ux ) = ut + ux + uy +g(x,t)
-c the port library stack and its aliases.
-c initialize the port library stack length.
- call istkin(350000, 4)
- call enter(1)
- nu = 1
- lx = 0
- rx = 1
- ly = 0
- ry = 1
- kx = 2
- ky = 2
- ndx = 3
- ndy = 3
- tstart = 0
- tstop = 1
- dt = 1
- errpar(1) = 1e-2
- errpar(2) = 1e-4
-c uniform grid.
- ix = iumb(lx, rx, ndx, kx, nx)
-c uniform grid.
- iy = iumb(ly, ry, ndy, ky, ny)
-c space for the solution.
- iu = istkgt(nu*(nx-kx)*(ny-ky), 3)
-c initial conditions for u.
- call setr(nu*(nx-kx)*(ny-ky), 0e0, ws(iu))
- call ttgr(ws(iu), nu, kx, ws(ix), nx, ky, ws(iy), ny, tstart,
- 1 tstop, dt, af, bc, errpar, handle)
- call leave
- call wrapup
- stop
- end
- subroutine af(t, x, nx, y, ny, nu, u, ut, ux, uy, uxt, uyt
- 1 , a, au, aut, aux, auy, auxt, auyt, f, fu, fut, fux, fuy, fuxt,
- 2 fuyt)
- integer nu, nx, ny
- real t, x(nx), y(ny), u(nx, ny, nu), ut(nx, ny, nu), ux(nx, ny,
- 1 nu)
- real uy(nx, ny, nu), uxt(nx, ny, nu), uyt(nx, ny, nu), a(nx, ny,
- 1 nu, 2), au(nx, ny, nu, nu, 2), aut(nx, ny, nu, nu, 2)
- real aux(nx, ny, nu, nu, 2), auy(nx, ny, nu, nu, 2), auxt(nx, ny
- 1 , nu, nu, 2), auyt(nx, ny, nu, nu, 2), f(nx, ny, nu), fu(nx,
- 2 ny, nu, nu)
- real fut(nx, ny, nu, nu), fux(nx, ny, nu, nu), fuy(nx, ny, nu, nu)
- 1 , fuxt(nx, ny, nu, nu), fuyt(nx, ny, nu, nu)
- integer i, p, q
- do 3 i = 1, nu
- do 2 q = 1, ny
- do 1 p = 1, nx
- a(p, q, i, 1) = ux(p, q, i)+.1*uy(p, q, i)+u(p, q, i)
- a(p, q, i, 2) = uy(p, q, i)+.1*ux(p, q, i)+u(p, q, i)
- aux(p, q, i, i, 1) = 1
- auy(p, q, i, i, 2) = 1
- auy(p, q, i, i, 1) = .1
- aux(p, q, i, i, 2) = .1
- au(p, q, i, i, 1) = 1
- au(p, q, i, i, 2) = 1
- f(p, q, i) = ut(p, q, i)+ux(p, q, i)+uy(p, q, i)
- fut(p, q, i, i) = 1
- fux(p, q, i, i) = 1
- fuy(p, q, i, i) = 1
- f(p, q, i) = f(p, q, i)+.2*t-x(p)*y(q)
- 1 continue
- 2 continue
- 3 continue
- return
- end
- subroutine bc(t, x, nx, y, ny, lx, rx, ly, ry, u, ut, ux,
- 1 uy, uxt, uyt, nu, b, bu, but, bux, buy, buxt, buyt)
- integer nu, nx, ny
- real t, x(nx), y(ny), lx, rx, ly
- real ry, u(nx, ny, nu), ut(nx, ny, nu), ux(nx, ny, nu), uy(nx, ny,
- 1 nu), uxt(nx, ny, nu)
- real uyt(nx, ny, nu), b(nx, ny, nu), bu(nx, ny, nu, nu), but(nx,
- 1 ny, nu, nu), bux(nx, ny, nu, nu), buy(nx, ny, nu, nu)
- real buxt(nx, ny, nu, nu), buyt(nx, ny, nu, nu)
- integer i, j
- do 2 j = 1, ny
- do 1 i = 1, nx
- bu(i, j, 1, 1) = 1
- b(i, j, 1) = u(i, j, 1)-t*x(i)*y(j)
- 1 continue
- 2 continue
- return
- end
- subroutine handle(t0, u0, t, u, nv, dt, tstop)
- integer nv
- real t0, u0(nv), t, u(nv), dt, tstop
- common /a7tgrp/ errpar, nu, mxq, myq
- integer nu, mxq, myq
- real errpar(2)
- common /a7tgrm/ kx, ix, nx, ky, iy, ny
- integer kx, ix, nx, ky, iy, ny
- if (t0 .ne. t) goto 2
- write (6, 1) t
- 1 format (16h restart for t =, 1pe10.2)
- return
-c get and print the error.
- 2 call gerr(kx, ix, nx, ky, iy, ny, u, nu, t)
- return
- end
- subroutine gerr(kx, ix, nx, ky, iy, ny, u, nu, t)
- integer kx, ix, nx, ky, iy, ny
- integer nu
- real u(1), t
- common /cstak/ ds
- double precision ds(500)
- integer ifa, ita(2), ixa(2), nta(2), nxa(2), ixs
- integer iys, nxs, nys, istkgt, i, iewe
- integer ka(2), ma(2), is(1000), ilumd, i1mach
- real abs, erru, amax1, rs(1000), ws(1000)
- logical ls(1000)
- complex cs(500)
- integer temp, temp1, temp2
- equivalence (ds(1), cs(1), ws(1), rs(1), is(1), ls(1))
-c to get and print the error at each time-step.
-c u(nx-kx,ny0ky,nu).
-c the port library stack and its aliases.
- call enter(1)
-c find the error in the solution at 2*kx * 2*ky points / mesh rectangle.
-c x search grid.
- ixs = ilumd(ws(ix), nx, 2*kx, nxs)
-c y search grid.
- iys = ilumd(ws(iy), ny, 2*ky, nys)
-c u search grid values.
- iewe = istkgt(nxs*nys, 3)
-c the exact solution.
- call ewe(t, ws(ixs), nxs, ws(iys), nys, ws(iewe), nu)
- ka(1) = kx
- ka(2) = ky
- ita(1) = ix
- ita(2) = iy
- nta(1) = nx
- nta(2) = ny
- ixa(1) = ixs
- ixa(2) = iys
- nxa(1) = nxs
- nxa(2) = nys
- ma(1) = 0
-c get solution.
- ma(2) = 0
-c approximate solution values.
- ifa = istkgt(nxs*nys, 3)
-c evaluate them.
- call tsd1(2, ka, ws, ita, nta, u, ws, ixa, nxa, ma, ws(ifa))
-c error in solution values.
- erru = 0
- temp = nxs*nys
- do 1 i = 1, temp
- temp2 = iewe+i
- temp1 = ifa+i
- erru = amax1(erru, abs(ws(temp2-1)-ws(temp1-1)))
- 1 continue
- temp = i1mach(2)
- write (temp, 2) t, erru
- 2 format (14h error in u(.,, 1pe10.2, 3h) =, 1pe10.2)
- call leave
- return
- end
- subroutine ewe(t, x, nx, y, ny, u, nu)
- integer nu, nx, ny
- real t, x(nx), y(ny), u(nx, ny, nu)
- integer i, j, p
-c the exact solution.
- do 3 p = 1, nu
- do 2 i = 1, nx
- do 1 j = 1, ny
- u(i, j, p) = t*x(i)*y(j)
- 1 continue
- 2 continue
- 3 continue
- return
- end
diff --git a/CEP/PyBDSM/src/port3/ttgrx1p.f b/CEP/PyBDSM/src/port3/ttgrx1p.f
deleted file mode 100644
index 98e6de78eea7ddc899b74bf95b2cffd131339498..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ttgrx1p.f
+++ /dev/null
@@ -1,177 +0,0 @@
-C$TEST TTGR1P
-c main program
- common /cstak/ ds
- double precision ds(350000)
- external handle, bc, af
- integer ndx, ndy, istkgt, iumb, is(1000), iu
- integer ix, iy, nu, kx, nx, ky
- integer ny
- real errpar(2), tstart, dt, lx, ly, rx
- real ry, ws(1000), rs(1000), tstop
- logical ls(1000)
- complex cs(500)
- equivalence (ds(1), cs(1), ws(1), rs(1), is(1), ls(1))
-c to solve the heat equation with solution u == t*x*y,
-c grad . ( u + ux + .1 * uy, u + uy + .1 * ux ) = ut + ux + uy +g(x,t)
-c the port library stack and its aliases.
-c initialize the port library stack length.
- call istkin(350000, 4)
- call enter(1)
- nu = 1
- lx = 0
- rx = 1
- ly = 0
- ry = 1
- kx = 2
- ky = 2
- ndx = 3
- ndy = 3
- tstart = 0
- tstop = 1
- dt = 1
- errpar(1) = 1e-2
- errpar(2) = 1e-4
-c uniform grid.
- ix = iumb(lx, rx, ndx, kx, nx)
-c uniform grid.
- iy = iumb(ly, ry, ndy, ky, ny)
-c space for the solution.
- iu = istkgt(nu*(nx-kx)*(ny-ky), 3)
-c initial conditions for u.
- call setr(nu*(nx-kx)*(ny-ky), 0e0, ws(iu))
- call ttgr(ws(iu), nu, kx, ws(ix), nx, ky, ws(iy), ny, tstart,
- 1 tstop, dt, af, bc, errpar, handle)
- call leave
- call wrapup
- stop
- end
- subroutine af(t, x, nx, y, ny, nu, u, ut, ux, uy, uxt, uyt
- 1 , a, au, aut, aux, auy, auxt, auyt, f, fu, fut, fux, fuy, fuxt,
- 2 fuyt)
- integer nu, nx, ny
- real t, x(nx), y(ny), u(nx, ny, nu), ut(nx, ny, nu), ux(nx, ny,
- 1 nu)
- real uy(nx, ny, nu), uxt(nx, ny, nu), uyt(nx, ny, nu), a(nx, ny,
- 1 nu, 2), au(nx, ny, nu, nu, 2), aut(nx, ny, nu, nu, 2)
- real aux(nx, ny, nu, nu, 2), auy(nx, ny, nu, nu, 2), auxt(nx, ny
- 1 , nu, nu, 2), auyt(nx, ny, nu, nu, 2), f(nx, ny, nu), fu(nx,
- 2 ny, nu, nu)
- real fut(nx, ny, nu, nu), fux(nx, ny, nu, nu), fuy(nx, ny, nu, nu)
- 1 , fuxt(nx, ny, nu, nu), fuyt(nx, ny, nu, nu)
- integer i, p, q
- do 3 i = 1, nu
- do 2 q = 1, ny
- do 1 p = 1, nx
- a(p, q, i, 1) = ux(p, q, i)+.1*uy(p, q, i)+u(p, q, i)
- a(p, q, i, 2) = uy(p, q, i)+.1*ux(p, q, i)+u(p, q, i)
- aux(p, q, i, i, 1) = 1
- auy(p, q, i, i, 2) = 1
- auy(p, q, i, i, 1) = .1
- aux(p, q, i, i, 2) = .1
- au(p, q, i, i, 1) = 1
- au(p, q, i, i, 2) = 1
- f(p, q, i) = ut(p, q, i)+ux(p, q, i)+uy(p, q, i)
- fut(p, q, i, i) = 1
- fux(p, q, i, i) = 1
- fuy(p, q, i, i) = 1
- f(p, q, i) = f(p, q, i)+.2*t-x(p)*y(q)
- 1 continue
- 2 continue
- 3 continue
- return
- end
- subroutine bc(t, x, nx, y, ny, lx, rx, ly, ry, u, ut, ux,
- 1 uy, uxt, uyt, nu, b, bu, but, bux, buy, buxt, buyt)
- integer nu, nx, ny
- real t, x(nx), y(ny), lx, rx, ly
- real ry, u(nx, ny, nu), ut(nx, ny, nu), ux(nx, ny, nu), uy(nx, ny,
- 1 nu), uxt(nx, ny, nu)
- real uyt(nx, ny, nu), b(nx, ny, nu), bu(nx, ny, nu, nu), but(nx,
- 1 ny, nu, nu), bux(nx, ny, nu, nu), buy(nx, ny, nu, nu)
- real buxt(nx, ny, nu, nu), buyt(nx, ny, nu, nu)
- integer i, j
- do 2 j = 1, ny
- do 1 i = 1, nx
- bu(i, j, 1, 1) = 1
- b(i, j, 1) = u(i, j, 1)-t*x(i)*y(j)
- 1 continue
- 2 continue
- return
- end
- subroutine handle(t0, u0, t, u, nv, dt, tstop)
- integer nv
- real t0, u0(nv), t, u(nv), dt, tstop
- common /a7tgrp/ errpar, nu, mxq, myq
- integer nu, mxq, myq
- real errpar(2)
- common /a7tgrm/ kx, ix, nx, ky, iy, ny
- integer kx, ix, nx, ky, iy, ny
- if (t0 .ne. t) goto 2
- write (6, 1) t
- 1 format (16h restart for t =, 1pe10.2)
- return
-c print results.
- 2 call gerr(kx, ix, nx, ky, iy, ny, u, nu, t)
- return
- end
- subroutine gerr(kx, ix, nx, ky, iy, ny, u, nu, t)
- integer kx, ix, nx, ky, iy, ny
- integer nu
- real u(1), t
- common /cstak/ ds
- double precision ds(500)
- integer ifa, ita(2), ixa(2), nta(2), nxa(2), ixs
- integer iys, nxs, nys, istkgt, i, ka(2)
- integer ma(2), is(1000), ilumd, i1mach
- real rs(1000), ws(1000)
- logical ls(1000)
- complex cs(500)
- integer temp, temp1
- equivalence (ds(1), cs(1), ws(1), rs(1), is(1), ls(1))
-c to print the solution at each time-step.
-c u(nx-kx,ny,ky,nu).
-c the port library stack and its aliases.
- call enter(1)
-c find the solution at 2 * 2 points / mesh rectangle.
-c x search grid.
- ixs = ilumd(ws(ix), nx, 2, nxs)
-c y search grid.
- iys = ilumd(ws(iy), ny, 2, nys)
- ka(1) = kx
- ka(2) = ky
- ita(1) = ix
- ita(2) = iy
- nta(1) = nx
- nta(2) = ny
- ixa(1) = ixs
- ixa(2) = iys
- nxa(1) = nxs
- nxa(2) = nys
- ma(1) = 0
-c get solution.
- ma(2) = 0
-c approximate solution values.
- ifa = istkgt(nxs*nys, 3)
-c evaluate them.
- call tsd1(2, ka, ws, ita, nta, u, ws, ixa, nxa, ma, ws(ifa))
- temp1 = ifa+nxs*nys-1
- temp = i1mach(2)
- write (temp, 1) t, (ws(i), i = ifa, temp1)
- 1 format (3h u(, 1pe10.2, 7h,.,.) =, (1p5e10.2/20x,1p4e10.2))
- call leave
- return
- end
- subroutine ewe(t, x, nx, y, ny, u, nu)
- integer nu, nx, ny
- real t, x(nx), y(ny), u(nx, ny, nu)
- integer i, j, p
-c the exact solution.
- do 3 p = 1, nu
- do 2 i = 1, nx
- do 1 j = 1, ny
- u(i, j, p) = t*x(i)*y(j)
- 1 continue
- 2 continue
- 3 continue
- return
- end
diff --git a/CEP/PyBDSM/src/port3/ttgrx2.f b/CEP/PyBDSM/src/port3/ttgrx2.f
deleted file mode 100644
index 12898df133c27a46d21da5929f7aaca7c7946510..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ttgrx2.f
+++ /dev/null
@@ -1,192 +0,0 @@
-C$TEST TTGR2
-c main program
- common /cstak/ ds
- double precision ds(350000)
- external handle, bc, af
- integer ndx, ndy, istkgt, iumb, is(1000), iu
- integer ix, iy, nu, kx, nx, ky
- integer ny
- real errpar(2), tstart, dt, lx, ly, rx
- real ry, ws(1000), rs(1000), tstop
- logical ls(1000)
- complex cs(500)
- equivalence (ds(1), cs(1), ws(1), rs(1), is(1), ls(1))
-c to solve two coupled, nonlinear heat equations.
-c u1 sub t = div . ( u1x, u1y ) - u1*u2 + g1
-c u2 sub t = div . ( u2x, u2y ) - u1*u2 + g2
-c the port library stack and its aliases.
-c initialize the port library stack length.
- call istkin(350000, 4)
- call enter(1)
- nu = 2
- lx = 0
- rx = 1
- ly = 0
- ry = 1
- kx = 4
- ky = 4
- ndx = 3
- ndy = 3
- tstart = 0
- tstop = 1
- dt = 1e-2
- errpar(1) = 1e-2
- errpar(2) = 1e-4
-c uniform grid.
- ix = iumb(lx, rx, ndx, kx, nx)
-c uniform grid.
- iy = iumb(ly, ry, ndy, ky, ny)
-c space for the solution.
- iu = istkgt(nu*(nx-kx)*(ny-ky), 3)
- call setr(nu*(nx-kx)*(ny-ky), 1e0, ws(iu))
- call ttgr(ws(iu), nu, kx, ws(ix), nx, ky, ws(iy), ny, tstart,
- 1 tstop, dt, af, bc, errpar, handle)
- call leave
- call wrapup
- stop
- end
- subroutine af(t, x, nx, y, ny, nu, u, ut, ux, uy, uxt, uyt
- 1 , a, au, aut, aux, auy, auxt, auyt, f, fu, fut, fux, fuy, fuxt,
- 2 fuyt)
- integer nu, nx, ny
- real t, x(nx), y(ny), u(nx, ny, nu), ut(nx, ny, nu), ux(nx, ny,
- 1 nu)
- real uy(nx, ny, nu), uxt(nx, ny, nu), uyt(nx, ny, nu), a(nx, ny,
- 1 nu, 2), au(nx, ny, nu, nu, 2), aut(nx, ny, nu, nu, 2)
- real aux(nx, ny, nu, nu, 2), auy(nx, ny, nu, nu, 2), auxt(nx, ny
- 1 , nu, nu, 2), auyt(nx, ny, nu, nu, 2), f(nx, ny, nu), fu(nx,
- 2 ny, nu, nu)
- real fut(nx, ny, nu, nu), fux(nx, ny, nu, nu), fuy(nx, ny, nu, nu)
- 1 , fuxt(nx, ny, nu, nu), fuyt(nx, ny, nu, nu)
- integer p, q
- real exp
- do 2 q = 1, ny
- do 1 p = 1, nx
- a(p, q, 1, 1) = ux(p, q, 1)
- aux(p, q, 1, 1, 1) = 1
- a(p, q, 1, 2) = uy(p, q, 1)
- auy(p, q, 1, 1, 2) = 1
- f(p, q, 1) = ut(p, q, 1)+u(p, q, 1)*u(p, q, 2)
- fu(p, q, 1, 1) = u(p, q, 2)
- fu(p, q, 1, 2) = u(p, q, 1)
- fut(p, q, 1, 1) = 1
- a(p, q, 2, 1) = ux(p, q, 2)
- aux(p, q, 2, 2, 1) = 1
- a(p, q, 2, 2) = uy(p, q, 2)
- auy(p, q, 2, 2, 2) = 1
- f(p, q, 2) = ut(p, q, 2)+u(p, q, 1)*u(p, q, 2)
- fu(p, q, 2, 1) = u(p, q, 2)
- fu(p, q, 2, 2) = u(p, q, 1)
- fut(p, q, 2, 2) = 1
- f(p, q, 1) = f(p, q, 1)-(exp(t*(x(p)-y(q)))*(x(p)-y(q)-2.*t*
- 1 t)+1.)
- f(p, q, 2) = f(p, q, 2)-(exp(t*(y(q)-x(p)))*(y(q)-x(p)-2.*t*
- 1 t)+1.)
- 1 continue
- 2 continue
- return
- end
- subroutine bc(t, x, nx, y, ny, lx, rx, ly, ry, u, ut, ux,
- 1 uy, uxt, uyt, nu, b, bu, but, bux, buy, buxt, buyt)
- integer nu, nx, ny
- real t, x(nx), y(ny), lx, rx, ly
- real ry, u(nx, ny, nu), ut(nx, ny, nu), ux(nx, ny, nu), uy(nx, ny,
- 1 nu), uxt(nx, ny, nu)
- real uyt(nx, ny, nu), b(nx, ny, nu), bu(nx, ny, nu, nu), but(nx,
- 1 ny, nu, nu), bux(nx, ny, nu, nu), buy(nx, ny, nu, nu)
- real buxt(nx, ny, nu, nu), buyt(nx, ny, nu, nu)
- integer i, j
- real exp
- do 2 j = 1, ny
- do 1 i = 1, nx
- bu(i, j, 1, 1) = 1
- b(i, j, 1) = u(i, j, 1)-exp(t*(x(i)-y(j)))
- bu(i, j, 2, 2) = 1
- b(i, j, 2) = u(i, j, 2)-exp(t*(y(j)-x(i)))
- 1 continue
- 2 continue
- return
- end
- subroutine handle(t0, u0, t, u, nv, dt, tstop)
- integer nv
- real t0, u0(nv), t, u(nv), dt, tstop
- common /cstak/ ds
- double precision ds(500)
- common /a7tgrp/ errpar, nu, mxq, myq
- integer nu, mxq, myq
- real errpar(2)
- common /a7tgrm/ kx, ix, nx, ky, iy, ny
- integer kx, ix, nx, ky, iy, ny
- integer ifa, ita(2), ixa(2), nta(2), nxa(2), ixs
- integer iys, nxs, nys, istkgt, i, j
- integer iewe, ka(2), ma(2), is(1000), ilumd, i1mach
- real abs, erru, amax1, rs(1000), ws(1000)
- logical ls(1000)
- complex cs(500)
- integer temp, temp1, temp2
- equivalence (ds(1), cs(1), ws(1), rs(1), is(1), ls(1))
-c the port library stack and its aliases.
- if (t0 .ne. t) goto 2
- write (6, 1) t
- 1 format (16h restart for t =, 1pe10.2)
- return
- 2 call enter(1)
-c find the error in the solution at 2*kx * 2*ky points / mesh rectangle.
-c x search grid.
- ixs = ilumd(ws(ix), nx, 2*kx, nxs)
-c y search grid.
- iys = ilumd(ws(iy), ny, 2*ky, nys)
-c u search grid values.
- iewe = istkgt(nu*nxs*nys, 3)
-c the exact solution.
- call ewe(t, ws(ixs), nxs, ws(iys), nys, ws(iewe), nu)
- ka(1) = kx
- ka(2) = ky
- ita(1) = ix
- ita(2) = iy
- nta(1) = nx
- nta(2) = ny
- ixa(1) = ixs
- ixa(2) = iys
- nxa(1) = nxs
- nxa(2) = nys
- ma(1) = 0
-c get solution.
- ma(2) = 0
-c approximate solution values.
- ifa = istkgt(nxs*nys, 3)
- do 5 j = 1, nu
-c evaluate them.
- temp = (j-1)*(nx-kx)*(ny-ky)
- call tsd1(2, ka, ws, ita, nta, u(temp+1), ws, ixa, nxa, ma, ws(
- 1 ifa))
-c error in solution values.
- erru = 0
- temp = nxs*nys
- do 3 i = 1, temp
- temp2 = iewe+i-1+(j-1)*nxs*nys
- temp1 = ifa+i
- erru = amax1(erru, abs(ws(temp2)-ws(temp1-1)))
- 3 continue
- temp = i1mach(2)
- write (temp, 4) t, j, erru
- 4 format (14h error in u(.,, 1pe10.2, 1h,, i2, 3h) =, 1pe10.2)
- 5 continue
- call leave
- return
- end
- subroutine ewe(t, x, nx, y, ny, u, nu)
- integer nu, nx, ny
- real t, x(nx), y(ny), u(nx, ny, nu)
- integer i, j, p
- real exp, float
-c the exact solution.
- do 3 p = 1, nu
- do 2 i = 1, nx
- do 1 j = 1, ny
- u(i, j, p) = exp(float((-1)**(p+1))*t*(x(i)-y(j)))
- 1 continue
- 2 continue
- 3 continue
- return
- end
diff --git a/CEP/PyBDSM/src/port3/ttgrx3.f b/CEP/PyBDSM/src/port3/ttgrx3.f
deleted file mode 100644
index a8d8f7b9b51213ee3e124f28c836af24f162da59..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ttgrx3.f
+++ /dev/null
@@ -1,226 +0,0 @@
-C$TEST TTGR3
-c main program
- common /cstak/ ds
- double precision ds(350000)
- external handle, bc, af
- integer ndx, ndy, istkgt, i, iumb, immm
- integer is(1000), iu, ix, iy, nu, kx
- integer nx, ky, ny, ilumb
- real errpar(2), tstart, dt, yb(4), lx, rs(1000)
- real rx, ws(1000), tstop
- logical ls(1000)
- complex cs(500)
- equivalence (ds(1), cs(1), ws(1), rs(1), is(1), ls(1))
-c to solve the layered heat equation, with kappa = 1, 1/2, 1/3,
-c div . ( kappa(x,y) * grad u ) = ut + g
-c the port library stack and its aliases.
-c initialize the port library stack length.
- call istkin(350000, 4)
- call enter(1)
- nu = 1
- lx = 0
- rx = 1
- do 1 i = 1, 4
- yb(i) = i-1
- 1 continue
- kx = 2
- ky = 2
- ndx = 3
- ndy = 3
- tstart = 0
- tstop = 1
- dt = 1
- errpar(1) = 1e-2
- errpar(2) = 1e-4
-c uniform grid.
- ix = iumb(lx, rx, ndx, kx, nx)
-c uniform grid.
- iy = ilumb(yb, 4, ndy, ky, ny)
-c make mult = ky-1.
- iy = immm(iy, ny, yb(2), ky-1)
-c make mult = ky-1.
- iy = immm(iy, ny, yb(3), ky-1)
-c space for the solution.
- iu = istkgt(nu*(nx-kx)*(ny-ky), 3)
- call setr(nu*(nx-kx)*(ny-ky), 0e0, ws(iu))
- call ttgr(ws(iu), nu, kx, ws(ix), nx, ky, ws(iy), ny, tstart,
- 1 tstop, dt, af, bc, errpar, handle)
- call leave
- call wrapup
- stop
- end
- subroutine af(t, x, nx, y, ny, nu, u, ut, ux, uy, uxt, uyt
- 1 , a, au, aut, aux, auy, auxt, auyt, f, fu, fut, fux, fuy, fuxt,
- 2 fuyt)
- integer nu, nx, ny
- real t, x(nx), y(ny), u(nx, ny, nu), ut(nx, ny, nu), ux(nx, ny,
- 1 nu)
- real uy(nx, ny, nu), uxt(nx, ny, nu), uyt(nx, ny, nu), a(nx, ny,
- 1 nu, 2), au(nx, ny, nu, nu, 2), aut(nx, ny, nu, nu, 2)
- real aux(nx, ny, nu, nu, 2), auy(nx, ny, nu, nu, 2), auxt(nx, ny
- 1 , nu, nu, 2), auyt(nx, ny, nu, nu, 2), f(nx, ny, nu), fu(nx,
- 2 ny, nu, nu)
- real fut(nx, ny, nu, nu), fux(nx, ny, nu, nu), fuy(nx, ny, nu, nu)
- 1 , fuxt(nx, ny, nu, nu), fuyt(nx, ny, nu, nu)
- integer i, p, q
- real kappa
- logical temp
- do 7 i = 1, nu
- do 6 q = 1, ny
- do 5 p = 1, nx
- if (y(q) .ge. 1.) goto 1
- kappa = 1
- goto 4
- 1 if (y(q) .ge. 2.) goto 2
- kappa = 0.5
- goto 3
- 2 kappa = 1./3e0
- 3 continue
- 4 a(p, q, i, 1) = kappa*ux(p, q, i)
- aux(p, q, i, i, 1) = kappa
- a(p, q, i, 2) = kappa*uy(p, q, i)
- auy(p, q, i, i, 2) = kappa
- f(p, q, i) = ut(p, q, i)
- fut(p, q, i, i) = 1
- f(p, q, i) = f(p, q, i)-y(q)/kappa
- temp = 1. .lt. y(q)
- if (temp) temp = y(q) .lt. 2.
- if (temp) f(p, q, i) = f(p, q, i)+1.
- temp = 2. .lt. y(q)
- if (temp) temp = y(q) .lt. 3.
- if (temp) f(p, q, i) = f(p, q, i)+3.
- 5 continue
- 6 continue
- 7 continue
- return
- end
- subroutine bc(t, x, nx, y, ny, lx, rx, ly, ry, u, ut, ux,
- 1 uy, uxt, uyt, nu, b, bu, but, bux, buy, buxt, buyt)
- integer nu, nx, ny
- real t, x(nx), y(ny), lx, rx, ly
- real ry, u(nx, ny, nu), ut(nx, ny, nu), ux(nx, ny, nu), uy(nx, ny,
- 1 nu), uxt(nx, ny, nu)
- real uyt(nx, ny, nu), b(nx, ny, nu), bu(nx, ny, nu, nu), but(nx,
- 1 ny, nu, nu), bux(nx, ny, nu, nu), buy(nx, ny, nu, nu)
- real buxt(nx, ny, nu, nu), buyt(nx, ny, nu, nu)
- integer i, j
- logical temp
- do 6 j = 1, ny
- do 5 i = 1, nx
- temp = x(i) .eq. lx
- if (.not. temp) temp = x(i) .eq. rx
- if (.not. temp) goto 1
- bux(i, j, 1, 1) = 1
-c left or right.
-c neumann bcs.
- b(i, j, 1) = ux(i, j, 1)
- goto 4
- 1 if (y(j) .ne. ly) goto 2
- b(i, j, 1) = u(i, j, 1)
-c bottom.
- bu(i, j, 1, 1) = 1
- goto 3
- 2 b(i, j, 1) = u(i, j, 1)-6.*t
-c top.
- bu(i, j, 1, 1) = 1
- 3 continue
- 4 continue
- 5 continue
- 6 continue
- return
- end
- subroutine handle(t0, u0, t, u, nv, dt, tstop)
- integer nv
- real t0, u0(nv), t, u(nv), dt, tstop
- common /a7tgrp/ errpar, nu, mxq, myq
- integer nu, mxq, myq
- real errpar(2)
- common /a7tgrm/ kx, ix, nx, ky, iy, ny
- integer kx, ix, nx, ky, iy, ny
- if (t0 .ne. t) goto 2
- write (6, 1) t
- 1 format (16h restart for t =, 1pe10.2)
- return
- 2 call gerr(kx, ix, nx, ky, iy, ny, u, nu, t)
- return
- end
- subroutine gerr(kx, ix, nx, ky, iy, ny, u, nu, t)
- integer kx, ix, nx, ky, iy, ny
- integer nu
- real u(1), t
- common /cstak/ ds
- double precision ds(500)
- integer ifa, ita(2), ixa(2), nta(2), nxa(2), ixs
- integer iys, nxs, nys, istkgt, i, iewe
- integer ka(2), ma(2), is(1000), ilumd, i1mach
- real abs, erru, amax1, rs(1000), ws(1000)
- logical ls(1000)
- complex cs(500)
- integer temp, temp1, temp2
- equivalence (ds(1), cs(1), ws(1), rs(1), is(1), ls(1))
-c to get and print the error at each time-step.
-c u(nx-kx,ny,ky,nu).
-c the port library stack and its aliases.
- call enter(1)
-c find the error in the solution at 2*kx * 2*ky points / mesh rectangle.
-c x search grid.
- ixs = ilumd(ws(ix), nx, 2*kx, nxs)
-c y search grid.
- iys = ilumd(ws(iy), ny, 2*ky, nys)
-c u search grid values.
- iewe = istkgt(nxs*nys, 3)
-c the exact solution.
- call ewe(t, ws(ixs), nxs, ws(iys), nys, ws(iewe), nu)
- ka(1) = kx
- ka(2) = ky
- ita(1) = ix
- ita(2) = iy
- nta(1) = nx
- nta(2) = ny
- ixa(1) = ixs
- ixa(2) = iys
- nxa(1) = nxs
- nxa(2) = nys
- ma(1) = 0
-c get solution.
- ma(2) = 0
-c approximate solution values.
- ifa = istkgt(nxs*nys, 3)
-c evaluate them.
- call tsd1(2, ka, ws, ita, nta, u, ws, ixa, nxa, ma, ws(ifa))
-c error in solution values.
- erru = 0
- temp = nxs*nys
- do 1 i = 1, temp
- temp2 = iewe+i
- temp1 = ifa+i
- erru = amax1(erru, abs(ws(temp2-1)-ws(temp1-1)))
- 1 continue
- temp = i1mach(2)
- write (temp, 2) t, erru
- 2 format (14h error in u(.,, 1pe10.2, 3h) =, 1pe10.2)
- call leave
- return
- end
- subroutine ewe(t, x, nx, y, ny, u, nu)
- integer nu, nx, ny
- real t, x(nx), y(ny), u(nx, ny, nu)
- integer i, j, p
-c the exact solution.
- do 7 p = 1, nu
- do 6 i = 1, nx
- do 5 j = 1, ny
- if (y(j) .ge. 1.) goto 1
- u(i, j, p) = t*y(j)
- goto 4
- 1 if (y(j) .ge. 2.) goto 2
- u(i, j, p) = 2.*t*y(j)-t
- goto 3
- 2 u(i, j, p) = 3.*t*y(j)-3.*t
- 3 continue
- 4 continue
- 5 continue
- 6 continue
- 7 continue
- return
- end
diff --git a/CEP/PyBDSM/src/port3/ttgrx4.f b/CEP/PyBDSM/src/port3/ttgrx4.f
deleted file mode 100644
index 3c0e208d473e4eabac27a3bffff156ab30c5a0ea..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ttgrx4.f
+++ /dev/null
@@ -1,256 +0,0 @@
-C$TEST TTGR4
-c main program
- common /cstak/ ds
- double precision ds(350000)
- external handle, bc, af
- integer ndx, ndy, istkgt, iumb, is(1000), iu
- integer ix, iy, nu, kx, nx, ky
- integer ny
- real errpar(2), tstart, dt, lx, ly, rx
- real ry, ws(1000), rs(1000), tstop
- logical ls(1000)
- complex cs(500)
- equivalence (ds(1), cs(1), ws(1), rs(1), is(1), ls(1))
-c to solve the linear heat equation
-c grad . ( ux - 0.1 * uy , 0.1*ux + uy ) = ut - x*y
-c with solution u == t*x*y on [0,+1]**2, exact for k = 4,
-c with tilted top and bottom, normal bcs there.
-c the port library stack and its aliases.
-c initialize the port library stack length.
- call istkin(350000, 4)
- call enter(1)
- nu = 1
- lx = 0
- rx = 1
- ly = 0
- ry = 1
- kx = 4
- ky = 4
- ndx = 3
- ndy = 3
- tstart = 0
- tstop = 1
- dt = 1
- errpar(1) = 1e-2
- errpar(2) = 1e-4
-c uniform grid.
- ix = iumb(lx, rx, ndx, kx, nx)
-c uniform grid.
- iy = iumb(ly, ry, ndy, ky, ny)
-c space for the solution.
- iu = istkgt(nu*(nx-kx)*(ny-ky), 3)
- call setr(nu*(nx-kx)*(ny-ky), 0e0, ws(iu))
- call ttgr(ws(iu), nu, kx, ws(ix), nx, ky, ws(iy), ny, tstart,
- 1 tstop, dt, af, bc, errpar, handle)
- call leave
- call wrapup
- stop
- end
- subroutine af(t, xi, nx, yi, ny, nu, u, ut, ux, uy, uxt,
- 1 uyt, a, au, aut, aux, auy, auxt, auyt, f, fu, fut, fux, fuy,
- 2 fuxt, fuyt)
- integer nu, nx, ny
- real t, xi(nx), yi(ny), u(nx, ny, nu), ut(nx, ny, nu), ux(nx, ny
- 1 , nu)
- real uy(nx, ny, nu), uxt(nx, ny, nu), uyt(nx, ny, nu), a(nx, ny,
- 1 nu, 2), au(nx, ny, nu, nu, 2), aut(nx, ny, nu, nu, 2)
- real aux(nx, ny, nu, nu, 2), auy(nx, ny, nu, nu, 2), auxt(nx, ny
- 1 , nu, nu, 2), auyt(nx, ny, nu, nu, 2), f(nx, ny, nu), fu(nx,
- 2 ny, nu, nu)
- real fut(nx, ny, nu, nu), fux(nx, ny, nu, nu), fuy(nx, ny, nu, nu)
- 1 , fuxt(nx, ny, nu, nu), fuyt(nx, ny, nu, nu)
- external bt, lr
- integer i, p, q
- real d(600), x, y, xx(100), yy(100)
- integer temp
- if (nx*ny .gt. 100) call seterr(19haf - nx*ny .gt. 100, 19, 1, 2)
- call btmap(t, xi, yi, nx, ny, lr, bt, xx, yy, d)
-c map into (x,y).
- call ttgru(nx, ny, d, ux, uy, ut, nu)
- do 3 i = 1, nu
- do 2 q = 1, ny
- do 1 p = 1, nx
- temp = p+(q-1)*nx
- x = xx(temp)
- temp = p+(q-1)*nx
- y = yy(temp)
- a(p, q, i, 1) = ux(p, q, i)-.1*uy(p, q, i)
- a(p, q, i, 2) = uy(p, q, i)+.1*ux(p, q, i)
- aux(p, q, i, i, 1) = 1
- auy(p, q, i, i, 2) = 1
- auy(p, q, i, i, 1) = -.1
- aux(p, q, i, i, 2) = .1
- f(p, q, 1) = ut(p, q, 1)-x*y
- fut(p, q, 1, 1) = 1
- 1 continue
- 2 continue
- 3 continue
-c map into (xi,eta).
- call ttgrg(nx, ny, d, nu, a, au, aux, auy, f, fu, fux, fuy)
- return
- end
- subroutine bc(t, xi, nx, yi, ny, lx, rx, ly, ry, u, ut, ux
- 1 , uy, uxt, uyt, nu, b, bu, but, bux, buy, buxt, buyt)
- integer nu, nx, ny
- real t, xi(nx), yi(ny), lx, rx, ly
- real ry, u(nx, ny, nu), ut(nx, ny, nu), ux(nx, ny, nu), uy(nx, ny,
- 1 nu), uxt(nx, ny, nu)
- real uyt(nx, ny, nu), b(nx, ny, nu), bu(nx, ny, nu, nu), but(nx,
- 1 ny, nu, nu), bux(nx, ny, nu, nu), buy(nx, ny, nu, nu)
- real buxt(nx, ny, nu, nu), buyt(nx, ny, nu, nu)
- external bt, lr
- integer i, j
- real d(600), x, y, xx(100), yy(100)
- integer temp1
- logical temp
- if (nx*ny .gt. 100) call seterr(19hbc - nx*ny .gt. 100, 19, 1, 2)
- call btmap(t, xi, yi, nx, ny, lr, bt, xx, yy, d)
-c map into (x,y).
- call ttgru(nx, ny, d, ux, uy, ut, nu)
- do 6 j = 1, ny
- do 5 i = 1, nx
- temp1 = i+(j-1)*nx
- x = xx(temp1)
- temp1 = i+(j-1)*nx
- y = yy(temp1)
- temp = xi(i) .eq. lx
- if (.not. temp) temp = xi(i) .eq. rx
- if (.not. temp) goto 1
- bu(i, j, 1, 1) = 1
-c left or right.
- b(i, j, 1) = u(i, j, 1)-t*x*y
- goto 4
- 1 if (yi(j) .ne. ly) goto 2
- b(i, j, 1) = (ux(i, j, 1)-t*y)-(uy(i, j, 1)-t*x)
-c bottom.
- bux(i, j, 1, 1) = 1
-c normal is (1,-1).
- buy(i, j, 1, 1) = -1
- goto 3
- 2 b(i, j, 1) = (uy(i, j, 1)-t*x)-(ux(i, j, 1)-t*y)
-c top.
- bux(i, j, 1, 1) = -1
-c normal is (-1,1).
- buy(i, j, 1, 1) = 1
- 3 continue
- 4 continue
- 5 continue
- 6 continue
-c map into (xi,eta).
- call ttgrb(nx, ny, d, nu, bux, buy, but)
- return
- end
- subroutine handle(t0, u0, t, u, nv, dt, tstop)
- integer nv
- real t0, u0(nv), t, u(nv), dt, tstop
- common /a7tgrp/ errpar, nu, mxq, myq
- integer nu, mxq, myq
- real errpar(2)
- common /a7tgrm/ kx, ix, nx, ky, iy, ny
- integer kx, ix, nx, ky, iy, ny
- if (t0 .ne. t) goto 2
- write (6, 1) t
- 1 format (16h restart for t =, 1pe10.2)
- return
- 2 call gerr(kx, ix, nx, ky, iy, ny, u, nu, t)
- return
- end
- subroutine gerr(kx, ix, nx, ky, iy, ny, u, nu, t)
- integer kx, ix, nx, ky, iy, ny
- integer nu
- real u(1), t
- common /cstak/ ds
- double precision ds(500)
- integer ifa, ita(2), ixa(2), nta(2), nxa(2), ixs
- integer iys, nxs, nys, istkgt, i, iewe
- integer ka(2), ma(2), is(1000), ilumd, i1mach
- real abs, erru, amax1, rs(1000), ws(1000)
- logical ls(1000)
- complex cs(500)
- integer temp, temp1, temp2
- equivalence (ds(1), cs(1), ws(1), rs(1), is(1), ls(1))
-c to get and print the error at each time-step.
-c u(nx-kx,ny-ky,nu).
-c the port library stack and its aliases.
- call enter(1)
-c find the error in the solution at 2*kx * 2*ky points / mesh rectangle.
-c x search grid.
- ixs = ilumd(ws(ix), nx, 2*kx, nxs)
-c y search grid.
- iys = ilumd(ws(iy), ny, 2*ky, nys)
-c u search grid values.
- iewe = istkgt(nxs*nys, 3)
-c the exact solution.
- call ewe(t, ws(ixs), nxs, ws(iys), nys, ws(iewe), nu)
- ka(1) = kx
- ka(2) = ky
- ita(1) = ix
- ita(2) = iy
- nta(1) = nx
- nta(2) = ny
- ixa(1) = ixs
- ixa(2) = iys
- nxa(1) = nxs
- nxa(2) = nys
- ma(1) = 0
-c get solution.
- ma(2) = 0
-c approximate solution values.
- ifa = istkgt(nxs*nys, 3)
-c evaluate them.
- call tsd1(2, ka, ws, ita, nta, u, ws, ixa, nxa, ma, ws(ifa))
-c error in solution values.
- erru = 0
- temp = nxs*nys
- do 1 i = 1, temp
- temp2 = iewe+i
- temp1 = ifa+i
- erru = amax1(erru, abs(ws(temp2-1)-ws(temp1-1)))
- 1 continue
- temp = i1mach(2)
- write (temp, 2) t, erru
- 2 format (14h error in u(.,, 1pe10.2, 3h) =, 1pe10.2)
- call leave
- return
- end
- subroutine ewe(t, xi, nx, yi, ny, u, nu)
- integer nu, nx, ny
- real t, xi(nx), yi(ny), u(nx, ny, nu)
- external bt, lr
- integer i, j, p
- real d(6000), x, y, xx(1000), yy(1000)
-c the exact solution.
- if (ny .gt. 1000) call seterr(18hewe - ny .gt. 1000, 18, 1, 2)
- do 3 p = 1, nu
- do 2 i = 1, nx
- call btmap(t, xi(i), yi, 1, ny, lr, bt, xx, yy, d)
- do 1 j = 1, ny
- x = xx(j)
- y = yy(j)
- u(i, j, p) = t*x*y
- 1 continue
- 2 continue
- 3 continue
- return
- end
- subroutine lr(t, lx, rx, lxt, rxt)
- real t, lx, rx, lxt, rxt
-c to get the l and r end-points of the mapping in x.
- lx = 0
- rx = 1
- lxt = 0
- rxt = 0
- return
- end
- subroutine bt(t, x, f, g, fx, gx, ft, gt)
- real t, x, f, g, fx, gx
- real ft, gt
-c to get the bottom and top of mapping in y.
- f = x-1.
- g = x
- ft = 0
- gt = 0
- fx = 1
- gx = 1
- return
- end
diff --git a/CEP/PyBDSM/src/port3/ttgrx5.f b/CEP/PyBDSM/src/port3/ttgrx5.f
deleted file mode 100644
index 8e5abf32a30fe6b36ff4c2dd94ca41eba0650b80..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ttgrx5.f
+++ /dev/null
@@ -1,229 +0,0 @@
-C$TEST TTGR5
-c main program
- common /cstak/ ds
- double precision ds(350000)
- external handle, bc, af
- integer ndx, ndy, istkgt, i, is(1000), iu
- integer ix, iy, nu, kx, nx, ky
- integer ny
- real errpar(2), tstart, dt, lx, ly, rx
- real ry, ws(1000), rs(1000), float, tstop
- logical ls(1000)
- complex cs(500)
- integer temp, temp1
- equivalence (ds(1), cs(1), ws(1), rs(1), is(1), ls(1))
-c to solve laplaces equation with real ( z*log(z) ) as solution.
-c the port library stack and its aliases.
-c initialize the port library stack length.
- call istkin(350000, 4)
- call enter(1)
- nu = 1
- lx = 0
- rx = 1
- ly = 0
- ry = 1
- kx = 4
- ky = 4
- ndx = 2
- ndy = 2
- tstart = 0
- tstop = 1
- dt = 1
- errpar(1) = 1e-2
- errpar(2) = 1e-4
- nx = ndx+2*(kx-1)
-c space for x mesh.
- ix = istkgt(nx, 3)
- do 1 i = 1, kx
- temp = ix+i
- ws(temp-1) = 0
- temp = ix+nx-i
- ws(temp) = rx
- 1 continue
-c 0 and rx mult = kx.
- temp = ndx-1
- do 2 i = 1, temp
- temp1 = ix+kx-2+i
- ws(temp1) = rx*(float(i-1)/(float(ndx)-1e0))**kx
- 2 continue
- ny = ndy+2*(ky-1)
-c space for y mesh.
- iy = istkgt(ny, 3)
- do 3 i = 1, ky
- temp = iy+i
- ws(temp-1) = 0
- temp = iy+ny-i
- ws(temp) = ry
- 3 continue
-c 0 and ry mult = ky.
- temp = ndy-1
- do 4 i = 1, temp
- temp1 = iy+ky-2+i
- ws(temp1) = ry*(float(i-1)/(float(ndy)-1e0))**ky
- 4 continue
-c space for the solution.
- iu = istkgt(nu*(nx-kx)*(ny-ky), 3)
- call setr(nu*(nx-kx)*(ny-ky), 0e0, ws(iu))
- call ttgr(ws(iu), nu, kx, ws(ix), nx, ky, ws(iy), ny, tstart,
- 1 tstop, dt, af, bc, errpar, handle)
- call leave
- call wrapup
- stop
- end
- subroutine af(t, xi, nx, yi, ny, nu, u, ut, ux, uy, uxt,
- 1 uyt, a, au, aut, aux, auy, auxt, auyt, f, fu, fut, fux, fuy,
- 2 fuxt, fuyt)
- integer nu, nx, ny
- real t, xi(nx), yi(ny), u(nx, ny, nu), ut(nx, ny, nu), ux(nx, ny
- 1 , nu)
- real uy(nx, ny, nu), uxt(nx, ny, nu), uyt(nx, ny, nu), a(nx, ny,
- 1 nu, 2), au(nx, ny, nu, nu, 2), aut(nx, ny, nu, nu, 2)
- real aux(nx, ny, nu, nu, 2), auy(nx, ny, nu, nu, 2), auxt(nx, ny
- 1 , nu, nu, 2), auyt(nx, ny, nu, nu, 2), f(nx, ny, nu), fu(nx,
- 2 ny, nu, nu)
- real fut(nx, ny, nu, nu), fux(nx, ny, nu, nu), fuy(nx, ny, nu, nu)
- 1 , fuxt(nx, ny, nu, nu), fuyt(nx, ny, nu, nu)
- integer i, p, q
- do 3 i = 1, nu
- do 2 q = 1, ny
- do 1 p = 1, nx
- a(p, q, i, 1) = ux(p, q, i)
- a(p, q, i, 2) = uy(p, q, i)
- aux(p, q, i, i, 1) = 1
- auy(p, q, i, i, 2) = 1
- 1 continue
- 2 continue
- 3 continue
- return
- end
- subroutine bc(t, x, nx, y, ny, lx, rx, ly, ry, u, ut, ux,
- 1 uy, uxt, uyt, nu, b, bu, but, bux, buy, buxt, buyt)
- integer nu, nx, ny
- real t, x(nx), y(ny), lx, rx, ly
- real ry, u(nx, ny, nu), ut(nx, ny, nu), ux(nx, ny, nu), uy(nx, ny,
- 1 nu), uxt(nx, ny, nu)
- real uyt(nx, ny, nu), b(nx, ny, nu), bu(nx, ny, nu, nu), but(nx,
- 1 ny, nu, nu), bux(nx, ny, nu, nu), buy(nx, ny, nu, nu)
- real buxt(nx, ny, nu, nu), buyt(nx, ny, nu, nu)
- integer i, j
- real cos, sin, r, alog, atan, sqrt
- real theta
- do 6 j = 1, ny
- do 5 i = 1, nx
- if (y(j) .ne. ly) goto 1
- b(i, j, 1) = uy(i, j, 1)
-c neumann data on bottom.
- buy(i, j, 1, 1) = 1
- goto 4
- 1 r = sqrt(x(i)**2+y(j)**2)
-c dirichlet data.
- if (x(i) .le. 0.) goto 2
- theta = atan(y(j)/x(i))
- goto 3
- 2 theta = 2.*atan(1e0)
- 3 b(i, j, 1) = u(i, j, 1)-r*(cos(theta)*alog(r)-theta*sin(
- 1 theta))
- bu(i, j, 1, 1) = 1
- 4 continue
- 5 continue
- 6 continue
- return
- end
- subroutine handle(t0, u0, t, u, nv, dt, tstop)
- integer nv
- real t0, u0(nv), t, u(nv), dt, tstop
- common /a7tgrp/ errpar, nu, mxq, myq
- integer nu, mxq, myq
- real errpar(2)
- common /a7tgrm/ kx, ix, nx, ky, iy, ny
- integer kx, ix, nx, ky, iy, ny
- if (t0 .ne. t) goto 2
- write (6, 1) t
- 1 format (16h restart for t =, 1pe10.2)
- return
- 2 call gerr(kx, ix, nx, ky, iy, ny, u, nu, t)
- return
- end
- subroutine gerr(kx, ix, nx, ky, iy, ny, u, nu, t)
- integer kx, ix, nx, ky, iy, ny
- integer nu
- real u(1), t
- common /cstak/ ds
- double precision ds(500)
- integer ifa, ita(2), ixa(2), nta(2), nxa(2), ixs
- integer iys, nxs, nys, istkgt, i, iewe
- integer ka(2), ma(2), is(1000), ilumd, i1mach
- real abs, erru, amax1, rs(1000), ws(1000)
- logical ls(1000)
- complex cs(500)
- integer temp, temp1, temp2
- equivalence (ds(1), cs(1), ws(1), rs(1), is(1), ls(1))
-c to get and print the error at each time-step.
-c u(nx-kx,ny-ky,nu).
-c the port library stack and its aliases.
- call enter(1)
-c find the error in the solution at 2*kx * 2*ky points / mesh rectangle.
-c x search grid.
- ixs = ilumd(ws(ix), nx, 2*kx, nxs)
-c y search grid.
- iys = ilumd(ws(iy), ny, 2*ky, nys)
-c u search grid values.
- iewe = istkgt(nxs*nys, 3)
-c the exact solution.
- call ewe(t, ws(ixs), nxs, ws(iys), nys, ws(iewe), nu)
- ka(1) = kx
- ka(2) = ky
- ita(1) = ix
- ita(2) = iy
- nta(1) = nx
- nta(2) = ny
- ixa(1) = ixs
- ixa(2) = iys
- nxa(1) = nxs
- nxa(2) = nys
- ma(1) = 0
-c get solution.
- ma(2) = 0
-c approximate solution values.
- ifa = istkgt(nxs*nys, 3)
-c evaluate them.
- call tsd1(2, ka, ws, ita, nta, u, ws, ixa, nxa, ma, ws(ifa))
-c error in solution values.
- erru = 0
- temp = nxs*nys
- do 1 i = 1, temp
- temp2 = iewe+i
- temp1 = ifa+i
- erru = amax1(erru, abs(ws(temp2-1)-ws(temp1-1)))
- 1 continue
- temp = i1mach(2)
- write (temp, 2) t, erru
- 2 format (14h error in u(.,, 1pe10.2, 3h) =, 1pe10.2)
- call leave
- return
- end
- subroutine ewe(t, x, nx, y, ny, u, nu)
- integer nu, nx, ny
- real t, x(nx), y(ny), u(nx, ny, nu)
- integer i, j, p
- real cos, sin, r, alog, atan, sqrt
- real theta
-c the exact solution.
- do 7 p = 1, nu
- do 6 i = 1, nx
- do 5 j = 1, ny
- r = sqrt(x(i)**2+y(j)**2)
- if (x(i) .le. 0.) goto 1
- theta = atan(y(j)/x(i))
- goto 2
- 1 theta = 2.*atan(1e0)
- 2 if (r .le. 0.) goto 3
- u(i, j, p) = r*(cos(theta)*alog(r)-theta*sin(theta))
- goto 4
- 3 u(i, j, p) = 0
- 4 continue
- 5 continue
- 6 continue
- 7 continue
- return
- end
diff --git a/CEP/PyBDSM/src/port3/ttgrx6.f b/CEP/PyBDSM/src/port3/ttgrx6.f
deleted file mode 100644
index a77bf5ad3651005da88b9922ee1b422544ba7d54..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ttgrx6.f
+++ /dev/null
@@ -1,374 +0,0 @@
-C$TEST TTGR6
-c main program
- common /cstak/ ds
- double precision ds(350000)
- external handle, bc, af
- integer iue, ndx, ndy, iur, ixr, iyr
- integer nxr, nyr, istkgt, i, is(1000), iu
- integer ix, iy, nu, kx, nx, ky
- integer ny, i1mach
- real abs, errpar(2), tstart, eerr, erre, errr
- real amax1, dt, lx, ly, rx, ry
- real ws(1000), rs(1000), float, tstop
- logical ls(1000)
- complex cs(500)
- integer temp, temp1, temp2
- equivalence (ds(1), cs(1), ws(1), rs(1), is(1), ls(1))
-c to get error estimates for laplaces equation with real ( z*log(z) ) as
-c solution.
-c the port library stack and its aliases.
-c initialize the port library stack length.
- call istkin(350000, 4)
- call enter(1)
- nu = 1
- lx = 0
- rx = 1
- ly = 0
- ry = 1
- kx = 4
- ky = 4
- ndx = 2
- ndy = 2
- tstart = 0
- tstop = 1
- dt = 1
- errpar(1) = 1e-2
- errpar(2) = 1e-4
- nx = ndx+2*(kx-1)
-c space for x mesh.
- ix = istkgt(nx, 3)
- do 1 i = 1, kx
- temp = ix+i
- ws(temp-1) = 0
- temp = ix+nx-i
- ws(temp) = rx
- 1 continue
-c 0 and rx mult = kx.
- temp = ndx-1
- do 2 i = 1, temp
- temp2 = ix+kx-2+i
- ws(temp2) = rx*(float(i-1)/(float(ndx)-1e0))**kx
- 2 continue
- ny = ndy+2*(ky-1)
-c space for y mesh.
- iy = istkgt(ny, 3)
- do 3 i = 1, ky
- temp = iy+i
- ws(temp-1) = 0
- temp = iy+ny-i
- ws(temp) = ry
- 3 continue
-c 0 and ry mult = ky.
- temp = ndy-1
- do 4 i = 1, temp
- temp2 = iy+ky-2+i
- ws(temp2) = ry*(float(i-1)/(float(ndy)-1e0))**ky
- 4 continue
-c space for the solution.
- iu = istkgt(nu*(nx-kx)*(ny-ky), 3)
- call setr(nu*(nx-kx)*(ny-ky), 0e0, ws(iu))
- temp = i1mach(2)
- write (temp, 5)
- 5 format (23h solving on crude mesh.)
- call ttgr(ws(iu), nu, kx, ws(ix), nx, ky, ws(iy), ny, tstart,
- 1 tstop, dt, af, bc, errpar, handle)
- dt = 1
- ndx = 2*ndx-1
-c refine mesh.
- ndy = 2*ndy-1
- nxr = ndx+2*(kx-1)
-c space for x mesh.
- ixr = istkgt(nxr, 3)
- do 6 i = 1, kx
- temp = ixr+i
- ws(temp-1) = 0
- temp = ixr+nxr-i
- ws(temp) = rx
- 6 continue
-c 0 and rx mult = kx.
- temp = ndx-1
- do 7 i = 1, temp
- temp2 = ixr+kx-2+i
- ws(temp2) = rx*(float(i-1)/(float(ndx)-1e0))**kx
- 7 continue
- nyr = ndy+2*(ky-1)
-c space for y mesh.
- iyr = istkgt(nyr, 3)
- do 8 i = 1, ky
- temp = iyr+i
- ws(temp-1) = 0
- temp = iyr+nyr-i
- ws(temp) = ry
- 8 continue
-c 0 and ry mult = ky.
- temp = ndy-1
- do 9 i = 1, temp
- temp2 = iyr+ky-2+i
- ws(temp2) = ry*(float(i-1)/(float(ndy)-1e0))**ky
- 9 continue
-c space for the solution.
- iur = istkgt(nu*(nxr-kx)*(nyr-ky), 3)
- call setr(nu*(nxr-kx)*(nyr-ky), 0e0, ws(iur))
- temp = i1mach(2)
- write (temp, 10)
- 10 format (25h solving on refined mesh.)
- call ttgr(ws(iur), nu, kx, ws(ixr), nxr, ky, ws(iyr), nyr, tstart,
- 1 tstop, dt, af, bc, errpar, handle)
- dt = 1
- errpar(1) = errpar(1)/10.
- errpar(2) = errpar(2)/10.
-c space for the solution.
- iue = istkgt(nu*(nx-kx)*(ny-ky), 3)
- call setr(nu*(nx-kx)*(ny-ky), 0e0, ws(iue))
- temp = i1mach(2)
- write (temp, 11)
- 11 format (24h solving with errpar/10.)
- call ttgr(ws(iue), nu, kx, ws(ix), nx, ky, ws(iy), ny, tstart,
- 1 tstop, dt, af, bc, errpar, handle)
- errr = eerr(kx, ix, nx, ky, iy, ny, ws(iu), nu, ixr, nxr, iyr,
- 1 nyr, ws(iur), tstop)
- erre = 0
- temp = nu*(nx-kx)*(ny-ky)
- do 12 i = 1, temp
- temp2 = iu+i
- temp1 = iue+i
- erre = amax1(erre, abs(ws(temp2-1)-ws(temp1-1)))
- 12 continue
- temp = i1mach(2)
- write (temp, 13) erre
- 13 format (24h u error from u and ue =, 1pe10.2)
- temp = i1mach(2)
- write (temp, 14) errr
- 14 format (24h u error from u and ur =, 1pe10.2)
- call leave
- call wrapup
- stop
- end
- subroutine af(t, xi, nx, yi, ny, nu, u, ut, ux, uy, uxt,
- 1 uyt, a, au, aut, aux, auy, auxt, auyt, f, fu, fut, fux, fuy,
- 2 fuxt, fuyt)
- integer nu, nx, ny
- real t, xi(nx), yi(ny), u(nx, ny, nu), ut(nx, ny, nu), ux(nx, ny
- 1 , nu)
- real uy(nx, ny, nu), uxt(nx, ny, nu), uyt(nx, ny, nu), a(nx, ny,
- 1 nu, 2), au(nx, ny, nu, nu, 2), aut(nx, ny, nu, nu, 2)
- real aux(nx, ny, nu, nu, 2), auy(nx, ny, nu, nu, 2), auxt(nx, ny
- 1 , nu, nu, 2), auyt(nx, ny, nu, nu, 2), f(nx, ny, nu), fu(nx,
- 2 ny, nu, nu)
- real fut(nx, ny, nu, nu), fux(nx, ny, nu, nu), fuy(nx, ny, nu, nu)
- 1 , fuxt(nx, ny, nu, nu), fuyt(nx, ny, nu, nu)
- integer i, p, q
- do 3 i = 1, nu
- do 2 q = 1, ny
- do 1 p = 1, nx
- a(p, q, i, 1) = ux(p, q, i)
- a(p, q, i, 2) = uy(p, q, i)
- aux(p, q, i, i, 1) = 1
- auy(p, q, i, i, 2) = 1
- 1 continue
- 2 continue
- 3 continue
- return
- end
- subroutine bc(t, x, nx, y, ny, lx, rx, ly, ry, u, ut, ux,
- 1 uy, uxt, uyt, nu, b, bu, but, bux, buy, buxt, buyt)
- integer nu, nx, ny
- real t, x(nx), y(ny), lx, rx, ly
- real ry, u(nx, ny, nu), ut(nx, ny, nu), ux(nx, ny, nu), uy(nx, ny,
- 1 nu), uxt(nx, ny, nu)
- real uyt(nx, ny, nu), b(nx, ny, nu), bu(nx, ny, nu, nu), but(nx,
- 1 ny, nu, nu), bux(nx, ny, nu, nu), buy(nx, ny, nu, nu)
- real buxt(nx, ny, nu, nu), buyt(nx, ny, nu, nu)
- integer i, j
- real cos, sin, r, alog, atan, sqrt
- real theta
- do 6 j = 1, ny
- do 5 i = 1, nx
- if (y(j) .ne. ly) goto 1
- b(i, j, 1) = uy(i, j, 1)
-c neumann data on bottom.
- buy(i, j, 1, 1) = 1
- goto 4
- 1 r = sqrt(x(i)**2+y(j)**2)
-c dirichlet data.
- if (x(i) .le. 0.) goto 2
- theta = atan(y(j)/x(i))
- goto 3
- 2 theta = 2.*atan(1e0)
- 3 b(i, j, 1) = u(i, j, 1)-r*(cos(theta)*alog(r)-theta*sin(
- 1 theta))
- bu(i, j, 1, 1) = 1
- 4 continue
- 5 continue
- 6 continue
- return
- end
- subroutine handle(t0, u0, t, u, nv, dt, tstop)
- integer nv
- real t0, u0(nv), t, u(nv), dt, tstop
- common /a7tgrp/ errpar, nu, mxq, myq
- integer nu, mxq, myq
- real errpar(2)
- common /a7tgrm/ kx, ix, nx, ky, iy, ny
- integer kx, ix, nx, ky, iy, ny
- if (t0 .ne. t) goto 2
- write (6, 1) t
- 1 format (16h restart for t =, 1pe10.2)
- return
- 2 call gerr(kx, ix, nx, ky, iy, ny, u, nu, t)
- return
- end
- subroutine gerr(kx, ix, nx, ky, iy, ny, u, nu, t)
- integer kx, ix, nx, ky, iy, ny
- integer nu
- real u(1), t
- common /cstak/ ds
- double precision ds(500)
- integer ifa, ita(2), ixa(2), nta(2), nxa(2), ixs
- integer iys, nxs, nys, istkgt, i, iewe
- integer ka(2), ma(2), is(1000), ilumd, i1mach
- real abs, erru, amax1, rs(1000), ws(1000)
- logical ls(1000)
- complex cs(500)
- integer temp, temp1, temp2
- equivalence (ds(1), cs(1), ws(1), rs(1), is(1), ls(1))
-c to get and print the error at each time-step.
-c u(nx-kx,ny-ky,nu).
-c the port library stack and its aliases.
- call enter(1)
-c find the error in the solution at 2*kx * 2*ky points / mesh rectangle.
-c x search grid.
- ixs = ilumd(ws(ix), nx, 2*kx, nxs)
-c y search grid.
- iys = ilumd(ws(iy), ny, 2*ky, nys)
-c u search grid values.
- iewe = istkgt(nxs*nys, 3)
-c the exact solution.
- call ewe(t, ws(ixs), nxs, ws(iys), nys, ws(iewe), nu)
- ka(1) = kx
- ka(2) = ky
- ita(1) = ix
- ita(2) = iy
- nta(1) = nx
- nta(2) = ny
- ixa(1) = ixs
- ixa(2) = iys
- nxa(1) = nxs
- nxa(2) = nys
- ma(1) = 0
-c get solution.
- ma(2) = 0
-c approximate solution values.
- ifa = istkgt(nxs*nys, 3)
-c evaluate them.
- call tsd1(2, ka, ws, ita, nta, u, ws, ixa, nxa, ma, ws(ifa))
-c error in solution values.
- erru = 0
- temp = nxs*nys
- do 1 i = 1, temp
- temp2 = iewe+i
- temp1 = ifa+i
- erru = amax1(erru, abs(ws(temp2-1)-ws(temp1-1)))
- 1 continue
- temp = i1mach(2)
- write (temp, 2) t, erru
- 2 format (14h error in u(.,, 1pe10.2, 3h) =, 1pe10.2)
- call leave
- return
- end
- real function eerr(kx, ix, nx, ky, iy, ny, u, nu, ixr, nxr
- 1 , iyr, nyr, ur, t)
- integer kx, ix, nx, ky, iy, ny
- integer nu, ixr, nxr, iyr, nyr
- real u(1), ur(1), t
- common /cstak/ ds
- double precision ds(500)
- integer ifa, ita(2), ixa(2), nta(2), nxa(2), ixs
- integer iys, nxs, nys, istkgt, i, ifar
- integer ka(2), ma(2), is(1000), ilumd, i1mach
- real abs, erru, amax1, rs(1000), ws(1000)
- logical ls(1000)
- complex cs(500)
- integer temp, temp1, temp2
- equivalence (ds(1), cs(1), ws(1), rs(1), is(1), ls(1))
-c to get and print the error estimate at each time-step.
-c u(nx-kx,ny-ky,nu), ur(nxr-kx,nyr-ky,nu).
-c the port library stack and its aliases.
- call enter(1)
-c find the error in the solution at 2*kx * 2*ky points / fine mesh recta
-cngle.
-c x search grid.
- ixs = ilumd(ws(ixr), nxr, 2*kx, nxs)
-c y search grid.
- iys = ilumd(ws(iyr), nyr, 2*ky, nys)
- ka(1) = kx
- ka(2) = ky
- ita(1) = ix
- ita(2) = iy
- nta(1) = nx
- nta(2) = ny
- ixa(1) = ixs
- ixa(2) = iys
- nxa(1) = nxs
- nxa(2) = nys
- ma(1) = 0
-c get solution.
- ma(2) = 0
-c approximate solution values.
- ifa = istkgt(nxs*nys, 3)
-c evaluate them.
- call tsd1(2, ka, ws, ita, nta, u, ws, ixa, nxa, ma, ws(ifa))
- ka(1) = kx
- ka(2) = ky
- ita(1) = ixr
- ita(2) = iyr
- nta(1) = nxr
- nta(2) = nyr
- ixa(1) = ixs
- ixa(2) = iys
- nxa(1) = nxs
- nxa(2) = nys
- ma(1) = 0
-c get solution.
- ma(2) = 0
-c approximate solution values.
- ifar = istkgt(nxs*nys, 3)
-c evaluate them.
- call tsd1(2, ka, ws, ita, nta, ur, ws, ixa, nxa, ma, ws(ifar))
-c error in solution values.
- erru = 0
- temp = nxs*nys
- do 1 i = 1, temp
- temp2 = ifar+i
- temp1 = ifa+i
- erru = amax1(erru, abs(ws(temp2-1)-ws(temp1-1)))
- 1 continue
- call leave
- eerr = erru
- return
- end
- subroutine ewe(t, x, nx, y, ny, u, nu)
- integer nu, nx, ny
- real t, x(nx), y(ny), u(nx, ny, nu)
- integer i, j, p
- real cos, sin, r, alog, atan, sqrt
- real theta
-c the exact solution.
- do 7 p = 1, nu
- do 6 i = 1, nx
- do 5 j = 1, ny
- r = sqrt(x(i)**2+y(j)**2)
- if (x(i) .le. 0.) goto 1
- theta = atan(y(j)/x(i))
- goto 2
- 1 theta = 2.*atan(1e0)
- 2 if (r .le. 0.) goto 3
- u(i, j, p) = r*(cos(theta)*alog(r)-theta*sin(theta))
- goto 4
- 3 u(i, j, p) = 0
- 4 continue
- 5 continue
- 6 continue
- 7 continue
- return
- end
diff --git a/CEP/PyBDSM/src/port3/ttgux1.f b/CEP/PyBDSM/src/port3/ttgux1.f
deleted file mode 100644
index 5711ec3de01de38e05d11da6bb10150322073b08..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ttgux1.f
+++ /dev/null
@@ -1,222 +0,0 @@
-C$TEST TTGU1
-c main program
-c to solve the heat equation with solution u == t*x*y,
-c grad . ( u + ux + .1 * uy, u + uy + .1 * ux ) = ut + ux + uy +g(x,t)
- common /cstak/ ds
- real ds(350000)
- integer ixb(4), iyb(4), nxr(4), nyr(4), kxr(4), kyr(4)
- external handlu, bc, af
- integer ndx, ndy, istkgt, is(1000), iu, nu, kx, ky, IUMB
- real errpar(2), rs(1000)
- logical ls(1000)
- complex cs(500)
- real tstart, dt, tstop, ws(500)
-c the port library stack and its aliases.
- equivalence (ds(1), cs(1), ws(1), rs(1), is(1), ls(1))
-c initialize the port library stack length.
- call istkin(350000, 3)
- call enter(1)
- nu = 1
- kx = 2
- ky = 2
- ndx = 3
- ndy = 3
- nr=4
- tstart = 0.e0
- tstop = 1.e0
- dt = 1
- errpar(1) = 1e-2
- errpar(2) = 1e-4
-c uniform grid.
-c
-c make grid for t-shaped region
-c
- ixb(1) = IUMB(-1.0e0, 0.0e0, ndx, kx, nxr(1))
- ixb(2) = IUMB(0.0e0, 1.0e0, ndx, kx, nxr(2))
- ixb(3) = IUMB(1.0e0, 2.0e0, ndx, kx, nxr(3))
- ixb(4) = IUMB(0.0e0, 1.0e0, ndx, kx, nxr(4))
- iyb(1) = IUMB(0.0e0, 1.0e0, ndy, ky, nyr(1))
- iyb(2) = IUMB(0.0e0, 1.0e0, ndy, ky, nyr(2))
- iyb(3) = IUMB(0.0e0, 1.0e0, ndy, ky, nyr(3))
- iyb(4) = IUMB(-1.0e0, 0.0e0, ndy, ky, nyr(4))
- nnu =nu*((nxr(1)-kx)*(nyr(1)+nyr(3)-2*ky)+
- 1 (nxr(2)-kx)*(nyr(2)-ky)+
- 4 (nxr(4)-kx)*(nyr(4)-ky))
- nr=4
-c space for the solution.
- iu = istkgt(nnu, 3)
- do 1 i=1,nr
- kxr(i)=kx
- kyr(i)=ky
-1 continue
-c initial conditions for u.
- call SETR(nnu, 0.e0,ws(iu))
- call ttgu(ws(iu),nu,nr,kxr,ws,nxr,ixb,kyr,ws,nyr,iyb,tstart,
- 1 tstop, dt, af, bc, errpar, handlu)
- call leave
- call wrapup
- stop
- end
- subroutine af(t, x, nx, y, ny, nu, u, ut, ux, uy, uxt, uyt
- 1 , a, au, aut, aux, auy, auxt, auyt, f, fu, fut, fux, fuy, fuxt,
- 2 fuyt)
- integer nu, nx, ny
- real t, x(nx), y(ny), u(nx, ny, nu), ut(nx, ny, nu),
- 1 ux(nx, ny, nu)
- real uy(nx, ny, nu), uxt(nx, ny, nu), uyt(nx, ny, nu),
- 1 a(nx, ny, nu, 2), au(nx, ny, nu, nu, 2), aut(nx, ny, nu, nu, 2)
- real aux(nx, ny, nu, nu, 2), auy(nx, ny, nu, nu, 2),
- 1 auxt(nx, ny, nu, nu, 2), auyt(nx, ny, nu, nu, 2), f(nx, ny, nu)
- 2 , fu(nx, ny, nu, nu)
- real fut(nx, ny, nu, nu), fux(nx, ny, nu, nu), fuy(nx,
- 1 ny, nu, nu), fuxt(nx, ny, nu, nu), fuyt(nx, ny, nu, nu)
- integer i, p, q
- do 3 i = 1, nu
- do 2 q = 1, ny
- do 1 p = 1, nx
- a(p, q, i, 1) = ux(p, q, i)+.1*uy(p, q, i)+u(p, q, i)
- a(p, q, i, 2) = uy(p, q, i)+.1*ux(p, q, i)+u(p, q, i)
- aux(p, q, i, i, 1) = 1
- auy(p, q, i, i, 2) = 1
- auy(p, q, i, i, 1) = .1
- aux(p, q, i, i, 2) = .1
- au(p, q, i, i, 1) = 1
- au(p, q, i, i, 2) = 1
- f(p, q, i) = ut(p, q, i)+ux(p, q, i)+uy(p, q, i)
- fut(p, q, i, i) = 1
- fux(p, q, i, i) = 1
- fuy(p, q, i, i) = 1
- f(p, q, i) = f(p, q, i)+.2*t-x(p)*y(q)
- 1 continue
- 2 continue
- 3 continue
- return
- end
- subroutine bc(t, x, nx, y, ny, lx, rx, ly, ry, u, ut, ux,
- 1 uy, uxt, uyt, nu, b, bu, but, bux, buy, buxt, buyt)
- integer nu, nx, ny
- real t, x(nx), y(ny), lx, rx, ly
- real ry, u(nx, ny, nu), ut(nx, ny, nu), ux(nx, ny, nu)
- 1 , uy(nx, ny, nu), uxt(nx, ny, nu)
- real uyt(nx, ny, nu), b(nx, ny, nu), bu(nx, ny, nu,
- 1 nu), but(nx, ny, nu, nu), bux(nx, ny, nu, nu), buy(nx, ny, nu
- 2 , nu)
- real buxt(nx, ny, nu, nu), buyt(nx, ny, nu, nu)
- integer i, j
- do 2 j = 1, ny
- do 1 i = 1, nx
- bu(i, j, 1, 1) = 1
- b(i, j, 1) = u(i, j, 1)-t*x(i)*y(j)
- 1 continue
- 2 continue
- return
- end
- subroutine handlu(t0, u0, t, u, nv, dt, tstop)
- integer nv
- real t0, u0(nv), t, u(nv), dt, tstop
- common /a7tgup/ errpar, nu, mxp, myp
- integer nu
- real errpar(2)
- common /a7tgum/ kxp,ix,nxp,kyp,iy,nyp,nxnyt,nr,iup
- integer kx, ix, nx, ky, iy, ny
- common /cstak/is
- integer is(1000)
- iwrite=i1mach(2)
- if (t0 .ne. t) goto 2
- write (iwrite, 1) t
- 1 format (16h restart for t =, 1pe10.2)
- return
-c get and print the error.
- 2 continue
- write(iwrite, 3)t
- 3 format(6h at t=,1pe10.2)
- ius=1
- do 5 inu = 1, nu
- iyr=iy
- ixr=ix
- do 4 ir=1,nr
- ir1=ir-1
- nx=is(nxp+ir1)
- ny=is(nyp+ir1)
- kx=is(kxp+ir1)
- ky=is(kyp+ir1)
- call gerr(kx, ixr, nx, ky, iyr, ny, u(ius), inu, t, ir)
- ixr=ixr+nx
- iyr=iyr+ny
- ius=ius+(nx-kx)*(ny-ky)
- 4 continue
- 5 continue
- return
- end
- subroutine ewe2(t, x, nx, y, ny, u, inu, ir)
- integer inu, ir, nx, ny
- real t, x(nx), y(ny), u(nx, ny)
- integer i, j
-c the exact solution.
- do 2 i = 1, nx
- do 1 j = 1, ny
- u(i, j) = t*x(i)*y(j)
- 1 continue
- 2 continue
- return
- end
- subroutine gerr(kx, ix, nx, ky, iy, ny, u, inu, t, ir)
- integer kx, ix, nx, ky, iy, ny, inu, ir
- real u(1), t
- common /cstak/ ds
- real ds(500)
- integer ifa, ita(2), ixa(2), nta(2), nxa(2), ILUMD
- integer ixs, iys, nxs, nys, istkgt, i
- integer iewe, ka(2), ma(2), is(1000), i1mach
- real rs(1000)
- logical ls(1000)
- complex cs(500)
- real ABS, erru, AMAX1, ws(500)
- integer temp, temp1, temp2
- equivalence (ds(1), cs(1), ws(1), rs(1), is(1), ls(1))
-c to get and print the error at each time-step.
-c for variable inu for rectangle ir
-c u(nx-kx,ny-ky).
-c the port library stack and its aliases.
- call enter(1)
-c find the error in the solution at 2*kx * 2*ky points / mesh rectangle.
-c x search grid.
- ixs = ILUMD(ws(ix), nx, 2*kx, nxs)
-c y search grid.
- iys = ILUMD(ws(iy), ny, 2*ky, nys)
-c u search grid values.
- iewe = istkgt(nxs*nys, 3)
-c the exact solution.
- call ewe2(t, ws(ixs), nxs, ws(iys), nys, ws(iewe), inu, ir)
- ka(1) = kx
- ka(2) = ky
- ita(1) = ix
- ita(2) = iy
- nta(1) = nx
- nta(2) = ny
- ixa(1) = ixs
- ixa(2) = iys
- nxa(1) = nxs
- nxa(2) = nys
- ma(1) = 0
-c get solution.
- ma(2) = 0
-c approximate solution values.
- ifa = istkgt(nxs*nys, 3)
-c evaluate them.
- call tsd1(2, ka, ws, ita, nta, u, ws, ixa, nxa, ma, ws(ifa))
-c error in solution values.
- erru = 0
- temp = nxs*nys
- do 1 i = 1, temp
- temp2 = iewe+i
- temp1 = ifa+i
- erru = AMAX1(erru, ABS(ws(temp2-1)-ws(temp1-1)))
- 1 continue
- temp = i1mach(2)
- write (temp, 2) ir, inu, erru
- 2 format(9h for rect,i3,14h error in u(.,, i2,
- 1 3h) =, 1pe10.2)
- call leave
- return
- end
diff --git a/CEP/PyBDSM/src/port3/ttgux1p.f b/CEP/PyBDSM/src/port3/ttgux1p.f
deleted file mode 100644
index 088a8383060c56ae45a4b649b65c3aac21c1f2ed..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ttgux1p.f
+++ /dev/null
@@ -1,213 +0,0 @@
-C$TEST TTGU1P
-c main program
-c to solve the heat equation with solution u == t*x*y,
-c grad . ( u + ux + .1 * uy, u + uy + .1 * ux ) = ut + ux + uy +g(x,t)
- common /cstak/ ds
- real ds(350000)
- integer ixb(4), iyb(4), nxr(4), nyr(4), kxr(4), kyr(4)
- external handlu, bc, af
- integer ndx, ndy, istkgt, is(1000), iu, nu, kx, ky, IUMB
- real errpar(2), rs(1000)
- logical ls(1000)
- complex cs(500)
- real tstart, dt, tstop, ws(500)
-c the port library stack and its aliases.
- equivalence (ds(1), cs(1), ws(1), rs(1), is(1), ls(1))
-c initialize the port library stack length.
- call istkin(350000, 3)
- call enter(1)
- nu = 1
- kx = 2
- ky = 2
- ndx = 3
- ndy = 3
- nr=4
- tstart = 0.e0
- tstop = 1.e0
- dt = 1
- errpar(1) = 1e-2
- errpar(2) = 1e-4
-c uniform grid.
-c
-c make grid for t-shaped region
-c
- ixb(1) = IUMB(-1.0e0, 0.0e0, ndx, kx, nxr(1))
- ixb(2) = IUMB(0.0e0, 1.0e0, ndx, kx, nxr(2))
- ixb(3) = IUMB(1.0e0, 2.0e0, ndx, kx, nxr(3))
- ixb(4) = IUMB(0.0e0, 1.0e0, ndx, kx, nxr(4))
- iyb(1) = IUMB(0.0e0, 1.0e0, ndy, ky, nyr(1))
- iyb(2) = IUMB(0.0e0, 1.0e0, ndy, ky, nyr(2))
- iyb(3) = IUMB(0.0e0, 1.0e0, ndy, ky, nyr(3))
- iyb(4) = IUMB(-1.0e0, 0.0e0, ndy, ky, nyr(4))
- nnu =nu*((nxr(1)-kx)*(nyr(1)+nyr(3)-2*ky)+
- 1 (nxr(2)-kx)*(nyr(2)-ky)+
- 4 (nxr(4)-kx)*(nyr(4)-ky))
- nr=4
-c space for the solution.
- iu = istkgt(nnu, 3)
- do 1 i=1,nr
- kxr(i)=kx
- kyr(i)=ky
-1 continue
-c initial conditions for u.
- call SETR(nnu, 0.e0,ws(iu))
- call ttgu(ws(iu),nu,nr,kxr,ws,nxr,ixb,kyr,ws,nyr,iyb,tstart,
- 1 tstop, dt, af, bc, errpar, handlu)
- call leave
- call wrapup
- stop
- end
- subroutine af(t, x, nx, y, ny, nu, u, ut, ux, uy, uxt, uyt
- 1 , a, au, aut, aux, auy, auxt, auyt, f, fu, fut, fux, fuy, fuxt,
- 2 fuyt)
- integer nu, nx, ny
- real t, x(nx), y(ny), u(nx, ny, nu), ut(nx, ny, nu),
- 1 ux(nx, ny, nu)
- real uy(nx, ny, nu), uxt(nx, ny, nu), uyt(nx, ny, nu),
- 1 a(nx, ny, nu, 2), au(nx, ny, nu, nu, 2), aut(nx, ny, nu, nu, 2)
- real aux(nx, ny, nu, nu, 2), auy(nx, ny, nu, nu, 2),
- 1 auxt(nx, ny, nu, nu, 2), auyt(nx, ny, nu, nu, 2), f(nx, ny, nu)
- 2 , fu(nx, ny, nu, nu)
- real fut(nx, ny, nu, nu), fux(nx, ny, nu, nu), fuy(nx,
- 1 ny, nu, nu), fuxt(nx, ny, nu, nu), fuyt(nx, ny, nu, nu)
- integer i, p, q
- do 3 i = 1, nu
- do 2 q = 1, ny
- do 1 p = 1, nx
- a(p, q, i, 1) = ux(p, q, i)+.1*uy(p, q, i)+u(p, q, i)
- a(p, q, i, 2) = uy(p, q, i)+.1*ux(p, q, i)+u(p, q, i)
- aux(p, q, i, i, 1) = 1
- auy(p, q, i, i, 2) = 1
- auy(p, q, i, i, 1) = .1
- aux(p, q, i, i, 2) = .1
- au(p, q, i, i, 1) = 1
- au(p, q, i, i, 2) = 1
- f(p, q, i) = ut(p, q, i)+ux(p, q, i)+uy(p, q, i)
- fut(p, q, i, i) = 1
- fux(p, q, i, i) = 1
- fuy(p, q, i, i) = 1
- f(p, q, i) = f(p, q, i)+.2*t-x(p)*y(q)
- 1 continue
- 2 continue
- 3 continue
- return
- end
- subroutine bc(t, x, nx, y, ny, lx, rx, ly, ry, u, ut, ux,
- 1 uy, uxt, uyt, nu, b, bu, but, bux, buy, buxt, buyt)
- integer nu, nx, ny
- real t, x(nx), y(ny), lx, rx, ly
- real ry, u(nx, ny, nu), ut(nx, ny, nu), ux(nx, ny, nu)
- 1 , uy(nx, ny, nu), uxt(nx, ny, nu)
- real uyt(nx, ny, nu), b(nx, ny, nu), bu(nx, ny, nu,
- 1 nu), but(nx, ny, nu, nu), bux(nx, ny, nu, nu), buy(nx, ny, nu
- 2 , nu)
- real buxt(nx, ny, nu, nu), buyt(nx, ny, nu, nu)
- integer i, j
- do 2 j = 1, ny
- do 1 i = 1, nx
- bu(i, j, 1, 1) = 1
- b(i, j, 1) = u(i, j, 1)-t*x(i)*y(j)
- 1 continue
- 2 continue
- return
- end
- subroutine ewe(t, x, nx, y, ny, u, nu)
- integer nu, nx, ny
- real t, x(nx), y(ny), u(nx, ny, nu)
- integer i, j, p
-c the exact solution.
- do 3 p = 1, nu
- do 2 i = 1, nx
- do 1 j = 1, ny
- u(i, j, p) = t*x(i)*y(j)
- 1 continue
- 2 continue
- 3 continue
- return
- end
- subroutine handlu(t0, u0, t, u, nv, dt, tstop)
- integer nv
- real t0, u0(nv), t, u(nv), dt, tstop
- common /a7tgup/ errpar, nu, mxp, myp
- integer nu
- real errpar(2)
- common /a7tgum/ kxp,ix,nxp,kyp,iy,nyp,nxnyt,nr,iup
- integer kx, ix, nx, ky, iy, ny
- common /cstak/is
- integer is(1000)
- iwrite=i1mach(2)
- if (t0 .ne. t) goto 2
- write (iwrite, 1) t
- 1 format (16h restart for t =, 1pe10.2)
- return
-c get and print the error.
- 2 continue
- write(iwrite, 3)t
- 3 format(6h at t=,1pe10.2)
- ius=1
- do 5 inu = 1, nu
- iyr=iy
- ixr=ix
- do 4 ir=1,nr
- ir1=ir-1
- nx=is(nxp+ir1)
- ny=is(nyp+ir1)
- kx=is(kxp+ir1)
- ky=is(kyp+ir1)
- call gerr(kx, ixr, nx, ky, iyr, ny, u(ius), inu, t, ir)
- ixr=ixr+nx
- iyr=iyr+ny
- ius=ius+(nx-kx)*(ny-ky)
- 4 continue
- 5 continue
- return
- end
- subroutine gerr(kx, ix, nx, ky, iy, ny, u, inu, t, ir)
-c to print the solution at each time-step
- integer kx, ix, nx, ky, iy, ny
- integer inu, ir
- real u(1), t
- common /cstak/ ds
- real ds(500)
- integer ifa, ita(2), ixa(2), nta(2), nxa(2), ILUMD
- integer ixs, iys, nxs, nys, istkgt, i
- integer ka(2), ma(2), is(1000), i1mach
- real rs(1000)
- logical ls(1000)
- complex cs(500)
- real ws(500)
- integer temp
- equivalence (ds(1), cs(1), ws(1), rs(1), is(1), ls(1))
-c u(nx-kx,ny-ky).
-c the port library stack and its aliases.
- call enter(1)
-c x search grid.
-c find the solution at 2 * 2 points / mesh rectangle.
- ixs = ILUMD(ws(ix), nx, 2, nxs)
-c y search grid.
- iys = ILUMD(ws(iy), ny, 2, nys)
-c u search grid values.
- ka(1) = kx
- ka(2) = ky
- ita(1) = ix
- ita(2) = iy
- nta(1) = nx
- nta(2) = ny
- ixa(1) = ixs
- ixa(2) = iys
- nxa(1) = nxs
- nxa(2) = nys
- ma(1) = 0
- ma(2) = 0
-c get solution.
-c approximate solution values.
- ifa = istkgt(nxs*nys, 3)
-c evaluate them.
- call tsd1(2, ka, ws, ita, nta, u, ws, ixa, nxa, ma, ws(ifa))
- temp = i1mach(2)
- write(temp,9001)ir,inu,(ws(i),i=iFA,IFa+nxs*nys-1)
-9001 format(" for rect",i3," u(.,",i2,")=",
- 1((1p5e10.2/20x,1p4d10.2)))
- call leave
- return
- end
diff --git a/CEP/PyBDSM/src/port3/ttgux2.f b/CEP/PyBDSM/src/port3/ttgux2.f
deleted file mode 100644
index 465ed7fdcc97ca6ab2b4cf508620d53edc208b99..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ttgux2.f
+++ /dev/null
@@ -1,232 +0,0 @@
-C$TEST TTGU2
-c main program
- common /cstak/ ds
- real ds(350000)
- external handlu, bc, af
- integer ndx, ndy, istkgt, is(1000), iu
- integer nu, nr, iyb(3), ixb(3), kx, ky
- integer nxr(3), nyr(3), kxr(3), kyr(3)
- integer IUMB
- real errpar(2), rs(1000)
- logical ls(1000)
- complex cs(500)
- real tstart, dt
- real ws(500), tstop
- equivalence (ds(1), cs(1), ws(1), rs(1), is(1), ls(1))
-c to solve two coupled, nonlinear heat equations.
-c u1 sub t = div . ( u1x, u1y ) - u1*u2 + g1
-c u2 sub t = div . ( u2x, u2y ) - u1*u2 + g2
-c the port library stack and its aliases.
-c initialize the port library stack length.
- call istkin(350000, 3)
- call enter(1)
- nu = 2
- kx = 4
- ky = 4
- ndx = 3
- ndy = 3
- nr = 3
- tstart = 0
- dt = 1e-2
- tstop =1.e0
- errpar(1) = 1e-2
- errpar(2) = 1e-4
-c uniform grid.
- ixb(1) = IUMB(0.0e0, 1.0e0, ndx, kx, nxr(1))
- ixb(2) = IUMB(0.0e0, 1.0e0, ndx, kx, nxr(2))
- ixb(3) = IUMB(1.0e0, 2.0e0, ndx, kx, nxr(3))
- iyb(1) = IUMB(0.0e0, 1.0e0, ndy, ky, nyr(1))
- iyb(2) = IUMB(1.0e0, 2.0e0, ndy, ky, nyr(2))
- iyb(3) = IUMB(0.0e0, 1.0e0, ndy, ky, nyr(3))
-c uniform grid.
-c space for the solution.
- nnu=0
- do 1 i=1,nr
- nnu=nnu+nu*((nxr(i)-kx)*(nyr(i)-ky))
- 1 continue
- iu = istkgt(nnu, 3)
- do 2 i=1,nr
- kxr(i)=kx
- kyr(i)=ky
- 2 continue
- call SETR(nnu, 1.e0,ws(iu))
- call ttgu(ws(iu),nu,nr,kxr,ws,nxr,ixb,kyr,ws,nyr,iyb,tstart,
- 1 tstop, dt, af, bc, errpar, handlu)
- call leave
- call wrapup
- stop
- end
- subroutine af(t, x, nx, y, ny, nu, u, ut, ux, uy, uxt, uyt
- 1 , a, au, aut, aux, auy, auxt, auyt, f, fu, fut, fux, fuy, fuxt,
- 2 fuyt)
- integer nu, nx, ny
- real t, x(nx), y(ny), u(nx, ny, nu), ut(nx, ny, nu),
- 1 ux(nx, ny, nu)
- real uy(nx, ny, nu), uxt(nx, ny, nu), uyt(nx, ny, nu),
- 1 a(nx, ny, nu, 2), au(nx, ny, nu, nu, 2), aut(nx, ny, nu, nu, 2)
- real aux(nx, ny, nu, nu, 2), auy(nx, ny, nu, nu, 2),
- 1 auxt(nx, ny, nu, nu, 2), auyt(nx, ny, nu, nu, 2), f(nx, ny, nu)
- 2 , fu(nx, ny, nu, nu)
- real fut(nx, ny, nu, nu), fux(nx, ny, nu, nu), fuy(nx,
- 1 ny, nu, nu), fuxt(nx, ny, nu, nu), fuyt(nx, ny, nu, nu)
- integer p, q
- real EXP
- do 2 q = 1, ny
- do 1 p = 1, nx
- a(p, q, 1, 1) = ux(p, q, 1)
- aux(p, q, 1, 1, 1) = 1
- a(p, q, 1, 2) = uy(p, q, 1)
- auy(p, q, 1, 1, 2) = 1
- f(p, q, 1) = ut(p, q, 1)+u(p, q, 1)*u(p, q, 2)
- fu(p, q, 1, 1) = u(p, q, 2)
- fu(p, q, 1, 2) = u(p, q, 1)
- fut(p, q, 1, 1) = 1
- a(p, q, 2, 1) = ux(p, q, 2)
- aux(p, q, 2, 2, 1) = 1
- a(p, q, 2, 2) = uy(p, q, 2)
- auy(p, q, 2, 2, 2) = 1
- f(p, q, 2) = ut(p, q, 2)+u(p, q, 1)*u(p, q, 2)
- fu(p, q, 2, 1) = u(p, q, 2)
- fu(p, q, 2, 2) = u(p, q, 1)
- fut(p, q, 2, 2) = 1
- f(p, q, 1) = f(p, q, 1)-( EXP(t*(x(p)-y(q)))*(x(p)-y(q)-2e0*
- 1 t*t)+1e0)
- f(p, q, 2) = f(p, q, 2)-( EXP(t*(y(q)-x(p)))*(y(q)-x(p)-2e0*
- 1 t*t)+1e0)
- 1 continue
- 2 continue
- return
- end
- subroutine bc(t, x, nx, y, ny, lx, rx, ly, ry, u, ut, ux,
- 1 uy, uxt, uyt, nu, b, bu, but, bux, buy, buxt, buyt)
- integer nu, nx, ny
- real t, x(nx), y(ny), lx, rx, ly
- real ry, u(nx, ny, nu), ut(nx, ny, nu), ux(nx, ny, nu)
- 1 , uy(nx, ny, nu), uxt(nx, ny, nu)
- real uyt(nx, ny, nu), b(nx, ny, nu), bu(nx, ny, nu,
- 1 nu), but(nx, ny, nu, nu), bux(nx, ny, nu, nu), buy(nx, ny, nu
- 2 , nu)
- real buxt(nx, ny, nu, nu), buyt(nx, ny, nu, nu)
- integer i, j
- real EXP
- do 2 j = 1, ny
- do 1 i = 1, nx
- bu(i, j, 1, 1) = 1
- b(i, j, 1) = u(i, j, 1)- EXP(t*(x(i)-y(j)))
- bu(i, j, 2, 2) = 1
- b(i, j, 2) = u(i, j, 2)- EXP(t*(y(j)-x(i)))
- 1 continue
- 2 continue
- return
- end
- subroutine ewe2(t, x, nx, y, ny, u, inu, ir)
- integer inu, ir, nx, ny
- real t, x(nx), y(ny), u(nx, ny)
- integer i, j
- real float
- real dble, EXP
-c the exact solution.
- do 2 i = 1, nx
- do 1 j = 1, ny
- u(i, j) = EXP((float((-1)**(inu+1)))*t*(x(i)-y(j)))
- 1 continue
- 2 continue
- return
- end
- subroutine handlu(t0, u0, t, u, nv, dt, tstop)
- integer nv
- real t0, u0(nv), t, u(nv), dt, tstop
- common /a7tgup/ errpar, nu, mxp, myp
- integer nu
- real errpar(2)
- common /a7tgum/ kxp,ix,nxp,kyp,iy,nyp,nxnyt,nr,iup
- integer kx, ix, nx, ky, iy, ny
- common /cstak/is
- integer is(1000)
- iwrite=i1mach(2)
- if (t0 .ne. t) goto 2
- write (iwrite, 1) t
- 1 format (16h restart for t =, 1pe10.2)
- return
-c get and print the error.
- 2 continue
- write(iwrite, 3)t
- 3 format(6h at t=,1pe10.2)
- ius=1
- do 5 inu = 1, nu
- iyr=iy
- ixr=ix
- do 4 ir=1,nr
- ir1=ir-1
- nx=is(nxp+ir1)
- ny=is(nyp+ir1)
- kx=is(kxp+ir1)
- ky=is(kyp+ir1)
- call gerr(kx, ixr, nx, ky, iyr, ny, u(ius), inu, t, ir)
- ixr=ixr+nx
- iyr=iyr+ny
- ius=ius+(nx-kx)*(ny-ky)
- 4 continue
- 5 continue
- return
- end
- subroutine gerr(kx, ix, nx, ky, iy, ny, u, inu, t, ir)
- integer kx, ix, nx, ky, iy, ny, inu, ir
- real u(1), t
- common /cstak/ ds
- real ds(500)
- integer ifa, ita(2), ixa(2), nta(2), nxa(2), ILUMD
- integer ixs, iys, nxs, nys, istkgt, i
- integer iewe, ka(2), ma(2), is(1000), i1mach
- real rs(1000)
- logical ls(1000)
- complex cs(500)
- real ABS, erru, AMAX1, ws(500)
- integer temp, temp1, temp2
- equivalence (ds(1), cs(1), ws(1), rs(1), is(1), ls(1))
-c to get and print the error at each time-step.
-c for variable inu for rectangle ir
-c u(nx-kx,ny-ky).
-c the port library stack and its aliases.
- call enter(1)
-c find the error in the solution at 2*kx * 2*ky points / mesh rectangle.
-c x search grid.
- ixs = ILUMD(ws(ix), nx, 2*kx, nxs)
-c y search grid.
- iys = ILUMD(ws(iy), ny, 2*ky, nys)
-c u search grid values.
- iewe = istkgt(nxs*nys, 3)
-c the exact solution.
- call ewe2(t, ws(ixs), nxs, ws(iys), nys, ws(iewe), inu, ir)
- ka(1) = kx
- ka(2) = ky
- ita(1) = ix
- ita(2) = iy
- nta(1) = nx
- nta(2) = ny
- ixa(1) = ixs
- ixa(2) = iys
- nxa(1) = nxs
- nxa(2) = nys
- ma(1) = 0
-c get solution.
- ma(2) = 0
-c approximate solution values.
- ifa = istkgt(nxs*nys, 3)
-c evaluate them.
- call tsd1(2, ka, ws, ita, nta, u, ws, ixa, nxa, ma, ws(ifa))
-c error in solution values.
- erru = 0
- temp = nxs*nys
- do 1 i = 1, temp
- temp2 = iewe+i
- temp1 = ifa+i
- erru = AMAX1(erru, ABS(ws(temp2-1)-ws(temp1-1)))
- 1 continue
- temp = i1mach(2)
- write (temp, 2) ir, inu, erru
- 2 format(9h for rect,i3,14h error in u(.,, i2,
- 1 3h) =, 1pe10.2)
- call leave
- return
- end
diff --git a/CEP/PyBDSM/src/port3/ttgux3.f b/CEP/PyBDSM/src/port3/ttgux3.f
deleted file mode 100644
index 93223ae17b4ecfaafd9beb4033db5a4b1f66930b..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ttgux3.f
+++ /dev/null
@@ -1,247 +0,0 @@
-C$TEST TTGU3
-c main program
- common /cstak/ ds
- real ds(350000)
- external handlu, bc, af
- integer ndx, ndy, istkgt, is(1000), iu
- integer nu, nr, iyb(3), ixb(3), kx, ky
- integer nxr(3), nyr(3), kxr(3), kyr(3)
- integer IUMB
- real errpar(2), rs(1000)
- logical ls(1000)
- complex cs(500)
- real tstart, dt, ws(500)
- real tstop
- equivalence (ds(1), cs(1), ws(1), rs(1), is(1), ls(1))
-c to solve the layered heat equation, with kappa = 1, 1/2, 1/3,
-c div . ( kappa(x,y) * grad u ) = ut + g
-c the port library stack and its aliases.
-c initialize the port library stack length.
- call istkin(350000, 3)
- call enter(1)
- nu = 1
- nr = 3
- kx = 2
- ky = 2
- ndx = 3
- ndy = 3
- tstart = 0
- tstop = 1
- dt = 1
- errpar(1) = 1e-2
- errpar(2) = 1e-4
-c uniform grid.
- ixb(1) = IUMB(0.0e0, 1.0e0, ndx, kx, nxr(1))
- ixb(2) = IUMB(0.0e0, 1.0e0, ndx, kx, nxr(2))
- ixb(3) = IUMB(0.0e0, 1.0e0, ndx, kx, nxr(3))
- iyb(1) = IUMB(0.0e0, 1.0e0, ndy, ky, nyr(1))
- iyb(2) = IUMB(1.0e0, 2.0e0, ndy, ky, nyr(2))
- iyb(3) = IUMB(2.0e0, 3.0e0, ndy, ky, nyr(3))
-c space for the solution.
- nnu=0
- do 1 i=1,nr
- nnu=nnu+nu*((nxr(i)-kx)*(nyr(i)-ky))
- 1 continue
- iu = istkgt(nnu, 3)
- do 2 i=1,nr
- kxr(i)=kx
- kyr(i)=ky
- 2 continue
- call SETR(nnu, 0.e0,ws(iu))
- call ttgu(ws(iu),nu,nr,kxr,ws,nxr,ixb,kyr,ws,nyr,iyb,tstart,
- 1 tstop, dt, af, bc, errpar, handlu)
- call leave
- call wrapup
- stop
- end
- subroutine af(t, x, nx, y, ny, nu, u, ut, ux, uy, uxt, uyt
- 1 , a, au, aut, aux, auy, auxt, auyt, f, fu, fut, fux, fuy, fuxt,
- 2 fuyt)
- integer nu, nx, ny
- real t, x(nx), y(ny), u(nx, ny, nu), ut(nx, ny, nu),
- 1 ux(nx, ny, nu)
- real uy(nx, ny, nu), uxt(nx, ny, nu), uyt(nx, ny, nu),
- 1 a(nx, ny, nu, 2), au(nx, ny, nu, nu, 2), aut(nx, ny, nu, nu, 2)
- real aux(nx, ny, nu, nu, 2), auy(nx, ny, nu, nu, 2),
- 1 auxt(nx, ny, nu, nu, 2), auyt(nx, ny, nu, nu, 2), f(nx, ny, nu)
- 2 , fu(nx, ny, nu, nu)
- real fut(nx, ny, nu, nu), fux(nx, ny, nu, nu), fuy(nx,
- 1 ny, nu, nu), fuxt(nx, ny, nu, nu), fuyt(nx, ny, nu, nu)
- integer i, p, q
- real kappa
- logical temp
- do 7 i = 1, nu
- do 6 q = 1, ny
- do 5 p = 1, nx
- if (y(q) .ge. 1e0) goto 1
- kappa = 1
- goto 4
- 1 if (y(q) .ge. 2e0) goto 2
- kappa = 0.5
- goto 3
- 2 kappa = 1e0/3e0
- 3 continue
- 4 a(p, q, i, 1) = kappa*ux(p, q, i)
- aux(p, q, i, i, 1) = kappa
- a(p, q, i, 2) = kappa*uy(p, q, i)
- auy(p, q, i, i, 2) = kappa
- f(p, q, i) = ut(p, q, i)
- fut(p, q, i, i) = 1
- f(p, q, i) = f(p, q, i)-y(q)/kappa
- temp = 1e0 .lt. y(q)
- if (temp) temp = y(q) .lt. 2e0
- if (temp) f(p, q, i) = f(p, q, i)+1e0
- temp = 2e0 .lt. y(q)
- if (temp) temp = y(q) .lt. 3e0
- if (temp) f(p, q, i) = f(p, q, i)+3e0
- 5 continue
- 6 continue
- 7 continue
- return
- end
- subroutine bc(t, x, nx, y, ny, lx, rx, ly, ry, u, ut, ux,
- 1 uy, uxt, uyt, nu, b, bu, but, bux, buy, buxt, buyt)
- integer nu, nx, ny
- real t, x(nx), y(ny), lx, rx, ly
- real ry, u(nx, ny, nu), ut(nx, ny, nu), ux(nx, ny, nu)
- 1 , uy(nx, ny, nu), uxt(nx, ny, nu)
- real uyt(nx, ny, nu), b(nx, ny, nu), bu(nx, ny, nu,
- 1 nu), but(nx, ny, nu, nu), bux(nx, ny, nu, nu), buy(nx, ny, nu
- 2 , nu)
- real buxt(nx, ny, nu, nu), buyt(nx, ny, nu, nu)
- integer i, j
- logical temp
- do 6 j = 1, ny
- do 5 i = 1, nx
- temp = x(i) .eq. lx
- if (.not. temp) temp = x(i) .eq. rx
- if (.not. temp) goto 1
- bux(i, j, 1, 1) = 1
-c left or right.
-c neumann bcs.
- b(i, j, 1) = ux(i, j, 1)
- goto 4
- 1 if (y(j) .ne. ly) goto 2
- b(i, j, 1) = u(i, j, 1)
-c bottom.
- bu(i, j, 1, 1) = 1
- goto 3
- 2 b(i, j, 1) = u(i, j, 1)-6e0*t
-c top.
- bu(i, j, 1, 1) = 1
- 3 continue
- 4 continue
- 5 continue
- 6 continue
- return
- end
- subroutine ewe2(t, x, nx, y, ny, u, inu, ir)
- integer inu, ir, nx, ny
- real t, x(nx), y(ny), u(nx, ny), dble
- integer i, j
-c the exact solution.
- do 6 i = 1, nx
- do 5 j = 1, ny
- u(i, j) = (float(ir))*t*y(j)-(float(ir-1))*t
- if(ir.eq.3) u(i,j)=u(i,j)-t
- 5 continue
- 6 continue
- return
- end
- subroutine handlu(t0, u0, t, u, nv, dt, tstop)
- integer nv
- real t0, u0(nv), t, u(nv), dt, tstop
- common /a7tgup/ errpar, nu, mxp, myp
- integer nu
- real errpar(2)
- common /a7tgum/ kxp,ix,nxp,kyp,iy,nyp,nxnyt,nr,iup
- integer kx, ix, nx, ky, iy, ny
- common /cstak/is
- integer is(1000)
- iwrite=i1mach(2)
- if (t0 .ne. t) goto 2
- write (iwrite, 1) t
- 1 format (16h restart for t =, 1pe10.2)
- return
-c get and print the error.
- 2 continue
- write(iwrite, 3)t
- 3 format(6h at t=,1pe10.2)
- ius=1
- do 5 inu = 1, nu
- iyr=iy
- ixr=ix
- do 4 ir=1,nr
- ir1=ir-1
- nx=is(nxp+ir1)
- ny=is(nyp+ir1)
- kx=is(kxp+ir1)
- ky=is(kyp+ir1)
- call gerr(kx, ixr, nx, ky, iyr, ny, u(ius), inu, t, ir)
- ixr=ixr+nx
- iyr=iyr+ny
- ius=ius+(nx-kx)*(ny-ky)
- 4 continue
- 5 continue
- return
- end
- subroutine gerr(kx, ix, nx, ky, iy, ny, u, inu, t, ir)
- integer kx, ix, nx, ky, iy, ny, inu, ir
- real u(1), t
- common /cstak/ ds
- real ds(500)
- integer ifa, ita(2), ixa(2), nta(2), nxa(2), ILUMD
- integer ixs, iys, nxs, nys, istkgt, i
- integer iewe, ka(2), ma(2), is(1000), i1mach
- real rs(1000)
- logical ls(1000)
- complex cs(500)
- real ABS, erru, AMAX1, ws(500)
- integer temp, temp1, temp2
- equivalence (ds(1), cs(1), ws(1), rs(1), is(1), ls(1))
-c to get and print the error at each time-step.
-c for variable inu for rectangle ir
-c u(nx-kx,ny-ky).
-c the port library stack and its aliases.
- call enter(1)
-c find the error in the solution at 2*kx * 2*ky points / mesh rectangle.
-c x search grid.
- ixs = ILUMD(ws(ix), nx, 2*kx, nxs)
-c y search grid.
- iys = ILUMD(ws(iy), ny, 2*ky, nys)
-c u search grid values.
- iewe = istkgt(nxs*nys, 3)
-c the exact solution.
- call ewe2(t, ws(ixs), nxs, ws(iys), nys, ws(iewe), inu, ir)
- ka(1) = kx
- ka(2) = ky
- ita(1) = ix
- ita(2) = iy
- nta(1) = nx
- nta(2) = ny
- ixa(1) = ixs
- ixa(2) = iys
- nxa(1) = nxs
- nxa(2) = nys
- ma(1) = 0
-c get solution.
- ma(2) = 0
-c approximate solution values.
- ifa = istkgt(nxs*nys, 3)
-c evaluate them.
- call tsd1(2, ka, ws, ita, nta, u, ws, ixa, nxa, ma, ws(ifa))
-c error in solution values.
- erru = 0
- temp = nxs*nys
- do 1 i = 1, temp
- temp2 = iewe+i
- temp1 = ifa+i
- erru = AMAX1(erru, ABS(ws(temp2-1)-ws(temp1-1)))
- 1 continue
- temp = i1mach(2)
- write (temp, 2) ir, inu, erru
- 2 format(9h for rect,i3,14h error in u(.,, i2,
- 1 3h) =, 1pe10.2)
- call leave
- return
- end
diff --git a/CEP/PyBDSM/src/port3/ttgux4.f b/CEP/PyBDSM/src/port3/ttgux4.f
deleted file mode 100644
index 5747c60ba3667058756d130aa19ffb6788e1321e..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ttgux4.f
+++ /dev/null
@@ -1,256 +0,0 @@
-c main program
- common /cstak/ ds
- real ds(350000)
- external handlu, bc, af, ic
- integer ndx, ndy, istkgt, is(1000), iu
- integer nu, nr, iyb(3), ixb(3), kx, ky
- integer nxr(3), nyr(3), kxr(3), kyr(3)
- integer IUMB
- real errpar(2), rs(1000)
- logical ls(1000)
- complex cs(500)
- real tstart, dt
- real ws(500), tstop
- equivalence (ds(1), cs(1), ws(1), rs(1), is(1), ls(1))
-c to solve two coupled, nonlinear heat equations.
-c u1 sub t = div . ( u1x, u1y ) - u1*u2 + g1
-c u2 sub t = div . ( u2x, u2y ) - u1*u2 + g2
-c the port library stack and its aliases.
-c initialize the port library stack length.
- call istkin(350000, 3)
- call enter(1)
- nu = 2
- kx = 4
- ky = 4
- ndx = 3
- ndy = 3
- nr = 3
- tstart = 1.0e0
- dt = 1e-2
- tstop =1.01e0
- errpar(1) = 1e-2
- errpar(2) = 1e-4
-c uniform grid.
- ixb(1) = IUMB(0.0e0, 1.0e0, ndx, kx, nxr(1))
- ixb(2) = IUMB(0.0e0, 1.0e0, ndx, kx, nxr(2))
- ixb(3) = IUMB(1.0e0, 2.0e0, ndx, kx, nxr(3))
- iyb(1) = IUMB(0.0e0, 1.0e0, ndy, ky, nyr(1))
- iyb(2) = IUMB(1.0e0, 2.0e0, ndy, ky, nyr(2))
- iyb(3) = IUMB(0.0e0, 1.0e0, ndy, ky, nyr(3))
-c uniform grid.
-c space for the solution.
- nnu=0
- do 1 i=1,nr
- nnu=nnu+nu*((nxr(i)-kx)*(nyr(i)-ky))
- 1 continue
- iu = istkgt(nnu, 3)
- do 2 i=1,nr
- kxr(i)=kx
- kyr(i)=ky
- 2 continue
- call icon(ws(iu),nu,nr,kxr,ws,nxr,ixb,kyr,ws,nyr,iyb,ic)
- iu1=iu
- iwrite=i1mach(2)
- write(iwrite,3)
-3 format(10h initially)
- do 5 inu=1,nu
- do 4 i=1,nr
- call gerr(kxr(i),ixb(i),nxr(i),kyr(i),iyb(i),nyr(i),
- 1 ws(iu1),inu,1.0e0,i)
- iu1=iu1+(nxr(i)-kxr(i))*(nyr(i)-kyr(i))
-4 continue
-5 continue
- call ttgu(ws(iu),nu,nr,kxr,ws,nxr,ixb,kyr,ws,nyr,iyb,tstart,
- 1 tstop, dt, af, bc, errpar, handlu)
- call leave
- call wrapup
- stop
- end
- subroutine af(t, x, nx, y, ny, nu, u, ut, ux, uy, uxt, uyt
- 1 , a, au, aut, aux, auy, auxt, auyt, f, fu, fut, fux, fuy, fuxt,
- 2 fuyt)
- integer nu, nx, ny
- real t, x(nx), y(ny), u(nx, ny, nu), ut(nx, ny, nu),
- 1 ux(nx, ny, nu)
- real uy(nx, ny, nu), uxt(nx, ny, nu), uyt(nx, ny, nu),
- 1 a(nx, ny, nu, 2), au(nx, ny, nu, nu, 2), aut(nx, ny, nu, nu, 2)
- real aux(nx, ny, nu, nu, 2), auy(nx, ny, nu, nu, 2),
- 1 auxt(nx, ny, nu, nu, 2), auyt(nx, ny, nu, nu, 2), f(nx, ny, nu)
- 2 , fu(nx, ny, nu, nu)
- real fut(nx, ny, nu, nu), fux(nx, ny, nu, nu), fuy(nx,
- 1 ny, nu, nu), fuxt(nx, ny, nu, nu), fuyt(nx, ny, nu, nu)
- integer p, q
- real EXP
- do 2 q = 1, ny
- do 1 p = 1, nx
- a(p, q, 1, 1) = ux(p, q, 1)
- aux(p, q, 1, 1, 1) = 1
- a(p, q, 1, 2) = uy(p, q, 1)
- auy(p, q, 1, 1, 2) = 1
- f(p, q, 1) = ut(p, q, 1)+u(p, q, 1)*u(p, q, 2)
- fu(p, q, 1, 1) = u(p, q, 2)
- fu(p, q, 1, 2) = u(p, q, 1)
- fut(p, q, 1, 1) = 1
- a(p, q, 2, 1) = ux(p, q, 2)
- aux(p, q, 2, 2, 1) = 1
- a(p, q, 2, 2) = uy(p, q, 2)
- auy(p, q, 2, 2, 2) = 1
- f(p, q, 2) = ut(p, q, 2)+u(p, q, 1)*u(p, q, 2)
- fu(p, q, 2, 1) = u(p, q, 2)
- fu(p, q, 2, 2) = u(p, q, 1)
- fut(p, q, 2, 2) = 1
- f(p, q, 1) = f(p, q, 1)-( EXP(t*(x(p)-y(q)))*(x(p)-y(q)-2e0*
- 1 t*t)+1e0)
- f(p, q, 2) = f(p, q, 2)-( EXP(t*(y(q)-x(p)))*(y(q)-x(p)-2e0*
- 1 t*t)+1e0)
- 1 continue
- 2 continue
- return
- end
- subroutine bc(t, x, nx, y, ny, lx, rx, ly, ry, u, ut, ux,
- 1 uy, uxt, uyt, nu, b, bu, but, bux, buy, buxt, buyt)
- integer nu, nx, ny
- real t, x(nx), y(ny), lx, rx, ly
- real ry, u(nx, ny, nu), ut(nx, ny, nu), ux(nx, ny, nu)
- 1 , uy(nx, ny, nu), uxt(nx, ny, nu)
- real uyt(nx, ny, nu), b(nx, ny, nu), bu(nx, ny, nu,
- 1 nu), but(nx, ny, nu, nu), bux(nx, ny, nu, nu), buy(nx, ny, nu
- 2 , nu)
- real buxt(nx, ny, nu, nu), buyt(nx, ny, nu, nu)
- integer i, j
- real EXP
- do 2 j = 1, ny
- do 1 i = 1, nx
- bu(i, j, 1, 1) = 1
- b(i, j, 1) = u(i, j, 1)- EXP(t*(x(i)-y(j)))
- bu(i, j, 2, 2) = 1
- b(i, j, 2) = u(i, j, 2)- EXP(t*(y(j)-x(i)))
- 1 continue
- 2 continue
- return
- end
- subroutine ic(nu,ir,xq,nxq,yq,nyq,ui)
- integer nu, ir, nxq, nyq
- real xq(nxq), yq(nyq), ui(nxq, nyq,nu)
- real dble, EXP
- integer p
- do 30 p=1,nu
- do 20 j=1,nyq
- do 10 i=1, nxq
- ui(i, j, p) = EXP((float((-1)**(p+1)))*(xq(i)-yq(j)))
-10 continue
-20 continue
-30 continue
- return
- end
- subroutine ewe2(t, x, nx, y, ny, u, inu, ir)
- integer inu, nx, ny, ir
- real t, x(nx), y(ny), u(nx, ny)
- integer i, j
- real float
- real dble, EXP
-c the exact solution.
- do 2 i = 1, nx
- do 1 j = 1, ny
- u(i, j) = EXP((float((-1)**(inu+1)))*t*(x(i)-y(j)))
-1 continue
- 2 continue
- return
- end
- subroutine handlu(t0, u0, t, u, nv, dt, tstop)
- integer nv
- real t0, u0(nv), t, u(nv), dt, tstop
- common /a7tgup/ errpar, nu, mxp, myp
- integer nu
- real errpar(2)
- common /a7tgum/ kxp,ix,nxp,kyp,iy,nyp,nxnyt,nr,iup
- integer kx, ix, nx, ky, iy, ny
- common /cstak/is
- integer is(1000)
- iwrite=i1mach(2)
- if (t0 .ne. t) goto 2
- write (iwrite, 1) t
- 1 format (16h restart for t =, 1pe10.2)
- return
-c get and print the error.
- 2 continue
- write(iwrite, 3)t
- 3 format(6h at t=,1pe10.2)
- ius=1
- do 5 inu = 1, nu
- iyr=iy
- ixr=ix
- do 4 ir=1,nr
- ir1=ir-1
- nx=is(nxp+ir1)
- ny=is(nyp+ir1)
- kx=is(kxp+ir1)
- ky=is(kyp+ir1)
- call gerr(kx, ixr, nx, ky, iyr, ny, u(ius), inu, t, ir)
- ixr=ixr+nx
- iyr=iyr+ny
- ius=ius+(nx-kx)*(ny-ky)
- 4 continue
- 5 continue
- return
- end
- subroutine gerr(kx, ix, nx, ky, iy, ny, u, inu, t, ir)
- integer kx, ix, nx, ky, iy, ny, inu, ir
- real u(1), t
- common /cstak/ ds
- real ds(500)
- integer ifa, ita(2), ixa(2), nta(2), nxa(2), ILUMD
- integer ixs, iys, nxs, nys, istkgt, i
- integer iewe, ka(2), ma(2), is(1000), i1mach
- real rs(1000)
- logical ls(1000)
- complex cs(500)
- real ABS, erru, AMAX1, ws(500)
- integer temp, temp1, temp2
- equivalence (ds(1), cs(1), ws(1), rs(1), is(1), ls(1))
-c to get and print the error at each time-step.
-c for variable inu for rectangle ir
-c u(nx-kx,ny-ky).
-c the port library stack and its aliases.
- call enter(1)
-c find the error in the solution at 2*kx * 2*ky points / mesh rectangle.
-c x search grid.
- ixs = ILUMD(ws(ix), nx, 2*kx, nxs)
-c y search grid.
- iys = ILUMD(ws(iy), ny, 2*ky, nys)
-c u search grid values.
- iewe = istkgt(nxs*nys, 3)
-c the exact solution.
- call ewe2(t, ws(ixs), nxs, ws(iys), nys, ws(iewe), inu, ir)
- ka(1) = kx
- ka(2) = ky
- ita(1) = ix
- ita(2) = iy
- nta(1) = nx
- nta(2) = ny
- ixa(1) = ixs
- ixa(2) = iys
- nxa(1) = nxs
- nxa(2) = nys
- ma(1) = 0
-c get solution.
- ma(2) = 0
-c approximate solution values.
- ifa = istkgt(nxs*nys, 3)
-c evaluate them.
- call tsd1(2, ka, ws, ita, nta, u, ws, ixa, nxa, ma, ws(ifa))
-c error in solution values.
- erru = 0
- temp = nxs*nys
- do 1 i = 1, temp
- temp2 = iewe+i
- temp1 = ifa+i
- erru = AMAX1(erru, ABS(ws(temp2-1)-ws(temp1-1)))
- 1 continue
- temp = i1mach(2)
- write (temp, 2) ir, inu, erru
- 2 format(9h for rect,i3,14h error in u(.,, i2,
- 1 3h) =, 1pe10.2)
- call leave
- return
- end
diff --git a/CEP/PyBDSM/src/port3/ttgux5.f b/CEP/PyBDSM/src/port3/ttgux5.f
deleted file mode 100644
index 8906bfd83eea75cd0c1df0b36a6dd72d15314c0d..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/ttgux5.f
+++ /dev/null
@@ -1,267 +0,0 @@
-C$TEST TTGU5
-c main program
- common /cstak/ ds
- real ds(350000)
- external handlu, bc, af
- integer ndx, ndy, istkgt, is(1000), iu, ix, temp, temp1
- integer nu, nr, iyb(5), ixb(5), kx, ky
- integer nxr(5), nyr(5), kxr(5), kyr(5)
- integer IUMB
- real errpar(2), rs(1000)
- logical ls(1000)
- complex cs(500)
- real tstart, dt, rx
- real ws(500), tstop
- equivalence (ds(1), cs(1), ws(1), rs(1), is(1), ls(1))
-c to solve laplaces equation with real ( z*log(z) ) as solution.
-c the port library stack and its aliases.
-c initialize the port library stack length.
- call istkin(350000, 3)
- call enter(1)
- nu = 1
- kx = 4
- ky = 4
- ndx = 3
- ndy = 3
- nr = 5
- tstart = 0
- dt = 1.e0
- tstop =1.e0
- errpar(1) = 1e-2
- errpar(2) = 1e-4
- nx = ndx+2*(kx-1)
- rx=1.0e0
-c space for x mesh for rectangle 1
- ix = istkgt(nx, 3)
-c 0 and rx mult = kx.
- ixb(1)=ix
- do 1 i = 1, kx
- temp = ix+i
- ws(temp-1) = 0
- temp = ix+nx-i
- ws(temp) = rx
- 1 continue
- temp = ndx-1
- do 2 i = 1, temp
- temp1 = ix+kx-2+i
- ws(temp1) = rx*((float(i-1))/((float(ndx))-1e0))**kx
- 2 continue
-c rectangle 2 has same grid in x direction as rectanlge 1
- ixb(2)=istkgt(nx, 3)
- call SCOPY(nx, ws(ix), 1, ws(ixb(2)), 1)
-c uniform grid for rectanlges 3,4, and 5 in x direction
- ixb(3) = IUMB(1.0e0, 2.0e0, ndx, kx, nxr(3))
- ixb(4) = IUMB(2.0e0, 3.0e0, ndx, kx, nxr(4))
- ixb(5) = IUMB(2.0e0, 3.0e0, ndx, kx, nxr(5))
- ny = ndy+2*(ky-1)
-c rectangles 1,3, and 4 use the same grid in the y direction as
-c is used for the x direction in rectangle 1
-c space for y mesh.
- iyb(1) = istkgt(ny, 3)
- call SCOPY( nx, ws(ix), 1, ws(iyb(1)), 1)
- iyb(3) =istkgt(ny, 3)
- call SCOPY( nx, ws(ix), 1, ws(iyb(3)), 1)
- iyb(4) =istkgt(ny, 3)
- call SCOPY( nx, ws(ix), 1, ws(iyb(4)), 1)
-c rectangles 2 and 5 use uniform mesh in y direction
- iyb(2) = IUMB(1.0e0, 2.0e0, ndy, ky, nyr(2))
- iyb(5) = IUMB(1.0e0, 2.0e0, ndy, ky, nyr(5))
-c space for the solution.
- nnu=0
- do 3 i=1,nr
- nxr(i)=nx
- nyr(i)=ny
- nnu=nnu+nu*((nxr(i)-kx)*(nyr(i)-ky))
- 3 continue
- iu = istkgt(nnu, 3)
- do 4 i=1,nr
- kxr(i)=kx
- kyr(i)=ky
- 4 continue
- call SETR(nnu, 0.0e0,ws(iu))
- call ttgu(ws(iu),nu,nr,kxr,ws,nxr,ixb,kyr,ws,nyr,iyb,tstart,
- 1 tstop, dt, af, bc, errpar, handlu)
- call leave
- call wrapup
- stop
- end
- subroutine af(t, xi, nx, yi, ny, nu, u, ut, ux, uy, uxt,
- 1 uyt, a, au, aut, aux, auy, auxt, auyt, f, fu, fut, fux, fuy,
- 2 fuxt, fuyt)
- integer nu, nx, ny
- real t, xi(nx), yi(ny), u(nx, ny, nu), ut(nx, ny, nu),
- 1 ux(nx, ny, nu)
- real uy(nx, ny, nu), uxt(nx, ny, nu), uyt(nx, ny, nu),
- 1 a(nx, ny, nu, 2), au(nx, ny, nu, nu, 2), aut(nx, ny, nu, nu, 2)
- real aux(nx, ny, nu, nu, 2), auy(nx, ny, nu, nu, 2),
- 1 auxt(nx, ny, nu, nu, 2), auyt(nx, ny, nu, nu, 2), f(nx, ny, nu)
- 2 , fu(nx, ny, nu, nu)
- real fut(nx, ny, nu, nu), fux(nx, ny, nu, nu), fuy(nx,
- 1 ny, nu, nu), fuxt(nx, ny, nu, nu), fuyt(nx, ny, nu, nu)
- integer i, p, q
- do 3 i = 1, nu
- do 2 q = 1, ny
- do 1 p = 1, nx
- a(p, q, i, 1) = ux(p, q, i)
- a(p, q, i, 2) = uy(p, q, i)
- aux(p, q, i, i, 1) = 1
- auy(p, q, i, i, 2) = 1
- 1 continue
- 2 continue
- 3 continue
- return
- end
- subroutine bc(t, x, nx, y, ny, lx, rx, ly, ry, u, ut, ux,
- 1 uy, uxt, uyt, nu, b, bu, but, bux, buy, buxt, buyt)
- integer nu, nx, ny
- real t, x(nx), y(ny), lx, rx, ly
- real ry, u(nx, ny, nu), ut(nx, ny, nu), ux(nx, ny, nu)
- 1 , uy(nx, ny, nu), uxt(nx, ny, nu)
- real uyt(nx, ny, nu), b(nx, ny, nu), bu(nx, ny, nu,
- 1 nu), but(nx, ny, nu, nu), bux(nx, ny, nu, nu), buy(nx, ny, nu
- 2 , nu)
- real buxt(nx, ny, nu, nu), buyt(nx, ny, nu, nu)
- integer i, j
- real r, COS, ALOG, SIN, ATAN, theta
- real SQRT
- do 6 j = 1, ny
- do 5 i = 1, nx
- if (y(j) .ne. ly) goto 1
- b(i, j, 1) = uy(i, j, 1)
-c neumann data on bottom.
- buy(i, j, 1, 1) = 1
- goto 4
- 1 r = SQRT(x(i)**2+y(j)**2)
-c dirichlet data.
- if (x(i) .le. 0e0) goto 2
- theta = ATAN(y(j)/x(i))
- goto 3
- 2 theta = 2e0* ATAN(1e0)
- 3 b(i, j, 1) = u(i, j, 1)-r*( COS(theta)*ALOG(r)-theta*
- 1 SIN(theta))
- bu(i, j, 1, 1) = 1
- 4 continue
- 5 continue
- 6 continue
- return
- end
- subroutine ewe2(t, x, nx, y, ny, u, inu, ir)
- integer inu,ir, nx, ny
- real t, x(nx), y(ny), u(nx, ny)
- integer i, j
- real r, COS, ALOG, SIN, ATAN, theta
- real SQRT
-c the exact solution.
- do 6 i = 1, nx
- do 5 j = 1, ny
- r = SQRT(x(i)**2+y(j)**2)
- if (x(i) .le. 0e0) goto 1
- theta = ATAN(y(j)/x(i))
- goto 2
- 1 theta = 2e0* ATAN(1e0)
- 2 if (r .le. 0e0) goto 3
- u(i, j) = r*( COS(theta)*ALOG(r)-theta* SIN(theta))
- goto 4
- 3 u(i, j) = 0
- 4 continue
- 5 continue
- 6 continue
- return
- end
- subroutine handlu(t0, u0, t, u, nv, dt, tstop)
- integer nv
- real t0, u0(nv), t, u(nv), dt, tstop
- common /a7tgup/ errpar, nu, mxp, myp
- integer nu
- real errpar(2)
- common /a7tgum/ kxp,ix,nxp,kyp,iy,nyp,nxnyt,nr,iup
- integer kx, ix, nx, ky, iy, ny
- common /cstak/is
- integer is(1000)
- iwrite=i1mach(2)
- if (t0 .ne. t) goto 2
- write (iwrite, 1) t
- 1 format (16h restart for t =, 1pe10.2)
- return
-c get and print the error.
- 2 continue
- write(iwrite, 3)t
- 3 format(6h at t=,1pe10.2)
- ius=1
- do 5 inu = 1, nu
- iyr=iy
- ixr=ix
- do 4 ir=1,nr
- ir1=ir-1
- nx=is(nxp+ir1)
- ny=is(nyp+ir1)
- kx=is(kxp+ir1)
- ky=is(kyp+ir1)
- call gerr(kx, ixr, nx, ky, iyr, ny, u(ius), inu, t, ir)
- ixr=ixr+nx
- iyr=iyr+ny
- ius=ius+(nx-kx)*(ny-ky)
- 4 continue
- 5 continue
- return
- end
- subroutine gerr(kx, ix, nx, ky, iy, ny, u, inu, t, ir)
- integer kx, ix, nx, ky, iy, ny, inu, ir
- real u(1), t
- common /cstak/ ds
- real ds(500)
- integer ifa, ita(2), ixa(2), nta(2), nxa(2), ILUMD
- integer ixs, iys, nxs, nys, istkgt, i
- integer iewe, ka(2), ma(2), is(1000), i1mach
- real rs(1000)
- logical ls(1000)
- complex cs(500)
- real ABS, erru, AMAX1, ws(500)
- integer temp, temp1, temp2
- equivalence (ds(1), cs(1), ws(1), rs(1), is(1), ls(1))
-c to get and print the error at each time-step.
-c for variable inu for rectangle ir
-c u(nx-kx,ny-ky).
-c the port library stack and its aliases.
- call enter(1)
-c find the error in the solution at 2*kx * 2*ky points / mesh rectangle.
-c x search grid.
- ixs = ILUMD(ws(ix), nx, 2*kx, nxs)
-c y search grid.
- iys = ILUMD(ws(iy), ny, 2*ky, nys)
-c u search grid values.
- iewe = istkgt(nxs*nys, 3)
-c the exact solution.
- call ewe2(t, ws(ixs), nxs, ws(iys), nys, ws(iewe), inu, ir)
- ka(1) = kx
- ka(2) = ky
- ita(1) = ix
- ita(2) = iy
- nta(1) = nx
- nta(2) = ny
- ixa(1) = ixs
- ixa(2) = iys
- nxa(1) = nxs
- nxa(2) = nys
- ma(1) = 0
-c get solution.
- ma(2) = 0
-c approximate solution values.
- ifa = istkgt(nxs*nys, 3)
-c evaluate them.
- call tsd1(2, ka, ws, ita, nta, u, ws, ixa, nxa, ma, ws(ifa))
-c error in solution values.
- erru = 0
- temp = nxs*nys
- do 1 i = 1, temp
- temp2 = iewe+i
- temp1 = ifa+i
- erru = AMAX1(erru, ABS(ws(temp2-1)-ws(temp1-1)))
- 1 continue
- temp = i1mach(2)
- write (temp, 2) ir, inu, erru
- 2 format(9h for rect,i3,14h error in u(.,, i2,
- 1 3h) =, 1pe10.2)
- call leave
- return
- end
diff --git a/CEP/PyBDSM/src/port3/u9dmp.f b/CEP/PyBDSM/src/port3/u9dmp.f
deleted file mode 100644
index 5e7323531e9304d076eaf295d5eaace1f9740ac2..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/u9dmp.f
+++ /dev/null
@@ -1,74 +0,0 @@
- SUBROUTINE U9DMP(LNG, NCOL, WI, WR, DR, WD, DD)
-C
-C THIS SUBROUTINE ASSUMES THAT THE TYPE (INTEGER, ETC.) OF THE DATA
-C IN THE PORT STACK IS NOT KNOWN - SO IT PRINTS OUT, IN ALL FORMATS
-C THE STACK CONTENTS, USING THE ARRAY OUTPUT ROUTINES APRNTX.
-C
-C WRITTEN BY DAN WARNER, REVISED BY PHYL FOX, NOVEMBER 8, 1982.
-C
-C INPUT PARAMETERS -
-C
-C LNG - AN INTEGER VECTOR ARRAY CONTAINING IN
-C LNG(1) THE LENGTH OF THE ARRAY IF LOGICAL
-C LNG(2) THE LENGTH OF THE ARRAY IF INTEGER
-C LNG(3) THE LENGTH OF THE ARRAY IF REAL
-C LNG(4) THE LENGTH OF THE ARRAY IF DOUBLE PRECISION
-C LNG(5) THE LENGTH OF THE ARRAY IF COMPLEX
-C
-C NCOL - THE NUMBER OF SPACES ACROSS A PRINTED LINE
-C
-C WI - THE FORMAT WIDTH FOR AN INTEGER
-C
-C WR - THE FORMAT WIDTH FOR A REAL (W IN 1PEW.D)
-C
-C DR - THE NUMBER OF DIGITS AFTER THE DECIMAL POINT
-C (THE D IN THE 1PEW.D FORMULA)
-C
-C WD - THE FORMAT WIDTH FOR A REAL (W IN 1PDW.D)
-C
-C DD - THE NUMBER OF DIGITS AFTER THE DECIMAL POINT
-C (THE D IN THE 1PDW.D FORMULA)
-C
-C
-C ERROR STATES - NONE. U9DMP IS CALLED BY SETERR,
-C SO IT CANNOT CALL SETERR.
-C
-C
- INTEGER LNG(5), NCOL, WI, WR, DR, WD
- INTEGER DD
- COMMON /CSTAK/ DSTAK
- DOUBLE PRECISION DSTAK(500)
- INTEGER ERROUT, ISTAK(1000), I1MACH
- REAL RSTAK(1000)
- LOGICAL LSTAK(1000)
-C/R
-C REAL CMSTAK(2,500)
-C EQUIVALENCE (DSTAK(1), CMSTAK(1,1))
-C/C
- COMPLEX CMSTAK(500)
- EQUIVALENCE (DSTAK(1), CMSTAK(1))
-C/
- EQUIVALENCE (DSTAK(1), ISTAK(1))
- EQUIVALENCE (DSTAK(1), LSTAK(1))
- EQUIVALENCE (DSTAK(1), RSTAK(1))
-C
- ERROUT = I1MACH(4)
-C
- WRITE (ERROUT, 1)
- 1 FORMAT (14H0LOGICAL STACK)
- CALL A9RNTL(LSTAK, LNG(1), ERROUT, NCOL)
- WRITE (ERROUT, 2)
- 2 FORMAT (14H0INTEGER STACK)
- CALL A9RNTI(ISTAK, LNG(2), ERROUT, NCOL, WI)
- WRITE (ERROUT, 3)
- 3 FORMAT (11H0REAL STACK)
- CALL A9RNTR(RSTAK, LNG(3), ERROUT, NCOL, WR, DR)
- WRITE (ERROUT, 4)
- 4 FORMAT (23H0DOUBLE PRECISION STACK)
- CALL A9RNTD(DSTAK, LNG(4), ERROUT, NCOL, WD, DD)
- WRITE (ERROUT, 5)
- 5 FORMAT (14H0COMPLEX STACK)
- CALL A9RNTC(CMSTAK, LNG(5), ERROUT, NCOL, WR, DR)
-C
- RETURN
- END
diff --git a/CEP/PyBDSM/src/port3/v2axy.f b/CEP/PyBDSM/src/port3/v2axy.f
deleted file mode 100644
index b33980030915e5eac9719c8a16f7d86d2cd67d33..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/v2axy.f
+++ /dev/null
@@ -1,13 +0,0 @@
- SUBROUTINE V2AXY(P, W, A, X, Y)
-C
-C *** SET W = A*X + Y -- W, X, Y = P-VECTORS, A = SCALAR ***
-C
- INTEGER P
- REAL A, W(P), X(P), Y(P)
-C
- INTEGER I
-C
- DO 10 I = 1, P
- 10 W(I) = A*X(I) + Y(I)
- RETURN
- END
diff --git a/CEP/PyBDSM/src/port3/v2nrm.f b/CEP/PyBDSM/src/port3/v2nrm.f
deleted file mode 100644
index afca414d298eb269dd7261551e7216520f3d6dfe..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/v2nrm.f
+++ /dev/null
@@ -1,61 +0,0 @@
- REAL FUNCTION V2NRM(P, X)
-C
-C *** RETURN THE 2-NORM OF THE P-VECTOR X, TAKING ***
-C *** CARE TO AVOID THE MOST LIKELY UNDERFLOWS. ***
-C
- INTEGER P
- REAL X(P)
-C
- INTEGER I, J
- REAL ONE, R, SCALE, SQTETA, T, XI, ZERO
-C/+
- REAL SQRT
-C/
- REAL R7MDC
- EXTERNAL R7MDC
-C
-C/6
-C DATA ONE/1.E+0/, ZERO/0.E+0/
-C/7
- PARAMETER (ONE=1.E+0, ZERO=0.E+0)
- SAVE SQTETA
-C/
- DATA SQTETA/0.E+0/
-C
- IF (P .GT. 0) GO TO 10
- V2NRM = ZERO
- GO TO 999
- 10 DO 20 I = 1, P
- IF (X(I) .NE. ZERO) GO TO 30
- 20 CONTINUE
- V2NRM = ZERO
- GO TO 999
-C
- 30 SCALE = ABS(X(I))
- IF (I .LT. P) GO TO 40
- V2NRM = SCALE
- GO TO 999
- 40 T = ONE
- IF (SQTETA .EQ. ZERO) SQTETA = R7MDC(2)
-C
-C *** SQTETA IS (SLIGHTLY LARGER THAN) THE SQUARE ROOT OF THE
-C *** SMALLEST POSITIVE FLOATING POINT NUMBER ON THE MACHINE.
-C *** THE TESTS INVOLVING SQTETA ARE DONE TO PREVENT UNDERFLOWS.
-C
- J = I + 1
- DO 60 I = J, P
- XI = ABS(X(I))
- IF (XI .GT. SCALE) GO TO 50
- R = XI / SCALE
- IF (R .GT. SQTETA) T = T + R*R
- GO TO 60
- 50 R = SCALE / XI
- IF (R .LE. SQTETA) R = ZERO
- T = ONE + T * R*R
- SCALE = XI
- 60 CONTINUE
-C
- V2NRM = SCALE * SQRT(T)
- 999 RETURN
-C *** LAST LINE OF V2NRM FOLLOWS ***
- END
diff --git a/CEP/PyBDSM/src/port3/v7cpy.f b/CEP/PyBDSM/src/port3/v7cpy.f
deleted file mode 100644
index 30ff4b293f8c4a527f24d1a8d3d88c5285dfda26..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/v7cpy.f
+++ /dev/null
@@ -1,13 +0,0 @@
- SUBROUTINE V7CPY(P, Y, X)
-C
-C *** SET Y = X, WHERE X AND Y ARE P-VECTORS ***
-C
- INTEGER P
- REAL X(P), Y(P)
-C
- INTEGER I
-C
- DO 10 I = 1, P
- 10 Y(I) = X(I)
- RETURN
- END
diff --git a/CEP/PyBDSM/src/port3/v7dfl.f b/CEP/PyBDSM/src/port3/v7dfl.f
deleted file mode 100644
index a78fb6f392e0f38f3204bc7a157efbaa7fa4dfa2..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/v7dfl.f
+++ /dev/null
@@ -1,104 +0,0 @@
- SUBROUTINE V7DFL(ALG, LV, V)
-C
-C *** SUPPLY ***SOL (VERSION 2.3) DEFAULT VALUES TO V ***
-C
-C *** ALG = 1 MEANS REGRESSION CONSTANTS.
-C *** ALG = 2 MEANS GENERAL UNCONSTRAINED OPTIMIZATION CONSTANTS.
-C
- INTEGER ALG, LV
- REAL V(LV)
-C
- REAL R7MDC
- EXTERNAL R7MDC
-C R7MDC... RETURNS MACHINE-DEPENDENT CONSTANTS
-C
- REAL MACHEP, MEPCRT, ONE, SQTEPS, THREE
-C
-C *** SUBSCRIPTS FOR V ***
-C
- INTEGER AFCTOL, BIAS, COSMIN, DECFAC, DELTA0, DFAC, DINIT, DLTFDC,
- 1 DLTFDJ, DTINIT, D0INIT, EPSLON, ETA0, FUZZ, HUBERC,
- 2 INCFAC, LMAX0, LMAXS, PHMNFC, PHMXFC, RDFCMN, RDFCMX,
- 3 RFCTOL, RLIMIT, RSPTOL, SCTOL, SIGMIN, TUNER1, TUNER2,
- 4 TUNER3, TUNER4, TUNER5, XCTOL, XFTOL
-C
-C/6
-C DATA ONE/1.E+0/, THREE/3.E+0/
-C/7
- PARAMETER (ONE=1.E+0, THREE=3.E+0)
-C/
-C
-C *** V SUBSCRIPT VALUES ***
-C
-C/6
-C DATA AFCTOL/31/, BIAS/43/, COSMIN/47/, DECFAC/22/, DELTA0/44/,
-C 1 DFAC/41/, DINIT/38/, DLTFDC/42/, DLTFDJ/43/, DTINIT/39/,
-C 2 D0INIT/40/, EPSLON/19/, ETA0/42/, FUZZ/45/, HUBERC/48/,
-C 3 INCFAC/23/, LMAX0/35/, LMAXS/36/, PHMNFC/20/, PHMXFC/21/,
-C 4 RDFCMN/24/, RDFCMX/25/, RFCTOL/32/, RLIMIT/46/, RSPTOL/49/,
-C 5 SCTOL/37/, SIGMIN/50/, TUNER1/26/, TUNER2/27/, TUNER3/28/,
-C 6 TUNER4/29/, TUNER5/30/, XCTOL/33/, XFTOL/34/
-C/7
- PARAMETER (AFCTOL=31, BIAS=43, COSMIN=47, DECFAC=22, DELTA0=44,
- 1 DFAC=41, DINIT=38, DLTFDC=42, DLTFDJ=43, DTINIT=39,
- 2 D0INIT=40, EPSLON=19, ETA0=42, FUZZ=45, HUBERC=48,
- 3 INCFAC=23, LMAX0=35, LMAXS=36, PHMNFC=20, PHMXFC=21,
- 4 RDFCMN=24, RDFCMX=25, RFCTOL=32, RLIMIT=46, RSPTOL=49,
- 5 SCTOL=37, SIGMIN=50, TUNER1=26, TUNER2=27, TUNER3=28,
- 6 TUNER4=29, TUNER5=30, XCTOL=33, XFTOL=34)
-C/
-C
-C------------------------------- BODY --------------------------------
-C
- MACHEP = R7MDC(3)
- V(AFCTOL) = 1.E-20
- IF (MACHEP .GT. 1.E-10) V(AFCTOL) = MACHEP**2
- V(DECFAC) = 0.5E+0
- SQTEPS = R7MDC(4)
- V(DFAC) = 0.6E+0
- V(DTINIT) = 1.E-6
- MEPCRT = MACHEP ** (ONE/THREE)
- V(D0INIT) = 1.E+0
- V(EPSLON) = 0.1E+0
- V(INCFAC) = 2.E+0
- V(LMAX0) = 1.E+0
- V(LMAXS) = 1.E+0
- V(PHMNFC) = -0.1E+0
- V(PHMXFC) = 0.1E+0
- V(RDFCMN) = 0.1E+0
- V(RDFCMX) = 4.E+0
- V(RFCTOL) = AMAX1(1.E-10, MEPCRT**2)
- V(SCTOL) = V(RFCTOL)
- V(TUNER1) = 0.1E+0
- V(TUNER2) = 1.E-4
- V(TUNER3) = 0.75E+0
- V(TUNER4) = 0.5E+0
- V(TUNER5) = 0.75E+0
- V(XCTOL) = SQTEPS
- V(XFTOL) = 1.E+2 * MACHEP
-C
- IF (ALG .GE. 2) GO TO 10
-C
-C *** REGRESSION VALUES
-C
- V(COSMIN) = AMAX1(1.E-6, 1.E+2 * MACHEP)
- V(DINIT) = 0.E+0
- V(DELTA0) = SQTEPS
- V(DLTFDC) = MEPCRT
- V(DLTFDJ) = SQTEPS
- V(FUZZ) = 1.5E+0
- V(HUBERC) = 0.7E+0
- V(RLIMIT) = R7MDC(5)
- V(RSPTOL) = 1.E-3
- V(SIGMIN) = 1.E-4
- GO TO 999
-C
-C *** GENERAL OPTIMIZATION VALUES
-C
- 10 V(BIAS) = 0.8E+0
- V(DINIT) = -1.0E+0
- V(ETA0) = 1.0E+3 * MACHEP
-C
- 999 RETURN
-C *** LAST CARD OF V7DFL FOLLOWS ***
- END
diff --git a/CEP/PyBDSM/src/port3/v7ipr.f b/CEP/PyBDSM/src/port3/v7ipr.f
deleted file mode 100644
index f289af596342ab705328fb63f4432209b7db27c7..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/v7ipr.f
+++ /dev/null
@@ -1,29 +0,0 @@
- SUBROUTINE V7IPR(N, IP, X)
-C
-C PERMUTE X SO THAT X.OUTPUT(I) = X.INPUT(IP(I)).
-C IP IS UNCHANGED ON OUTPUT.
-C
- INTEGER N
- INTEGER IP(N)
- REAL X(N)
-C
- INTEGER I, J, K
- REAL T
- DO 30 I = 1, N
- J = IP(I)
- IF (J .EQ. I) GO TO 30
- IF (J .GT. 0) GO TO 10
- IP(I) = -J
- GO TO 30
- 10 T = X(I)
- K = I
- 20 X(K) = X(J)
- K = J
- J = IP(K)
- IP(K) = -J
- IF (J .GT. I) GO TO 20
- X(K) = T
- 30 CONTINUE
- 999 RETURN
-C *** LAST LINE OF V7IPR FOLLOWS ***
- END
diff --git a/CEP/PyBDSM/src/port3/v7prm.f b/CEP/PyBDSM/src/port3/v7prm.f
deleted file mode 100644
index 684feb4bceb03c430e5503f2d1791b48206ac86d..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/v7prm.f
+++ /dev/null
@@ -1,30 +0,0 @@
- SUBROUTINE V7PRM(N, IP, X)
-C
-C PERMUTE X SO THAT X.OUTPUT(IP(I)) = X.INPUT(I).
-C IP IS UNCHANGED ON OUTPUT.
-C
- INTEGER N
- INTEGER IP(N)
- REAL X(N)
-C
- INTEGER I, J, K
- REAL S, T
- DO 30 I = 1, N
- J = IP(I)
- IF (J .EQ. I) GO TO 30
- IF (J .GT. 0) GO TO 10
- IP(I) = -J
- GO TO 30
- 10 T = X(I)
- 20 S = X(J)
- X(J) = T
- T = S
- K = J
- J = IP(K)
- IP(K) = -J
- IF (J .GT. I) GO TO 20
- X(J) = T
- 30 CONTINUE
- 999 RETURN
-C *** LAST LINE OF V7PRM FOLLOWS ***
- END
diff --git a/CEP/PyBDSM/src/port3/v7scl.f b/CEP/PyBDSM/src/port3/v7scl.f
deleted file mode 100644
index bd71e4966948f5179b7148293d8293eb312c7754..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/v7scl.f
+++ /dev/null
@@ -1,14 +0,0 @@
- SUBROUTINE V7SCL(N, X, A, Y)
-C
-C *** SET X(I) = A*Y(I), I = 1(1)N ***
-C
- INTEGER N
- REAL A, X(N), Y(N)
-C
- INTEGER I
-C
- DO 10 I = 1, N
- 10 X(I) = A * Y(I)
- 999 RETURN
-C *** LAST LINE OF V7SCL FOLLOWS ***
- END
diff --git a/CEP/PyBDSM/src/port3/v7scp.f b/CEP/PyBDSM/src/port3/v7scp.f
deleted file mode 100644
index bf9613d19e50fea0cf5a1b1479a678e495bdd1af..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/v7scp.f
+++ /dev/null
@@ -1,13 +0,0 @@
- SUBROUTINE V7SCP(P, Y, S)
-C
-C *** SET P-VECTOR Y TO SCALAR S ***
-C
- INTEGER P
- REAL S, Y(P)
-C
- INTEGER I
-C
- DO 10 I = 1, P
- 10 Y(I) = S
- RETURN
- END
diff --git a/CEP/PyBDSM/src/port3/v7shf.f b/CEP/PyBDSM/src/port3/v7shf.f
deleted file mode 100644
index ad5e2897c4a00d91435de16254c4fc06307845b8..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/v7shf.f
+++ /dev/null
@@ -1,18 +0,0 @@
- SUBROUTINE V7SHF(N, K, X)
-C
-C *** SHIFT X(K),...,X(N) LEFT CIRCULARLY ONE POSITION ***
-C
- INTEGER N, K
- REAL X(N)
-C
- INTEGER I, NM1
- REAL T
-C
- IF (K .GE. N) GO TO 999
- NM1 = N - 1
- T = X(K)
- DO 10 I = K, NM1
- 10 X(I) = X(I+1)
- X(N) = T
- 999 RETURN
- END
diff --git a/CEP/PyBDSM/src/port3/v7swp.f b/CEP/PyBDSM/src/port3/v7swp.f
deleted file mode 100644
index 1169743959416a14839e1bd7c9cacbed75631cce..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/v7swp.f
+++ /dev/null
@@ -1,18 +0,0 @@
- SUBROUTINE V7SWP(N, X, Y)
-C
-C *** INTERCHANGE N-VECTORS X AND Y. ***
-C
- INTEGER N
- REAL X(N), Y(N)
-C
- INTEGER I
- REAL T
-C
- DO 10 I = 1, N
- T = X(I)
- X(I) = Y(I)
- Y(I) = T
- 10 CONTINUE
- 999 RETURN
-C *** LAST CARD OF V7SWP FOLLOWS ***
- END
diff --git a/CEP/PyBDSM/src/port3/v7vmp.f b/CEP/PyBDSM/src/port3/v7vmp.f
deleted file mode 100644
index 2c035c4d63a4fb69fb17aca19d3b2ec7e549618b..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/v7vmp.f
+++ /dev/null
@@ -1,18 +0,0 @@
- SUBROUTINE V7VMP(N, X, Y, Z, K)
-C
-C *** SET X(I) = Y(I) * Z(I)**K, 1 .LE. I .LE. N (FOR K = 1 OR -1) ***
-C
- INTEGER N, K
- REAL X(N), Y(N), Z(N)
- INTEGER I
-C
- IF (K .GE. 0) GO TO 20
- DO 10 I = 1, N
- 10 X(I) = Y(I) / Z(I)
- GO TO 999
-C
- 20 DO 30 I = 1, N
- 30 X(I) = Y(I) * Z(I)
- 999 RETURN
-C *** LAST CARD OF V7VMP FOLLOWS ***
- END
diff --git a/CEP/PyBDSM/src/port3/w7zbf.f b/CEP/PyBDSM/src/port3/w7zbf.f
deleted file mode 100644
index d6aa7ec5cde5b6b7df4b762388282700a5d0d4f0..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/w7zbf.f
+++ /dev/null
@@ -1,84 +0,0 @@
- SUBROUTINE W7ZBF (L, N, S, W, Y, Z)
-C
-C *** COMPUTE Y AND Z FOR L7UPD CORRESPONDING TO BFGS UPDATE.
-C
- INTEGER N
- REAL L(1), S(N), W(N), Y(N), Z(N)
-C DIMENSION L(N*(N+1)/2)
-C
-C-------------------------- PARAMETER USAGE --------------------------
-C
-C L (I/O) CHOLESKY FACTOR OF HESSIAN, A LOWER TRIANG. MATRIX STORED
-C COMPACTLY BY ROWS.
-C N (INPUT) ORDER OF L AND LENGTH OF S, W, Y, Z.
-C S (INPUT) THE STEP JUST TAKEN.
-C W (OUTPUT) RIGHT SINGULAR VECTOR OF RANK 1 CORRECTION TO L.
-C Y (INPUT) CHANGE IN GRADIENTS CORRESPONDING TO S.
-C Z (OUTPUT) LEFT SINGULAR VECTOR OF RANK 1 CORRECTION TO L.
-C
-C------------------------------- NOTES -------------------------------
-C
-C *** ALGORITHM NOTES ***
-C
-C WHEN S IS COMPUTED IN CERTAIN WAYS, E.G. BY GQTSTP OR
-C DBLDOG, IT IS POSSIBLE TO SAVE N**2/2 OPERATIONS SINCE (L**T)*S
-C OR L*(L**T)*S IS THEN KNOWN.
-C IF THE BFGS UPDATE TO L*(L**T) WOULD REDUCE ITS DETERMINANT TO
-C LESS THAN EPS TIMES ITS OLD VALUE, THEN THIS ROUTINE IN EFFECT
-C REPLACES Y BY THETA*Y + (1 - THETA)*L*(L**T)*S, WHERE THETA
-C (BETWEEN 0 AND 1) IS CHOSEN TO MAKE THE REDUCTION FACTOR = EPS.
-C
-C *** GENERAL ***
-C
-C CODED BY DAVID M. GAY (FALL 1979).
-C THIS SUBROUTINE WAS WRITTEN IN CONNECTION WITH RESEARCH SUPPORTED
-C BY THE NATIONAL SCIENCE FOUNDATION UNDER GRANTS MCS-7600324 AND
-C MCS-7906671.
-C
-C------------------------ EXTERNAL QUANTITIES ------------------------
-C
-C *** FUNCTIONS AND SUBROUTINES CALLED ***
-C
- REAL D7TPR
- EXTERNAL D7TPR, L7IVM, L7TVM
-C D7TPR RETURNS INNER PRODUCT OF TWO VECTORS.
-C L7IVM MULTIPLIES L**-1 TIMES A VECTOR.
-C L7TVM MULTIPLIES L**T TIMES A VECTOR.
-C
-C *** INTRINSIC FUNCTIONS ***
-C/+
- REAL SQRT
-C/
-C-------------------------- LOCAL VARIABLES --------------------------
-C
- INTEGER I
- REAL CS, CY, EPS, EPSRT, ONE, SHS, YS, THETA
-C
-C *** DATA INITIALIZATIONS ***
-C
-C/6
-C DATA EPS/0.1E+0/, ONE/1.E+0/
-C/7
- PARAMETER (EPS=0.1E+0, ONE=1.E+0)
-C/
-C
-C+++++++++++++++++++++++++++++++ BODY ++++++++++++++++++++++++++++++++
-C
- CALL L7TVM(N, W, L, S)
- SHS = D7TPR(N, W, W)
- YS = D7TPR(N, Y, S)
- IF (YS .GE. EPS*SHS) GO TO 10
- THETA = (ONE - EPS) * SHS / (SHS - YS)
- EPSRT = SQRT(EPS)
- CY = THETA / (SHS * EPSRT)
- CS = (ONE + (THETA-ONE)/EPSRT) / SHS
- GO TO 20
- 10 CY = ONE / ( SQRT(YS) * SQRT(SHS))
- CS = ONE / SHS
- 20 CALL L7IVM(N, Z, L, Y)
- DO 30 I = 1, N
- 30 Z(I) = CY * Z(I) - CS * W(I)
-C
- 999 RETURN
-C *** LAST CARD OF W7ZBF FOLLOWS ***
- END
diff --git a/CEP/PyBDSM/src/port3/xtrap.f b/CEP/PyBDSM/src/port3/xtrap.f
deleted file mode 100644
index efa6b8110399716b361d5c01f40bcea125f52383..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/xtrap.f
+++ /dev/null
@@ -1,129 +0,0 @@
- SUBROUTINE XTRAP(TM,M,NVAR,NG,KMAX,XPOLY,T,ERROR,EBEST)
-C
-C ASSUME AN EXPANSION FOR THE VECTOR VALUED FUNCTION T(H) OF THE FORM
-C
-C T(H) = T(0) + SUM(J=1,2,3,...)(A(J)*H**(J*GAMMA))
-C
-C WHERE THE A(J) ARE CONSTANT VECTORS AND GAMMA IS A POSITIVE CONSTANT.
-C
-C GIVEN T(H(M)), WHERE H(M)=H0/N(M), M=1,2,3,..., THIS ROUTINE USES
-C POLYNOMIAL (XPOLY), OR RATIONAL (.NOT.XPOLY), EXTRAPOLATION TO
-C SEQUENTIALLY APPROXIMATE T(0).
-C
-C INPUT
-C
-C TM - TM = T(H(M)) FOR THIS CALL.
-C M - H(M) WAS USED TO OBTAIN TM.
-C NVAR - THE LENGTH OF THE VECTOR TM.
-C NG - THE REAL VALUES
-C
-C NG(I) = N(I)**GAMMA
-C
-C FOR I=1,...,M. NG MUST BE A MONOTONE INCREASING ARRAY.
-C KMAX - THE MAXIMUM NUMBER OF COLUMNS TO BE USED IN THE
-C EXTRAPOLATION PROCESS.
-C XPOLY - IF XPOLY=.TRUE., THEN _USE_ POLYNOMIAL EXTRAPOLATION.
-C IF XPOLY=.FALSE., THEN _USE_ RATIONAL EXTRAPOLATION.
-C T - THE BOTTOM EDGE OF THE EXTRAPOLATION LOZENGE.
-C T(I,J) SHOULD CONTAIN THE J-TH EXTRAPOLATE OF THE I-TH
-C COMPONENT OF T(H) BASED ON THE SEQUENCE H(1),...,H(M-1),
-C FOR I=1,...,NVAR AND J=1,...,MIN(M-1,KMAX).
-C
-C WHEN M=1, T MAY CONTAIN ANYTHING.
-C
-C FOR M.GT.1, NOTE THAT THE OUTPUT VALUE OF T AT THE
-C (M-1)-ST CALL IS THE INPUT FOR THE M-TH CALL.
-C THUS, THE USER NEED NEVER PUT ANYTHING INTO T,
-C BUT HE CAN NOT ALTER ANY ELEMENT OF T BETWEEN
-C CALLS TO XTRAP.
-C
-C OUTPUT
-C
-C TM - TM(I)=THE MOST ACCURATE APPROXIMATION IN THE LOZENGE
-C FOR THE I-TH VARIABLE, I=1,...,NVAR.
-C T - T(I,J) CONTAINS THE J-TH EXTRAPOLATE OF THE I-TH
-C COMPONENT OF T(H) BASED ON THE SEQUENCE H(1),...,H(M),
-C FOR I=1,...,NVAR AND J=1,...,MIN(M,KMAX).
-C ERROR - ERROR(I,J) GIVES THE SIGNED BULIRSCH-STOER ESTIMATE OF THE
-C ERROR IN THE J-TH EXTRAPOLATE OF THE I-TH COMPONENT OF
-C T(H) BASED ON THE SEQUENCE H(1),...,H(M-1),
-C FOR I=1,...,NVAR AND J=1,...,MIN(M-1,KMAX).
-C IF ERROR=EBEST AS ARRAYS, THEN THE ABOVE ELEMENTS
-C ARE NOT STORED. RATHER, EBEST=ERROR IS LOADED AS DESCRIBED
-C BELOW.
-C EBEST - EBEST(I)=THE ABSOLUTE VALUE OF THE ERROR IN TM(I),
-C I=1,...,NVAR. THIS ARRAY IS FULL OF GARBAGE WHEN M=1.
-C
-C SCRATCH SPACE ALLOCATED - MIN(M-1,KMAX) REAL WORDS +
-C
-C MIN(M-1,KMAX) INTEGER WORDS.
-C
-C ERROR STATES -
-C
-C 1 - M.LT.1.
-C 2 - NVAR.LT.1.
-C 3 - NG(1).LT.1.
-C 4 - KMAX.LT.1.
-C 5 - NG IS NOT MONOTONE INCREASING.
-C
- REAL TM(NVAR),NG(M),T(NVAR,1)
-C REAL T(NVAR,MIN(M,KMAX))
- REAL ERROR(NVAR,1),EBEST(NVAR)
-C REAL ERROR(NVAR,MIN(M-1,KMAX))
- LOGICAL XPOLY
-C
- LOGICAL ESAVE
-C
- COMMON /CSTAK/DS
- DOUBLE PRECISION DS(500)
- REAL WS(1)
- REAL RS(1000)
- EQUIVALENCE (DS(1),WS(1)),(DS(1),RS(1))
-C
-C ... CHECK THE INPUT.
-C
-C/6S
-C IF (M.LT.1) CALL SETERR(15H XTRAP - M.LT.1,15,1,2)
-C IF (NVAR.LT.1) CALL SETERR(18H XTRAP - NVAR.LT.1,18,2,2)
-C IF (NG(1).LT.1.0E0) CALL SETERR(19H XTRAP - NG(1).LT.1,19,3,2)
-C IF (KMAX.LT.1) CALL SETERR(18H XTRAP - KMAX.LT.1,18,4,2)
-C/7S
- IF (M.LT.1) CALL SETERR(' XTRAP - M.LT.1',15,1,2)
- IF (NVAR.LT.1) CALL SETERR(' XTRAP - NVAR.LT.1',18,2,2)
- IF (NG(1).LT.1.0E0) CALL SETERR(' XTRAP - NG(1).LT.1',19,3,2)
- IF (KMAX.LT.1) CALL SETERR(' XTRAP - KMAX.LT.1',18,4,2)
-C/
-C
- IF (M.EQ.1) GO TO 20
-C
- DO 10 I=2,M
-C/6S
-C IF (NG(I-1).GE.NG(I)) CALL SETERR
-C 1 (38H XTRAP - NG IS NOT MONOTONE INCREASING,38,5,2)
-C/7S
- IF (NG(I-1).GE.NG(I)) CALL SETERR
- 1 (' XTRAP - NG IS NOT MONOTONE INCREASING',38,5,2)
-C/
- 10 CONTINUE
-C
-C ... SEE IF ERROR=EBEST AS ARRAYS. IF (ESAVE), THEN LOAD ERROR.
-C
- 20 ERROR(1,1)=1.0E0
- EBEST(1)=2.0E0
- ESAVE=ERROR(1,1).NE.EBEST(1)
-C
-C ... ALLOCATE SCRATCH SPACE.
-C
- IRHG=1
- IEMAG=1
- IF (M.GT.1) IRHG=ISTKGT(MIN0(M-1,KMAX),3)
- IF (M.GT.1) IEMAG=ISTKGT(MIN0(M-1,KMAX),3)
-C
- CALL A0XTRP(TM,M,NVAR,NG,KMAX,XPOLY,T,ERROR,EBEST,WS(IRHG),
- 1 RS(IEMAG),ESAVE)
-C
- IF (M.GT.1) CALL ISTKRL(2)
-C
- RETURN
-C
- END
diff --git a/CEP/PyBDSM/src/port3/zero.f b/CEP/PyBDSM/src/port3/zero.f
deleted file mode 100644
index da8544faa18c969466860e018812797c5300cc01..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/port3/zero.f
+++ /dev/null
@@ -1,143 +0,0 @@
- REAL FUNCTION ZERO(F,A,B,T)
-C
-C FINDS THE REAL ROOT OF THE FUNCTION F LYING BETWEEN A AND B
-C TO WITHIN A TOLERANCE OF
-C
-C 6*R1MACH(3) * ABS(ZERO) + 2 * T
-C
-C F(A) AND F(B) MUST HAVE OPPOSITE SIGNS
-C
-C THIS IS BRENTS ALGORITHM
-C
-C A, STORED IN SA, IS THE PREVIOUS BEST APPROXIMATION (I.E. THE OLD B)
-C B, STORED IN SB, IS THE CURRENT BEST APPROXIMATION
-C C IS THE MOST RECENTLY COMPUTED POINT SATISFYING F(B)*F(C) .LT. 0
-C D CONTAINS THE CORRECTION TO THE APPROXIMATION
-C E CONTAINS THE PREVIOUS VALUE OF D
-C M CONTAINS THE BISECTION QUANTITY (C-B)/2
-C
- REAL A,B,T,TT,SA,SB,C,D,E,FA,FB,FC,TOL,M,P,Q,R,S
- EXTERNAL F
-C
- TT = T
- IF (T .LE. 0.0) TT = 10.*R1MACH(1)
-C
- SA = A
- SB = B
- FA = F(SA)
- FB = F(SB)
- IF (FA .NE. 0.0) GO TO 5
- ZERO = SA
- RETURN
- 5 IF (FB .EQ. 0.0) GO TO 140
-C/6S
-C IF (SIGN(FA,FB) .EQ. FA) CALL SETERR(
-C 1 46H ZERO - F(A) AND F(B) ARE NOT OF OPPOSITE SIGN, 46, 1, 1)
-C/7S
- IF (SIGN(FA,FB) .EQ. FA) CALL SETERR(
- 1 ' ZERO - F(A) AND F(B) ARE NOT OF OPPOSITE SIGN', 46, 1, 1)
-C/
-C
- 10 C = SA
- FC = FA
- E = SB-SA
- D = E
-C
-C INTERCHANGE B AND C IF ABS F(C) .LT. ABS F(B)
-C
- 20 IF (ABS(FC).GE.ABS(FB)) GO TO 30
- SA = SB
- SB = C
- C = SA
- FA = FB
- FB = FC
- FC = FA
-C
- 30 TOL = 2.0*R1MACH(4)*ABS(SB)+TT
- M = 0.5*(C-SB)
-C
-C SUCCESS INDICATED BY M REDUCES TO UNDER TOLERANCE OR
-C BY F(B) = 0
-C
- IF ((ABS(M).LE.TOL).OR.(FB.EQ.0.0)) GO TO 140
-C
-C A BISECTION IS FORCED IF E, THE NEXT-TO-LAST CORRECTION
-C WAS LESS THAN THE TOLERANCE OR IF THE PREVIOUS B GAVE
-C A SMALLER F(B). OTHERWISE GO TO 40.
-C
- IF ((ABS(E).GE.TOL).AND.(ABS(FA).GE.ABS(FB))) GO TO 40
- E = M
- D = E
- GO TO 100
- 40 S = FB/FA
-C
-C QUADRATIC INTERPOLATION CAN ONLY BE DONE IF A (IN SA)
-C AND C ARE DIFFERENT POINTS.
-C OTHERWISE DO THE FOLLOWING LINEAR INTERPOLATION
-C
- IF (SA.NE.C) GO TO 50
- P = 2.0*M*S
- Q = 1.0-S
- GO TO 60
-C
-C INVERSE QUADRATIC INTERPOLATION
-C
- 50 Q = FA/FC
- R = FB/FC
- P = S*(2.0*M*Q*(Q-R)-(SB-SA)*(R-1.0))
- Q = (Q-1.0)*(R-1.0)*(S-1.0)
- 60 IF (P.LE.0.0) GO TO 70
- Q = -Q
- GO TO 80
- 70 P = -P
-C
-C UPDATE THE QUANTITIES USING THE NEWLY COMPUTED
-C INTERPOLATE UNLESS IT WOULD EITHER FORCE THE
-C NEW POINT TOO FAR TO ONE SIDE OF THE INTERVAL
-C OR WOULD REPRESENT A CORRECTION GREATER THAN
-C HALF THE PREVIOUS CORRECTION.
-C
-C IN THESE LAST TWO CASES - DO THE BISECTION
-C BELOW (FROM STATEMENT 90 TO 100)
-C
- 80 S = E
- E = D
- IF ((2.0*P.GE.3.0*M*Q-ABS(TOL*Q)).OR.
- 1 (P.GE.ABS(0.5*S*Q))) GO TO 90
- D = P/Q
- GO TO 100
- 90 E = M
- D = E
-C
-C SET A TO THE PREVIOUS B
-C
- 100 SA = SB
- FA = FB
-C
-C IF THE CORRECTION TO BE MADE IS SMALLER THAN
-C THE TOLERANCE, JUST TAKE A DELTA STEP (DELTA=TOLERANCE)
-C B = B + DELTA * SIGN(M)
-C
- IF (ABS(D).LE.TOL) GO TO 110
- SB = SB+D
- GO TO 130
-C
- 110 IF (M.LE.0.0) GO TO 120
- SB = SB+TOL
- GO TO 130
-C
- 120 SB = SB-TOL
- 130 FB = F(SB)
-C
-C IF F(B) AND F(C) HAVE THE SAME SIGN ONLY
-C LINEAR INTERPOLATION (NOT INVERSE QUADRATIC)
-C CAN BE DONE
-C
- IF ((FB.GT.0.0).AND.(FC.GT.0.0)) GO TO 10
- IF ((FB.LE.0.0).AND.(FC.LE.0.0)) GO TO 10
- GO TO 20
-C
-C***SUCCESS***
- 140 ZERO = SB
- RETURN
- END
diff --git a/CEP/PyBDSM/src/python/CMakeLists.txt b/CEP/PyBDSM/src/python/CMakeLists.txt
deleted file mode 100644
index 41dc4e9d0a8a26103348b081b46600870eeb03fc..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/python/CMakeLists.txt
+++ /dev/null
@@ -1,35 +0,0 @@
-# $Id$
-
-python_install(
- __init__.py
- _version.py
- cleanup.py
- collapse.py
- const.py
- functions.py
- gaul2srl.py
- gausfit.py
- image.py
- interface.py
- islands.py
- make_residimage.py
- multi_proc.py
- mylogger.py
- opts.py
- output.py
- plotresults.py
- polarisation.py
- preprocess.py
- psf_vary.py
- pybdsm.py
- readimage.py
- rmsimage.py
- shapefit.py
- shapelets.py
- sourcecounts.py
- spectralindex.py
- statusbar.py
- tc.py
- threshold.py
- wavelet_atrous.py
- DESTINATION lofar/bdsm)
diff --git a/CEP/PyBDSM/src/python/__init__.py b/CEP/PyBDSM/src/python/__init__.py
deleted file mode 100644
index 083aacaac4d59d135cd9a4cd7861d5b01b76c23e..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/python/__init__.py
+++ /dev/null
@@ -1,244 +0,0 @@
-"""Initialize PyBDSM namespace.
-
-Import all standard operations, define default chain of
-operations and provide function 'execute', which can
-execute chain of operations properly. Also define the
-'process_image' convienence function that can take
-options as arguments rather than as a dictionary (as
-required by 'execute').
-"""
-try:
- import matplotlib.pyplot as pl
- has_pl = True
-except (RuntimeError, ImportError):
- print "\033[31;1mWARNING\033[0m: Matplotlib pyplot could not be imported. Plotting is disabled."
- has_pl = False
-from readimage import Op_readimage
-from collapse import Op_collapse
-from preprocess import Op_preprocess
-from rmsimage import Op_rmsimage
-from threshold import Op_threshold
-from islands import Op_islands
-from gausfit import Op_gausfit
-from make_residimage import Op_make_residimage
-from output import Op_outlist
-from shapefit import Op_shapelets
-from gaul2srl import Op_gaul2srl
-from spectralindex import Op_spectralindex
-from polarisation import Op_polarisation
-from wavelet_atrous import Op_wavelet_atrous
-from psf_vary import Op_psf_vary
-from cleanup import Op_cleanup
-from _version import __version__, __revision__
-import gc
-
-default_chain = [Op_readimage(),
- Op_collapse(),
- Op_preprocess(),
- Op_rmsimage(),
- Op_threshold(),
- Op_islands(),
- Op_gausfit(),
- Op_wavelet_atrous(),
- Op_shapelets(),
- Op_gaul2srl(),
- Op_spectralindex(),
- Op_polarisation(),
- Op_make_residimage(),
- Op_psf_vary(),
- Op_outlist(),
- Op_cleanup()
- ]
-fits_chain = default_chain # for legacy scripts
-
-def execute(chain, opts):
- """Execute chain.
-
- Create new Image with given options and apply chain of
- operations to it. The opts input must be a dictionary.
- """
- from image import Image
- import mylogger
-
- if 'quiet' in opts:
- quiet = opts['quiet']
- else:
- quiet = False
- if 'debug' in opts:
- debug = opts['debug']
- else:
- debug = False
- log_filename = opts["filename"] + '.pybdsm.log'
- mylogger.init_logger(log_filename, quiet=quiet, debug=debug)
- mylog = mylogger.logging.getLogger("PyBDSM.Init")
- mylog.info("Processing "+opts["filename"])
-
- try:
- img = Image(opts)
- img.log = log_filename
- _run_op_list(img, chain)
- return img
- except RuntimeError, err:
- # Catch and log, then re-raise if needed (e.g., for AstroWise)
- mylog.error(str(err))
- raise
- except KeyboardInterrupt:
- mylogger.userinfo(mylog, "\n\033[31;1mAborted\033[0m")
- raise
-
-
-def _run_op_list(img, chain):
- """Runs an Image object through chain of op's.
-
- This is separate from execute() to allow other modules (such as
- interface.py) to use it as well.
- """
- from time import time
- from types import ClassType, TypeType
- from interface import raw_input_no_history
- from gausfit import Op_gausfit
- import mylogger
- import gc
-
- ops = []
- stopat = img.opts.stop_at
- # Make sure all op's are instances
- for op in chain:
- if isinstance(op, (ClassType, TypeType)):
- ops.append(op())
- else:
- ops.append(op)
- if stopat == 'read' and isinstance(op, Op_readimage): break
- if stopat == 'isl' and isinstance(op, Op_islands): break
-
- # Log all non-default parameters
- mylog = mylogger.logging.getLogger("PyBDSM.Init")
- mylog.info("PyBDSM version %s (LUS revision %s)"
- % (__version__, __revision__))
- par_msg = "Non-default input parameters:\n"
- user_opts = img.opts.to_list()
- for user_opt in user_opts:
- k, v = user_opt
- val = img.opts.__getattribute__(k)
- if val != v._default and v.group() != 'hidden':
- par_msg += ' %-20s = %s\n' % (k, repr(val))
- mylog.info(par_msg[:-1]) # -1 is to trim final newline
-
- # Run all op's
- dc = '\033[34;1m'
- nc = '\033[0m'
- for op in ops:
- if isinstance(op, Op_gausfit) and img.opts.interactive:
- print dc + '--> Displaying islands and rms image...' + nc
- if max(img.ch0_arr.shape) > 4096:
- print dc + '--> Image is large. Showing islands only.' + nc
- img.show_fit(rms_image=False, mean_image=False, ch0_image=False,
- ch0_islands=True, gresid_image=False, sresid_image=False,
- gmodel_image=False, smodel_image=False, pyramid_srcs=False)
- else:
- img.show_fit(rms_image=True, mean_image=True,
- ch0_islands=True, gresid_image=False, sresid_image=False,
- gmodel_image=False, smodel_image=False, pyramid_srcs=False)
- prompt = dc + "Press enter to continue or 'q' to quit .. : " + nc
- answ = raw_input_no_history(prompt)
- while answ != '':
- if answ == 'q':
- return False
- answ = raw_input_no_history(prompt)
- op.__start_time = time()
- op(img)
- op.__stop_time = time()
- gc.collect()
-
- if img.opts.interactive and not img._pi:
- print dc + 'Fitting complete. Displaying results...' + nc
- if img.opts.shapelet_do:
- show_smod = True
- show_sres = True
- else:
- show_smod = False
- show_sres = False
- if img.opts.spectralindex_do:
- show_spec = True
- else:
- show_spec = False
- if max(img.ch0_arr.shape) > 4096:
- print dc + '--> Image is large. Showing Gaussian residual image only.' + nc
- img.show_fit(rms_image=False, mean_image=False, ch0_image=False,
- ch0_islands=False, gresid_image=True, sresid_image=False,
- gmodel_image=False, smodel_image=False, pyramid_srcs=False,
- source_seds=show_spec)
- else:
- img.show_fit(smodel_image=show_smod, sresid_image=show_sres,
- source_seds=show_spec)
-
- if img.opts.print_timing:
- print "="*36
- print "%18s : %10s" % ("Module", "Time (sec)")
- print "-"*36
- for i, op in enumerate(chain):
- if hasattr(op, '__start_time'):
- print "%18s : %f" % (op.__class__.__name__,
- (op.__stop_time - op.__start_time))
- indx_stop = i
- print "="*36
- print "%18s : %f" % ("Total",
- (chain[indx_stop].__stop_time - chain[0].__start_time))
-
- # Log all internally derived parameters
- mylog = mylogger.logging.getLogger("PyBDSM.Final")
- par_msg = "Internally derived parameters:\n"
- import inspect
- import types
-
- for attr in inspect.getmembers(img.opts):
- if attr[0][0] != '_':
- if isinstance(attr[1], (int, str, bool, float, types.NoneType, tuple, list)):
- if hasattr(img, attr[0]):
- used = img.__getattribute__(attr[0])
- if used != attr[1] and isinstance(used, (int, str, bool, float,
- types.NoneType, tuple,
- list)):
-
- par_msg += ' %-20s : %s\n' % (attr[0], repr(used))
- mylog.info(par_msg[:-1]) # -1 is to trim final newline
-
- return True
-
-def process_image(input, **kwargs):
- """Run a standard analysis and returns the associated Image object.
-
- The input can be a FITS or CASA image, a PyBDSM parameter save
- file, or a dictionary of options. Partial names are allowed for the
- parameters as long as they are unique. Parameters are set to default
- values if par = ''.
-
- Examples:
- > img = bdsm.process_image('example.fits', thresh_isl=4)
- --> process FITS image names 'example.fits'
- > img_3C196 = bdsm.process_image('3C196.image', mea='map')
- --> process CASA image, 'mean_map' parameter is abbreviated
- > img_VirA = bdsm.process_image('VirA_im.pybdsm.sav')
- --> load parameter save file and process
- """
- from interface import load_pars
- from image import Image
- import os
-
- # Try to load input assuming it's a parameter save file or a dictionary.
- # load_pars returns None if this doesn't work.
- img, err = load_pars(input)
-
- # If load_pars fails (returns None), assume that input is an image file. If it's not a
- # valid image file (but is an existing file), an error will be raised
- # by img.process() during reading of the file.
- if img is None:
- if os.path.exists(input):
- img = Image({'filename': input})
- else:
- raise RuntimeError("File '" + input + "' not found.")
-
- # Now process it. Any kwargs specified by the user will
- # override those read in from the parameter save file or dictionary.
- img.process(**kwargs)
- return img
diff --git a/CEP/PyBDSM/src/python/_version.py b/CEP/PyBDSM/src/python/_version.py
deleted file mode 100644
index bfcd931bb6aa90921266bd5e44143bc162767f52..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/python/_version.py
+++ /dev/null
@@ -1,610 +0,0 @@
-"""Version module.
-
-This module simply stores the version and svn revision numbers, as well
-as a changelog. The svn revision number will be updated automatically
-whenever there is a change to this file. However, if no change is made
-to this file, the revision number will get out of sync. Therefore, one
-must update this file with each (significant) update of the code:
-adding to the changelog will naturally do this.
-"""
-
-# Version number
-__version__ = '1.8.7'
-
-# Store svn Revision number. For this to work, one also needs to do:
-#
-# "svn propset svn:keywords Revision CEP/PyBDSM/src/python/_version.py"
-#
-# from the LOFAR directory. Then, the revision number is
-# added automatically with each update to this file. The line below does not
-# need to be edited by hand.
-__revision__ = filter(str.isdigit, "$Revision$")
-
-
-# Changelog
-def changelog():
- """
- PyBDSM Changelog.
- -----------------------------------------------------------------------
-
- 2017/02/28 - Fix to issues related to numpy >= 1.12 and astropy >= 1.3
-
- 2016/06/10 - Version 1.8.7
-
- 2016/06/10 - Fix to bug that caused incorrect output images when input
- image was not square.
-
- 2016/01/20 - Version 1.8.6
-
- 2016/01/15 - Fix to bug that caused incorrect island mask when two
- islands are very close together.
-
- 2015/12/07 - Fix to bug that caused crash when image is masked and
- the src_ra_dec option is used.
-
- 2015/11/30 - Version 1.8.5
-
- 2015/11/25 - Fix to bug in export_image that resulted in incorrect
- output image when both trim_box and pad_image were used.
-
- 2015/11/20 - Fix to bug in wavelet module related to merging of islands.
-
- 2015/11/20 - Fix to bug in polarization module related to numbering of
- new islands.
-
- 2015/11/20 - Fix to bug in spectral index module related to rms map
- calculation.
-
- 2015/11/20 - Added option to use much faster (but also much more memory
- intensive) SciPy fftconvolve function instead of custom PyBDSM one.
- The option (use_scipy_fft) defaults to True.
-
- 2015/11/20 - Increased number of digits for values in output text
- catalogs
-
- 2015/08/06 - Version 1.8.4
-
- 2015/08/06 - Improved speed of wavelet module.
-
- 2015/08/06 - Added option to use PyFFTW in wavelet module if available.
-
- 2015/08/06 - Fix to IPython version check.
-
- 2015/08/06 - Fix to bug that caused a failure to write shapelet models
- in FITS format.
-
- 2014/11/07 - Fix to bug that caused a crash when both atrous_do = True
- and output_all = True. Fixed a bug that caused a crash on machines
- with only one core.
-
- 2014/09/26 - Version 1.8.3
-
- 2014/09/26 - Fix to bug that caused a crash when using the wavelet
- module and all Gaussians in an island were flagged.
-
- 2014/07/03 - Mask will now be expanded to match input image shape. Fix
- to bug that caused image read failure when image lacks a Stokes axis.
-
- 2014/05/14 - Version 1.8.2
-
- 2014/05/15 - Fix to bug in CASA masks generated with export_image() that
- caused cleaning to fail in CASA 4.2 and above.
-
- 2014/02/05 - Fix to bug that resulted in output file names being
- converted to lower case inappropriately.
-
- 2014/01/14 - Version 1.8.1
-
- 2014/01/13 - Added option (bbs_patches = 'mask') to allow patches in
- an output BBS sky model to be defined using a mask image.
-
- 2014/01/09 - Fix to bug that caused the incl_empty option to be
- ignored when format='fits' in the write_catalog task.
-
- 2013/12/05 - Enabled output of images in CASA format in the export_image
- task (img_format = 'casa'). Added an option to export_image task to
- export an island-mask image, with ones where there is emission and
- zeros elsewhere (image_type = 'island_mask'). Features in the island
- mask may be optionally dilated by specifying the number of dilation
- iterations with the mask_dilation parameter. Added an option to
- write a CASA region file to the write_catalog task (format =
- 'casabox'). Added an option to write a CSV catalog to the
- write_catalog task (format = 'csv').
-
- 2013/11/04 - Added error message when the rms is zero in some part of the
- rms map.
-
- 2013/10/16 - Version 1.8.0
-
- 2013/10/16 - Improved wavelet fitting. Added option so that wavelet
- fitting can be done to the sum of images on the remaining wavelet
- scales, improving the signal for fitting (controlled with the
- atrous_sum option). Added option so that user can choose whether to
- include new islands found only in the wavelet images in the final
- fit or not (controlled with the atrous_orig_isl option).
-
- 2013/10/10 - Fixed a bug that could lead to incomplete fitting of
- some islands. Improved overall convergence of fits.
-
- 2013/10/10 - Version 1.7.7
-
- 2013/10/10 - Improved fitting of bright sources under certain
- circumstances.
-
- 2013/09/27 - Version 1.7.6
-
- 2013/09/27 - Changed caching behavior to ensure that temporary files
- are always deleted after they are no longer needed or on exit.
-
- 2013/09/05 - Renamed blank_zeros to blank_limit. The blank_limit
- option now specifies a limit below which pixels are blanked.
-
- 2013/09/05 - Enabled SAGECAL sky-model output.
-
- 2013/09/02 - Version 1.7.5
-
- 2013/09/02 - Fix to bug that caused a crash when images with 2 or
- 3 axes were used. Improved rms and mean calculation (following the
- implementation used in PySE, see http://dare.uva.nl/document/174052
- for details). The threshold used to determine the clipped rms and
- mean values is now determined internally by default (kappa_clip =
- None).
-
- 2013/08/27 - Version 1.7.4
-
- 2013/08/29 - Fix to bug in show_fit() that caused error when
- 'i' is pressed in the plot window and shapelet decomposition
- had not been done. Tweak to 'pybdsm' startup shell script to
- avoid problems with the Mac OS X matplotlib backend on non-
- framework Python installations (such as Anaconda Python).
-
- 2013/08/28 - Fix to bug in process_image() that could result in
- wavelet Gaussians being excluded from model image under certain
- conditions.
-
- 2013/08/27 - Version 1.7.3
-
- 2013/08/27 - Fix to bug in image reading that caused images to be
- distorted.
-
- 2013/08/23 - Version 1.7.2
-
- 2013/08/23 - Improved handling of non-standard FITS CUNIT keywords.
- Improved loading of FITS images when trim_box is specified.
-
- 2013/08/22 - Version 1.7.1
-
- 2013/08/21 - Fix to bug that caused cached images to be deleted when
- rerunning an analysis. Fix to bug in show_fit() due to undefined
- images. Fix to bug in process_image() that would result in unneeded
- reprocessing.
-
- 2013/08/20 - Version 1.7.0
-
- 2013/08/19 - PyBDSM will now use Astropy if installed for FITS and WCS
- modules.
-
- 2013/08/11 - Fix to avoid excessive memory usage in the wavelet module
- (replaced scipy.signal.fftconvolve with a custom function).
-
- 2013/08/11 - Added option to use disk caching for internally derived
- images (do_cache). Caching can reduce memory usage and is
- therefore useful when processing large images.
-
- 2013/07/11 - Implemented a variable operation chain for process_image
- (and img.process()) that allows unneeded steps to be skipped if
- the image is being reprocessed.
-
- 2013/07/11 - Fixed a bug that could cause Gaussian fitting to hang
- during iterative fitting of large islands.
-
- 2013/06/24 - Added option (fix_to_beam) to fix the size and position
- angle of Gaussians to the restoring beam during fitting. Fix to
- bug that caused the position angle used to initialize fitting to
- be incorrect.
-
- 2013/03/22 - Version 1.6.1
-
- 2013/03/21 - Fix to bug in ds9 and kvis catalog files that resulted in
- incorrect position angles. Fix to bug in position-dependent WCS
- transformations that caused incorrect source parameters in output
- catalogs. Added option to output uncorrected source parameters
- to a BBS sky model file (correct_proj).
-
- 2013/03/14 - Removed sky transformations for flagged Gaussians, as
- these could sometimes give math domain errors. Disabled aperture
- flux measurement on wavelet images as it is not used/needed.
-
- 2013/02/25 - Version 1.6.0
-
- 2013/02/25 - Improved speed and accuracy of aperture flux
- calculation.
-
- 2013/02/20 - Added option to use the curvature map method of
- Hancock et al. (2012) for the initial estimation of Gaussian
- parameters (ini_method = 'curvature') and for grouping of
- Gaussians into sources (group_method = 'curvature').
-
- 2013/02/18 - Fix to bug in spectral index module that caused sources
- with multiple Gaussians to be skipped. Minor adjustments to the
- wavelet module to improve performance.
-
- 2013/02/08 - Implemented position-dependent WCS transformations.
-
- 2013/02/08 - Added option to fit to any arbitrary location in the
- image within a given radius (src_ra_dec and src_radius_pix).
-
- 2013/02/04 - Fix to bug in wavelet module that caused crash when
- no Gaussians were fit to the main image.
-
- 2013/01/30 - Fix to bug that resulted in incorrect numbering of
- wavelet Gaussians. Added 'srl' output in ds9 format when using
- output_all = True.
-
- 2013/01/28 - Fix to bug in source grouping algorithm. Improved fitting
- when background mean is nonzero. Fix to allow images with GLAT and
- GLON WCS coordinates. Fix to bug when equinox is taken from the
- epoch keyword.
-
- 2012/12/19 - Version 1.5.1
-
- 2012/12/19 - Fix to bug in wavelet module that occurred when the
- center of the wavelet Gaussian lies outside of the image. Fix
- to re-enable srl output catalogs in ds9 region format. Fix to
- bug that resulted in the output directory not always being
- created. Added an option (aperture_posn), used when aperture
- fluxes are desired, to specify whether to center the aperture
- on the source centroid or the source peak.
-
- 2012/12/02 - Changes to reduce memory usage, particularly in the
- wavelet module.
-
- 2012/11/30 - Fix to bypass bug in matplotlib when display variable
- is not set.
-
- 2012/11/21 - Fixed bug that caused a crash when a detection image
- was used. Fixed a bug with incorrect save directory when
- plot_allgaus = True.
-
- 2012/10/29 - Version 1.5.0
-
- 2012/10/29 - Improved handling of WCS information so that a much
- greater variety of WCS systems may be used. Fixed a bug in logging
- that occurred when negative values were found in the rms map.
- Updated installation instructions.
-
- 2012/10/12 - Version 1.4.5
-
- 2012/10/12 - Added option (incl_empty) to include empty islands (that
- have no un-flagged Gaussians) in output catalogs. Any such empty
- islands are given negative source IDs and positions given by the
- location of the peak of the island.
-
- 2012/10/10 - Fixed a bug in Gaussian fitting that could cause a crash
- when fitting fails. Fixed a bug in parallelization that could
- cause a crash due to improper concatenation of result lists.
-
- 2012/10/09 - Version 1.4.4
-
- 2012/10/09 - Improved logging. Added a warning when one or more islands
- are not fit properly (i.e., no valid, unflagged Gaussians were
- fit). Fixed a bug in parallelization of Gaussian fitting that
- could cause a crash due to improper mapping of island lists to
- processes.
-
- 2012/10/05 - Added code to handle images with no unblanked pixels.
- Improved fitting robustness.
-
- 2012/10/04 - Version 1.4.3
-
- 2012/10/04 - Fixed a bug in the mean map calculation that caused mean
- maps with constant values (i.e., non-2D maps) to have values of
- 0.0 Jy/beam unless mean_map = 'const' was explicitly specified.
- Fixed a bug in Gaussian fitting that could cause an island to be
- skipped.
-
- 2012/10/02 - Fixed a bug in the PSF vary module that resulted in
- incorrect PSF generators being used. Added an option to smooth
- the resulting PSF images (psf_smooth). Parallelized the PSF
- interpolation and smoothing steps. Improved PSF vary documentation.
-
- 2012/09/25 - Version 1.4.2
-
- 2012/09/25 - Dramatically reduced the time required to identify valid
- wavelet islands.
-
- 2012/09/21 - Fixed bug that resulted in output FITS gaul tables being
- improperly sorted. Fixed cosmetic bug in the statusbar that could
- sometimes cause improper formatting. Added example of SAMP usage
- to the documentation.
-
- 2012/09/20 - Version 1.4.1
-
- 2012/09/20 - Fixed a bug in the wavelet module that caused a crash when
- no Gaussians were fit to the ch0 image.
-
- 2012/09/19 - Added option (broadcast) to show_fit task to send
- coordinates and row highlight request to a SAMP hub when a Gaussian
- is clicked. Fixed bug in aperture flux masking that sometimes caused
- the mask to be the wrong shape.
-
- 2012/09/18 - Added option to send images and catalogs to a SAMP hub
- (activated by setting outfile = 'SAMP' in the export_image and
- write_catalog tasks).
-
- 2012/09/13 - Improved speed of plotting when images are large and in
- mean/rms map generation. Fixed bug that caused residual image
- statistics to fail when NaNs are present.
-
- 2012/09/11 - Version 1.4.0
-
- 2012/09/11 - Parallelized Gaussian fitting, shapelet decomposition,
- validation of wavelet islands, and mean/rms map generation.
- The number of cores to be used can be specified with the ncores
- option (default is to use up to 8). Fixed bug in SED plotting in
- the show_fit task.
-
- 2012/08/29 - Fixed incorrect terminal size in parameter listing. Added
- logging of non-default input parameters and internally derived
- parameters.
-
- 2012/08/22 - Version 1.3.2
-
- 2012/08/22 - Fixed a bug that caused the user-specified rms_box to be
- ignored. Added an option to enable the Monte Carlo error estimation
- for 'M'-type sources (the do_mc_errors option), which is now
- disabled by default.
-
- 2012/07/11 - Version 1.3.1
-
- 2012/07/11 - Cleaned up unused options.
-
- 2012/07/10 - Fixed a bug that caused a segfault during Gaussian
- fitting. Fixed a bug that caused a crash when a detection image
- is used.
-
- 2012/07/05 - Fixed a bug that caused images written when output_all =
- True to be transposed. Added frequency information to all output
- images. Improved fitting robustness to prevent rare cases in
- which no valid Gaussians could be fit to an island. Modified the
- island-finding routine to handle NaNs properly.
-
- 2012/07/03 - Version 1.3
-
- 2012/07/03 - Fixed a bug in calculation of the positional errors of
- Gaussians. If interactive=True and image is large (> 4096 pixels),
- display is limited to 'ch0_islands' only; otherwise, show_fit()
- is very slow. Tweaked show_fit() to better display a single image.
-
- 2012/07/02 - Adjusted rms_box algorithm to check for negative rms
- values (due to interpolation with cubic spline). If negative
- values are found, either the box size is increased or the
- interpolation is done with order=1 (bilinear) instead.
-
- 2012/06/28 - Output now includes the residual image produced by
- using only wavelet Gaussians (if any) when atrous_do=True and
- output_all=True. Improved organization of files when
- output_all=True. Added logging of simple statistics (mean,
- std. dev, skew, and kurtosis) of the residual images.
-
- 2012/06/22 - Included image rotation (if any) in beam definition.
- Rotation angle can vary across the image (defined by image WCS).
-
- 2012/06/19 - Changed exception handling to raise exceptions when
- the interactive shell is not being used. Fixed bug that
- caused a crash when using show_fit() when no islands were
- found.
-
- 2012/06/15 - Added Sagecal output format for Gaussian catalogs.
-
- 2012/06/14 - Added check for newer versions of the PyBDSM
- software tar.gz file available on ftp.strw.leidenuniv.nl.
-
- 2012/06/13 - Added total island flux (from sum of pixels) to
- "gaul" and "srl" catalogs.
-
- 2012/06/06 - Version 1.2
-
- 2012/06/06 - Added option to calculate fluxes within a specified
- aperture radius in pixels (set with the "aperture" option).
- Aperture fluxes, if measured, are output in the 'srl' catalogs.
- Changed code that determines terminal width to be more robust.
-
- 2012/05/07 - Removed dependencies on matplotlib -- if matplotlib is
- not available, plotting is disabled. Corrected inconsistencies,
- spelling mistakes, etc. in help text and documentation. Cleaned
- up unneeded modules and files.
-
- 2012/05/02 - Added option to output flux densities for every channel
- found by the spectral index module. Added option to spectral index
- module to allow use of flux densities that do not meet the desired
- SNR. Changed flag_maxsnr criterion to also flag if the peak flux
- density per beam of the Gaussian exceeds the value at its center.
- Removed incl_wavelet option.
-
- 2012/04/20 - Promoted the adaptive_rms_box parameter to the main options
- listing and added the rms_box_bright option so that the user can
- specify either (or both) of the rms_boxes. Fixed bug in wavelet
- module so that invalid Gaussians (i.e., those that lie outside of
- islands in the ch0 image) are not used when making the residual
- images at each scale. Improved speed of Gaussian fitting to wavelet
- images. Fixed bug that resulted in pixels found to be outside the
- universe (check is enabled with the check_outsideuniv option) not
- being masked properly.
-
- 2012/04/17 - Fixed bug in psf_vary module that resulted in PSF major and
- minor axis maps in terms of sigma instead of FWHM. Added option
- (psf_stype_only) to allow PSF fitting to non- S-type sources
- (useful if sources are very distorted).
-
- 2012/04/12 - Fixed bug in adaptive scaling code that could cause
- incorrect small-scale rms_box size. Added a parameter
- (adaptive_thresh) that controls the minimum threshold for sources
- used to set the small-scale rms_box size.
-
- 2012/04/02 - Implemented an adaptive scaling scheme for the rms_box
- parameter that shrinks the box size near bright sources and expands
- it far from them (enabled with the adaptive_rms_box option when
- rms_box=None). This scheme generally results in improved rms and
- mean maps when both strong artifacts and extended sources are
- present. Fixed bug that prevented plotting of results during wavelet
- decomposition when interactive = True.
-
- 2012/03/29 - Fixed bug in wavelet module that could cause incorrect
- associations of Gaussians. Fixed bug in show_fit that displayed
- incorrect model and residual images when wavelets were used.
-
- 2012/03/28 - Version 1.1
-
- 2012/03/28 - Fixed bug that caused mask to be ignored when determining
- whether variations in rms and mean maps is significant. Fixed bug
- that caused internally derived rms_box value to be ignored.
-
- 2012/03/27 - Modified calculation of rms_box parameter (when rms_box
- option is None) to work better with fields composed mainly of point
- sources when strong artifacts are present. Tweaked flagging on FWHM
- to prevent over-flagging of Gaussians in small islands. Changed
- wavelet module to flag Gaussians whose centers fall outside of
- islands found in the original image and removed atrous_orig_isl
- option (as redundant).
-
- 2012/03/26 - Modified fitting of large islands to adopt an iterative
- fitting scheme that limits the number of Gaussians fit
- simultaneously per iteration to 10. This change speeds up fitting of
- large islands considerably. The options peak_fit and peak_maxsize
- control whether iterative fitting is done. Added new Gaussian
- flagging condition (flag_maxsize_fwhm) that flags Gaussians whose
- sigma contour times factor extends beyond the island boundary. This
- flag prevents fitting of Gaussians that extend far beyond the island
- boundary.
-
- 2012/03/23 - Tweaked settings that affect fitting of Gaussians to
- improve fitting in general.
-
- 2012/03/19 - Added output of shapelet parameters to FITS tables. Fixed
- issue with resizing of sources in spectral index module.
-
- 2012/03/16 - Fixed bugs in polarisation module that caused incorrect
- polarization fractions.
-
- 2012/03/13 - Improved plotting speed (by factor of ~ 4) in show_fit when
- there is a large number of islands. Simplified the spectral index
- module to make it more user friendly and stable. Added the option to
- use a "detection" image for island detection (the detection_image
- option); source properties are still measured from the main input
- image.
-
- 2012/03/01 - Fixed a bug in the polarisation module that could result in
- incorrect flux densities. Changed logging module to suppress output
- of ANSI color codes to the log file.
-
- 2012/02/27 - Implemented fitting of Gaussians in polarisation module,
- instead of simple summation of pixel values, to determine polarized
- flux densities.
-
- 2012/02/17 - In scripts, process_image() will now accept a dictionary of
- parameters as input.
-
- 2012/02/10 - Sources that appear only in Stokes Q or U (and hence not in
- Stokes I) are now identified and included in the polarisation
- module. This identification is done using the polarized intensity
- (PI) image. show_fit() and export_image() were updated to allow
- display and export of the PI image.
-
- 2012/02/06 - Fixed bug in island splitting code that could result in
- duplicate Gaussians.
-
- 2012/02/02 - Improved polarisation module. Polarization quantities are
- now calculated for Gaussians as well as sources.
-
- 2012/01/27 - Fixed bug in psf_vary module that affected tesselation.
- Fixed many small typos in parameter descriptions.
-
- 2012/01/18 - Fixed a bug that resulted in incorrect coordinates when the
- trim_box option was used with a CASA image. Added option
- (blank_zeros) to blank pixels in the input image that are exactly
- zero.
-
- 2012/01/13 - Fixed minor bugs in the interactive shell and updated
- pybdsm.py to support IPython 0.12.
-
- 2011/12/21 - Fixed bug in gaul2srl module due to rare cases in which an
- island has a negative rms value. Fixed a memory issue in which
- memory was not released after using show_fit.
-
- 2011/11/28 - Added option to have minpix_isl estimated automatically as
- 1/3 of the beam area. This estimate should help exclude false
- islands that are much smaller than the beam. This estimate is not
- let to fall below 6 pixels.
-
- 2011/11/11 - Fixed bugs in source generation that would lead to masking
- of all pixels for certain sources during moment analysis. Adjusted
- calculation of jmax in wavelet module to use island sizes (instead
- of image size) if opts.atrous_orig_isl is True.
-
- 2011/11/04 - Implemented new island fitting routine (enabled with the
- peak_fit option) that can speed up fitting of large islands. Changed
- plotting of Gaussians in show_fit to use Ellipse artists to improve
- plotting speed.
-
- 2011/11/03 - Altered reading of images to correctly handle 4D cubes.
- Fixed bug in readimage that affected filenames.
-
- 2011/10/26 - Extended psf_vary module to include fitting of stacked PSFs
- with Gaussians, interpolation of the resulting parameters across the
- image, and correction of the de- convolved source sizes using the
- interpolated PSFs. Changed plotting of Gaussians in show_fit() to
- use the FWHM instead of sigma. Modified error calculation of M
- sources to be more robust when sources are small. Fixed spelling of
- "gaussian" in bbs_patches option list.
-
- 2011/10/24 - Many small bug fixes to the psf_vary module. Fixed use of
- input directory so that input files not in the current directory are
- handled correctly.
-
- 2011/10/14 - Added residual rms and mean values to sources and source
- list catalogs. These values can be compared to background rms and
- mean values as a quick check of fit quality.
-
- 2011/10/13 - Modified deconvolution to allow 1-D Gaussians and sources.
- Added FREQ0, EQUINOX, INIMAGE keywords to output fits catalogs.
- Fixed bug in source position angles. Adjusted column names of output
- catalogs slightly to be more descriptive.
-
- 2011/10/12 - Added errors to source properties (using a Monte Carlo
- method for M sources). Fixed bug in output column names.
-
- 2011/10/11 - Tweaked autocomplete to support IPython shell commands
- (e.g., "!more file.txt"). Fixed bug in gaul2srl that resulted in
- some very nearby Gaussians being placed into different sources.
- Added group_tol option so that user can adjust the tolerance of how
- Gaussians are grouped into sources.
-
- 2011/10/05 - Added output of source lists. Changed name of write_gaul
- method to write_catalog (more general).
-
- 2011/10/04 - Added option to force source grouping by island
- (group_by_isl). Added saving of parameters to a PyBDSM save file to
- Op_output.
-
- 2011/09/21 - Fixed issue with shapelet centering failing: it now falls
- back to simple moment when this happens. Fixed issue with
- plotresults when shapelets are fit.
-
- 2011/09/14 - Placed output column names and units in TC properties of
- Gaussians. This allows easy standardization of the column names and
- units.
-
- 2011/09/13 - Fixes to trim_box and resetting of Image objects in
- interface.process(). Changed thr1 --> thr2 in fit_iter in
- guasfit.py, as bright sources are often "overfit" when using thr1,
- leading to large negative residuals. Restricted fitting of Gaussians
- to wavelet images to be only in islands found in the original image
- if opts.atrous_orig_isl is True.
-
- 2011/09/08 - Version 1.0
-
- 2011/09/08 - Versioning system changed to use _version.py.
-
- """
- pass
diff --git a/CEP/PyBDSM/src/python/cleanup.py b/CEP/PyBDSM/src/python/cleanup.py
deleted file mode 100644
index de5856789041c0a6247a7f0db9f6b1754d006bd5..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/python/cleanup.py
+++ /dev/null
@@ -1,54 +0,0 @@
-"""
- Does miscellaneous jobs at the end, which assumes all other tasks are run.
-"""
-
-import numpy as N
-import os
-from image import *
-import mylogger, os
-from . import has_pl
-if has_pl:
- import matplotlib.pyplot as pl
- import matplotlib.cm as cm
-import functions as func
-
-class Op_cleanup(Op):
- """ """
- def __call__(self, img):
-
- mylog = mylogger.logging.getLogger("PyBDSM.Cleanup")
-
- ### plotresults for all gaussians together
- if img.opts.plot_allgaus and has_pl:
- pl.figure()
- pl.title('All gaussians including wavelet images')
- allgaus = img.gaussians
- if hasattr(img, 'atrous_gaussians'):
- for gg in img.atrous_gaussians:
- allgaus += gg
-
- for g in allgaus:
- ellx, elly = func.drawellipse(g)
- pl.plot(ellx, elly, 'r')
-
- from math import log10
- bdir = img.basedir + '/misc/'
- if not os.path.isdir(bdir): os.makedirs(bdir)
- im_mean = img.clipped_mean
- im_rms = img.clipped_rms
- low = 1.1*abs(img.min_value)
- low1 = 1.1*abs(N.min(im_mean-im_rms*5.0))
- if low1 > low: low = low1
- vmin = log10(im_mean-im_rms*5.0 + low)
- vmax = log10(im_mean+im_rms*15.0 + low)
- im = N.log10(img.ch0_arr + low)
-
- pl.imshow(N.transpose(im), origin='lower', interpolation='nearest',vmin=vmin, vmax=vmax, \
- cmap=cm.gray); pl.colorbar()
- pl.savefig(bdir+'allgaussians.png')
- pl.close()
-
- img.completed_Ops.append('cleanup')
-
-
-
diff --git a/CEP/PyBDSM/src/python/collapse.py b/CEP/PyBDSM/src/python/collapse.py
deleted file mode 100644
index 96e007e2701c271808940c51d4f113183c9f02fb..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/python/collapse.py
+++ /dev/null
@@ -1,315 +0,0 @@
-"""Module collapse
-
-Defines operation Op_collapse which collapses 3D image. Calculates and
-stores mean and rms (normal and clipped) per channel anyway for further
-use, even if weights are unity.
-"""
-
-import numpy as N
-from image import *
-import _cbdsm
-import mylogger
-import functions as func
-
-avspc_wtarr = NArray(doc = "Weight array for channel collapse")
-channel_rms = NArray(doc = "RMS per channel")
-channel_mean = NArray(doc = "Mean per channel")
-channel_clippedrms = NArray(doc = "Clipped RMS per channel")
-channel_clippedmean = NArray(doc = "Clipped mean per channel")
-
-class Op_collapse(Op):
- """Collapse 3D image"""
-
- def __call__(self, img):
- mylog = mylogger.logging.getLogger("PyBDSM."+img.log+"Collapse")
- if img.opts.polarisation_do:
- pols = ['I', 'Q', 'U', 'V'] # make sure I is done first
- else:
- pols = ['I'] # assume I is always present
- img.ch0_Q_arr = None
- img.ch0_U_arr = None
- img.ch0_V_arr = None
-
- if img.shape[1] > 1:
- c_mode = img.opts.collapse_mode
- chan0 = img.opts.collapse_ch0
- c_list = img.opts.collapse_av
- c_wts = img.opts.collapse_wt
- if c_list == []: c_list = N.arange(img.shape[1])
- if len(c_list) == 1:
- c_mode = 'single'
- chan0 = c_list[0]
- img.collapse_ch0 = chan0
- ch0sh = img.image_arr.shape[2:]
- if img.opts.polarisation_do:
- ch0images = ['ch0_arr', 'ch0_Q_arr', 'ch0_U_arr', 'ch0_V_arr']
- else:
- ch0images = ['ch0_arr']
-
- # assume all Stokes images have the same blank pixels as I:
- blank = N.isnan(img.image_arr[0])
- hasblanks = blank.any()
- if img.opts.kappa_clip is None:
- kappa = -img.pixel_beamarea()
- else:
- kappa = img.opts.kappa_clip
-
- mean, rms, cmean, crms = chan_stats(img, kappa)
- img.channel_mean = mean; img.channel_rms = rms
- img.channel_clippedmean = cmean; img.channel_clippedrms = crms
-
- for ipol, pol in enumerate(pols):
- if c_mode == 'single':
- if pol == 'I':
- ch0 = img.image_arr[0, chan0]
- img.ch0_arr = ch0
- mylogger.userinfo(mylog, 'Source extraction will be ' \
- 'done on channel', '%i (%.3f MHz)' % \
- (chan0, img.frequency/1e6))
- else:
- ch0[:] = img.image_arr[ipol, chan0][:]
- img.__setattr__(ch0images[ipol][:], ch0)
-
- if c_mode == 'average':
- if not hasblanks:
- if pol == 'I':
- ch0, wtarr = avspc_direct(c_list, img.image_arr[0], img.channel_clippedrms, c_wts)
- else:
- # use wtarr from the I image, which is always collapsed first
- ch0, wtarr = avspc_direct(c_list, img.image_arr[ipol], img.channel_clippedrms, c_wts, wtarr=wtarr)
- else:
- if pol == 'I':
- ch0, wtarr = avspc_blanks(c_list, img.image_arr[0], img.channel_clippedrms, c_wts)
- else:
- # use wtarr from the I image, which is always collapsed first
- ch0, wtarr = avspc_blanks(c_list, img.image_arr[ipol], img.channel_clippedrms, c_wts, wtarr=wtarr)
- img.__setattr__(ch0images[ipol][:], ch0)
-
- if pol == 'I':
- img.avspc_wtarr = wtarr
- init_freq_collapse(img, wtarr)
- if c_wts == 'unity':
- mylogger.userinfo(mylog, 'Channels averaged with '\
- 'uniform weights')
- else:
- mylogger.userinfo(mylog, 'Channels averaged with '\
- 'weights=(1/rms)^2')
- mylogger.userinfo(mylog, 'Source extraction will be '\
- 'done on averaged ("ch0") image')
- mylogger.userinfo(mylog, 'Frequency of averaged '\
- 'image', '%.3f MHz' % \
- (img.frequency/1e6,))
- str1 = " ".join(str(n) for n in c_list)
- mylog.debug('%s %s' % ('Channels averaged : ', str1))
- str1 = " ".join(["%9.4e" % n for n in wtarr])
- mylog.debug('%s %s %s' % ('Channel weights : ', str1, '; unity=zero if c_wts="rms"'))
-
- if img.opts.output_all:
- func.write_image_to_file(img.use_io, img.imagename+'.ch0_'+pol+'.fits', ch0, img)
- mylog.debug('%s %s ' % ('Writing file ', img.imagename+'.ch0_'+pol+'.fits'))
-
- else:
- # Only one channel in image
- image = img.image_arr
- img.ch0_arr = image[0, 0]
- mylogger.userinfo(mylog, 'Frequency of image',
- '%.3f MHz' % (img.frequency/1e6,))
- if img.opts.polarisation_do:
- for pol in pols[1:]:
- if pol == 'Q':
- img.ch0_Q_arr = image[1, 0][:]
- if pol == 'U':
- img.ch0_U_arr = image[2, 0][:]
- if pol == 'V':
- img.ch0_V_arr = image[3, 0][:]
-
- # create mask if needed (assume all pols have the same mask as I)
- image = img.ch0_arr
- mask = N.isnan(image)
- img.blankpix = N.sum(mask)
- frac_blank = round(
- float(img.blankpix) / float(image.shape[0] * image.shape[1]),
- 3)
- mylogger.userinfo(mylog, "Number of blank pixels", str(img.blankpix)
- + ' (' + str(frac_blank * 100.0) + '%)')
-
- # Check whether the input image might be an AWimage. If so, and there
- # are no blank pixels, tell the user that they might to set blank_limit.
- # Once the AWimager incorporates blanking, this check can be removed.
- if img.opts.blank_limit is None and (img.blankpix == 0 and
- ('restored' in img.filename.lower() or
- 'corr' in img.filename.lower() or
- 'aw' in img.filename.lower())):
- check_low = True
- else:
- check_low = False
-
- if img.opts.blank_limit is not None or check_low:
- import scipy
- import sys
- if check_low:
- threshold = 1e-5
- else:
- threshold = img.opts.blank_limit
- mylogger.userinfo(mylog, "Blanking pixels with values "
- "below %.1e Jy/beam" % (threshold,))
- bad = (abs(image) < threshold)
- original_stdout = sys.stdout # keep a reference to STDOUT
- sys.stdout = func.NullDevice() # redirect the real STDOUT
- count = scipy.signal.convolve2d(bad, N.ones((3, 3)), mode='same')
- sys.stdout = original_stdout # turn STDOUT back on
- mask_low = (count >= 5)
- if check_low:
- nlow = len(N.where(mask_low)[0])
- if nlow / float(image.shape[0] * image.shape[1]) > 0.2:
- mylog.warn('A significant area of the image has very low values. To blank\nthese regions (e.g., because they are outside the primary beam), set the\nblank_limit option (values of 1e-5 to 1e-4 Jy/beam usually work well).\n')
-
- else:
- image[N.where(mask_low)] = N.nan
- mask = N.isnan(image)
- img.blankpix = N.sum(mask)
- frac_blank = round(
- float(img.blankpix) / float(image.shape[0] *
- image.shape[1]), 3)
- mylogger.userinfo(mylog, "Total number of blanked pixels",
- str(img.blankpix) + ' (' + str(frac_blank * 100.0) + '%)')
-
- masked = mask.any()
- img.masked = masked
- if masked:
- img.mask_arr = mask
- else:
- img.mask_arr = None
-
- if img.blankpix == image.shape[0] * image.shape[1]:
- # ALL pixels are blanked!
- raise RuntimeError('All pixels in the image are blanked.')
- img.completed_Ops.append('collapse')
-
-
-########################################################################################
-
-def chan_stats(img, kappa):
-
- bstat = func.bstat #_cbdsm.bstat
- nchan = img.shape[1]
- mean = []; rms = []; cmean = []; crms = []
- for ichan in range(nchan):
- if isinstance(img, Image): # check if img is an Image or just an ndarray
- im = img.image_arr[0, ichan]
- else:
- im = img[0, ichan]
-
- if N.any(im):
- immask = N.isnan(im)
- if immask.all():
- m, r, cm, cr = 0, 0, 0, 0
- else:
- if immask.any():
- m, r, cm, cr, cnt = bstat(im, immask, kappa)
- else:
- m, r, cm, cr, cnt = bstat(im, None, kappa)
- else:
- m, r, cm, cr = 0, 0, 0, 0
- mean.append(m); rms.append(r); cmean.append(cm); crms.append(cr)
-
- return N.array(mean), N.array(rms), N.array(cmean), N.array(crms)
-
-
-########################################################################################
-
-def avspc_direct(c_list, image, rmsarr, c_wts, wtarr=None):
-
- shape2 = image.shape[1:]
- ch0 = N.zeros(shape2, dtype=N.float32)
- sumwts = 0.0
- if wtarr is None:
- wtarr = N.zeros(len(c_list))
- for i, ch in enumerate(c_list):
- im = image[ch]
- r = rmsarr[ch]
- if c_wts == 'unity': wt = 1.0
- if c_wts == 'rms': wt = r
- if r != 0:
- wt = 1.0/(wt*wt)
- else:
- wt = 0
- sumwts += wt
- ch0 += im*wt
- wtarr[i] = wt
- else:
- for i, ch in enumerate(c_list):
- im = image[ch]
- sumwts += wtarr[i]
- ch0 += im*wtarr[i]
- ch0 = ch0/sumwts
-
- return ch0, wtarr
-
-########################################################################################
-
-def avspc_blanks(c_list, image, rmsarr, c_wts, wtarr=None):
-
- shape2 = image.shape[1:]
- ch0 = N.zeros(shape2, dtype=N.float32)
- sumwtim = N.zeros(shape2, dtype=N.float32)
- if wtarr is None:
- wtarr = N.zeros(len(c_list))
- for i, ch in enumerate(c_list):
- im = image[ch]
- r = rmsarr[ch]
- if c_wts == 'unity': wt = 1.0
- if c_wts == 'rms': wt = r
- if r != 0:
- wt = 1.0/(wt*wt)
- else:
- wt = 0
- wtim = N.ones(shape2, dtype=N.float32)*wt*(~N.isnan(im))
- sumwtim += wtim
- ch0 += N.nan_to_num(im)*wtim
- wtarr[i] = wt
- else:
- for i, ch in enumerate(c_list):
- im = image[ch]
- wtim = N.ones(shape2)*wtarr[i]*(~N.isnan(im))
- sumwtim += wtim
- ch0 += N.nan_to_num(im)*wtim
- ch0 = ch0/sumwtim
-
- return ch0, wtarr
-
-########################################################################################
-
-def init_freq_collapse(img, wtarr):
- # Place appropriate, post-collapse frequency info in img
- # Calculate weighted average frequency
- if img.opts.frequency_sp is not None:
- c_list = img.opts.collapse_av
- if c_list == []: c_list = N.arange(img.image_arr.shape[1])
- freqs = img.opts.frequency_sp
- if len(freqs) != len(c_list):
- raise RuntimeError("Number of channels and number of frequencies specified "\
- "by user do not match")
- sumwts = 0.0
- sumfrq = 0.0
- for i, ch in enumerate(c_list):
- sumwts += wtarr[i]
- sumfrq += freqs[ch]*wtarr[i]
- img.frequency = sumfrq / sumwts
- img.freq_pars = (img.frequency, 0.0, 0.0)
- else:
- # Calculate from header info
- c_list = img.opts.collapse_av
- if c_list == []: c_list = N.arange(img.image_arr.shape[1])
- sumwts = 0.0
- sumfrq = 0.0
- spec_indx = img.wcs_obj.wcs.spec
- if spec_indx == -1 and img.opts.frequency_sp is None:
- raise RuntimeError("Frequency information not found in header and frequencies "\
- "not specified by user")
- else:
- for i, ch in enumerate(c_list):
- sumwts += wtarr[i]
- freq = img.wcs_obj.p2f(ch)
- sumfrq += freq*wtarr[i]
- img.frequency = sumfrq / sumwts
diff --git a/CEP/PyBDSM/src/python/const.py b/CEP/PyBDSM/src/python/const.py
deleted file mode 100644
index 8ca3b4583a26f2a4fbd08c5a89a44d30624d4297..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/python/const.py
+++ /dev/null
@@ -1,14 +0,0 @@
-"""Constants
-
-Some universal constants
-"""
-
-import math
-
-pi=math.pi
-fwsig=2.35482
-rad=180.0/pi
-c=2.99792458e8
-bolt=1.3806505e-23
-sq2=math.sqrt(2)
-
diff --git a/CEP/PyBDSM/src/python/functions.py b/CEP/PyBDSM/src/python/functions.py
deleted file mode 100755
index 77d2c27028add9fe248ea63745d6e7e2211a68c6..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/python/functions.py
+++ /dev/null
@@ -1,2235 +0,0 @@
-# some functions
-
-def poly(c,x):
- """ y = Sum { c(i)*x^i }, i=0,len(c)"""
- import numpy as N
- y=N.zeros(len(x))
- for i in range(len(c)):
- y += c[i]*(x**i)
- return y
-
-def sp_in(c, x):
- """ Spectral index in freq-flux space """
- import numpy as N
-
- order = len(c)-1
- if order == 1:
- y = c[0]*N.power(x, c[1])
- else:
- if order == 2:
- y = c[0]*N.power(x, c[1])*N.power(x, c[2]*N.log(x))
- else:
- print 'Not yet implemented'
-
- return y
-
-def wenss_fit(c,x):
- """ sqrt(c0*c0 + c1^2/x^2)"""
- import numpy as N
- y = N.sqrt(c[0]*c[0]+c[1]*c[1]/(x*x))
- return y
-
-def nanmean(x):
- """ Mean of array with NaN """
- import numpy as N
-
- sum = N.nansum(x)
- n = N.sum(~N.isnan(x))
-
- if n > 0:
- mean = sum/n
- else:
- mean = float("NaN")
-
- return mean
-
-def shapeletfit(cf, Bset, cfshape):
- """ The function """
- import numpy as N
-
- ordermax = Bset.shape[0]
- y = (Bset[0,0,::]).flatten()
- y = N.zeros(y.shape)
- index = [(i,j) for i in range(ordermax) for j in range(ordermax-i)] # i=0->nmax, j=0-nmax-i
- for coord in index:
- linbasis = (Bset[coord[0], coord[1], ::]).flatten()
- y += cf.reshape(cfshape)[coord]*linbasis
-
- return y
-
-def func_poly2d(ord,p,x,y):
- """ 2d polynomial.
- ord=0 : z=p[0]
- ord=1 : z=p[0]+p[1]*x+p[2]*y
- ord=2 : z=p[0]+p[1]*x+p[2]*y+p[3]*x*x+p[4]*y*y+p[5]*x*y
- ord=3 : z=p[0]+p[1]*x+p[2]*y+p[3]*x*x+p[4]*y*y+p[5]*x*y+
- p[6]*x*x*x+p[7]*x*x*y+p[8]*x*y*y+p[9]*y*y*y"""
-
- if ord == 0:
- z=p[0]
- if ord == 1:
- z=p[0]+p[1]*x+p[2]*y
- if ord == 2:
- z=p[0]+p[1]*x+p[2]*y+p[3]*x*x+p[4]*y*y+p[5]*x*y
- if ord == 3:
- z=p[0]+p[1]*x+p[2]*y+p[3]*x*x+p[4]*y*y+p[5]*x*y+\
- p[6]*x*x*x+p[7]*x*x*y+p[8]*x*y*y+p[9]*y*y*y
- if ord > 3:
- print " We do not trust polynomial fits > 3 "
- z = None
-
- return z
-
-def func_poly2d_ini(ord, av):
- """ Initial guess -- assume flat plane. """
-
- if ord == 0:
- p0 = N.asarray([av])
- if ord == 1:
- p0 = N.asarray([av] + [0.0]*2)
- if ord == 2:
- p0 = N.asarray([av] + [0.0]*5)
- if ord == 3:
- p0 = N.asarray([av] + [0.0]*9)
- if ord > 3:
- p0 = None
-
- return p0
-
-def ilist(x):
- """ integer part of a list of floats. """
-
- fn = lambda x : [int(round(i)) for i in x]
- return fn(x)
-
-def cart2polar(cart, cen):
- """ convert cartesian coordinates to polar coordinates around cen. theta is
- zero for +ve xaxis and goes counter clockwise. cart is a numpy array [x,y] where
- x and y are numpy arrays of all the (>0) values of coordinates."""
- import math
-
- polar = N.zeros(cart.shape)
- pi = math.pi
- rad = 180.0/pi
-
- cc = N.transpose(cart)
- cc = (cc-cen)*(cc-cen)
- polar[0] = N.sqrt(N.sum(cc,1))
- th = N.arctan2(cart[1]-cen[1],cart[0]-cen[0])*rad
- polar[1] = N.where(th > 0, th, 360+th)
-
- return polar
-
-
-def polar2cart(polar, cen):
- """ convert polar coordinates around cen to cartesian coordinates. theta is
- zero for +ve xaxis and goes counter clockwise. polar is a numpy array of [r], [heta]
- and cart is a numpy array [x,y] where x and y are numpy arrays of all the (>0)
- values of coordinates."""
- import math
-
- cart = N.zeros(polar.shape)
- pi = math.pi
- rad = 180.0/pi
-
- cart[0]=polar[0]*N.cos(polar[1]/rad)+cen[0]
- cart[1]=polar[0]*N.sin(polar[1]/rad)+cen[1]
-
- return cart
-
-def gaus_pixval(g, pix):
- """ Calculates the value at a pixel pix due to a gaussian object g. """
- from const import fwsig, pi
- from math import sin, cos, exp
-
- cen = g.centre_pix
- peak = g.peak_flux
- bmaj_p, bmin_p, bpa_p = g.size_pix
-
- a4 = bmaj_p/fwsig; a5 = bmin_p/fwsig
- a6 = (bpa_p+90.0)*pi/180.0
- spa = sin(a6); cpa = cos(a6)
- dr1 = ((pix[0]-cen[0])*cpa + (pix[1]-cen[1])*spa)/a4
- dr2 = ((pix[1]-cen[1])*cpa - (pix[0]-cen[0])*spa)/a5
- pixval = peak*exp(-0.5*(dr1*dr1+dr2*dr2))
-
- return pixval
-
-def atanproper(dumr, dx, dy):
- from math import pi
-
- ysign = (dy >= 0.0)
- xsign = (dx >= 0.0)
- if ysign and (not xsign): dumr = pi - dumr
- if (not ysign) and (not xsign): dumr = pi + dumr
- if (not ysign) and xsign: dumr = 2.0*pi - dumr
-
- return dumr
-
-def gdist_pa(pix1, pix2, gsize):
- """ Computes FWHM in degrees in the direction towards second source, of an elliptical gaussian. """
- from math import atan, pi, sqrt, cos, sin, tan
-
- dx = pix2[0] - pix1[0]
- dy = pix2[1] - pix1[1]
- if dx == 0.0:
- val = pi/2.0
- else:
- dumr = atan(abs(dy/dx))
- val = atanproper(dumr, dx, dy)
-
- psi = val - (gsize[2]+90.0)/180.0*pi
-
- # convert angle to eccentric anomaly
- if approx_equal(gsize[1], 0.0):
- psi = pi/2.0
- else:
- psi=atan(gsize[0]/gsize[1]*tan(psi))
- dumr2 = gsize[0]*cos(psi)
- dumr3 = gsize[1]*sin(psi)
- fwhm = sqrt(dumr2*dumr2+dumr3*dumr3)
-
- return fwhm
-
-def gaus_2d(c, x, y):
- """ x and y are 2d arrays with the x and y positions. """
- import math
- import numpy as N
-
- rad = 180.0/math.pi
- cs = math.cos(c[5]/rad)
- sn = math.sin(c[5]/rad)
- f1 = ((x-c[1])*cs+(y-c[2])*sn)/c[3]
- f2 = ((y-c[2])*cs-(x-c[1])*sn)/c[4]
- val = c[0]*N.exp(-0.5*(f1*f1+f2*f2))
-
- return val
-
-def gaus_2d_itscomplicated(c, x, y, p_tofix, ind):
- """ x and y are 2d arrays with the x and y positions. c is a list (of lists) of gaussian parameters to fit, p_tofix
- are gaussian parameters to fix. ind is a list with 0, 1; 1 = fit; 0 = fix. """
-
- import math
- import numpy as N
-
- val = N.zeros(x.shape)
- indx = N.array(ind)
- if len(indx) % 6 != 0:
- print " Something wrong with the parameters passed - need multiples of 6 !"
- else:
- ngaus = len(indx)/6
- params = N.zeros(6*ngaus)
- params[N.where(indx==1)[0]] = c
- params[N.where(indx==0)[0]] = p_tofix
- for i in range(ngaus):
- gau = params[i*6:i*6+6]
- val = val + gaus_2d(gau, x, y)
-
- return val
-
-def g2param(g, adj=False):
- """Convert gaussian object g to param list [amp, cenx, ceny, sigx, sigy, theta] """
- from const import fwsig
- from math import pi
-
- A = g.peak_flux
- if adj and hasattr(g, 'size_pix_adj'):
- sigx, sigy, th = g.size_pix_adj
- else:
- sigx, sigy, th = g.size_pix
- cenx, ceny = g.centre_pix
- sigx = sigx/fwsig; sigy = sigy/fwsig; th = th+90.0
- params = [A, cenx, ceny, sigx, sigy, th]
-
- return params
-
-def g2param_err(g, adj=False):
- """Convert errors on gaussian object g to param list [Eamp, Ecenx, Eceny, Esigx, Esigy, Etheta] """
- from const import fwsig
- from math import pi
-
- A = g.peak_fluxE
- if adj and hasattr(g, 'size_pix_adj'):
- sigx, sigy, th = g.size_pix_adj
- else:
- sigx, sigy, th = g.size_pixE
- cenx, ceny = g.centre_pixE
- sigx = sigx/fwsig; sigy = sigy/fwsig
- params = [A, cenx, ceny, sigx, sigy, th]
-
- return params
-
-def corrected_size(size):
- """ convert major and minor axis from sigma to fwhm and angle from horizontal to P.A. """
-
- from const import fwsig
-
- csize = [0,0,0]
- csize[0] = size[0]*fwsig
- csize[1] = size[1]*fwsig
- bpa = size[2]
- pa = bpa-90.0
- pa = pa % 360
- if pa < 0.0: pa = pa + 360.0
- if pa > 180.0: pa = pa - 180.0
- csize[2] = pa
-
- return csize
-
-def drawellipse(g):
- import math
- import numpy as N
- from gausfit import Gaussian
-
- rad = 180.0/math.pi
- if isinstance(g, Gaussian):
- param = g2param(g)
- else:
- if isinstance(g, list) and len(g)>=6:
- param = g
- else:
- raise RuntimeError("Input to drawellipse neither Gaussian nor list")
-
- x2 = []; y2 = []
- size = [param[3], param[4], param[5]]
- size_fwhm = corrected_size(size)
- for th in range(0, 370, 10):
- x1=size_fwhm[0]*math.cos(th/rad)
- y1=size_fwhm[1]*math.sin(th/rad)
- x2.append(x1*math.cos(param[5]/rad)-y1*math.sin(param[5]/rad)+param[1])
- y2.append(x1*math.sin(param[5]/rad)+y1*math.cos(param[5]/rad)+param[2])
- x2 = N.array(x2); y2 = N.array(y2)
-
- return x2, y2
-
-def drawsrc(src):
- import math
- import numpy as N
- import matplotlib.path as mpath
- Path = mpath.Path
- paths = []
- xmin = []
- xmax = []
- ymin = []
- ymax = []
- ellx = []
- elly = []
- for indx, g in enumerate(src.gaussians):
- gellx, gelly = drawellipse(g)
- ellx += gellx.tolist()
- elly += gelly.tolist()
- yarr = N.array(elly)
- minyarr = N.min(yarr)
- maxyarr = N.max(yarr)
- xarr = N.array(ellx)
- for i in range(10):
- inblock = N.where(yarr > minyarr + float(i)*(maxyarr-minyarr)/10.0)
- yarr = yarr[inblock]
- xarr = xarr[inblock]
- inblock = N.where(yarr < minyarr + float(i+1)*(maxyarr-minyarr)/10.0)
- xmin.append(N.min(xarr[inblock])-1.0)
- xmax.append(N.max(xarr[inblock])+1.0)
- ymin.append(N.mean(yarr[inblock]))
- ymax.append(N.mean(yarr[inblock]))
-
- xmax.reverse()
- ymax.reverse()
- pathdata = [(Path.MOVETO, (xmin[0], ymin[0]))]
- for i in range(10):
- pathdata.append((Path.LINETO, (xmin[i], ymin[i])))
- pathdata.append((Path.CURVE3, (xmin[i], ymin[i])))
- pathdata.append((Path.LINETO, ((xmin[9]+xmax[0])/2.0, (ymin[9]+ymax[0])/2.0+1.0)))
- for i in range(10):
- pathdata.append((Path.LINETO, (xmax[i], ymax[i])))
- pathdata.append((Path.CURVE3, (xmax[i], ymax[i])))
- pathdata.append((Path.LINETO, ((xmin[0]+xmax[9])/2.0, (ymin[0]+ymax[9])/2.0-1.0)))
- pathdata.append((Path.CLOSEPOLY, (xmin[0], ymin[0])))
- codes, verts = zip(*pathdata)
- path = Path(verts, codes)
- return path
-
-def mask_fwhm(g, fac1, fac2, delc, shap):
- """ take gaussian object g and make a mask (as True) for pixels which are outside (less flux)
- fac1*FWHM and inside (more flux) fac2*FWHM. Also returns the values as well."""
- import math
- import numpy as N
- from const import fwsig
-
- x, y = N.indices(shap)
- params = g2param(g)
- params[1] -= delc[0]; params[2] -= delc[1]
- gau = gaus_2d(params, x, y)
- dumr1 = 0.5*fac1*fwsig
- dumr2 = 0.5*fac2*fwsig
- flux1= params[0]*math.exp(-0.5*dumr1*dumr1)
- flux2 = params[0]*math.exp(-0.5*dumr2*dumr2)
- mask = (gau <= flux1) * (gau > flux2)
- gau = gau * mask
-
- return mask, gau
-
-def flatten(x):
- """flatten(sequence) -> list
- Taken from http://kogs-www.informatik.uni-hamburg.de/~meine/python_tricks
-
- Returns a single, flat list which contains all elements retrieved
- from the sequence and all recursively contained sub-sequences
- (iterables).
-
- Examples:
- >>> [1, 2, [3,4], (5,6)]
- [1, 2, [3, 4], (5, 6)]
- >>> flatten([[[1,2,3], (42,None)], [4,5], [6], 7, MyVector(8,9,10)])
- [1, 2, 3, 42, None, 4, 5, 6, 7, 8, 9, 10]"""
-
- result = []
- for el in x:
- #if isinstance(el, (list, tuple)):
- if hasattr(el, "__iter__") and not isinstance(el, basestring):
- result.extend(flatten(el))
- else:
- result.append(el)
- return result
-
-def moment(x,mask=None):
- """
- Calculates first 3 moments of numpy array x. Only those values of x
- for which mask is False are used, if mask is given. Works for any
- dimension of x.
- """
- import numpy as N
-
- if mask is None:
- mask=N.zeros(x.shape, dtype=bool)
- m1=N.zeros(1)
- m2=N.zeros(x.ndim)
- m3=N.zeros(x.ndim)
- for i, val in N.ndenumerate(x):
- if not mask[i]:
- m1 += val
- m2 += val*N.array(i)
- m3 += val*N.array(i)*N.array(i)
- m2 /= m1
- m3 = N.sqrt(m3/m1-m2*m2)
- return m1, m2, m3
-
-def fit_mask_1d(x, y, sig, mask, funct, do_err, order=0, p0 = None):
- """
- Calls scipy.optimise.leastsq for a 1d function with a mask.
- Takes values only where mask=False.
- """
- from scipy.optimize import leastsq
- from math import sqrt, pow
- import numpy as N
- import sys
-
- ind=N.where(~N.array(mask))[0]
- if len(ind) > 1:
- n=sum(mask)
-
- if isinstance(x, list): x = N.array(x)
- if isinstance(y, list): y = N.array(y)
- if isinstance(sig, list): sig = N.array(sig)
- xfit=x[ind]; yfit=y[ind]; sigfit=sig[ind]
-
- if p0 is None:
- if funct == poly:
- p0=N.array([0]*(order+1))
- p0[1]=(yfit[0]-yfit[-1])/(xfit[0]-xfit[-1])
- p0[0]=yfit[0]-p0[1]*xfit[0]
- if funct == wenss_fit:
- p0=N.array([yfit[N.argmax(xfit)]] + [1.])
- if funct == sp_in:
- ind1 = N.where(yfit > 0.)[0]
- if len(ind1) >= 2:
- low = ind1[0]; hi = ind1[-1]
- sp = N.log(yfit[low]/yfit[hi])/N.log(xfit[low]/xfit[hi])
- p0=N.array([yfit[low]/pow(xfit[low], sp), sp] + [0.]*(order-1))
- elif len(ind1) == 1:
- p0=N.array([ind1[0], -0.8] + [0.]*(order-1))
- else:
- return [0, 0], [0, 0]
- res=lambda p, xfit, yfit, sigfit: (yfit-funct(p, xfit))/sigfit
- try:
- (p, cov, info, mesg, flag)=leastsq(res, p0, args=(xfit, yfit, sigfit), full_output=True, warning=False)
- except TypeError:
- # This error means no warning argument is available, so redirect stdout to a null device
- # to suppress printing of (unnecessary) warning messages
- original_stdout = sys.stdout # keep a reference to STDOUT
- sys.stdout = NullDevice() # redirect the real STDOUT
- (p, cov, info, mesg, flag)=leastsq(res, p0, args=(xfit, yfit, sigfit), full_output=True)
- sys.stdout = original_stdout # turn STDOUT back on
-
- if do_err:
- if cov is not None:
- if N.sum(sig != 1.) > 0:
- err = N.array([sqrt(abs(cov[i,i])) for i in range(len(p))])
- else:
- chisq=sum(info["fvec"]*info["fvec"])
- dof=len(info["fvec"])-len(p)
- err = N.array([sqrt(abs(cov[i,i])*chisq/dof) for i in range(len(p))])
- else:
- p, err = [0, 0], [0, 0]
- else: err = [0]
- else:
- p, err = [0, 0], [0, 0]
-
- return p, err
-
-def dist_2pt(p1, p2):
- """ Calculated distance between two points given as tuples p1 and p2. """
- from math import sqrt
- dx=p1[0]-p2[0]
- dy=p1[1]-p2[1]
- dist=sqrt(dx*dx + dy*dy)
-
- return dist
-
-
-def angsep(ra1, dec1, ra2, dec2):
- """Returns angular separation between two coordinates (all in degrees)"""
- import math
-
- const = math.pi/180.
- ra1 = ra1*const
- rb1 = dec1*const
- ra2 = ra2*const
- rb2 = dec2*const
-
- v1_1 = math.cos(ra1)*math.cos(rb1)
- v1_2 = math.sin(ra1)*math.cos(rb1)
- v1_3 = math.sin(rb1)
-
- v2_1 = math.cos(ra2)*math.cos(rb2)
- v2_2 = math.sin(ra2)*math.cos(rb2)
- v2_3 = math.sin(rb2)
-
- w = ( (v1_1-v2_1)**2 + (v1_2-v2_2)**2 + (v1_3-v2_3)**2 )/4.0
-
- x = math.sqrt(w)
- y = math.sqrt(max(0.0, 1.0-w))
- angle = 2.0*math.atan2(x, y)/const
- return angle
-
-
-def std(y):
- """ Returns unbiased standard deviation. """
- from math import sqrt
- import numpy as N
-
- l=len(y)
- s=N.std(y)
- if l == 1:
- return s
- else:
- return s*sqrt(float(l)/(l-1))
-
-def imageshift(image, shift):
- """ Shifts a 2d-image by the tuple (shift). Positive shift is to the right and upwards.
- This is done by fourier shifting. """
- import scipy
- from scipy import ndimage
-
- shape=image.shape
-
- f1=scipy.fft(image, shape[0], axis=0)
- f2=scipy.fft(f1, shape[1], axis=1)
-
- s=ndimage.fourier_shift(f2,shift, axis=0)
-
- y1=scipy.ifft(s, shape[1], axis=1)
- y2=scipy.ifft(y1, shape[0], axis=0)
-
- return y2.real
-
-def trans_gaul(q):
- " transposes a tuple "
- y=[]
- if len(q) > 0:
- for i in range(len(q[0])):
- elem=[]
- for j in range(len(q)):
- elem.append(q[j][i])
- y.append(elem)
- return y
-
-def momanalmask_gaus(subim, mask, isrc, bmar_p, allpara=True):
- """ Compute 2d gaussian parameters from moment analysis, for an island with
- multiple gaussians. Compute only for gaussian with index (mask value) isrc.
- Returns normalised peak, centroid, fwhm and P.A. assuming North is top.
- """
- from math import sqrt, atan, pi
- from const import fwsig
- import numpy as N
- N.seterr(all='ignore')
-
- m1 = N.zeros(2); m2 = N.zeros(2); m11 = 0.0; tot = 0.0
- mompara = N.zeros(6)
- n, m = subim.shape[0], subim.shape[1]
- index = [(i, j) for i in range(n) for j in range(m) if mask[i,j]==isrc]
- for coord in index:
- tot += subim[coord]
- m1 += N.array(coord)*subim[coord]
- mompara[0] = tot/bmar_p
- mompara[1:3] = m1/tot
-
- if allpara:
- for coord in index:
- co = N.array(coord)
- m2 += (co - mompara[1:3])*(co - mompara[1:3])*subim[coord]
- m11 += N.product(co - mompara[1:3])*subim[coord]
-
- mompara[3] = sqrt((m2[0]+m2[1]+sqrt((m2[0]-m2[1])*(m2[0]-m2[1])+4.0*m11*m11))/(2.0*tot))*fwsig
- mompara[4] = sqrt((m2[0]+m2[1]-sqrt((m2[0]-m2[1])*(m2[0]-m2[1])+4.0*m11*m11))/(2.0*tot))*fwsig
- dumr = atan(abs(2.0*m11/(m2[0]-m2[1])))
- dumr = atanproper(dumr, m2[0]-m2[1], 2.0*m11)
- mompara[5] = 0.5*dumr*180.0/pi - 90.0
- if mompara[5] < 0.0: mompara[5] += 180.0
- return mompara
-
-def fit_gaus2d(data, p_ini, x, y, mask = None, err = None):
- """ Fit 2d gaussian to data with x and y also being 2d numpy arrays with x and y positions.
- Takes an optional error array and a mask array (True => pixel is masked). """
- from scipy.optimize import leastsq
- import numpy as N
- import sys
-
- if mask is not None and mask.shape != data.shape:
- print 'Data and mask array dont have the same shape, ignoring mask'
- mask = None
- if err is not None and err.shape != data.shape:
- print 'Data and error array dont have the same shape, ignoring error'
- err = None
-
- if mask is None: mask = N.zeros(data.shape, bool)
- g_ind = N.where(~N.ravel(mask))[0]
-
- if err is None:
- errorfunction = lambda p: N.ravel(gaus_2d(p, x, y) - data)[g_ind]
- else:
- errorfunction = lambda p: N.ravel((gaus_2d(p, x, y) - data)/err)[g_ind]
- try:
- p, success = leastsq(errorfunction, p_ini, warning=False)
- except TypeError:
- # This error means no warning argument is available, so redirect stdout to a null device
- # to suppress printing of warning messages
- original_stdout = sys.stdout # keep a reference to STDOUT
- sys.stdout = NullDevice() # redirect the real STDOUT
- p, success = leastsq(errorfunction, p_ini)
- sys.stdout = original_stdout # turn STDOUT back on
-
-
- return p, success
-
-def deconv(gaus_bm, gaus_c):
- """ Deconvolves gaus_bm from gaus_c to give gaus_dc.
- Stolen shamelessly from aips DECONV.FOR.
- All PA is in degrees."""
- from math import pi, cos, sin, atan, sqrt
-
- rad = 180.0/pi
- gaus_d = [0.0, 0.0, 0.0]
-
- phi_c = gaus_c[2]+900.0 % 180
- phi_bm = gaus_bm[2]+900.0 % 180
- maj2_bm = gaus_bm[0]*gaus_bm[0]; min2_bm = gaus_bm[1]*gaus_bm[1]
- maj2_c = gaus_c[0]*gaus_c[0]; min2_c = gaus_c[1]*gaus_c[1]
- theta=2.0*(phi_c-phi_bm)/rad
- cost = cos(theta)
- sint = sin(theta)
-
- rhoc = (maj2_c-min2_c)*cost-(maj2_bm-min2_bm)
- if rhoc == 0.0:
- sigic = 0.0
- rhoa = 0.0
- else:
- sigic = atan((maj2_c-min2_c)*sint/rhoc) # in radians
- rhoa = ((maj2_bm-min2_bm)-(maj2_c-min2_c)*cost)/(2.0*cos(sigic))
-
- gaus_d[2] = sigic*rad/2.0+phi_bm
- dumr = ((maj2_c+min2_c)-(maj2_bm+min2_bm))/2.0
- gaus_d[0] = dumr-rhoa
- gaus_d[1] = dumr+rhoa
- error = 0
- if gaus_d[0] < 0.0: error += 1
- if gaus_d[1] < 0.0: error += 1
-
- gaus_d[0] = max(0.0,gaus_d[0])
- gaus_d[1] = max(0.0,gaus_d[1])
- gaus_d[0] = sqrt(abs(gaus_d[0]))
- gaus_d[1] = sqrt(abs(gaus_d[1]))
- if gaus_d[0] < gaus_d[1]:
- sint = gaus_d[0]
- gaus_d[0] = gaus_d[1]
- gaus_d[1] = sint
- gaus_d[2] = gaus_d[2]+90.0
-
- gaus_d[2] = gaus_d[2]+900.0 % 180
- if gaus_d[0] == 0.0:
- gaus_d[2] = 0.0
- else:
- if gaus_d[1] == 0.0:
- if (abs(gaus_d[2]-phi_c) > 45.0) and (abs(gaus_d[2]-phi_c) < 135.0):
- gaus_d[2] = gaus_d[2]+450.0 % 180
-
-# errors
- #if rhoc == 0.0:
- #if gaus_d[0] != 0.0:
- # ed_1 = gaus_c[0]/gaus_d[0]*e_1
- #else:
- # ed_1 = sqrt(2.0*e_1*gaus_c[0])
- #if gaus_d[1] != 0.0:
- # ed_2 = gaus_c[1]/gaus_d[1]*e_2
- #else:
- # ed_2 = sqrt(2.0*e_2*gaus_c[1])
- #ed_3 =e_3
- #else:
- # pass
-
- return gaus_d
-
-def deconv2(gaus_bm, gaus_c):
- """ Deconvolves gaus_bm from gaus_c to give gaus_dc.
- Stolen shamelessly from Miriad gaupar.for.
- All PA is in degrees.
-
- Returns deconvolved gaussian parameters and flag:
- 0 All OK.
- 1 Result is pretty close to a point source.
- 2 Illegal result.
-
- """
- from math import pi, cos, sin, atan2, sqrt
-
- rad = 180.0/pi
-
- phi_c = gaus_c[2]+900.0 % 180.0
- phi_bm = gaus_bm[2]+900.0 % 180.0
- theta1 = phi_c / rad
- theta2 = phi_bm / rad
- bmaj1 = gaus_c[0]
- bmaj2 = gaus_bm[0]
- bmin1 = gaus_c[1]
- bmin2 = gaus_bm[1]
-
- alpha = ( (bmaj1*cos(theta1))**2 + (bmin1*sin(theta1))**2 -
- (bmaj2*cos(theta2))**2 - (bmin2*sin(theta2))**2 )
- beta = ( (bmaj1*sin(theta1))**2 + (bmin1*cos(theta1))**2 -
- (bmaj2*sin(theta2))**2 - (bmin2*cos(theta2))**2 )
- gamma = 2.0 * ( (bmin1**2-bmaj1**2)*sin(theta1)*cos(theta1) -
- (bmin2**2-bmaj2**2)*sin(theta2)*cos(theta2) )
-
- s = alpha + beta
- t = sqrt((alpha-beta)**2 + gamma**2)
- limit = min(bmaj1, bmin1, bmaj2, bmin2)
- limit = 0.1*limit*limit
-
- if alpha < 0.0 or beta < 0.0 or s < t:
- if alpha < 0.0 or beta < 0.0:
- bmaj = 0.0
- bpa = 0.0
- else:
- bmaj = sqrt(0.5*(s+t))
- bpa = rad * 0.5 * atan2(-gamma, alpha-beta)
- bmin = 0.0
- if 0.5*(s-t) < limit and alpha > -limit and beta > -limit:
- ifail = 1
- else:
- ifail = 2
- else:
- bmaj = sqrt(0.5*(s+t))
- bmin = sqrt(0.5*(s-t))
- if abs(gamma) + abs(alpha-beta) == 0.0:
- bpa = 0.0
- else:
- bpa = rad * 0.5 * atan2(-gamma, alpha-beta)
- ifail = 0
- return (bmaj, bmin, bpa), ifail
-
-
-def get_errors(img, p, stdav, bm_pix=None):
- """ Returns errors from Condon 1997
-
- Returned list includes errors on:
- peak flux [Jy/beam]
- x_0 [pix]
- y_0 [pix]
- e_maj [pix]
- e_min [pix]
- e_pa [deg]
- e_tot [Jy]
-
- """
- from const import fwsig
- from math import sqrt, log, pow, pi
- import mylogger
- import numpy as N
-
- mylog = mylogger.logging.getLogger("PyBDSM.Compute")
-
- if len(p) % 7 > 0:
- mylog.error("Gaussian parameters passed have to have 7n numbers")
- ngaus = len(p)/7
- errors = []
- for i in range(ngaus):
- pp = p[i*7:i*7+7]
- ### Now do error analysis as in Condon (and fBDSM)
- size = pp[3:6]
- size = corrected_size(size) # angle is now degrees CCW from +y-axis
- if size[0] == 0.0 or size[1] == 0.0:
- errors = errors + [0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0]
- else:
- sq2 = sqrt(2.0)
- if bm_pix is None:
- bm_pix = N.array([img.pixel_beam()[0]*fwsig, img.pixel_beam()[1]*fwsig, img.pixel_beam()[2]])
- dumr = sqrt(abs(size[0] * size[1] / (4.0 * bm_pix[0] * bm_pix[1])))
- dumrr1 = 1.0 + bm_pix[0] * bm_pix[1] / (size[0] * size[0])
- dumrr2 = 1.0 + bm_pix[0] * bm_pix[1] / (size[1] * size[1])
- dumrr3 = dumr * pp[0] / stdav
- d1 = sqrt(8.0 * log(2.0))
- d2 = (size[0] * size[0] - size[1] * size[1]) / (size[0] * size[0])
- try:
- e_peak = pp[0] * sq2 / (dumrr3 * pow(dumrr1, 0.75) * pow(dumrr2, 0.75))
- e_maj = size[0] * sq2 / (dumrr3 * pow(dumrr1, 1.25) * pow(dumrr2, 0.25))
- e_min = size[1] * sq2 / (dumrr3 * pow(dumrr1, 0.25) * pow(dumrr2, 1.25)) # in fw
- pa_rad = size[2] * pi / 180.0
- e_x0 = sqrt( (e_maj * N.sin(pa_rad))**2 + (e_min * N.cos(pa_rad))**2 ) / d1
- e_y0 = sqrt( (e_maj * N.cos(pa_rad))**2 + (e_min * N.sin(pa_rad))**2 ) / d1
- e_pa = 2.0 / (d2 * dumrr3 * pow(dumrr1, 0.25) * pow(dumrr2, 1.25))
- e_pa = e_pa * 180.0/pi
- e_tot = pp[0] * sqrt(e_peak * e_peak / (pp[0] * pp[0]) + (0.25 / dumr / dumr) * (e_maj * e_maj / (size[0] * size[0]) + e_min * e_min / (size[1] * size[1])))
- except:
- e_peak = 0.0
- e_x0 = 0.0
- e_y0 = 0.0
- e_maj = 0.0
- e_min = 0.0
- e_pa = 0.0
- e_tot = 0.0
- if abs(e_pa) > 180.0: e_pa=180.0 # dont know why i did this
- errors = errors + [e_peak, e_x0, e_y0, e_maj, e_min, e_pa, e_tot]
-
- return errors
-
-def fit_chisq(x, p, ep, mask, funct, order):
- import numpy as N
-
- ind = N.where(N.array(mask)==False)[0]
- if order == 0:
- fit = [funct(p)]*len(p)
- else:
- fitpara, efit = fit_mask_1d(x, p, ep, mask, funct, True, order)
- fit = funct(fitpara, x)
-
- dev = (p-fit)*(p-fit)/(ep*ep)
- num = order+1
- csq = N.sum(dev[ind])/(len(fit)-num-1)
-
- return csq
-
-def calc_chisq(x, y, ey, p, mask, funct, order):
- import numpy as N
-
- if order == 0:
- fit = [funct(y)]*len(y)
- else:
- fit = funct(p, x)
-
- dev = (y-fit)*(y-fit)/(ey*ey)
- ind = N.where(~N.array(mask))
- num = order+1
- csq = N.sum(dev[ind])/(len(mask)-num-1)
-
- return csq
-
-def get_windowsize_av(S_i, rms_i, chanmask, K, minchan):
- import numpy as N
-
- av_window = N.arange(2, int(len(S_i)/minchan)+1)
- win_size = 0
- for window in av_window:
- fluxes, vars, mask = variance_of_wted_windowedmean(S_i, rms_i, chanmask, window)
- minsnr = N.min(fluxes[~mask]/vars[~mask])
- if minsnr > K*1.1: ### K*1.1 since fitted peak can be less than wted peak
- win_size = window # is the size of averaging window
- break
-
- return win_size
-
-def variance_of_wted_windowedmean(S_i, rms_i, chanmask, window_size):
- from math import sqrt
- import numpy as N
-
- nchan = len(S_i)
- nwin = nchan/window_size
- wt = 1/rms_i/rms_i
- wt = wt/N.median(wt)
- fluxes = N.zeros(nwin); vars = N.zeros(nwin); mask = N.zeros(nwin, bool)
- for i in range(nwin):
- strt = i*window_size; stp = (i+1)*window_size
- if i == nwin-1: stp = nchan
- ind = N.arange(strt,stp)
- m = chanmask[ind]
- index = [arg for ii,arg in enumerate(ind) if not m[ii]]
- if len(index) > 0:
- s = S_i[index]; r = rms_i[index]; w = wt[index]
- fluxes[i] = N.sum(s*w)/N.sum(w)
- vars[i] = 1.0/sqrt(N.sum(1.0/r/r))
- mask[i] = N.product(m)
- else:
- fluxes[i] = 0
- vars[i] = 0
- mask[i] = True
-
- return fluxes, vars, mask
-
-def fit_mulgaus2d(image, gaus, x, y, mask = None, fitfix = None, err = None, adj=False):
- """ fitcode : 0=fit all; 1=fit amp; 2=fit amp, posn; 3=fit amp, size """
- from scipy.optimize import leastsq
- import numpy as N
- import sys
-
- if mask is not None and mask.shape != image.shape:
- print 'Data and mask array dont have the same shape, ignoring mask'
- mask = None
- if err is not None and err.shape != image.shape:
- print 'Data and error array dont have the same shape, ignoring error'
- err = None
- if mask is None: mask = N.zeros(image.shape, bool)
-
- g_ind = N.where(~N.ravel(mask))[0]
-
- ngaus = len(gaus)
- if ngaus > 0:
- p_ini = []
- for g in gaus:
- p_ini = p_ini + g2param(g, adj)
- p_ini = N.array(p_ini)
-
- if fitfix is None: fitfix = [0]*ngaus
- ind = N.ones(6*ngaus) # 1 => fit ; 0 => fix
- for i in range(ngaus):
- if fitfix[i] == 1: ind[i*6+1:i*6+6] = 0
- if fitfix[i] == 2: ind[i*6+3:i*6+6] = 0
- if fitfix[i] == 3: ind[i*6+1:i*6+3] = 0
- ind = N.array(ind)
- p_tofit = p_ini[N.where(ind==1)[0]]
- p_tofix = p_ini[N.where(ind==0)[0]]
- if err is None: err = N.ones(image.shape)
-
- errorfunction = lambda p, x, y, p_tofix, ind, image, err, g_ind: \
- N.ravel((gaus_2d_itscomplicated(p, x, y, p_tofix, ind)-image)/err)[g_ind]
- try:
- p, success = leastsq(errorfunction, p_tofit, args=(x, y, p_tofix, ind, image, err, g_ind), warning=False)
- except TypeError:
- # This error means no warning argument is available, so redirect stdout to a null device
- # to suppress printing of warning messages
- original_stdout = sys.stdout # keep a reference to STDOUT
- sys.stdout = NullDevice() # redirect the real STDOUT
- p, success = leastsq(errorfunction, p_tofit, args=(x, y, p_tofix, ind, image, err, g_ind))
- sys.stdout = original_stdout # turn STDOUT back on
- else:
- p, sucess = None, 1
-
- para = N.zeros(6*ngaus)
- para[N.where(ind==1)[0]] = p
- para[N.where(ind==0)[0]] = p_tofix
-
- for igaus in range(ngaus):
- para[igaus*6+3] = abs(para[igaus*6+3])
- para[igaus*6+4] = abs(para[igaus*6+4])
-
- return para, success
-
-def gaussian_fcn(g, x1, x2):
- """Evaluate Gaussian on the given grid.
-
- Parameters:
- x1, x2: grid (as produced by numpy.mgrid f.e.)
- g: Gaussian object or list of Gaussian paramters
- """
- from math import radians, sin, cos
- from const import fwsig
- import numpy as N
-
- if isinstance(g, list):
- A, C1, C2, S1, S2, Th = g
- else:
- A = g.peak_flux
- C1, C2 = g.centre_pix
- S1, S2, Th = g.size_pix
- S1 = S1/fwsig; S2 = S2/fwsig; Th = Th + 90.0 # Define theta = 0 on x-axis
-
- th = radians(Th)
- cs = cos(th)
- sn = sin(th)
-
- f1 = ((x1-C1)*cs + (x2-C2)*sn)/S1
- f2 = (-(x1-C1)*sn + (x2-C2)*cs)/S2
-
- return A*N.exp(-(f1*f1 + f2*f2)/2)
-
-def mclean(im1, c, beam):
- """ Simple image plane clean of one gaussian at posn c and size=beam """
- import numpy as N
-
- amp = im1[c]
- b1, b2, b3 = beam
- b3 += 90.0
- para = [amp, c[0], c[1], b1, b2, b3]
- x, y = N.indices(im1.shape)
-
- im = gaus_2d(para, x, y)
- im1 = im1-im
-
- return im1
-
-def arrstatmask(im, mask):
- """ Basic statistics for a masked array. dont wanna use numpy.ma """
- import numpy as N
-
- ind = N.where(~mask)
- im1 = im[ind]
- av = N.mean(im1)
- std = N.std(im1)
- maxv = N.max(im1)
- x, y = N.where(im == maxv)
- xmax = x[0]; ymax = y[0]
- minv = N.min(im1)
- x, y = N.where(im == minv)
- xmin = x[0]; ymin = y[0]
-
- return (av, std, maxv, (xmax, ymax), minv, (xmin, ymin))
-
-def get_maxima(im, mask, thr, shape, beam, im_pos=None):
- """ Gets the peaks in an image """
- from copy import deepcopy as cp
- import numpy as N
-
- if im_pos is None:
- im_pos = im
- im1 = cp(im)
- ind = N.array(N.where(~mask)).transpose()
- ind = [tuple(coord) for coord in ind if im_pos[tuple(coord)] > thr]
- n, m = shape
- iniposn = []
- inipeak = []
- for c in ind:
- goodlist = [im_pos[i,j] for i in range(c[0]-1,c[0]+2) for j in range(c[1]-1,c[1]+2) \
- if i>=0 and i<n and j>=0 and j<m and (i,j) != c]
- peak = N.sum(im_pos[c] > goodlist) == len(goodlist)
- if peak:
- iniposn.append(c)
- inipeak.append(im[c])
- im1 = mclean(im1, c, beam)
-
- return inipeak, iniposn, im1
-
-def watershed(image, mask=None, markers=None, beam=None, thr=None):
- import numpy as N
- from copy import deepcopy as cp
- import scipy.ndimage as nd
- #import matplotlib.pyplot as pl
- #import pylab as pl
-
- if thr==None: thr = -1e9
- if mask==None: mask = N.zeros(image.shape, bool)
- if beam==None: beam = (2.0, 2.0, 0.0)
- if markers==None:
- inipeak, iniposn, im1 = get_maxima(image, mask, thr, image.shape, beam)
- ng = len(iniposn); markers = N.zeros(image.shape, int)
- for i in range(ng): markers[iniposn[i]] = i+2
- markers[N.unravel_index(N.argmin(image), image.shape)] = 1
-
- im1 = cp(image)
- if im1.min() < 0.: im1 = im1-im1.min()
- im1 = 255 - im1/im1.max()*255
- opw = nd.watershed_ift(N.array(im1, N.uint16), markers)
-
- return opw, markers
-
-def get_kwargs(kwargs, key, typ, default):
- obj = True
- if key in kwargs:
- obj = kwargs[key]
- if not isinstance(obj, typ):
- obj = default
-
- return obj
-
-def read_image_from_file(filename, img, indir, quiet=False):
- """ Reads data and header from indir/filename.
-
- We can use either pyfits or pyrap depending on the value
- of img.use_io = 'fits'/'rap'
-
- PyFITS is required, as it is used to standardize the header format. pyrap
- is optional.
- """
- import mylogger
- import os
- import numpy as N
- from copy import deepcopy as cp
- from distutils.version import StrictVersion
-
- mylog = mylogger.logging.getLogger("PyBDSM."+img.log+"Readfile")
- if indir is None or indir == './':
- prefix = ''
- else:
- prefix = indir + '/'
- image_file = prefix + filename
-
- # Check that file exists
- if not os.path.exists(image_file):
- img._reason = 'File does not exist'
- return None
-
- # If img.use_io is set, then use appropriate io module
- if img.use_io != '':
- if img.use_io == 'fits':
- try:
- from astropy.io import fits as pyfits
- old_pyfits = False
- use_sections = True
- except ImportError, err:
- import pyfits
- if StrictVersion(pyfits.__version__) < StrictVersion('2.2'):
- old_pyfits = True
- use_sections = False
- elif StrictVersion(pyfits.__version__) < StrictVersion('2.4'):
- old_pyfits = False
- use_sections = False
- else:
- old_pyfits = False
- try:
- if not old_pyfits:
- fits = pyfits.open(image_file, mode="readonly", ignore_missing_end=True)
- else:
- fits = pyfits.open(image_file, mode="readonly")
- except IOError, err:
- img._reason = 'Problem reading file.\nOriginal error: {0}'.format(str(err))
- return None
- if img.use_io == 'rap':
- import pyrap.images as pim
- try:
- inputimage = pim.image(image_file)
- except IOError, err:
- img._reason = 'Problem reading file.\nOriginal error: {0}'.format(str(err))
- return None
- else:
- # Simple check of whether pyrap and pyfits are available
- # We need pyfits version 2.2 or greater to use the
- # "ignore_missing_end" argument to pyfits.open().
- try:
- try:
- from astropy.io import fits as pyfits
- old_pyfits = False
- use_sections = True
- except ImportError, err:
- import pyfits
- if StrictVersion(pyfits.__version__) < StrictVersion('2.2'):
- old_pyfits = True
- use_sections = False
- elif StrictVersion(pyfits.__version__) < StrictVersion('2.4'):
- old_pyfits = False
- use_sections = False
- else:
- old_pyfits = False
- use_sections = True
- has_pyfits = True
- except ImportError, err:
- raise RuntimeError("Astropy or PyFITS is required.")
- try:
- import pyrap.images as pim
- has_pyrap = True
- except ImportError, err:
- has_pyrap = False
- e_pyrap = str(err)
-
- # First assume image is a fits file, and use pyfits to open it (if
- # available). If that fails, try to use pyrap if available.
- failed_read = False
- reason = 0
- try:
- if not old_pyfits:
- fits = pyfits.open(image_file, mode="readonly", ignore_missing_end=True)
- else:
- fits = pyfits.open(image_file, mode="readonly")
- img.use_io = 'fits'
- except IOError, err:
- e_pyfits = str(err)
- if has_pyrap:
- try:
- inputimage = pim.image(image_file)
- img.use_io = 'rap'
- except IOError, err:
- e_pyrap = str(err)
- failed_read = True
- img._reason = 'File is not a valid FITS, CASA, or HDF5 image.'
- else:
- failed_read = True
- e_pyrap = "Pyrap unavailable"
- img._reason = 'Problem reading file.'
- if failed_read:
- img._reason += '\nOriginal errors: {0}\n {1}'.format(e_pyfits, e_pyrap)
- return None
-
- # Now that image has been read in successfully, get header (data is loaded
- # later to take advantage of sectioning if trim_box is specified).
- if not quiet:
- mylogger.userinfo(mylog, "Opened '"+image_file+"'")
- if img.use_io == 'rap':
- tmpdir = img.parentname+'_tmp'
- hdr = convert_pyrap_header(inputimage, tmpdir)
- coords = inputimage.coordinates()
- img.coords_dict = coords.dict()
- if img.coords_dict.has_key('telescope'):
- img._telescope = img.coords_dict['telescope']
- else:
- img._telescope = None
- if img.use_io == 'fits':
- hdr = fits[0].header
- img.coords_dict = None
- if 'TELESCOP' in hdr:
- img._telescope = hdr['TELESCOP']
- else:
- img._telescope = None
-
- # Make sure data is in proper order. Final order is [pol, chan, x (RA), y (DEC)],
- # so we need to rearrange dimensions if they are not in this order. Use the
- # ctype FITS keywords to determine order of dimensions. Note that both PyFITS
- # and pyrap reverse the order of the axes relative to NAXIS, so we must too.
- naxis = hdr['NAXIS']
- data_shape = []
- for i in range(naxis):
- data_shape.append(hdr['NAXIS'+str(i+1)])
- data_shape.reverse()
- data_shape = tuple(data_shape)
- mylog.info("Original data shape of " + image_file +': ' +str(data_shape))
- ctype_in = []
- for i in range(naxis):
- key_val_raw = hdr['CTYPE' + str(i+1)]
- key_val = key_val_raw.split('-')[0]
- ctype_in.append(key_val.strip())
- if 'RA' not in ctype_in or 'DEC' not in ctype_in:
- if 'GLON' not in ctype_in or 'GLAT' not in ctype_in:
- raise RuntimeError("Image data not found")
- else:
- lat_lon = True
- else:
- lat_lon = False
-
- # Check for incorrect spectral units. For example, "M/S" is not
- # recognized by PyWCS as velocity ("S" is actually Siemens, not
- # seconds). Note that we check CUNIT3 and CUNIT4 even if the
- # image has only 2 axes, as the header may still have these
- # entries.
- for i in range(4):
- key_val_raw = hdr.get('CUNIT' + str(i+1))
- if key_val_raw is not None:
- if 'M/S' in key_val_raw or 'm/S' in key_val_raw or 'M/s' in key_val_raw:
- hdr['CUNIT' + str(i+1)] = 'm/s'
- if 'HZ' in key_val_raw or 'hZ' in key_val_raw or 'hz' in key_val_raw:
- hdr['CUNIT' + str(i+1)] = 'Hz'
- if 'DEG' in key_val_raw or 'Deg' in key_val_raw:
- hdr['CUNIT' + str(i+1)] = 'deg'
-
- # Make sure that the spectral axis has been identified properly
- if len(ctype_in) > 2 and 'FREQ' not in ctype_in:
- try:
- from astropy.wcs import WCS
- t = WCS(hdr)
- t.wcs.fix()
- except ImportError, err:
- import warnings
- with warnings.catch_warnings():
- warnings.filterwarnings("ignore",category=DeprecationWarning)
- from pywcs import WCS
- t = WCS(hdr)
- t.wcs.fix()
- spec_indx = t.wcs.spec
- if spec_indx != -1:
- ctype_in[spec_indx] = 'FREQ'
-
- # Now reverse the axes order to match PyFITS/pyrap order and define the
- # final desired order (cytpe_out) and shape (shape_out).
- ctype_in.reverse()
- if lat_lon:
- ctype_out = ['STOKES', 'FREQ', 'GLON', 'GLAT']
- else:
- ctype_out = ['STOKES', 'FREQ', 'RA', 'DEC']
- indx_out = [-1, -1, -1, -1]
- indx_in = range(naxis)
- for i in indx_in:
- for j in range(4):
- if ctype_in[i] == ctype_out[j]:
- indx_out[j] = i
- shape_out = [1, 1, data_shape[indx_out[2]], data_shape[indx_out[3]]]
- if indx_out[0] != -1:
- shape_out[0] = data_shape[indx_out[0]]
- if indx_out[1] != -1:
- shape_out[1] = data_shape[indx_out[1]]
- indx_out = [a for a in indx_out if a >= 0] # trim unused axes
-
- # Read in data. If only a subsection of the image is desired (as defined
- # by the trim_box option), we can try to use PyFITS to read only that section.
- img._original_naxis = data_shape
- img._original_shape = (shape_out[2], shape_out[3])
- img._xy_hdr_shift = (0, 0)
- if img.opts.trim_box is not None:
- img.trim_box = img.opts.trim_box
- xmin, xmax, ymin, ymax = img.trim_box
- if xmin < 0: xmin = 0
- if ymin < 0: ymin = 0
- if xmax > shape_out[2]: xmax = shape_out[2]
- if ymax > shape_out[3]: ymax = shape_out[3]
- if xmin >= xmax or ymin >= ymax:
- raise RuntimeError("The trim_box option does not specify a valid part of the image.")
- shape_out_untrimmed = shape_out[:]
- shape_out[2] = xmax-xmin
- shape_out[3] = ymax-ymin
-
- if img.use_io == 'fits':
- sx = slice(int(xmin),int(xmax))
- sy = slice(int(ymin),int(ymax))
- sn = slice(None)
- s_array = [sx, sy]
- for i in range(naxis-2):
- s_array.append(sn)
- s_array.reverse() # to match ordering of data array returned by PyFITS
- if not old_pyfits and use_sections:
- if naxis == 2:
- data = fits[0].section[s_array[0], s_array[1]]
- elif naxis == 3:
- data = fits[0].section[s_array[0], s_array[1], s_array[2]]
- elif naxis == 4:
- data = fits[0].section[s_array[0], s_array[1], s_array[2], s_array[3]]
- else:
- # If more than 4 axes, just read in the whole image and
- # do the trimming after reordering.
- data = fits[0].data
- else:
- data = fits[0].data
- fits.close()
- data = data.transpose(*indx_out) # transpose axes to final order
- data.shape = data.shape[0:4] # trim unused dimensions (if any)
- if naxis > 4 or not use_sections:
- data = data.reshape(shape_out_untrimmed) # Add axes if needed
- data = data[:, :, xmin:xmax, ymin:ymax] # trim to trim_box
- else:
- data = data.reshape(shape_out) # Add axes if needed
- else:
- # With pyrap, just read in the whole image and then trim
- data = inputimage.getdata()
- data = data.transpose(*indx_out) # transpose axes to final order
- data.shape = data.shape[0:4] # trim unused dimensions (if any)
- data = data.reshape(shape_out_untrimmed) # Add axes if needed
- data = data[:, :, xmin:xmax, ymin:ymax] # trim to trim_box
-
- # Adjust WCS keywords for trim_box starting x and y.
- hdr['crpix1'] -= xmin
- hdr['crpix2'] -= ymin
- img._xy_hdr_shift = (xmin, ymin)
- else:
- if img.use_io == 'fits':
- data = fits[0].data
- fits.close()
- else:
- data = inputimage.getdata()
- data = data.transpose(*indx_out) # transpose axes to final order
- data.shape = data.shape[0:4] # trim unused dimensions (if any)
- data = data.reshape(shape_out) # Add axes if needed
-
- mylog.info("Final data shape (npol, nchan, x, y): " + str(data.shape))
-
- ### and make a copy of it to get proper layout & byteorder
- data = N.array(data, order='C',
- dtype=data.dtype.newbyteorder('='))
-
- return data, hdr
-
-
-def convert_pyrap_header(pyrap_image, tmpdir):
- """Converts a pyrap header to a PyFITS header."""
- import tempfile
- import os
- import atexit
- import shutil
- try:
- from astropy.io import fits as pyfits
- except ImportError, err:
- import pyfits
-
- if not os.path.exists(tmpdir):
- os.makedirs(tmpdir)
- tfile = tempfile.NamedTemporaryFile(delete=False, dir=tmpdir)
- pyrap_image.tofits(tfile.name)
- hdr = pyfits.getheader(tfile.name)
- if os.path.isfile(tfile.name):
- os.remove(tfile.name)
-
- # Register deletion of temp directory at exit to be sure it is deleted
- atexit.register(shutil.rmtree, tmpdir, ignore_errors=True)
-
- return hdr
-
-
-def write_image_to_file(use, filename, image, img, outdir=None,
- pad_image=False, clobber=True, is_mask=False):
- """ Writes image array to outdir/filename"""
- import numpy as N
- import os
- import mylogger
-
- mylog = mylogger.logging.getLogger("PyBDSM."+img.log+"Writefile")
-
- wcs_obj = img.wcs_obj
- if pad_image and img.opts.trim_box is not None:
- # Pad image to original size
- xsize, ysize = img._original_shape
- xmin, ymin = img._xy_hdr_shift
- image_pad = N.zeros((xsize, ysize), dtype=N.float32)
- image_pad[xmin:xmin+image.shape[0], ymin:ymin+image.shape[1]] = image
- image = image_pad
- else:
- xmin = 0
- ymin = 0
-
- if not hasattr(img, '_telescope'):
- telescope = None
- else:
- telescope = img._telescope
-
- if filename == 'SAMP':
- import tempfile
- if not hasattr(img,'samp_client'):
- s, private_key = start_samp_proxy()
- img.samp_client = s
- img.samp_key = private_key
-
- # Broadcast image to SAMP Hub
- temp_im = make_fits_image(N.transpose(image), wcs_obj, img.beam,
- img.frequency, img.equinox, telescope, xmin=xmin, ymin=ymin,
- is_mask=is_mask)
- tfile = tempfile.NamedTemporaryFile(delete=False)
- temp_im.writeto(tfile.name, clobber=clobber)
- send_fits_image(img.samp_client, img.samp_key, 'PyBDSM image', tfile.name)
- else:
- # Write image to FITS file
- if outdir is None:
- outdir = img.indir
- if not os.path.exists(outdir) and outdir != '':
- os.makedirs(outdir)
- if os.path.isfile(outdir+filename):
- if clobber:
- os.remove(outdir+filename)
- else:
- return
- if os.path.isdir(outdir+filename):
- if clobber:
- os.system("rm -rf "+outdir+filename)
- else:
- return
- temp_im = make_fits_image(N.transpose(image), wcs_obj, img.beam,
- img.frequency, img.equinox, telescope, xmin=xmin, ymin=ymin,
- is_mask=is_mask, shape=(img.shape[1], img.shape[0], image.shape[1],
- image.shape[0]))
- if use == 'rap':
- outfile = outdir + filename + '.fits'
- else:
- outfile = outdir + filename
- temp_im.writeto(outfile, clobber=clobber)
- temp_im.close()
-
- if use == 'rap':
- # For CASA images, read in FITS image and convert
- try:
- import pyrap.images as pim
- import pyrap.tables as pt
- import os
- outimage = pim.image(outfile)
- outimage.saveas(outdir+filename, overwrite=clobber)
-
- # For masks, use the coordinates dictionary from the input
- # image, as this is needed in order for the
- # image to work as a clean mask in CASA.
- if is_mask:
- if img.coords_dict is None:
- mylog.warning('Mask header information may be incomplete.')
- else:
- outtable = pt.table(outdir+filename, readonly=False, ack=False)
- outtable.putkeywords({'coords': img.coords_dict})
- outtable.done()
-
- except ImportError, err:
- import os
- os.remove(outfile)
- raise RuntimeError("Error writing CASA image. Use img_format = 'fits' instead.")
-
-
-def make_fits_image(imagedata, wcsobj, beam, freq, equinox, telescope, xmin=0, ymin=0,
- is_mask=False, shape=None):
- """Makes a simple FITS hdulist appropriate for single-channel images"""
- from distutils.version import StrictVersion
- try:
- from astropy.io import fits as pyfits
- use_header_update = False
- except ImportError, err:
- import pyfits
-
- # Due to changes in the way pyfits handles headers from version 3.1 on,
- # we need to check for older versions and change the setting of header
- # keywords accordingly.
- if StrictVersion(pyfits.__version__) < StrictVersion('3.1'):
- use_header_update = True
- else:
- use_header_update = False
- import numpy as np
-
- # If mask, expand to all channels and Stokes for compatibility with casa
- if is_mask and shape is not None:
- shape_out = shape
- else:
- shape_out = [1, 1, imagedata.shape[0], imagedata.shape[1]]
- hdu = pyfits.PrimaryHDU(np.resize(imagedata, shape_out))
- hdulist = pyfits.HDUList([hdu])
- header = hdulist[0].header
-
- # Add WCS info
- if use_header_update:
- header.update('CRVAL1', wcsobj.wcs.crval[0])
- header.update('CDELT1', wcsobj.wcs.cdelt[0])
- header.update('CRPIX1', wcsobj.wcs.crpix[0] + xmin)
- header.update('CUNIT1', str(wcsobj.wcs.cunit[0]).strip().lower()) # needed due to bug in pywcs/astropy
- header.update('CTYPE1', wcsobj.wcs.ctype[0])
- header.update('CRVAL2', wcsobj.wcs.crval[1])
- header.update('CDELT2', wcsobj.wcs.cdelt[1])
- header.update('CRPIX2', wcsobj.wcs.crpix[1] + ymin)
- header.update('CUNIT2', str(wcsobj.wcs.cunit[1]).strip().lower())
- header.update('CTYPE2', wcsobj.wcs.ctype[1])
- else:
- header['CRVAL1'] = wcsobj.wcs.crval[0]
- header['CDELT1'] = wcsobj.wcs.cdelt[0]
- header['CRPIX1'] = wcsobj.wcs.crpix[0] + xmin
- header['CUNIT1'] = str(wcsobj.wcs.cunit[0]).strip().lower() # needed due to bug in pywcs/astropy
- header['CTYPE1'] = wcsobj.wcs.ctype[0]
- header['CRVAL2'] = wcsobj.wcs.crval[1]
- header['CDELT2'] = wcsobj.wcs.cdelt[1]
- header['CRPIX2'] = wcsobj.wcs.crpix[1] + ymin
- header['CUNIT2'] = str(wcsobj.wcs.cunit[1]).strip().lower()
- header['CTYPE2'] = wcsobj.wcs.ctype[1]
-
- # Add STOKES info
- if use_header_update:
- header.update('CRVAL3', 1.0)
- header.update('CDELT3', 1.0)
- header.update('CRPIX3', 1.0)
- header.update('CUNIT3', ' ')
- header.update('CTYPE3', 'STOKES')
- else:
- header['CRVAL3'] = 1.0
- header['CDELT3'] = 1.0
- header['CRPIX3'] = 1.0
- header['CUNIT3'] = ''
- header['CTYPE3'] = 'STOKES'
-
- # Add frequency info
- if use_header_update:
- header.update('RESTFRQ', freq)
- header.update('CRVAL4', freq)
- header.update('CDELT4', 3e8)
- header.update('CRPIX4', 1.0)
- header.update('CUNIT4', 'HZ')
- header.update('CTYPE4', 'FREQ')
- header.update('SPECSYS', 'TOPOCENT')
- else:
- header['RESTFRQ'] = freq
- header['CRVAL4'] = freq
- header['CDELT4'] = 3e8
- header['CRPIX4'] = 1.0
- header['CUNIT4'] = 'HZ'
- header['CTYPE4'] = 'FREQ'
- header['SPECSYS'] = 'TOPOCENT'
-
- # Add beam info
- if not is_mask:
- if use_header_update:
- header.update('BMAJ', beam[0])
- header.update('BMIN', beam[1])
- header.update('BPA', beam[2])
- else:
- header['BMAJ'] = beam[0]
- header['BMIN'] = beam[1]
- header['BPA'] = beam[2]
-
- # Add equinox
- if use_header_update:
- header.update('EQUINOX', equinox)
- else:
- header['EQUINOX'] = equinox
-
- # Add telescope
- if telescope is not None:
- if use_header_update:
- header.update('TELESCOP', telescope)
- else:
- header['TELESCOP'] = telescope
-
- hdulist[0].header = header
- return hdulist
-
-def retrieve_map(img, map_name):
- """Returns a map cached on disk."""
- import numpy as N
- import os
-
- filename = get_name(img, map_name)
- if not os.path.isfile(filename):
- return None
- infile = file(filename, 'rb')
- data = N.load(infile)
- infile.close()
- return data
-
-def store_map(img, map_name, map_data):
- """Caches a map to disk."""
- import numpy as N
-
- filename = get_name(img, map_name)
- outfile = file(filename, 'wb')
- N.save(outfile, map_data)
- outfile.close()
-
-def del_map(img, map_name):
- """Deletes a cached map."""
- import os
-
- filename = get_name(img, map_name)
- if os.path.isfile(filename):
- os.remove(filename)
-
-def get_name(img, map_name):
- """Returns name of cache file."""
- import os
-
- if img._pi:
- pi_text = 'pi'
- else:
- pi_text = 'I'
- suffix = '/w%i_%s/' % (img.j, pi_text)
- dir = img.tempdir + suffix
- if not os.path.exists(dir):
- os.makedirs(dir)
- return dir + map_name + '.bin'
-
-def connect(mask):
- """ Find if a mask is singly or multiply connected """
- import scipy.ndimage as nd
-
- connectivity = nd.generate_binary_structure(2,2)
- labels, count = nd.label(mask, connectivity)
- if count > 1 :
- connected = 'multiple'
- else:
- connected = 'single'
-
- return connected, count
-
-def area_polygon(points):
- """ Given an ANGLE ORDERED array points of [[x], [y]], find the total area by summing each successsive
- triangle with the centre """
- import numpy as N
-
- x, y = points
- n_tri = len(x)-1
- cenx, ceny = N.mean(x), N.mean(y)
-
- area = 0.0
- for i in range(n_tri):
- p1, p2, p3 = N.array([cenx, ceny]), N.array([x[i], y[i]]), N.array([x[i+1], y[i+1]])
- t_area= N.linalg.norm(N.cross((p2 - p1), (p3 - p1)))/2.
- area += t_area
-
- return area
-
-def convexhull_deficiency(isl):
- """ Finds the convex hull for the island and returns the deficiency.
- Code taken from http://code.google.com/p/milo-lab/source/browse/trunk/src/toolbox/convexhull.py?spec=svn140&r=140
- """
-
- import random
- import time
- import numpy as N
- import scipy.ndimage as nd
-
- def _angle_to_point(point, centre):
- """calculate angle in 2-D between points and x axis"""
- delta = point - centre
- if delta[0] == 0.0:
- res = N.pi/2.0
- else:
- res = N.arctan(delta[1] / delta[0])
- if delta[0] < 0:
- res += N.pi
- return res
-
- def area_of_triangle(p1, p2, p3):
- """calculate area of any triangle given co-ordinates of the corners"""
- return N.linalg.norm(N.cross((p2 - p1), (p3 - p1)))/2.
-
- def convex_hull(points):
- """Calculate subset of points that make a convex hull around points
- Recursively eliminates points that lie inside two neighbouring points until only convex hull is remaining.
- points : ndarray (2 x m) array of points for which to find hull
- Returns: hull_points : ndarray (2 x n), convex hull surrounding points """
-
- n_pts = points.shape[1]
- #assert(n_pts > 5)
- centre = points.mean(1)
- angles = N.apply_along_axis(_angle_to_point, 0, points, centre)
- pts_ord = points[:,angles.argsort()]
- pts = [x[0] for x in zip(pts_ord.transpose())]
- prev_pts = len(pts) + 1
- k = 0
- while prev_pts > n_pts:
- prev_pts = n_pts
- n_pts = len(pts)
- i = -2
- while i < (n_pts - 2):
- Aij = area_of_triangle(centre, pts[i], pts[(i + 1) % n_pts])
- Ajk = area_of_triangle(centre, pts[(i + 1) % n_pts], \
- pts[(i + 2) % n_pts])
- Aik = area_of_triangle(centre, pts[i], pts[(i + 2) % n_pts])
- if Aij + Ajk < Aik:
- del pts[i+1]
- i += 1
- n_pts = len(pts)
- k += 1
- return N.asarray(pts)
-
- mask = ~isl.mask_active
- points = N.asarray(N.where(mask - nd.binary_erosion(mask)))
- hull_pts = list(convex_hull(points)) # these are already in angle-sorted order
-
- hull_pts.append(hull_pts[0])
- hull_pts = N.transpose(hull_pts)
-
- isl_area = isl.size_active
- hull_area = area_polygon(hull_pts)
- ratio1 = hull_area/(isl_area - 0.5*len(hull_pts[0]))
-
- return ratio1
-
-
-def open_isl(mask, index):
- """ Do an opening on a mask, divide left over pixels among opened sub islands. Mask = True => masked pixel """
- import scipy.ndimage as nd
- import numpy as N
-
- connectivity = nd.generate_binary_structure(2,2)
- ft = N.ones((index,index), int)
-
- open = nd.binary_opening(~mask, ft)
- open = check_1pixcontacts(open) # check if by removing one pixel from labels, you can split a sub-island
- labels, n_subisl = nd.label(open, connectivity) # get label/rank image for open. label = 0 for masked pixels
- labels, mask = assign_leftovers(mask, open, n_subisl, labels) # add the leftover pixels to some island
-
- if labels is not None:
- isl_pixs = [len(N.where(labels==i)[0]) for i in range(1,n_subisl+1)]
- isl_pixs = N.array(isl_pixs)/float(N.sum(isl_pixs))
- else:
- isl_pixs = None
-
- return n_subisl, labels, isl_pixs
-
-def check_1pixcontacts(open):
- import scipy.ndimage as nd
- import numpy as N
- from copy import deepcopy as cp
-
- connectivity = nd.generate_binary_structure(2,2)
- ind = N.transpose(N.where(open[1:-1,1:-1] > 0)) + [1,1] # exclude boundary to make it easier
- for pixel in ind:
- x, y = pixel
- grid = cp(open[x-1:x+2, y-1:y+2]); grid[1,1] = 0
- grid = N.where(grid == open[tuple(pixel)], 1, 0)
- ll, nn = nd.label(grid, connectivity)
- if nn > 1:
- open[tuple(pixel)] = 0
-
- return open
-
-def assign_leftovers(mask, open, nisl, labels):
- """
- Given isl and the image of the mask after opening (open) and the number of new independent islands n,
- connect up the left over pixels to the new islands if they connect to only one island and not more.
- Assign the remaining to an island. We need to assign the leftout pixels to either of many sub islands.
- Easiest is to assign to the sub island with least size.
- """
- import scipy.ndimage as nd
- import numpy as N
- from copy import deepcopy as cp
-
- n, m = mask.shape
- leftout = ~mask - open
-
- connectivity = nd.generate_binary_structure(2,2)
- mlabels, count = nd.label(leftout, connectivity)
- npix = [len(N.where(labels==b)[0]) for b in range(1,nisl+1)]
-
- for i_subisl in range(count):
- c_list = [] # is list of all bordering pixels of the sub island
- ii = i_subisl+1
- coords = N.transpose(N.where(mlabels==ii)) # the coordinates of island i of left-out pixels
- for co in coords:
- co8 = [[x,y] for x in range(co[0]-1,co[0]+2) for y in range(co[1]-1,co[1]+2) if x >=0 and y >=0 and x <n and y<m]
- c_list.extend([tuple(cc) for cc in co8 if mlabels[tuple(cc)] == 0])
- c_list = list(set(c_list)) # to avoid duplicates
- vals = N.array([labels[c] for c in c_list])
- belongs = list(set(vals[N.nonzero(vals)]))
- if len(belongs) == 0:
- # No suitable islands found => mask pixels
- for cc in coords:
- mask = (mlabels == ii)
-# mask[cc] = True
- return None, mask
- if len(belongs) == 1:
- for cc in coords:
- labels[tuple(cc)] = belongs[0]
- else: # get the border pixels of the islands
- nn = [npix[b-1] for b in belongs]
- addto = belongs[N.argmin(nn)]
- for cc in coords:
- labels[tuple(cc)] = addto
-
- return labels, mask
-
-
-def _float_approx_equal(x, y, tol=1e-18, rel=1e-7):
- if tol is rel is None:
- raise TypeError('cannot specify both absolute and relative errors are None')
- tests = []
- if tol is not None: tests.append(tol)
- if rel is not None: tests.append(rel*abs(x))
- assert tests
- return abs(x - y) <= max(tests)
-
-
-def approx_equal(x, y, *args, **kwargs):
- """approx_equal(float1, float2[, tol=1e-18, rel=1e-7]) -> True|False
- approx_equal(obj1, obj2[, *args, **kwargs]) -> True|False
-
- Return True if x and y are approximately equal, otherwise False.
-
- If x and y are floats, return True if y is within either absolute error
- tol or relative error rel of x. You can disable either the absolute or
- relative check by passing None as tol or rel (but not both).
-
- For any other objects, x and y are checked in that order for a method
- __approx_equal__, and the result of that is returned as a bool. Any
- optional arguments are passed to the __approx_equal__ method.
-
- __approx_equal__ can return NotImplemented to signal that it doesn't know
- how to perform that specific comparison, in which case the other object is
- checked instead. If neither object have the method, or both defer by
- returning NotImplemented, approx_equal falls back on the same numeric
- comparison used for floats.
-
- >>> almost_equal(1.2345678, 1.2345677)
- True
- >>> almost_equal(1.234, 1.235)
- False
-
- """
- if not (type(x) is type(y) is float):
- # Skip checking for __approx_equal__ in the common case of two floats.
- methodname = '__approx_equal__'
- # Allow the objects to specify what they consider "approximately equal",
- # giving precedence to x. If either object has the appropriate method, we
- # pass on any optional arguments untouched.
- for a,b in ((x, y), (y, x)):
- try:
- method = getattr(a, methodname)
- except AttributeError:
- continue
- else:
- result = method(b, *args, **kwargs)
- if result is NotImplemented:
- continue
- return bool(result)
- # If we get here without returning, then neither x nor y knows how to do an
- # approximate equal comparison (or are both floats). Fall back to a numeric
- # comparison.
- return _float_approx_equal(x, y, *args, **kwargs)
-
-def isl_tosplit(isl, opts):
- """ Splits an island and sends back parameters """
- import numpy as N
-
- size_extra5 = opts.splitisl_size_extra5
- frac_bigisl3 = opts.splitisl_frac_bigisl3
-
- connected, count = connect(isl.mask_active)
- index = 0
- n_subisl3, labels3, isl_pixs3 = open_isl(isl.mask_active, 3)
- n_subisl5, labels5, isl_pixs5 = open_isl(isl.mask_active, 5)
- isl_pixs3, isl_pixs5 = N.array(isl_pixs3), N.array(isl_pixs5)
-
- # take open 3 or 5
- open3, open5 = False, False
- if n_subisl3 > 0 and isl_pixs3 is not None: # open 3 breaks up island
- max_sub3 = N.max(isl_pixs3)
- if max_sub3 < frac_bigisl3 : open3 = True # if biggest sub island isnt too big
- if n_subisl5 > 0 and isl_pixs5 is not None: # open 5 breaks up island
- max_sub5 = N.max(isl_pixs5) # if biggest subisl isnt too big OR smallest extra islands add upto 10 %
- if (max_sub5 < 0.75*max_sub3) or (N.sum(N.sort(isl_pixs5)[:len(isl_pixs5)-n_subisl3]) > size_extra5):
- open5 = True
- # index=0 => dont split
- if open5: index = 5; n_subisl = n_subisl5; labels = labels5
- else:
- if open3: index = 3; n_subisl = n_subisl3; labels = labels3
- else: index = 0
- convex_def = convexhull_deficiency(isl)
- #print 'CONVEX = ',convex_def
-
- if opts.plot_islands:
- try:
- import matplotlib.pyplot as pl
- pl.figure()
- pl.suptitle('Island '+str(isl.island_id))
- pl.subplot(2,2,1); pl.imshow(N.transpose(isl.image*~isl.mask_active), origin='lower', interpolation='nearest'); pl.title('Image')
- pl.subplot(2,2,2); pl.imshow(N.transpose(labels3), origin='lower', interpolation='nearest'); pl.title('labels3')
- pl.subplot(2,2,3); pl.imshow(N.transpose(labels5), origin='lower', interpolation='nearest'); pl.title('labels5')
- except ImportError:
- print "\033[31;1mWARNING\033[0m: Matplotlib not found. Plotting disabled."
- if index == 0: return [index, n_subisl5, labels5]
- else: return [index, n_subisl, labels]
-
-
-class NullDevice():
- """Null device to suppress stdout, etc."""
- def write(self, s):
- pass
-
-def ch0_aperture_flux(img, posn_pix, aperture_pix):
- """Measure ch0 flux inside radius aperture_pix pixels centered on posn_pix.
-
- Returns [flux, fluxE]
- """
- import numpy as N
-
- if aperture_pix is None:
- return [0.0, 0.0]
-
- # Make ch0 and rms subimages
- ch0 = img.ch0_arr
- shape = ch0.shape
- xlo = posn_pix[0]-int(aperture_pix)-1
- if xlo < 0:
- xlo = 0
- xhi = posn_pix[0]+int(aperture_pix)+1
- if xhi > shape[0]:
- xhi = shape[0]
- ylo = posn_pix[1]-int(aperture_pix)-1
- if ylo < 0:
- ylo = 0
- yhi = posn_pix[1]+int(aperture_pix)+1
- if yhi > shape[1]:
- yhi = shape[1]
-
- mean = img.mean_arr
- rms = img.rms_arr
- aper_im = ch0[xlo:xhi, ylo:yhi] - mean[xlo:xhi, ylo:yhi]
- aper_rms = rms[xlo:xhi, ylo:yhi]
- posn_pix_new = [posn_pix[0]-xlo, posn_pix[1]-ylo]
- pixel_beamarea = img.pixel_beamarea()
- aper_flux = aperture_flux(aperture_pix, posn_pix_new, aper_im, aper_rms, pixel_beamarea)
- return aper_flux
-
-def aperture_flux(aperture_pix, posn_pix, aper_im, aper_rms, beamarea):
- """Returns aperture flux and error"""
- import numpy as N
-
- dist_mask = generate_aperture(aper_im.shape[0], aper_im.shape[1], posn_pix[0], posn_pix[1], aperture_pix)
- aper_mask = N.where(dist_mask.astype(bool))
- if N.size(aper_mask) == 0:
- return [0.0, 0.0]
- aper_flux = N.nansum(aper_im[aper_mask])/beamarea # Jy
- pixels_in_source = N.sum(~N.isnan(aper_im[aper_mask])) # number of unmasked pixels assigned to current source
- aper_fluxE = nanmean(aper_rms[aper_mask]) * N.sqrt(pixels_in_source/beamarea) # Jy
- return [aper_flux, aper_fluxE]
-
-def generate_aperture(xsize, ysize, xcenter, ycenter, radius):
- """Makes a mask (1 = inside aperture) for a circular aperture"""
- import numpy
-
- x, y = numpy.mgrid[0.5:xsize, 0.5:ysize]
- mask = ((x - xcenter)**2 + (y - ycenter)**2 <= radius**2) * 1
- return mask
-
-def make_src_mask(mask_size, posn_pix, aperture_pix):
- """Makes an island mask (1 = inside aperture)f or a given source position.
- """
- import numpy as N
-
- xsize, ysize = mask_size
- if aperture_pix is None:
- return N.zeros((xsize, ysize), dtype=N.int)
-
- # Make subimages
- xlo = posn_pix[0]-int(aperture_pix)-1
- if xlo < 0:
- xlo = 0
- xhi = posn_pix[0]+int(aperture_pix)+1
- if xhi > xsize:
- xhi = xsize
- ylo = posn_pix[1]-int(aperture_pix)-1
- if ylo < 0:
- ylo = 0
- yhi = posn_pix[1]+int(aperture_pix)+1
- if yhi > ysize:
- yhi = ysize
-
- mask = N.zeros((xsize, ysize), dtype=N.int)
- posn_pix_new = [posn_pix[0]-xlo, posn_pix[1]-ylo]
- submask_xsize = xhi - xlo
- submask_ysize = yhi - ylo
- submask = generate_aperture(submask_xsize, submask_ysize, posn_pix_new[0], posn_pix_new[1], aperture_pix)
- submask_slice = [slice(xlo, xhi), slice(ylo, yhi)]
- mask[submask_slice] = submask
- return mask
-
-def getTerminalSize():
- """
- returns (lines:int, cols:int)
- """
- import os, struct
- def ioctl_GWINSZ(fd):
- import fcntl, termios
- return struct.unpack("hh", fcntl.ioctl(fd, termios.TIOCGWINSZ, "1234"))
- # try stdin, stdout, stderr
- for fd in (0, 1, 2):
- try:
- return ioctl_GWINSZ(fd)
- except:
- pass
- # try os.ctermid()
- try:
- fd = os.open(os.ctermid(), os.O_RDONLY)
- try:
- return ioctl_GWINSZ(fd)
- finally:
- os.close(fd)
- except:
- pass
- # try `stty size`
- try:
- return tuple(int(x) for x in os.popen("stty size", "r").read().split())
- except:
- pass
- # try environment variables
- try:
- return tuple(int(os.getenv(var)) for var in ("LINES", "COLUMNS"))
- except:
- pass
- # Give up. return 0.
- return (0, 0)
-
-def eval_func_tuple(f_args):
- """Takes a tuple of a function and args, evaluates and returns result
-
- This function (in addition to itertools) gets around limitation that
- multiple-argument sequences are not supported by multiprocessing.
- """
- return f_args[0](*f_args[1:])
-
-
-def start_samp_proxy():
- """Starts (registers) and returns a SAMP proxy"""
- import os
- import xmlrpclib
-
- lockfile = os.path.expanduser('~/.samp')
- if not os.path.exists(lockfile):
- raise RuntimeError("A running SAMP hub was not found.")
- else:
- HUB_PARAMS = {}
- for line in open(lockfile):
- if not line.startswith('#'):
- key, value = line.split('=', 1)
- HUB_PARAMS[key] = value.strip()
-
- # Set up proxy
- s = xmlrpclib.ServerProxy(HUB_PARAMS['samp.hub.xmlrpc.url'])
-
- # Register with Hub
- metadata = {"samp.name": 'PyBDSM', "samp.description.text": 'PyBDSM: the Python Blob Detection and Source Measurement software'}
- result = s.samp.hub.register(HUB_PARAMS['samp.secret'])
- private_key = result['samp.private-key']
- s.samp.hub.declareMetadata(private_key, metadata)
- return s, private_key
-
-
-def stop_samp_proxy(img):
- """Stops (unregisters) a SAMP proxy"""
- import os
-
- if hasattr(img, 'samp_client'):
- lockfile = os.path.expanduser('~/.samp')
- if os.path.exists(lockfile):
- img.samp_client.samp.hub.unregister(img.samp_key)
-
-
-def send_fits_image(s, private_key, name, file_path):
- """Send a SAMP notification to load a fits image."""
- import os
-
- message = {}
- message['samp.mtype'] = "image.load.fits"
- message['samp.params'] = {}
- message['samp.params']['url'] = 'file://' + os.path.abspath(file_path)
- message['samp.params']['name'] = name
- lockfile = os.path.expanduser('~/.samp')
- if not os.path.exists(lockfile):
- raise RuntimeError("A running SAMP hub was not found.")
- else:
- s.samp.hub.notifyAll(private_key, message)
-
-def send_fits_table(s, private_key, name, file_path):
- """Send a SAMP notification to load a fits table."""
- import os
-
- message = {}
- message['samp.mtype'] = "table.load.fits"
- message['samp.params'] = {}
- message['samp.params']['url'] = 'file://' + os.path.abspath(file_path)
- message['samp.params']['name'] = name
- lockfile = os.path.expanduser('~/.samp')
- if not os.path.exists(lockfile):
- raise RuntimeError("A running SAMP hub was not found.")
- else:
- s.samp.hub.notifyAll(private_key, message)
-
-def send_highlight_row(s, private_key, url, row_id):
- """Send a SAMP notification to highlight a row in a table."""
- import os
-
- message = {}
- message['samp.mtype'] = "table.highlight.row"
- message['samp.params'] = {}
- message['samp.params']['row'] = str(row_id)
- message['samp.params']['url'] = url
- lockfile = os.path.expanduser('~/.samp')
- if not os.path.exists(lockfile):
- raise RuntimeError("A running SAMP hub was not found.")
- else:
- s.samp.hub.notifyAll(private_key, message)
-
-def send_coords(s, private_key, coords):
- """Send a SAMP notification to point at given coordinates."""
- import os
-
- message = {}
- message['samp.mtype'] = "coord.pointAt.sky"
- message['samp.params'] = {}
- message['samp.params']['ra'] = str(coords[0])
- message['samp.params']['dec'] = str(coords[1])
- lockfile = os.path.expanduser('~/.samp')
- if not os.path.exists(lockfile):
- raise RuntimeError("A running SAMP hub was not found.")
- else:
- s.samp.hub.notifyAll(private_key, message)
-
-def make_curvature_map(subim):
- """Makes a curvature map with the Aegean curvature algorithm
- (Hancock et al. 2012)
-
- The Aegean algorithm uses a curvature map to identify regions of negative
- curvature. These regions then define distinct sources.
- """
- import scipy.signal as sg
- import numpy as N
- import sys
-
- # Make average curavature map:
- curv_kernal = N.array([[1, 1, 1],[1, -8, 1],[1, 1, 1]])
- # The next step prints meaningless warnings, so suppress them
- original_stdout = sys.stdout # keep a reference to STDOUT
- sys.stdout = NullDevice() # redirect the real STDOUT
- curv_map = sg.convolve2d(subim, curv_kernal)
- sys.stdout = original_stdout # turn STDOUT back on
-
- return curv_map
-
-
-def bstat(indata, mask, kappa_npixbeam):
- """Numpy version of the c++ bstat routine
-
- Uses the PySE method for calculating the clipped mean and rms of an array.
- This method is superior to the c++ bstat routine (see section 2.7.3 of
- http://dare.uva.nl/document/174052 for details) and, since the Numpy
- functions used here are written in c, there should be no big computational
- penalty in using Python code.
- """
- import numpy
- from scipy.special import erf, erfcinv
-
- # Flatten array
- skpix = indata.flatten()
- if mask is not None:
- msk_flat = mask.flatten()
- unmasked = numpy.where(~msk_flat)
- skpix = skpix[unmasked]
-
- ct = skpix.size
- iter = 0
- c1 = 1.0
- c2 = 0.0
- maxiter = 200
- converge_num = 1e-6
- m_raw = numpy.mean(skpix)
- r_raw = numpy.std(skpix, ddof=1)
-
- while (c1 >= c2) and (iter < maxiter):
- npix = skpix.size
- if kappa_npixbeam > 0.0:
- kappa = kappa_npixbeam
- else:
- npixbeam = abs(kappa_npixbeam)
- kappa = numpy.sqrt(2.0)*erfcinv(1.0 / (2.0*npix/npixbeam))
- if kappa < 3.0:
- kappa = 3.0
- lastct = ct
- medval = numpy.median(skpix)
- sig = numpy.std(skpix)
- wsm = numpy.where(abs(skpix-medval) < kappa*sig)
- ct = len(wsm[0])
- if ct > 0:
- skpix = skpix[wsm]
-
- c1 = abs(ct - lastct)
- c2 = converge_num * lastct
- iter += 1
-
- mean = numpy.mean(skpix)
- median = numpy.median(skpix)
- sigma = numpy.std(skpix, ddof=1)
- mode = 2.5*median - 1.5*mean
-
- if sigma > 0.0:
- skew_par = abs(mean - median)/sigma
- else:
- raise RuntimeError("A region with an unphysical rms value has been found. "
- "Please check the input image.")
-
- if skew_par <= 0.3:
- m = mode
- else:
- m = median
-
- r1 = numpy.sqrt(2.0*numpy.pi)*erf(kappa/numpy.sqrt(2.0))
- r = numpy.sqrt(sigma**2 * (r1 / (r1 - 2.0*kappa*numpy.exp(-kappa**2/2.0))))
-
- return m_raw, r_raw, m, r, iter
-
-
diff --git a/CEP/PyBDSM/src/python/gaul2srl.py b/CEP/PyBDSM/src/python/gaul2srl.py
deleted file mode 100644
index e73bf60019029a28a83449b253c5f37aa3491b71..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/python/gaul2srl.py
+++ /dev/null
@@ -1,665 +0,0 @@
-
-"""Module gaul2srl
-
-This will group gaussians in an island into sources. Will code callgaul2srl.f here, though
-it could probably be made more efficient.
-
-img.sources is a list of source objects, which are instances of the class Source
-(with attributes the same as in .srl of fbdsm).
-img.sources[n] is a source.
-source.gaussians is the list of component gaussian objects.
-source.island_id is the island id of that source.
-source.source_id is the source id of that source, the index of source in img.sources.
-Each gaussian object gaus has gaus.source_id, the source id.
-
-Also, each island object of img.islands list has the source object island.source
-"""
-
-from image import *
-from islands import *
-from gausfit import Gaussian
-from interface import wrap
-import mylogger
-import numpy as N
-
-N.seterr(divide='raise')
-
-nsrc = Int(doc="Number of sources in the image")
-Gaussian.source_id = Int(doc="Source number of a gaussian", colname='Source_id')
-Gaussian.code = String(doc='Source code S, C, or M', colname='S_Code')
-
-class Op_gaul2srl(Op):
- """
- Slightly modified from fortran.
- """
-
- def __call__(self, img):
- # for each island, get the gaussians into a list and then send them to process
- # src_index is source number, starting from 0
- mylog = mylogger.logging.getLogger("PyBDSM."+img.log+"Gaul2Srl")
- mylogger.userinfo(mylog, 'Grouping Gaussians into sources')
- img.aperture = img.opts.aperture
- if img.aperture is not None and img.aperture <= 0.0:
- mylog.warn('Specified aperture is <= 0. Skipping aperture fluxes.')
- img.aperture = None
-
- src_index = -1
- dsrc_index = 0
- sources = []
- dsources = []
- no_gaus_islands = []
- for iisl, isl in enumerate(img.islands):
- isl_sources = []
- isl_dsources = []
- g_list = []
- for g in isl.gaul:
- if g.flag == 0:
- g_list.append(g)
-
- if len(g_list) > 0:
- if len(g_list) == 1:
- src_index, source = self.process_single_gaussian(img, g_list, src_index, code = 'S')
- sources.append(source)
- isl_sources.append(source)
- else:
- src_index, source = self.process_CM(img, g_list, isl, src_index)
- sources.extend(source)
- isl_sources.extend(source)
- else:
- if not img.waveletimage:
- dg = isl.dgaul[0]
- no_gaus_islands.append((isl.island_id, dg.centre_pix[0], dg.centre_pix[1]))
- # Put in the dummy Source as the source and use negative IDs
- g_list = isl.dgaul
- dsrc_index, dsource = self.process_single_gaussian(img, g_list, dsrc_index, code = 'S')
- dsources.append(dsource)
- isl_dsources.append(dsource)
-
- isl.sources = isl_sources
- isl.dsources = isl_dsources
- img.sources = sources
- img.dsources = dsources
- img.nsrc = src_index + 1
- mylogger.userinfo(mylog, "Number of sources formed from Gaussians",
- str(img.nsrc))
- if not img.waveletimage and not img._pi and len(no_gaus_islands) > 0 and not img.opts.quiet:
- message = 'All Gaussians were flagged for the following island'
- if len(no_gaus_islands) == 1:
- message += ':\n'
- else:
- message += 's:\n'
- for isl_id in no_gaus_islands:
- message += ' Island #%i (x=%i, y=%i)\n' % isl_id
- if len(no_gaus_islands) == 1:
- message += 'Please check this island. If it is a valid island and\n'
- else:
- message += 'Please check these islands. If they are valid islands and\n'
- if img.opts.atrous_do:
- message += 'should be fit, try adjusting the flagging options (use\n'\
- 'show_fit with "ch0_flagged=True" to see the flagged Gaussians).'
- else:
- message += 'should be fit, try adjusting the flagging options (use\n'\
- 'show_fit with "ch0_flagged=True" to see the flagged Gaussians)\n'\
- 'or enabling the wavelet module (with "atrous_do=True").'
- message += '\nTo include empty islands in output source catalogs, set\n'\
- 'incl_empty=True in the write_catalog task.'
- mylog.warning(message)
-
- img.completed_Ops.append('gaul2srl')
-
-#################################################################################################
-
- def process_single_gaussian(self, img, g_list, src_index, code):
- """ Process single gaussian into a source, for both S and C type sources. g is just one
- Gaussian object (not a list)."""
-
- g = g_list[0]
-
- total_flux = [g.total_flux, g.total_fluxE]
- peak_flux_centroid = peak_flux_max = [g.peak_flux, g.peak_fluxE]
- posn_sky_centroid = posn_sky_max = [g.centre_sky, g.centre_skyE]
- size_sky = [g.size_sky, g.size_skyE]
- size_sky_uncorr = [g.size_sky_uncorr, g.size_skyE]
- deconv_size_sky = [g.deconv_size_sky, g.deconv_size_skyE]
- deconv_size_sky_uncorr = [g.deconv_size_sky_uncorr, g.deconv_size_skyE]
- bbox = img.islands[g.island_id].bbox
- ngaus = 1
- island_id = g.island_id
- if g.gaus_num < 0:
- gaussians = []
- else:
- gaussians = list([g])
- aper_flux = func.ch0_aperture_flux(img, g.centre_pix, img.aperture)
-
- source_prop = list([code, total_flux, peak_flux_centroid, peak_flux_max, aper_flux, posn_sky_centroid, \
- posn_sky_max, size_sky, size_sky_uncorr, deconv_size_sky, deconv_size_sky_uncorr, bbox, ngaus, island_id, gaussians])
- source = Source(img, source_prop)
-
- if g.gaussian_idx == -1:
- src_index -= 1
- else:
- src_index += 1
- g.source_id = src_index
- g.code = code
- source.source_id = src_index
-
- return src_index, source
-
-##################################################################################################
-
- def process_CM(self, img, g_list, isl, src_index):
- """
- Bundle errors with the quantities.
- ngau = number of gaussians in island
- src_id = the source index array for every gaussian in island
- nsrc = final number of distinct sources in the island
- """
-
- ngau = len(g_list) # same as cisl in callgaul2srl.f
- nsrc = ngau # same as islct; initially make each gaussian as a source
- src_id = N.arange(nsrc) # same as islnum in callgaul2srl.f
-
- boxx, boxy = isl.bbox
- subn = boxx.stop-boxx.start; subm = boxy.stop-boxy.start
- delc = [boxx.start, boxy.start]
- subim = self.make_subim(subn, subm, g_list, delc)
-
- index = [(i,j) for i in range(ngau) for j in range(ngau) if j > i]
- for pair in index:
- same_island = self.in_same_island(pair, img, g_list, isl, subim, subn, subm, delc)
- if same_island:
- nsrc -= 1
- mmax, mmin = max(src_id[pair[0]],src_id[pair[1]]), min(src_id[pair[0]],src_id[pair[1]])
- arr = N.where(src_id == mmax)[0]; src_id[arr] = mmin
- # now reorder src_id so that it is contiguous
- for i in range(ngau):
- ind1 = N.where(src_id==i)[0]
- if len(ind1) == 0:
- arr = N.where(src_id > i)[0]
- if len(arr) > 0:
- decr = N.min(src_id[arr])-i
- for j in arr: src_id[j] -= decr
- nsrc = N.max(src_id)+1
- # now do whats in sub_calc_para_source
-
- source_list = []
- for isrc in range(nsrc):
- posn = N.where(src_id == isrc)[0]
- g_sublist=[]
- for i in posn:
- g_sublist.append(g_list[i])
- ngau_insrc = len(posn)
- # Do source type C
- if ngau_insrc == 1:
- src_index, source = self.process_single_gaussian(img, g_sublist, src_index, code = 'C')
- else:
- # make mask and subim. Invalid mask value is -1 since 0 is valid srcid
- mask = self.make_mask(isl, subn, subm, 1, isrc, g_sublist, delc)
- src_index, source = self.process_Multiple(img, g_sublist, mask, src_index, isrc, subim, \
- isl, delc, subn, subm)
- source_list.append(source)
-
- return src_index, source_list
-
-##################################################################################################
-
- def in_same_island(self, pair, img, g_list, isl, subim, subn, subm, delc):
- """ Whether two gaussians belong to the same source or not. """
- import functions as func
-
- def same_island_min(pair, g_list, subim, delc, tol=0.5):
- """ If the minimum of the reconstructed fluxes along the line joining the peak positions
- is greater than thresh_isl times the rms_clip, they belong to different islands. """
-
- g1 = g_list[pair[0]]
- g2 = g_list[pair[1]]
- pix1 = N.array(g1.centre_pix)
- pix2 = N.array(g2.centre_pix)
-
- x1, y1 = map(int, N.floor(pix1)-delc); x2, y2 = map(int, N.floor(pix2)-delc)
- pix1 = N.array(N.unravel_index(N.argmax(subim[x1:x1+2,y1:y1+2]), (2,2)))+[x1,y1]
- pix2 = N.array(N.unravel_index(N.argmax(subim[x2:x2+2,y2:y2+2]), (2,2)))+[x2,y2]
- if pix1[1] >= subn: pix1[1] = pix1[1]-1
- if pix2[1] >= subm: pix2[1] = pix2[1]-1
-
- maxline = int(round(N.max(N.abs(pix1-pix2)+1)))
- flux1 = g1.peak_flux
- flux2 = g2.peak_flux
- # get pix values of the line
- pixdif = pix2 - pix1
- same_island_min = False
- same_island_cont = False
- if maxline == 1:
- same_island_min = True
- same_island_cont = True
- else:
- if abs(pixdif[0]) > abs(pixdif[1]):
- xline = N.round(min(pix1[0],pix2[0])+N.arange(maxline))
- yline = N.round((pix1[1]-pix2[1])/(pix1[0]-pix2[0])* \
- (min(pix1[0],pix2[0])+N.arange(maxline)-pix1[0])+pix1[1])
- else:
- yline = N.round(min(pix1[1],pix2[1])+N.arange(maxline))
- xline = N.round((pix1[0]-pix2[0])/(pix1[1]-pix2[1])* \
- (min(pix1[1],pix2[1])+N.arange(maxline)-pix1[1])+pix1[0])
- rpixval = N.zeros(maxline, dtype=N.float32)
- xbig = N.where(xline >= N.size(subim,0))
- xline[xbig] = N.size(subim,0) - 1
- ybig = N.where(yline >= N.size(subim,1))
- yline[ybig] = N.size(subim,1) - 1
- for i in range(maxline):
- pixval = subim[xline[i],yline[i]]
- rpixval[i] = pixval
- min_pixval = N.min(rpixval)
- minind_p = N.argmin(rpixval)
- maxind_p = N.argmax(rpixval)
-
- if minind_p in (0, maxline-1) and maxind_p in (0, maxline-1):
- same_island_cont = True
- if min_pixval >= min(flux1, flux2):
- same_island_min = True
- elif abs(min_pixval-min(flux1,flux2)) <= tol*isl.rms*img.opts.thresh_isl:
- same_island_min = True
-
- return same_island_min, same_island_cont
-
- def same_island_dist(pair, g_list, tol=0.5):
- """ If the centres are seperated by a distance less than half the sum of their
- fwhms along the PA of the line joining them, they belong to the same island. """
- from math import sqrt
-
- g1 = g_list[pair[0]]
- g2 = g_list[pair[1]]
- pix1 = N.array(g1.centre_pix)
- pix2 = N.array(g2.centre_pix)
- gsize1 = g1.size_pix
- gsize2 = g2.size_pix
-
- fwhm1 = func.gdist_pa(pix1, pix2, gsize1)
- fwhm2 = func.gdist_pa(pix1, pix2, gsize2)
- dx = pix2[0]-pix1[0]; dy = pix2[1]-pix1[1]
- dist = sqrt(dy*dy + dx*dx)
-
- if dist <= tol*(fwhm1+fwhm2):
- same_island = True
- else:
- same_island = False
-
- return same_island
-
- if img.opts.group_by_isl:
- same_isl1_min = True
- same_isl1_cont = True
- same_isl2 = True
- else:
- if img.opts.group_method == 'curvature':
- subim = -1.0 * func.make_curvature_map(subim)
- tol = img.opts.group_tol
- same_isl1_min, same_isl1_cont = same_island_min(pair, g_list, subim, delc, tol)
- same_isl2 = same_island_dist(pair, g_list, tol/2.0)
-
- g1 = g_list[pair[0]]
-
- same_island = (same_isl1_min and same_isl2) or same_isl1_cont
-
- return same_island
-
-##################################################################################################
-
- def process_Multiple(self, img, g_sublist, mask, src_index, isrc, subim, isl, delc, subn, subm):
- """ Same as gaul_to_source.f. isrc is same as k in the fortran version. """
- from math import pi, sqrt
- from const import fwsig
- from scipy import ndimage
- import functions as func
-
- mylog = mylogger.logging.getLogger("PyBDSM."+img.log+"Gaul2Srl ")
- dum = img.beam[0]*img.beam[1]
- cdeltsq = img.wcs_obj.acdelt[0]*img.wcs_obj.acdelt[1]
- bmar_p = 2.0*pi*dum/(cdeltsq*fwsig*fwsig)
-
- # try
- subim_src = self.make_subim(subn, subm, g_sublist, delc)
- mompara = func.momanalmask_gaus(subim_src, mask, isrc, bmar_p, True)
- # initial peak posn and value
- maxv = N.max(subim_src)
- maxx, maxy = N.unravel_index(N.argmax(subim_src), subim_src.shape)
- # fit gaussian around this posn
- blc = N.zeros(2,dtype=N.int); trc = N.zeros(2,dtype=N.int)
- n, m = subim_src.shape[0:2]
- bm_pix = N.array([img.pixel_beam()[0]*fwsig, img.pixel_beam()[1]*fwsig, img.pixel_beam()[2]])
- ssubimsize = max(N.int(N.round(N.max(bm_pix[0:2])*2))+1, 5)
- blc[0] = max(0, maxx-(ssubimsize-1)/2); blc[1] = max(0, maxy-(ssubimsize-1)/2)
- trc[0] = min(n, maxx+(ssubimsize-1)/2); trc[1] = min(m, maxy+(ssubimsize-1)/2)
- s_imsize = trc - blc + 1
-
- p_ini = [maxv, (s_imsize[0]-1)/2.0*1.1, (s_imsize[1]-1)/2.0*1.1, bm_pix[0]/fwsig*1.3, \
- bm_pix[1]/fwsig*1.1, bm_pix[2]*2]
- data = subim_src[blc[0]:blc[0]+s_imsize[0], blc[1]:blc[1]+s_imsize[1]]
- smask = mask[blc[0]:blc[0]+s_imsize[0], blc[1]:blc[1]+s_imsize[1]]
- rmask = N.where(smask==isrc, False, True)
- x_ax, y_ax = N.indices(data.shape)
-
- if N.sum(~rmask) >=6:
- para, ierr = func.fit_gaus2d(data, p_ini, x_ax, y_ax, rmask)
- if (0.0<para[1]<s_imsize[0]) and (0.0<para[2]<s_imsize[1]) and \
- para[3]<s_imsize[0] and para[4]<s_imsize[1]:
- maxpeak = para[0]
- else:
- maxpeak = maxv
- posn = para[1:3]-(0.5*N.sum(s_imsize)-1)/2.0+N.array([maxx, maxy])-1+delc
- else:
- maxpeak = maxv
- posn = N.unravel_index(N.argmax(data*~rmask), data.shape)+N.array(delc) +blc
-
- # calculate peak by bilinear interpolation around centroid
- # First check that moment analysis gave a valid position. If not, use
- # posn from gaussian fit instead.
- if N.isnan(mompara[1]):
- mompara[1] = posn[0] - delc[0]
- x1 = N.int(N.floor(mompara[1]))
- if N.isnan(mompara[2]):
- mompara[2] = posn[1] - delc[1]
- y1 = N.int(N.floor(mompara[2]))
- xind = slice(x1, x1+2, 1); yind = slice(y1, y1+2, 1)
- if img.opts.flag_smallsrc and (N.sum(mask[xind, yind]==N.ones((2,2))*isrc) != 4):
- mylog.debug('Island = '+str(isl.island_id))
- mylog.debug('Mask = '+repr(mask[xind, yind])+'xind, yind, x1, y1 = '+repr(xind)+' '+repr(yind)+' '+repr(x1)+' '+repr(y1))
- t=(mompara[1]-x1)/(x1+1-x1) # in case u change it later
- u=(mompara[2]-y1)/(y1+1-y1)
- s_peak=(1.0-t)*(1.0-u)*subim_src[x1,y1]+t*(1.0-u)*subim_src[x1+1,y1]+ \
- t*u*subim_src[x1+1,y1+1]+(1.0-t)*u*subim_src[x1,y1+1]
- if (not img.opts.flag_smallsrc) and (N.sum(mask[xind, yind]==N.ones((2,2))*isrc) != 4):
- mylog.debug('Speak '+repr(s_peak)+'Mompara = '+repr(mompara))
- mylog.debug('x1, y1 : '+repr(x1)+', '+repr(y1))
- # import pylab as pl
- # pl.imshow(N.transpose(subim_src), origin='lower', interpolation='nearest')
- # pl.suptitle('Image of bad M source '+str(isl.island_id))
- # convert pixels to coords
- try:
- sra, sdec = img.pix2sky([mompara[1]+delc[0], mompara[2]+delc[1]])
- mra, mdec = img.pix2sky(posn)
- except RuntimeError, err:
- # Invalid pixel wcs coordinate
- sra, sdec = 0.0, 0.0
- mra, mdec = 0.0, 0.0
-
- # "deconvolve" the sizes
- gaus_c = [mompara[3], mompara[4], mompara[5]]
- gaus_bm = [bm_pix[0], bm_pix[1], bm_pix[2]]
- gaus_dc, err = func.deconv2(gaus_bm, gaus_c)
- deconv_size_sky = img.pix2gaus(gaus_dc, [mompara[1]+delc[0], mompara[2]+delc[1]])
- deconv_size_sky_uncorr = img.pix2gaus(gaus_dc, [mompara[1]+delc[0], mompara[2]+delc[1]], use_wcs=False)
-
- # update all objects etc
- tot = 0.0
- totE_sq = 0.0
- for g in g_sublist:
- tot += g.total_flux
- totE_sq += g.total_fluxE**2
- totE = sqrt(totE_sq)
- size_pix = [mompara[3], mompara[4], mompara[5]]
- size_sky = img.pix2gaus(size_pix, [mompara[1]+delc[0], mompara[2]+delc[1]])
- size_sky_uncorr = img.pix2gaus(size_pix, [mompara[1]+delc[0], mompara[2]+delc[1]], use_wcs=False)
-
- # Estimate uncertainties in source size and position due to
- # errors in the constituent Gaussians using a Monte Carlo technique.
- # Sum with Condon (1997) errors in quadrature.
- plist = mompara.tolist()+[tot]
- plist[0] = s_peak
- plist[3] /= fwsig
- plist[4] /= fwsig
- errors = func.get_errors(img, plist, isl.rms)
-
- if img.opts.do_mc_errors:
- nMC = 20
- mompara0_MC = N.zeros(nMC, dtype=N.float32)
- mompara1_MC = N.zeros(nMC, dtype=N.float32)
- mompara2_MC = N.zeros(nMC, dtype=N.float32)
- mompara3_MC = N.zeros(nMC, dtype=N.float32)
- mompara4_MC = N.zeros(nMC, dtype=N.float32)
- mompara5_MC = N.zeros(nMC, dtype=N.float32)
- for i in range(nMC):
- # Reconstruct source from component Gaussians. Draw the Gaussian
- # parameters from random distributions given by their errors.
- subim_src_MC = self.make_subim(subn, subm, g_sublist, delc, mc=True)
-
- try:
- mompara_MC = func.momanalmask_gaus(subim_src_MC, mask, isrc, bmar_p, True)
- mompara0_MC[i] = mompara_MC[0]
- mompara1_MC[i] = mompara_MC[1]
- mompara2_MC[i] = mompara_MC[2]
- mompara3_MC[i] = mompara_MC[3]
- mompara4_MC[i] = mompara_MC[4]
- mompara5_MC[i] = mompara_MC[5]
- except:
- mompara0_MC[i] = mompara[0]
- mompara1_MC[i] = mompara[1]
- mompara2_MC[i] = mompara[2]
- mompara3_MC[i] = mompara[3]
- mompara4_MC[i] = mompara[4]
- mompara5_MC[i] = mompara[5]
- mompara0E = N.std(mompara0_MC)
- mompara1E = N.std(mompara1_MC)
- if mompara1E > 2.0*mompara[1]:
- mompara1E = 2.0*mompara[1] # Don't let errors get too large
- mompara2E = N.std(mompara2_MC)
- if mompara2E > 2.0*mompara[2]:
- mompara2E = 2.0*mompara[2] # Don't let errors get too large
- mompara3E = N.std(mompara3_MC)
- if mompara3E > 2.0*mompara[3]:
- mompara3E = 2.0*mompara[3] # Don't let errors get too large
- mompara4E = N.std(mompara4_MC)
- if mompara4E > 2.0*mompara[4]:
- mompara4E = 2.0*mompara[4] # Don't let errors get too large
- mompara5E = N.std(mompara5_MC)
- if mompara5E > 2.0*mompara[5]:
- mompara5E = 2.0*mompara[5] # Don't let errors get too large
- else:
- mompara1E = 0.0
- mompara2E = 0.0
- mompara3E = 0.0
- mompara4E = 0.0
- mompara5E = 0.0
-
- # Now add MC errors in quadrature with Condon (1997) errors
- size_skyE = [sqrt(mompara3E**2 + errors[3]**2) * sqrt(cdeltsq),
- sqrt(mompara4E**2 + errors[4]**2) * sqrt(cdeltsq),
- sqrt(mompara5E**2 + errors[5]**2)]
- sraE, sdecE = (sqrt(mompara1E**2 + errors[1]**2) * sqrt(cdeltsq),
- sqrt(mompara2E**2 + errors[2]**2) * sqrt(cdeltsq))
- deconv_size_skyE = size_skyE # set deconvolved errors to non-deconvolved ones
-
- # Find aperture flux
- if img.opts.aperture_posn == 'centroid':
- aper_pos = [mompara[1]+delc[0], mompara[2]+delc[1]]
- else:
- aper_pos = posn
- aper_flux, aper_fluxE = func.ch0_aperture_flux(img, aper_pos, img.aperture)
-
- isl_id = isl.island_id
- source_prop = list(['M', [tot, totE], [s_peak, isl.rms], [maxpeak, isl.rms],
- [aper_flux, aper_fluxE], [[sra, sdec],
- [sraE, sdecE]], [[mra, mdec], [sraE, sdecE]], [size_sky, size_skyE], [size_sky_uncorr, size_skyE],
- [deconv_size_sky, deconv_size_skyE], [deconv_size_sky_uncorr, deconv_size_skyE], isl.bbox, len(g_sublist),
- isl_id, g_sublist])
- source = Source(img, source_prop)
-
- src_index += 1
- for g in g_sublist:
- g.source_id = src_index
- g.code = 'M'
- source.source_id = src_index
-
- return src_index, source
-
-##################################################################################################
-
- def make_subim(self, subn, subm, g_list, delc, mc=False):
- import functions as func
-
- subim = N.zeros((subn, subm), dtype=N.float32)
- x, y = N.indices((subn, subm))
- for g in g_list:
- params = func.g2param(g)
- params[1] -= delc[0]; params[2] -= delc[1]
- if mc:
- # draw random variables from distributions given by errors
- params_err = func.g2param_err(g)
- for i in range(len(params)):
- mc_param = N.random.normal(loc=params[i], scale=params_err[i])
- params[i] = mc_param
- gau = func.gaus_2d(params, x, y)
- subim = subim + gau
-
- return subim
-
-##################################################################################################
-
- def make_mask(self, isl, subn, subm, nsrc, src_id, g_list, delc):
- import functions as func
- # define stuff for calculating gaussian
- boxx, boxy = isl.bbox
- subn = boxx.stop-boxx.start; subm = boxy.stop-boxy.start
- x, y = N.indices((subn, subm))
- # construct image of each source in the island
- src_image = N.zeros((subn, subm, nsrc), dtype=N.float32)
- nn = 1
- for isrc in range(nsrc):
- if nsrc == 1:
- g_sublist = g_list
- else:
- posn = N.where(src_id == isrc)[0]
- g_sublist=[]
- for i in posn:
- g_sublist.append(g_list[i])
- for g in g_sublist:
- params = func.g2param(g)
- params[1] -= delc[0]; params[2] -= delc[1]
- gau = func.gaus_2d(params, x, y)
- src_image[:,:,isrc] = src_image[:,:,isrc] + gau
- # mark each pixel as belonging to one source
- # just compare value, should compare with sigma later
- mask = N.argmax(src_image, axis=2) + src_id
- orig_mask = isl.mask_active
- mask[N.where(orig_mask)] = -1
-
- return mask
-
-
-##################################################################################################
-# Define class Source
-##################################################################################################
-
-from image import *
-from gausfit import Gaussian
-from islands import Island
-
-class Source(object):
- """ Instances of this class store sources made from grouped gaussians. """
- source_id = Int(doc="Source index", colname='Source_id')
- code = String(doc='Source code S, C, or M', colname='S_Code')
- total_flux = Float(doc="Total flux density (Jy)", colname='Total_flux', units='Jy')
- total_fluxE = Float(doc="Error in total flux density (Jy)", colname='E_Total_flux',
- units='Jy')
- peak_flux_centroid = Float(doc="Peak flux density per beam at centroid of emission (Jy/beam)",
- colname='Peak_flux_cen', units='Jy/beam')
- peak_flux_centroidE = Float(doc="Error in peak flux density per beam at centroid of emission (Jy/beam)",
- colname='E_Peak_flux_cen', units='Jy/beam')
- peak_flux_max = Float(doc="Peak flux density per beam at posn of maximum emission (Jy/beam)",
- colname='Peak_flux', units='Jy/beam')
- peak_flux_maxE = Float(doc="Error in peak flux density per beam at posn of max emission (Jy/beam)",
- colname='E_Peak_flux', units='Jy/beam')
- aperture_flux = Float(doc="Total aperture flux density (Jy)", colname='Aperture_flux',
- units='Jy')
- aperture_fluxE = Float(doc="Error in total aperture flux density (Jy)", colname='E_Aperture_flux',
- units='Jy')
- posn_sky_centroid = List(Float(), doc="Posn (RA, Dec in deg) of centroid of source",
- colname=['RA', 'DEC'], units=['deg', 'deg'])
- posn_sky_centroidE = List(Float(), doc="Error in posn (RA, Dec in deg) of centroid of source",
- colname=['E_RA', 'E_DEC'], units=['deg', 'deg'])
- posn_sky_max = List(Float(), doc="Posn (RA, Dec in deg) of maximum emission of source",
- colname=['RA_max', 'DEC_max'], units=['deg', 'deg'])
- posn_sky_maxE = List(Float(), doc="Error in posn (deg) of maximum emission of source",
- colname=['E_RA_max', 'E_DEC_max'], units=['deg', 'deg'])
- posn_pix_centroid = List(Float(), doc="Position (x, y in pixels) of centroid of source",
- colname=['Xposn', 'Yposn'], units=['pix', 'pix'])
- posn_pix_centroidE = List(Float(), doc="Error in position (x, y in pixels) of centroid of source",
- colname=['E_Xposn', 'E_Yposn'], units=['pix', 'pix'])
- posn_pix_max = List(Float(), doc="Position (x, y in pixels) of maximum emission of source",
- colname=['Xposn_max', 'Yposn_max'], units=['pix', 'pix'])
- posn_pix_maxE = List(Float(), doc="Error in position (pixels) of maximum emission of source",
- colname=['E_Xposn_max', 'E_Yposn_max'], units=['pix', 'pix'])
- size_sky = List(Float(), doc="Shape of the source FWHM, BPA, deg",
- colname=['Maj', 'Min', 'PA'], units=['deg', 'deg',
- 'deg'])
- size_skyE = List(Float(), doc="Error on shape of the source FWHM, BPA, deg",
- colname=['E_Maj', 'E_Min', 'E_PA'], units=['deg', 'deg',
- 'deg'])
- deconv_size_sky = List(Float(), doc="Deconvolved shape of the source FWHM, BPA, deg",
- colname=['DC_Maj', 'DC_Min', 'DC_PA'], units=['deg', 'deg',
- 'deg'])
- deconv_size_skyE = List(Float(), doc="Error on deconvolved shape of the source FWHM, BPA, deg",
- colname=['E_DC_Maj', 'E_DC_Min', 'E_DC_PA'], units=['deg', 'deg',
- 'deg'])
- size_sky_uncorr = List(Float(), doc="Shape in image plane of the gaussian FWHM, PA, deg",
- colname=['Maj_img_plane', 'Min_img_plane', 'PA_img_plane'], units=['deg', 'deg',
- 'deg'])
- size_skyE_uncorr = List(Float(), doc="Error on shape in image plane of the gaussian FWHM, PA, deg",
- colname=['E_Maj_img_plane', 'E_Min_img_plane', 'E_PA_img_plane'], units=['deg', 'deg',
- 'deg'])
- deconv_size_sky_uncorr = List(Float(), doc="Deconvolved shape in image plane of the gaussian FWHM, PA, deg",
- colname=['DC_Maj_img_plane', 'DC_Min_img_plane', 'DC_PA_img_plane'], units=['deg', 'deg',
- 'deg'])
- deconv_size_skyE_uncorr = List(Float(), doc="Error on deconvolved shape in image plane of the gaussian FWHM, PA, deg",
- colname=['E_DC_Maj_img_plane', 'E_DC_Min_img_plane', 'E_DC_PA_img_plane'], units=['deg', 'deg',
- 'deg'])
- rms_isl = Float(doc="Island rms Jy/beam", colname='Isl_rms', units='Jy/beam')
- mean_isl = Float(doc="Island mean Jy/beam", colname='Isl_mean', units='Jy/beam')
- total_flux_isl = Float(doc="Island total flux from sum of pixels", colname='Isl_Total_flux', units='Jy')
- total_flux_islE = Float(doc="Error on island total flux from sum of pixels", colname='E_Isl_Total_flux', units='Jy')
- gresid_rms = Float(doc="Island rms in Gaussian residual image Jy/beam",
- colname='Resid_Isl_rms', units='Jy/beam')
- gresid_mean = Float(doc="Island mean in Gaussian residual image Jy/beam",
- colname='Resid_Isl_mean', units='Jy/beam')
- sresid_rms = Float(doc="Island rms in Shapelet residual image Jy/beam",
- colname='Resid_Isl_rms', units='Jy/beam')
- sresid_mean = Float(doc="Island mean in Shapelet residual image Jy/beam",
- colname='Resid_Isl_mean', units='Jy/beam')
- ngaus = Int(doc='Number of gaussians in the source', colname='N_gaus')
- island_id = Int(doc="Serial number of the island", colname='Isl_id')
- gaussians = List(tInstance(Gaussian), doc="")
- bbox = List(Instance(slice(0), or_none=False), doc = "")
-
- def __init__(self, img, sourceprop):
-
- code, total_flux, peak_flux_centroid, peak_flux_max, aper_flux, posn_sky_centroid, \
- posn_sky_max, size_sky, size_sky_uncorr, deconv_size_sky, \
- deconv_size_sky_uncorr, bbox, ngaus, island_id, gaussians = sourceprop
- self.code = code
- self.total_flux, self.total_fluxE = total_flux
- self.peak_flux_centroid, self.peak_flux_centroidE = peak_flux_centroid
- self.peak_flux_max, self.peak_flux_maxE = peak_flux_max
- self.posn_sky_centroid, self.posn_sky_centroidE = posn_sky_centroid
- self.posn_sky_max, self.posn_sky_maxE = posn_sky_max
- self.size_sky, self.size_skyE = size_sky
- self.size_sky_uncorr, self.size_skyE_uncorr = size_sky_uncorr
- self.deconv_size_sky, self.deconv_size_skyE = deconv_size_sky
- self.deconv_size_sky_uncorr, self.deconv_size_skyE_uncorr = deconv_size_sky_uncorr
- self.bbox = bbox
- self.ngaus = ngaus
- self.island_id = island_id
- self.gaussians = gaussians
- self.rms_isl = img.islands[island_id].rms
- self.mean_isl = img.islands[island_id].mean
- self.total_flux_isl = img.islands[island_id].total_flux
- self.total_flux_islE = img.islands[island_id].total_fluxE
- self.mean_isl = img.islands[island_id].mean
- self.jlevel = img.j
- self.aperture_flux, self.aperture_fluxE = aper_flux
-
-
-Image.sources = List(tInstance(Source), doc="List of Sources")
-Island.sources = List(tInstance(Source), doc="List of Sources")
-
-
-
diff --git a/CEP/PyBDSM/src/python/gausfit.py b/CEP/PyBDSM/src/python/gausfit.py
deleted file mode 100644
index ae3ca5c35f610b729297840df6c5aedf1d99a03d..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/python/gausfit.py
+++ /dev/null
@@ -1,1021 +0,0 @@
-"""Module gausfit.
-
-This module does multi-gaussian fits for all detected islands.
-At the moment fitting algorithm is quite simple -- we just add
-gaussians one-by-one as long as there are pixels with emission
-in the image, and do post-fitting flagging of the extracted
-gaussians.
-
-The fitting itself is implemented by the means of MGFunction
-class and a number of fitter routines in _cbdsm module.
-MGFunction class implements multi-gaussian function and
-provides all functionality required by the specific fitters.
-"""
-
-from image import *
-from copy import deepcopy as cp
-import mylogger
-import sys
-import time
-import statusbar
-import _cbdsm
-from . import has_pl
-if has_pl:
- import matplotlib.pyplot as pl
-import scipy.ndimage as nd
-import multi_proc as mp
-
-
-ngaus = Int(doc="Total number of gaussians extracted")
-total_flux_gaus = Float(doc="Total flux in the Gaussians extracted")
-
-class Op_gausfit(Op):
- """Fit a number of 2D gaussians to each island.
-
- The results of the fitting are stored in the Island
- structure itself as a list of Gaussian objects (gaul) and a
- list of flagged gaussians (fgaul).
-
- Prerequisites: module islands should be run first.
- """
- def __call__(self, img):
- from time import time
- import functions as func
- import itertools
-
- mylog = mylogger.logging.getLogger("PyBDSM."+img.log+"Gausfit")
- if len(img.islands) == 0:
- img.gaussians = []
- img.ngaus = 0
- img.total_flux_gaus = 0.0
- img.completed_Ops.append('gausfit')
- return img
-
- bar = statusbar.StatusBar('Fitting islands with Gaussians .......... : ',
- 0, img.nisl)
- opts = img.opts
- if opts.quiet == False and opts.verbose_fitting == False:
- bar.start()
- iter_ngmax = 10
- min_maxsize = 50.0
- maxsize = opts.splitisl_maxsize
- min_peak_size = 30.0
- peak_size = opts.peak_maxsize
- if maxsize < min_maxsize:
- maxsize = min_maxsize
- opts.splitisl_maxsize = min_maxsize
- if peak_size < min_peak_size:
- peak_size = min_peak_size
- opts.peak_maxsize = min_peak_size
-
- # Set up multiproccessing. First create a simple copy of the Image
- # object that contains the minimal data needed.
- opts_dict = opts.to_dict()
- img_simple = Image(opts_dict)
- img_simple.pixel_beamarea = img.pixel_beamarea
- img_simple.pixel_beam = img.pixel_beam
- img_simple.thresh_pix = img.thresh_pix
- img_simple.minpix_isl = img.minpix_isl
- img_simple.clipped_mean = img.clipped_mean
- img_simple.beam2pix = img.beam2pix
- img_simple.beam = img.beam
-
- # Next, define the weights to use when distributing islands among cores.
- # The weight should scale with the processing time. At the moment
- # we use the island area, but other parameters may be better.
- weights = []
- for isl in img.islands:
- weights.append(isl.size_active)
-
- # Now call the parallel mapping function. Returns a list of [gaul, fgaul]
- # for each island.
- gaus_list = mp.parallel_map(func.eval_func_tuple,
- itertools.izip(itertools.repeat(self.process_island),
- img.islands, itertools.repeat(img_simple),
- itertools.repeat(opts)), numcores=opts.ncores,
- bar=bar, weights=weights)
-
- for isl in img.islands:
- ### now convert gaussians into Gaussian objects and store
- idx = isl.island_id
- gaul = gaus_list[idx][0]
- fgaul = gaus_list[idx][1]
- dgaul = []
- gaul = [Gaussian(img, par, idx, gidx)
- for (gidx, par) in enumerate(gaul)]
-
- if len(gaul) == 0:
- # No good Gaussians were fit. In this case, make a dummy
- # Gaussian located at the island center so
- # that the source may still be included in output catalogs.
- # These dummy Gaussians all have an ID of -1. They do not
- # appear in any of the source or island Gaussian lists except
- # the island dgaul list.
- if opts.src_ra_dec is not None:
- # Center the dummy Gaussian on the user-specified source position
- posn_isl = (isl.shape[0]/2.0, isl.shape[1]/2.0)
- posn_img = (isl.shape[0]/2.0 + isl.origin[0], isl.shape[1]/2.0 + isl.origin[1])
- par = [isl.image[posn_isl], posn_img[0], posn_img[1], 0.0, 0.0, 0.0]
- else:
- # Center the dummy Gaussian on the maximum pixel
- posn = N.unravel_index(N.argmax(isl.image*~isl.mask_active), isl.shape) + N.array(isl.origin)
- par = [isl.max_value, posn[0], posn[1], 0.0, 0.0, 0.0]
- dgaul = [Gaussian(img, par, idx, -1)]
- gidx = 0
- fgaul= [Gaussian(img, par, idx, gidx + gidx2 + 1, flag)
- for (gidx2, (flag, par)) in enumerate(fgaul)]
-
- isl.gaul = gaul
- isl.fgaul= fgaul
- isl.dgaul = dgaul
-
- gaussian_list = [g for isl in img.islands for g in isl.gaul]
- img.gaussians = gaussian_list
-
- ### put in the serial number of the gaussians for the whole image
- n = 0
- nn = 0
- tot_flux = 0.0
- if img.waveletimage:
- # store the wavelet scale for each Gaussian
- # (wavelet img's have a img.j attribute)
- j = img.j
- else:
- j = 0
- for isl in img.islands:
- m = 0
- for g in isl.gaul:
- n += 1; m += 1
- g.gaus_num = n - 1
- tot_flux += g.total_flux
- for dg in isl.dgaul:
- nn -= 1
- dg.gaus_num = nn
-
- isl.ngaus = m
- img.ngaus = n
- img.total_flux_gaus = tot_flux
-
- mylogger.userinfo(mylog, "Total number of Gaussians fit to image",
- str(n))
- if not img._pi and not img.waveletimage:
- mylogger.userinfo(mylog, "Total flux density in model", '%.3f Jy' %
- tot_flux)
-
- # Check if model flux is very different from sum of flux in image
- if img.ch0_sum_jy > 0 and not img._pi:
- if img.total_flux_gaus/img.ch0_sum_jy < 0.5 or \
- img.total_flux_gaus/img.ch0_sum_jy > 2.0:
- mylog.warn('Total flux density in model is %0.2f times sum of pixels '\
- 'in input image. Large residuals may remain.' %
- (img.total_flux_gaus/img.ch0_sum_jy,))
-
- # Check if there are many Gaussians with deconvolved size of 0 in one
- # axis but not in the other. Don't bother to do this for wavelet images.
- fraction_1d = self.check_for_1d_gaussians(img)
- if fraction_1d > 0.5 and img.beam is not None and img.waveletimage == False:
- mylog.warn('After deconvolution, more than 50% of Gaussians are '\
- "1-D. Unless you're fitting an extended source, "\
- "beam may be incorrect.")
-
- img.completed_Ops.append('gausfit')
- return img
-
-
- def process_island(self, isl, img, opts=None):
- """Processes a single island.
-
- Returns a list of the best-fit Gaussians and flagged Gaussians.
- """
- import functions as func
-
- if opts is None:
- opts = img.opts
- iter_ngmax = 10
- maxsize = opts.splitisl_maxsize
- min_peak_size = 30.0
- min_maxsize = 50.0
- peak_size = opts.peak_maxsize
- if maxsize < min_maxsize:
- maxsize = min_maxsize
- opts.splitisl_maxsize = min_maxsize
- if peak_size < min_peak_size:
- peak_size = min_peak_size
- opts.peak_maxsize = min_peak_size
-
- size = isl.size_active/img.pixel_beamarea()*2.0 # 2.0 roughly corrects for thresh_isl
- if opts.verbose_fitting:
- print "Fitting isl #", isl.island_id, '; # pix = ',N.sum(~isl.mask_active),'; size = ',size
-
- if size > maxsize:
- tosplit = func.isl_tosplit(isl, opts)
- if opts.split_isl and tosplit[0] > 0:
- n_subisl, sub_labels = tosplit[1], tosplit[2]
- gaul = []; fgaul = []
- if opts.verbose_fitting:
- print 'SPLITTING ISLAND INTO ',n_subisl,' PARTS FOR ISLAND ',isl.island_id
- for i_sub in range(n_subisl):
- islcp = isl.copy(img.pixel_beamarea())
- islcp.mask_active = N.where(sub_labels == i_sub+1, False, True)
- islcp.mask_noisy = N.where(sub_labels == i_sub+1, False, True)
- size_subisl = (~islcp.mask_active).sum()/img.pixel_beamarea()*2.0
- if opts.peak_fit and size_subisl > peak_size:
- sgaul, sfgaul = self.fit_island_iteratively(img, islcp, iter_ngmax=iter_ngmax, opts=opts)
- else:
- sgaul, sfgaul = self.fit_island(islcp, opts, img)
- gaul = gaul + sgaul; fgaul = fgaul + sfgaul
- else:
- isl.islmean = 0.0
- if opts.peak_fit and size > peak_size:
- gaul, fgaul = self.fit_island_iteratively(img, isl, iter_ngmax=iter_ngmax, opts=opts)
- else:
- gaul, fgaul = self.fit_island(isl, opts, img)
-
- else:
- if opts.peak_fit and size > peak_size:
- gaul, fgaul = self.fit_island_iteratively(img, isl, iter_ngmax=iter_ngmax, opts=opts)
- else:
- gaul, fgaul = self.fit_island(isl, opts, img)
-
- # Return list of Gaussians
- return [gaul, fgaul]
-
- def fit_island(self, isl, opts, img, ngmax=None, ffimg=None, ini_gausfit=None):
- """Fit island with a set of 2D gaussians.
-
- Parameters:
- isl: island
- opts: Opts structure of the image
- beam: beam parameters which are used as an initial guess for
- gaussian shape
-
- Returns:
- Function returns 2 lists with parameters of good and flagged
- gaussians. Gaussian parameters are updated to be image-relative.
-
- Note: "fitok" indicates whether fit converged
- and one or more flagged Gaussians indicate
- that significant residuals remain (peak > thr).
- """
- from _cbdsm import MGFunction
- import functions as func
- from const import fwsig
-
- if ffimg is None:
- fit_image = isl.image-isl.islmean
- else:
- fit_image = isl.image-isl.islmean-ffimg
- fcn = MGFunction(fit_image, isl.mask_active, 1)
- # For fitting, use img.beam instead of img.pixel_beam, as we want
- # to pick up the wavelet beam (img.pixel_beam is not changed for
- # wavelet images, but img.beam is)
- beam = N.array(img.beam2pix(img.beam))
- beam = (beam[0]/fwsig, beam[1]/fwsig, beam[2]+90.0) # change angle from +y-axis to +x-axis and FWHM to sigma
-
- if abs(beam[0]/beam[1]) < 1.1:
- beam = (1.1*beam[0], beam[1], beam[2])
-
- thr1 = isl.mean + opts.thresh_isl*isl.rms
- thr2 = isl.mean + img.thresh_pix*isl.rms
- thr0 = thr1
- verbose = opts.verbose_fitting
- g3_only = opts.fix_to_beam
- peak = fcn.find_peak()[0]
- dof = isl.size_active
- shape = isl.shape
- isl_image = isl.image - isl.islmean
- size = isl.size_active/img.pixel_beamarea()*2.0
- gaul = []
- iter = 0
- ng1 = 0
- if ini_gausfit is None:
- ini_gausfit = opts.ini_gausfit
-
- if ini_gausfit not in ['default', 'simple', 'nobeam']:
- ini_gausfit = 'default'
- if ini_gausfit == 'simple' and ngmax is None:
- ngmax = 25
- if ini_gausfit == 'default' or opts.fix_to_beam:
- gaul, ng1, ngmax = self.inigaus_fbdsm(isl, thr0, beam, img)
- if ini_gausfit == 'nobeam' and not opts.fix_to_beam:
- gaul = self.inigaus_nobeam(isl, thr0, beam, img)
- ng1 = len(gaul); ngmax = ng1+2
- while iter < 5:
- iter += 1
- fitok = self.fit_iter(gaul, ng1, fcn, dof, beam, thr0, iter, ini_gausfit, ngmax, verbose, g3_only)
- gaul, fgaul = self.flag_gaussians(fcn.parameters, opts,
- beam, thr0, peak, shape, isl.mask_active,
- isl.image, size)
- ng1 = len(gaul)
- if fitok and len(fgaul) == 0:
- break
- if (not fitok or len(gaul) == 0) and ini_gausfit != 'simple':
- # If fits using default or nobeam methods did not work,
- # try using simple instead
- gaul = []
- iter = 0
- ng1 = 0
- ngmax = 25
- while iter < 5:
- iter += 1
- fitok = self.fit_iter(gaul, ng1, fcn, dof, beam, thr0, iter, 'simple', ngmax, verbose, g3_only)
- gaul, fgaul = self.flag_gaussians(fcn.parameters, opts,
- beam, thr0, peak, shape, isl.mask_active,
- isl.image, size)
- ng1 = len(gaul)
- if fitok and len(fgaul) == 0:
- break
- sm_isl = nd.binary_dilation(isl.mask_active)
- if (not fitok or len(gaul) == 0) and N.sum(~sm_isl) >= img.minpix_isl:
- # If fitting still fails, shrink the island a little and try again
- fcn = MGFunction(fit_image, nd.binary_dilation(isl.mask_active), 1)
- gaul = []
- iter = 0
- ng1 = 0
- ngmax = 25
- while iter < 5:
- iter += 1
- fitok = self.fit_iter(gaul, ng1, fcn, dof, beam, thr0, iter, 'simple', ngmax, verbose, g3_only)
- gaul, fgaul = self.flag_gaussians(fcn.parameters, opts,
- beam, thr0, peak, shape, isl.mask_active,
- isl.image, size)
- ng1 = len(gaul)
- if fitok and len(fgaul) == 0:
- break
- lg_isl = nd.binary_erosion(isl.mask_active)
- if (not fitok or len(gaul) == 0) and N.sum(~lg_isl) >= img.minpix_isl:
- # If fitting still fails, expand the island a little and try again
- fcn = MGFunction(fit_image, nd.binary_erosion(isl.mask_active), 1)
- gaul = []
- iter = 0
- ng1 = 0
- ngmax = 25
- while iter < 5:
- iter += 1
- fitok = self.fit_iter(gaul, ng1, fcn, dof, beam, thr0, iter, 'simple', ngmax, verbose, g3_only)
- gaul, fgaul = self.flag_gaussians(fcn.parameters, opts,
- beam, thr0, peak, shape, isl.mask_active,
- isl.image, size)
- ng1 = len(gaul)
- if fitok and len(fgaul) == 0:
- break
-
- if not fitok or len(gaul) == 0:
- # If all else fails, try to use moment analysis
- inisl = N.where(~isl.mask_active)
- mask_id = N.zeros(isl.image.shape, dtype=N.int32) - 1
- mask_id[inisl] = isl.island_id
- try:
- pixel_beamarea = img.pixel_beamarea()
- mompara = func.momanalmask_gaus(fit_image, mask_id, isl.island_id, pixel_beamarea, True)
- mompara[5] += 90.0
- if not N.isnan(mompara[1]) and not N.isnan(mompara[2]):
- x1 = N.int(N.floor(mompara[1]))
- y1 = N.int(N.floor(mompara[2]))
- xind = slice(x1, x1+2, 1); yind = slice(y1, y1+2, 1)
- t=(mompara[1]-x1)/(x1+1-x1)
- u=(mompara[2]-y1)/(y1+1-y1)
- s_peak=(1.0-t)*(1.0-u)*fit_image[x1,y1]+t*(1.0-u)*fit_image[x1+1,y1]+ \
- t*u*fit_image[x1+1,y1+1]+(1.0-t)*u*fit_image[x1,y1+1]
- mompara[0] = s_peak
- par = [mompara.tolist()]
- par[3] /= fwsig
- par[4] /= fwsig
- gaul, fgaul = self.flag_gaussians(par, opts,
- beam, thr0, peak, shape, isl.mask_active,
- isl.image, size)
- except:
- pass
-
- ### return whatever we got
- isl.mg_fcn = fcn
- gaul = [self.fixup_gaussian(isl, g) for g in gaul]
- fgaul = [(flag, self.fixup_gaussian(isl, g))
- for flag, g in fgaul]
-
- if verbose:
- print 'Number of good Gaussians: %i' % (len(gaul),)
- print 'Number of flagged Gaussians: %i' % (len(fgaul),)
- return gaul, fgaul
-
-
- def fit_island_iteratively(self, img, isl, iter_ngmax=5, opts=None):
- """Fits an island iteratively.
-
- For large islands, which can require many Gaussians to fit well,
- it is much faster to fit a small number of Gaussians simultaneously
- and iterate. However, this does usually result in larger residuals.
- """
- import functions as func
- sgaul = []; sfgaul = []
- gaul = []; fgaul = []
- if opts is None:
- opts = img.opts
- thresh_isl = opts.thresh_isl
- thresh_pix = opts.thresh_pix
- thresh = opts.fittedimage_clip
- thr = isl.mean + thresh_isl * isl.rms
- rms = isl.rms
-
- if opts.verbose_fitting:
- print 'Iteratively fitting island ', isl.island_id
- gaul = []; fgaul = []
- ffimg_tot = N.zeros(isl.shape, dtype=N.float32)
- peak_val = N.max(isl.image - isl.islmean)
- while peak_val >= thr:
- sgaul, sfgaul = self.fit_island(isl, opts, img, ffimg=ffimg_tot, ngmax=iter_ngmax, ini_gausfit='simple')
- gaul = gaul + sgaul; fgaul = fgaul + sfgaul
-
- # Calculate residual image
- if len(sgaul) > 0:
- for g in sgaul:
- gcopy = g[:]
- gcopy[1] -= isl.origin[0]
- gcopy[2] -= isl.origin[1]
- S1, S2, Th = func.corrected_size(gcopy[3:6])
- gcopy[3] = S1
- gcopy[4] = S2
- gcopy[5] = Th
- A, C1, C2, S1, S2, Th = gcopy
- shape = isl.shape
- b = find_bbox(thresh*isl.rms, gcopy)
- bbox = N.s_[max(0, int(C1-b)):min(shape[0], int(C1+b+1)),
- max(0, int(C2-b)):min(shape[1], int(C2+b+1))]
- x_ax, y_ax = N.mgrid[bbox]
- ffimg = func.gaussian_fcn(gcopy, x_ax, y_ax)
- ffimg_tot[bbox] += ffimg
- peak_val_prev = peak_val
- peak_val = N.max(isl.image - isl.islmean - ffimg_tot)
- if func.approx_equal(peak_val, peak_val_prev):
- break
- else:
- break
-
- if len(gaul) == 0:
- # Fitting iteratively did not work -- try normal fit
- gaul, fgaul = self.fit_island(isl, opts, img, ini_gausfit='default')
-
- return gaul, fgaul
-
-
- def inigaus_fbdsm(self, isl, thr, beam, img):
- """ initial guess for gaussians like in fbdsm """
- from math import sqrt
- from const import fwsig
- import functions as func
-
- im = isl.image-isl.islmean
- if img.opts.ini_method == 'curvature':
- im_pos = -1.0 * func.make_curvature_map(isl.image-isl.islmean)
- thr_pos = 0.0
- else:
- im_pos = im
- thr_pos = thr
- mask = isl.mask_active
- av = img.clipped_mean
- inipeak, iniposn, im1 = func.get_maxima(im, mask, thr_pos, isl.shape, beam, im_pos=im_pos)
- if len(inipeak) == 0:
- av, stdnew, maxv, maxp, minv, minp = func.arrstatmask(im, mask)
- inipeak = [maxv]; iniposn = [maxp]
- nmulsrc1 = len(iniposn)
-
- domore = True
- while domore:
- domore = False
- av, stdnew, maxv, maxp, minv, minp = func.arrstatmask(im1, mask)
- if stdnew > isl.rms and maxv >= thr and maxv >= isl.mean+2.0*isl.rms:
- domore = True
- x1, y1 = N.array(iniposn).transpose()
- dumr = N.sqrt((maxp[0]-x1)*(maxp[0]-x1)+(maxp[1]-y1)*(maxp[1]-y1))
- distbm = dumr/sqrt(beam[0]*beam[1]*fwsig*fwsig)
- if N.any((distbm < 0.5) + (dumr < 2.2)):
- domore = False
- if domore:
- iniposn.append(N.array(maxp)); inipeak.append(maxv)
- im1 = func.mclean(im1, maxp, beam)
-
- inipeak = N.array(inipeak); iniposn = N.array(iniposn)
- ind = list(N.argsort(inipeak)); ind.reverse()
- inipeak = inipeak[ind]
- iniposn = iniposn[ind]
- gaul = []
- for i in range(len(inipeak)):
- g = (float(inipeak[i]), int(iniposn[i][0]), int(iniposn[i][1])) + beam
- gaul.append(g)
-
- return gaul, nmulsrc1, len(inipeak)
-
- def inigaus_nobeam(self, isl, thr, beam, img):
- """ To get initial guesses when the source sizes are very different
- from the beam, and can also be elongated. Mainly in the context of
- a-trous transform images. Need to arrive at a good guess of the sizes
- and hence need to partition the image around the maxima first. Tried the
- IFT watershed algo but with markers, it segments the island only around
- the minima and not the whole island. Cant find a good weighting scheme
- for tesselation either. Hence will try this :
-
- Calculate number of maxima. If one, then take moment as initial
- guess. If more than one, then moment of whole island is one of the
- guesses if mom1 is within n pixels of one of the maxima. Else dont take
- whole island moment. Instead, find minima on lines connecting all maxima
- and use geometric mean of all minima of a peak as the size of that peak.
- """
- from math import sqrt
- from const import fwsig
- import scipy.ndimage as nd
- import functions as func
-
- im = isl.image-isl.islmean
- if img.opts.ini_method == 'curvature':
- im_pos = -1.0 * func.make_curvature_map(isl.image-isl.islmean)
- thr_pos = 0.0
- else:
- im_pos = im
- thr_pos = -1e9
- mask = isl.mask_active
- av = img.clipped_mean
- inipeak, iniposn, im1 = func.get_maxima(im, mask, thr_pos, isl.shape, beam, im_pos=im_pos)
- npeak = len(iniposn)
- gaul = []
-
- av, stdnew, maxv, maxp, minv, minp = func.arrstatmask(im, mask)
- mom = func.momanalmask_gaus(isl.image-isl.islmean, isl.mask_active, 0, 1.0, True)
- if npeak <= 1:
- g = (float(maxv), int(round(mom[1])), int(round(mom[2])), mom[3]/fwsig, \
- mom[4]/fwsig, mom[5])
- gaul.append(g)
-
- if npeak > 1: # markers start from 1=background, watershed starts from 1=background
- watershed, markers = func.watershed(im, mask=isl.mask_active)
- nshed = N.max(markers)-1 # excluding background
- xm, ym = N.transpose([N.where(markers==i) for i in range(1,nshed+2)])[0]
- coords = [c for c in N.transpose([xm,ym])[1:]]
- alldists = [func.dist_2pt(c1, c2) for c1 in coords for c2 in coords if N.any(c1!=c2)] # has double
- meandist = N.mean(alldists) # mean dist between all pairs of markers
- compact = []; invmask = []
- for ished in range(nshed):
- shedmask = N.where(watershed==ished+2, False, True) + isl.mask_active # good unmasked pixels = 0
- imm = nd.binary_dilation(~shedmask, N.ones((3,3), int))
- xbad, ybad = N.where((imm==1)*(im>im[xm[ished+1], ym[ished+1]]))
- imm[xbad, ybad] = 0
- invmask.append(imm); x, y = N.where(imm); xcen, ycen = N.mean(x), N.mean(y) # good pixels are now = 1
- dist = func.dist_2pt([xcen, ycen], [xm[ished+1], ym[ished+1]])
- if dist < max(3.0, meandist/4.0):
- compact.append(True) # if not compact, break source + diffuse
- else:
- compact.append(False)
- if not N.all(compact):
- avsize = []
- ind = N.where(compact)[0]
- for i in ind: avsize.append(N.sum(invmask[i]))
- avsize = sqrt(N.mean(N.array(avsize)))
- for i in range(len(compact)):
- if not compact[i]: # make them all compact
- newmask = N.zeros(imm.shape, bool)
- newmask[max(0,xm[i+1]-avsize/2):min(im.shape[0],xm[i+1]+avsize/2), \
- max(0,ym[i+1]-avsize/2):min(im.shape[1],ym[i+1]+avsize/2)] = True
- invmask[i] = invmask[i]*newmask
- resid = N.zeros(im.shape, dtype=N.float32) # approx fit all compact ones
- for i in range(nshed):
- mask1 = ~invmask[i]
- size = sqrt(N.sum(invmask))/fwsig
- xf, yf = coords[i][0], coords[i][1]
- p_ini = [im[xf, yf], xf, yf, size, size, 0.0]
- x, y = N.indices(im.shape)
- p, success = func.fit_gaus2d(im*invmask[i], p_ini, x, y)
- resid = resid + func.gaus_2d(p, x, y)
- gaul.append(p)
- resid = im - resid
- if not N.all(compact): # just add one gaussian to fit whole unmasked island
- maxv = N.max(resid) # assuming resid has only diffuse emission. can be false
- x, y = N.where(~isl.mask_active); xcen = N.mean(x); ycen = N.mean(y)
- invm = ~isl.mask_active
- #bound = invm - nd.grey_erosion(invm, footprint = N.ones((3,3), int)) # better to use bound for ellipse fitting
- mom = func.momanalmask_gaus(invm, N.zeros(invm.shape, dtype=N.int16), 0, 1.0, True)
- g = (maxv, xcen, ycen, mom[3]/fwsig, mom[4]/fwsig, mom[5]-90.)
- gaul.append(g)
- coords.append([xcen, ycen])
-
- return gaul
-
-
- def fit_iter(self, gaul, ng1, fcn, dof, beam, thr, iter, inifit, ngmax, verbose=1, g3_only=False):
- """One round of fitting
-
- Parameters:
- gaul : list of initial gaussians
- fcn : MGFunction object
- dof : maximal number of fitted parameters
- beam : initial shape for newly added gaussians
- [bmaj, bmin, bpa] in pixels
- thr : peak threshold for adding more gaussians
- verbose: whether to print fitting progress information
- """
- from _cbdsm import lmder_fit, dn2g_fit, dnsg_fit
- fit = lmder_fit
- beam = list(beam)
-
- ### first drop-in initial gaussians
- ### no error-checking here, they MUST fit
- fcn.reset()
- for ig in range(ng1):
- g = gaul[ig]
- self.add_gaussian(fcn, g, dof, g3_only)
-
- ### do a round of fitting if any initials were provided
- fitok = True
- if len(gaul) != 0:
- fitok = fit(fcn, final=0, verbose=verbose)
-
- ### iteratively add gaussians while there are high peaks
- ### in the image and fitting converges
- while fitok:
- peak, coords = fcn.find_peak()
- if peak < thr: ### no good peaks left
- break
- if len(fcn.parameters) < ngmax and iter == 1 and inifit == 'default' and len(gaul) >= ng1+1:
- ng1 = ng1 + 1
- g = gaul[ng1-1]
- else:
- if len(fcn.parameters) < ngmax:
- g = [peak, coords[0], coords[1]] + beam
- else:
- break
- fitok &= self.add_gaussian(fcn, g, dof, g3_only)
-
- fitok &= fit(fcn, final=0, verbose=verbose)
-
- ### and one last fit with higher precision
- ### make sure we return False when fitok==False due to lack
- ### of free parameters
- fitok &= fit(fcn, final=1, verbose=verbose)
-
- return fitok
-
- def add_gaussian(self, fcn, parameters, dof, g3_only=False):
- """Try adding one more gaussian to fcn object.
- It's trying to reduce number of fitted parameters if
- there is not enough DoF left.
-
- Note: g1 fits amplitude only
- g3 fits amplitude and position
- g6 fits all parameters
-
- Parameters:
- fcn: MGFunction object
- parameters: initial values for gaussian parameters
- dof: total possible number of fitted parameters
- """
- from _cbdsm import Gtype
-
- if g3_only:
- gtype = (Gtype.g3 if fcn.fitted_parameters() + 3 <= dof else None)
- else:
- gtype = (Gtype.g3 if fcn.fitted_parameters() + 3 <= dof else None)
- gtype = (Gtype.g6 if fcn.fitted_parameters() + 6 <= dof else gtype)
-
- if gtype:
- fcn.add_gaussian(gtype, parameters)
- return True
- else:
- return False
-
- def flag_gaussians(self, gaul, opts, beam, thr, peak, shape, isl_mask, isl_image, size):
- """Flag gaussians according to some rules.
- Splits list of gaussian parameters in 2, where the first
- one is a list of parameters for accepted gaussians, and
- the second one is a list of pairs (flag, parameters) for
- flagged gaussians.
-
- Parameters:
- gaul: input list of gaussians
- opts: Opts object to extract flagging parameters from
- beam: beam shape
- thr: threshold for pixels with signal
- peak: peak data value in the current island
- shape: shape of the current island
- isl_mask: island mask
- """
- good = []
- bad = []
- for g in gaul:
-
- flag = self._flag_gaussian(g, beam, thr, peak, shape, opts, isl_mask, isl_image, size)
- if flag:
- bad.append((flag, g))
- else:
- good.append(g)
-
- return good, bad
-
- def _flag_gaussian(self, g, beam, thr, peak, shape, opts, mask, image, size_bms):
- """The actual flagging routine. See above for description.
- """
- from math import sqrt, sin, cos, log, pi
- from const import fwsig
- import functions as func
- import scipy.ndimage as nd
-
- A, x1, x2, s1, s2, th = g
- s1, s2 = map(abs, [s1, s2])
- flag = 0
- if N.any(N.isnan(g)) or s1 == 0.0 or s2 == 0.0:
- return -1
-
- if s1 < s2: # s1 etc are sigma
- ss1 = s2
- ss2 = s1
- th1 = divmod(th+90.0, 180)[1]
- else:
- ss1 = s1
- ss2 = s2
- th1 = divmod(th, 180)[1]
- th1 = th1/180.0*pi
- if ss1 > 1e4 and ss2 > 1e4:
- xbox = 1e9; ybox = 1e9
- else:
- xbox = 2.0*(abs(ss1*cos(th1)*cos(th1))+abs(ss2*ss2/ss1*sin(th1)*sin(th1)))/ \
- sqrt(cos(th1)*cos(th1)+ss2*ss2/ss1/ss1*sin(th1)*sin(th1))
- ybox = 2.0*(abs(ss1*sin(th1)*sin(th1))+abs(ss2*ss2/ss1*cos(th1)*cos(th1)))/ \
- sqrt(sin(th1)*sin(th1)+ss2*ss2/ss1/ss1*cos(th1)*cos(th1))
-
- ### now check all conditions
- border = opts.flag_bordersize
- x1ok = True
- x2ok = True
- flagmax = False
- if A < opts.flag_minsnr*thr: flag += 1
- if A > opts.flag_maxsnr*peak:
- flag += 2
- flagmax = True
- if x1 - border < 0 or x1 + border + 1 > shape[0]:
- flag += 4
- x1ok = False
- if x2 - border < 0 or x2 + border + 1 > shape[1]:
- flag += 8
- x2ok = False
- if x1ok and x2ok:
- if not flagmax:
- # Check image value at Gaussian center
- im_val_at_cen = nd.map_coordinates(image, [N.array([x1]), N.array([x2])])
- if A > opts.flag_maxsnr*im_val_at_cen:
- flag += 2
- borx1_1 = x1 - border
- if borx1_1 < 0: borx1_1 = 0
- borx1_2 = x1 + border + 1
- if borx1_2 > shape[0]: borx1_2 = shape[0]
- if N.any(mask[int(borx1_1):int(borx1_2), int(x2)]):
- flag += 4
- borx2_1 = x2 - border
- if borx2_1 < 0: borx2_1 = 0
- borx2_2 = x2 + border + 1
- if borx2_2 > shape[1]: borx2_2 = shape[1]
- if N.any(mask[int(x1), int(borx2_1):int(borx2_2)]):
- flag += 8
- if xbox > opts.flag_maxsize_isl*shape[0]: flag += 16
- if ybox > opts.flag_maxsize_isl*shape[1]: flag += 32
- if s1*s2 > opts.flag_maxsize_bm*beam[0]*beam[1]: flag += 64
- if opts.flag_smallsrc:
- if s1*s2 < opts.flag_minsize_bm*beam[0]*beam[1]: flag += 128
- if not opts.flag_smallsrc:
- if s1*s2 == 0.: flag += 128
-
- if ss1/ss2 > 2.0:
- # Only check for fairly elliptical Gaussians, as this condition
- # is unreliable for more circular ones.
- ellx, elly = func.drawellipse([A, x1, x2, s1*opts.flag_maxsize_fwhm,
- s2*opts.flag_maxsize_fwhm, th])
- pt1 = [N.min(ellx), elly[N.argmin(ellx)]]
- pt2 = [ellx[N.argmax(elly)], N.max(elly)]
- pt3 = [N.max(ellx), elly[N.argmax(ellx)]]
- pt4 = [ellx[N.argmin(elly)], N.min(elly)]
- extremes = [pt1, pt2, pt3, pt4]
- for pt in extremes:
- if pt[0] < 0 or pt[0] >= shape[0] or pt[1] < 0 or pt[1] >= shape[1]:
- flag += 256
- break
- elif mask[int(pt[0]),int(pt[1])]:
- flag += 256
- break
- return flag
-
- def fixup_gaussian(self, isl, gaussian):
- """Normalize parameters by adjusting them to the
- proper image coordinates and ensuring that all of
- the implicit conventions (such as bmaj >= bmin) are met.
- """
- np = list(gaussian)
-
- ### update to the image coordinates
- np[1] += isl.origin[0]
- np[2] += isl.origin[1]
-
- ### shape values should be positive
- np[3] = abs(np[3])
- np[4] = abs(np[4])
-
- ### first extent is major
- if np[3] < np[4]:
- np[3:5] = np[4:2:-1]
- np[5] += 90
-
- ### clip position angle
- np[5] = divmod(np[5], 180)[1]
-
- return np
-
- def check_for_1d_gaussians(self, img):
- """Check for Gaussians with deconvolved sizes of 0 for one axis only."""
- n1d = 0
- ng = 0
- for g in img.gaussians:
- ng += 1
- dsize = g.deconv_size_sky
- if (dsize[0] == 0 and dsize[1] > 0) or (dsize[0] > 0 and dsize[1] == 0):
- n1d += 1
- if ng > 0:
- return float(n1d)/float(ng)
- else:
- return 0.0
-
-def find_bbox(thresh, g):
- """Calculate bounding box for gaussian.
-
- This function calculates size of the box for evaluating
- gaussian, so that value of gaussian is smaller than threshold
- outside of the box.
-
- Parameters:
- thres: threshold
- g: Gaussian object or list of paramters
- """
-
- from math import ceil, sqrt, log
- if isinstance(g, list):
- A = g[0]
- S = g[3]
- else:
- A = g.peak_flux
- S = g.size_pix[0]
- if A == 0.0:
- return ceil(S*1.5)
- if thresh/A >= 1.0 or thresh/A <= 0.0:
- return ceil(S*1.5)
- return ceil(S*sqrt(-2*log(thresh/A)))
-
-
-from image import *
-
-class Gaussian(object):
- """Instances of this class are used to store information about
- extracted gaussians in a structured way.
- """
- gaussian_idx = Int(doc="Serial number of the gaussian within island")
- gaus_num = Int(doc="Serial number of the gaussian for the image", colname='Gaus_id')
- island_id = Int(doc="Serial number of the island", colname='Isl_id')
- flag = Int(doc="Flag associated with gaussian", colname='Flag')
- parameters = List(Float(), doc="Raw gaussian parameters")
- total_flux = Float(doc="Total flux density, Jy", colname='Total_flux', units='Jy')
- total_fluxE = Float(doc="Total flux density error, Jy", colname='E_Total_flux',
- units='Jy')
- peak_flux = Float(doc="Peak flux density/beam, Jy/beam", colname='Peak_flux',
- units='Jy/beam')
- peak_fluxE = Float(doc="Peak flux density/beam error, Jy/beam",
- colname='E_Peak_flux', units='Jy/beam')
- centre_sky = List(Float(), doc="Sky coordinates of gaussian centre",
- colname=['RA', 'DEC'], units=['deg', 'deg'])
- centre_skyE = List(Float(), doc="Error on sky coordinates of gaussian centre",
- colname=['E_RA', 'E_DEC'], units=['deg', 'deg'])
- centre_pix = List(Float(), doc="Pixel coordinates of gaussian centre",
- colname=['Xposn', 'Yposn'], units=['pix', 'pix'])
- centre_pixE = List(Float(), doc="Error on pixel coordinates of gaussian centre",
- colname=['E_Xposn', 'E_Yposn'], units=['pix', 'pix'])
- size_sky = List(Float(), doc="Shape of the gaussian FWHM, PA, deg",
- colname=['Maj', 'Min', 'PA'], units=['deg', 'deg',
- 'deg'])
- size_skyE = List(Float(), doc="Error on shape of the gaussian FWHM, PA, deg",
- colname=['E_Maj', 'E_Min', 'E_PA'], units=['deg', 'deg',
- 'deg'])
- deconv_size_sky = List(Float(), doc="Deconvolved shape of the gaussian FWHM, PA, deg",
- colname=['DC_Maj', 'DC_Min', 'DC_PA'], units=['deg', 'deg',
- 'deg'])
- deconv_size_skyE = List(Float(), doc="Error on deconvolved shape of the gaussian FWHM, PA, deg",
- colname=['E_DC_Maj', 'E_DC_Min', 'E_DC_PA'], units=['deg', 'deg',
- 'deg'])
- size_sky_uncorr = List(Float(), doc="Shape in image plane of the gaussian FWHM, PA, deg",
- colname=['Maj_img_plane', 'Min_img_plane', 'PA_img_plane'], units=['deg', 'deg',
- 'deg'])
- size_skyE_uncorr = List(Float(), doc="Error on shape in image plane of the gaussian FWHM, PA, deg",
- colname=['E_Maj_img_plane', 'E_Min_img_plane', 'E_PA_img_plane'], units=['deg', 'deg',
- 'deg'])
- deconv_size_sky_uncorr = List(Float(), doc="Deconvolved shape in image plane of the gaussian FWHM, PA, deg",
- colname=['DC_Maj_img_plane', 'DC_Min_img_plane', 'DC_PA_img_plane'], units=['deg', 'deg',
- 'deg'])
- deconv_size_skyE_uncorr = List(Float(), doc="Error on deconvolved shape in image plane of the gaussian FWHM, PA, deg",
- colname=['E_DC_Maj_img_plane', 'E_DC_Min_img_plane', 'E_DC_PA_img_plane'], units=['deg', 'deg',
- 'deg'])
- size_pix = List(Float(), doc="Shape of the gaussian FWHM, pixel units")
- size_pixE = List(Float(), doc="Error on shape of the gaussian FWHM, pixel units")
- rms = Float(doc="Island rms Jy/beam", colname='Isl_rms', units='Jy/beam')
- mean = Float(doc="Island mean Jy/beam", colname='Isl_mean', units='Jy/beam')
- total_flux_isl = Float(doc="Island total flux from sum of pixels", colname='Isl_Total_flux', units='Jy')
- total_flux_islE = Float(doc="Error on island total flux from sum of pixels", colname='E_Isl_Total_flux', units='Jy')
- gresid_rms = Float(doc="Island rms in Gaussian residual image", colname='Resid_Isl_rms', units='Jy/beam')
- gresid_mean= Float(doc="Island mean in Gaussian residual image", colname='Resid_Isl_mean', units='Jy/beam')
- sresid_rms = Float(doc="Island rms in Shapelet residual image", colname='Resid_Isl_rms', units='Jy/beam')
- sresid_mean= Float(doc="Island mean in Shapelet residual image", colname='Resid_Isl_mean', units='Jy/beam')
- jlevel = Int(doc="Wavelet number to which Gaussian belongs", colname='Wave_id')
-
- def __init__(self, img, gaussian, isl_idx, g_idx, flag=0):
- """Initialize Gaussian object from fitting data
-
- Parameters:
- img: PyBDSM image object
- gaussian: 6-tuple of fitted numbers
- isl_idx: island serial number
- g_idx: gaussian serial number
- flag: flagging (if any)
- """
- import functions as func
- from const import fwsig
- import numpy as N
-
- use_wcs = True
- self.gaussian_idx = g_idx
- self.gaus_num = 0 # stored later
- self.island_id = isl_idx
- self.jlevel = img.j
- self.flag = flag
- self.parameters = gaussian
-
- p = gaussian
- self.peak_flux = p[0]
- self.centre_pix = p[1:3]
- size = p[3:6]
- if func.approx_equal(size[0], img.pixel_beam()[0]*1.1) and \
- func.approx_equal(size[1], img.pixel_beam()[1]) and \
- func.approx_equal(size[2], img.pixel_beam()[2]+90.0) or \
- img.opts.fix_to_beam:
- # Check whether fitted Gaussian is just the distorted pixel beam
- # given as an initial guess or if size was fixed to the beam. If so,
- # reset the size to the undistorted beam.
- # Note: these are sigma sizes, not FWHM sizes.
- size = img.pixel_beam()
- size = (size[0], size[1], size[2]+90.0) # adjust angle so that corrected_size() works correctly
- size = func.corrected_size(size) # gives fwhm and P.A.
- self.size_pix = size # FWHM in pixels and P.A. CCW from +y axis
-
- # Use img.orig_beam for flux calculation and deconvolution on wavelet
- # images, as img.beam has been altered to match the wavelet scale.
- # Note: these are all FWHM sizes.
- if img.waveletimage:
- bm_pix = N.array(img.beam2pix(img.orig_beam))
- else:
- bm_pix = N.array(img.beam2pix(img.beam))
-
- # Calculate fluxes, sky sizes, etc. All sizes are FWHM.
- tot = p[0]*size[0]*size[1]/(bm_pix[0]*bm_pix[1])
- if flag == 0:
- # These are good Gaussians
- errors = func.get_errors(img, p+[tot], img.islands[isl_idx].rms)
- self.centre_sky = img.pix2sky(p[1:3])
- self.centre_skyE = img.pix2coord(errors[1:3], self.centre_pix, use_wcs=use_wcs)
- self.size_sky = img.pix2gaus(size, self.centre_pix, use_wcs=use_wcs) # FWHM in degrees and P.A. east from north
- self.size_sky_uncorr = img.pix2gaus(size, self.centre_pix, use_wcs=False) # FWHM in degrees and P.A. east from +y axis
- self.size_skyE = img.pix2gaus(errors[3:6], self.centre_pix, use_wcs=use_wcs)
- self.size_skyE_uncorr = img.pix2gaus(errors[3:6], self.centre_pix, use_wcs=False)
- gaus_dc, err = func.deconv2(bm_pix, size)
- self.deconv_size_sky = img.pix2gaus(gaus_dc, self.centre_pix, use_wcs=use_wcs)
- self.deconv_size_sky_uncorr = img.pix2gaus(gaus_dc, self.centre_pix, use_wcs=False)
- self.deconv_size_skyE = img.pix2gaus(errors[3:6], self.centre_pix, use_wcs=use_wcs)
- self.deconv_size_skyE_uncorr = img.pix2gaus(errors[3:6], self.centre_pix, use_wcs=False)
- else:
- # These are flagged Gaussians, so don't calculate sky values or errors
- errors = [0]*7
- self.centre_sky = [0., 0.]
- self.centre_skyE = [0., 0.]
- self.size_sky = [0., 0., 0.]
- self.size_sky_uncorr = [0., 0., 0.]
- self.size_skyE = [0., 0.]
- self.size_skyE_uncorr = [0., 0., 0.]
- self.deconv_size_sky = [0., 0., 0.]
- self.deconv_size_sky_uncorr = [0., 0., 0.]
- self.deconv_size_skyE = [0., 0., 0.]
- self.deconv_size_skyE_uncorr = [0., 0., 0.]
- self.total_flux = tot
- self.total_fluxE = errors[6]
- self.peak_fluxE = errors[0]
- self.total_fluxE = errors[6]
- self.centre_pixE = errors[1:3]
- self.size_pixE = errors[3:6]
- self.rms = img.islands[isl_idx].rms
- self.mean = img.islands[isl_idx].mean
- self.total_flux_isl = img.islands[isl_idx].total_flux
- self.total_flux_islE = img.islands[isl_idx].total_fluxE
-
-
-### Insert attributes into Island class
-from islands import Island
-Island.gaul = List(tInstance(Gaussian), doc="List of extracted gaussians")
-Island.fgaul= List(tInstance(Gaussian),
- doc="List of extracted (flagged) gaussians")
diff --git a/CEP/PyBDSM/src/python/image.py b/CEP/PyBDSM/src/python/image.py
deleted file mode 100644
index cb4e1778211d115aa5c5e9cc4f649b2d69299210..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/python/image.py
+++ /dev/null
@@ -1,201 +0,0 @@
-"""Module image.
-
-Instances of class Image are a primary data-holders for all PyBDSM
-operations. They store the image itself together with some meta-information
-(such as headers), options for processing modules and all data generated during
-processing. A few convenience methods are also defined here for interactive
-use: to allow viewing and output of the most important data, to allow listing
-and setting of options, and to allow re-processing of Images (these methods are
-used by the interactive IPython shell made by pybdsm.py).
-
-This module also defines class Op, which is used as a base class for all PyBDSM
-operations.
-"""
-
-import numpy as N
-from opts import *
-
-class Image(object):
- """Image is a primary data container for PyBDSM.
-
- All the run-time data (such as image data, mask, etc.)
- is stored here. A number of type-checked properties
- are defined for the most basic image attributes, such
- as image data, mask, header, user options.
-
- To allow transparent caching of large image data to disk,
- the image data must be stored in attributes ending in
- "_arr". Additionally, setting subarrays does not work
- using the attributes directly (e.g., img.ch0_arr[0:100,0:100]
- = 0.0 will not work). Instead, set the subarray values then set
- the attribute (e.g., ch0[0:100,0:100] = 0.0; img.ch0_arr = ch0).
-
- There is little sense in declaring all possible attributes
- right here as it will introduce unneeded dependencies
- between modules, thus most other attributes (like island lists,
- gaussian lists, etc) are inserted at run-time by the specific
- PyBDSM modules.
- """
- opts = Instance(Opts, doc="User options")
- header = Any(doc="Image header")
- masked = Bool(False, doc="Flag if mask is present")
- basedir = String('DUMMY', doc="Base directory for output files")
- completed_Ops = List(String(), doc="List of completed operations")
- _is_interactive_shell = Bool(False, doc="PyBDSM is being used in the interactive shell")
- waveletimage = Bool(False, doc="Image is a wavelet transform image")
- _pi = Bool(False, doc="Image is a polarized intensity image")
- do_cache = Bool(False, doc="Cache images to disk")
-
- def __init__(self, opts):
- self.opts = Opts(opts)
- self._prev_opts = None
- self.extraparams = {}
-
- def __setstate__(self, state):
- """Needed for multiprocessing"""
- self.thresh_pix = state['thresh_pix']
- self.minpix_isl = state['minpix_isl']
- self.clipped_mean = state['clipped_mean']
-
- def __getstate__(self):
- """Needed for multiprocessing"""
- state = {}
- state['thresh_pix'] = self.thresh_pix
- state['minpix_isl'] = self.minpix_isl
- state['clipped_mean'] = self.clipped_mean
- return state
-
- def __getattribute__(self, name):
- import functions as func
- if name.endswith("_arr"):
- if self.do_cache:
- map_data = func.retrieve_map(self, name)
- if map_data is not None:
- return map_data
- else:
- return object.__getattribute__(self, name)
- else:
- return object.__getattribute__(self, name)
- else:
- return object.__getattribute__(self, name)
-
- def __setattr__(self, name, value):
- import functions as func
- if self.do_cache and name.endswith("_arr") and isinstance(value, N.ndarray):
- func.store_map(self, name, value)
- else:
- super(Image, self).__setattr__(name, value)
-
- def __delattr__(self, name):
- import functions as func
- if self.do_cache and name.endswith("_arr"):
- func.del_map(self, name)
- else:
- super(Image, self).__delattr__(name)
-
- def get_map(self, map_name):
- """Returns requested map."""
- import functions as func
- if self.do_cache:
- map_data = func.retrieve_map(self, map_name)
- else:
- map_data = getattr(self, map_name)
- return map_data
-
- def put_map(self, map_name, map_data):
- """Stores requested map."""
- import functions as func
- if self.do_cache:
- func.store_map(self, map_name, map_data)
- else:
- setattr(self, map_name, map_data)
-
- def list_pars(self):
- """List parameter values."""
- import interface
- interface.list_pars(self)
-
- def set_pars(self, **kwargs):
- """Set parameter values."""
- import interface
- interface.set_pars(self, **kwargs)
-
- def process(self, **kwargs):
- """Process Image object"""
- import interface
- success = interface.process(self, **kwargs)
- return success
-
- def save_pars(self, savefile=None):
- """Save parameter values."""
- import interface
- interface.save_pars(self, savefile)
-
- def load_pars(self, loadfile=None):
- """Load parameter values."""
- import interface
- import os
- if loadfile is None or loadfile == '':
- loadfile = self.opts.filename + '.pybdsm.sav'
- if os.path.exists(loadfile):
- timg, err = interface.load_pars(loadfile)
- if timg is not None:
- orig_filename = self.opts.filename
- self.opts = timg.opts
- self.opts.filename = orig_filename # reset filename to original
- else:
- if self._is_interactive_shell:
- print "\n\033[31;1mERROR\033[0m: '"+\
- loadfile+"' is not a valid parameter save file."
- else:
- raise RuntimeError(str(err))
- else:
- if self._is_interactive_shell:
- print "\n\033[31;1mERROR\033[0m: File '"+\
- loadfile+"' not found."
- else:
- raise RuntimeError('File not found')
-
- def show_fit(self, **kwargs):
- """Show results of the fit."""
- import plotresults
- if not hasattr(self, 'nisl'):
- print 'Image has not been processed. Please run process_image first.'
- return False
- plotresults.plotresults(self, **kwargs)
- return True
-
- def export_image(self, **kwargs):
- """Export an internal image to a file."""
- import interface
- try:
- result = interface.export_image(self, **kwargs)
- return result
- except RuntimeError, err:
- if self._is_interactive_shell:
- print "\n\033[31;1mERROR\033[0m: " + str(err)
- else:
- raise RuntimeError(str(err))
-
- def write_catalog(self, **kwargs):
- """Write the Gaussian, source, or shapelet list to a file"""
- import interface
- try:
- result = interface.write_catalog(self, **kwargs)
- return result
- except RuntimeError, err:
- if self._is_interactive_shell:
- print "\n\033[31;1mERROR\033[0m: " + str(err)
- else:
- raise RuntimeError(str(err))
-
-
-class Op(object):
- """Common base class for all PyBDSM operations.
-
- At the moment this class is empty and only defines placeholder
- for method __call__, which should be redefined in all derived
- classes.
- """
- def __call__(self, img):
- raise NotImplementedError("This method should be redefined")
diff --git a/CEP/PyBDSM/src/python/interface.py b/CEP/PyBDSM/src/python/interface.py
deleted file mode 100644
index e7c64fd2805f46903bc5c1d8bd64fb4767baa66a..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/python/interface.py
+++ /dev/null
@@ -1,1129 +0,0 @@
-"""Interface module.
-
-The interface module handles all functions typically needed by the user in an
-interactive environment such as IPython. Many are also used by the
-custom IPython shell defined in pybdsm.py.
-
-"""
-
-def process(img, **kwargs):
- """Find and measure sources in an image.
-
- This function is used by process_image in __init__.py and by process_image
- in pybdsm.py. It is also used as a method of the Image object in image.py
- to allow reprocessing of existing Image objects with the command
- img.process().
-
- Any options given as keyword arguments will override existing ones stored
- in img.opts.
- """
- from . import default_chain, _run_op_list
- from image import Image
- import mylogger
-
- # Start up logger. We need to initialize it each time process() is
- # called, in case the quiet or debug options have changed
- log = img.opts.filename + '.pybdsm.log'
- img.log = ''
- mylogger.init_logger(log, quiet=img.opts.quiet,
- debug=img.opts.debug)
- add_break_to_logfile(log)
- mylog = mylogger.logging.getLogger("PyBDSM.Process")
- mylog.info("Processing "+img.opts.filename)
-
- try:
- # set options if given
- if len(kwargs) > 0:
- set_pars(img, **kwargs)
- except RuntimeError, err:
- # Catch and log error
- mylog.error(str(err))
-
- # Re-throw error if the user is not in the interactive shell
- if img._is_interactive_shell:
- return False
- else:
- raise
-
- # Run all the op's
- try:
- # Run op's in chain
- img, op_chain = get_op_chain(img)
- if op_chain is not None:
- _run_op_list(img, op_chain)
- img._prev_opts = img.opts.to_dict()
- return True
- except RuntimeError, err:
- # Catch and log error
- mylog.error(str(err))
-
- # Re-throw error if the user is not in the interactive shell
- if img._is_interactive_shell:
- return False
- else:
- raise
- except KeyboardInterrupt:
- mylogger.userinfo(mylog, "\n\033[31;1mAborted\033[0m")
- return False
-
-def get_op_chain(img):
- """Determines the optimal Op chain for an Image object.
-
- This is useful when reprocessing an Image object. For example,
- if Gaussians were already fit, but the user now wants to use
- shapelets, we do not need to re-run Op_gausfit, etc.
-
- Note that any new options added to opts.py should also be
- added here. If not, a full reprocessing will be done if the
- new option is changed.
- """
- from . import default_chain
- Op_chain = default_chain[:]
- Op_names = ['readimage',
- 'collapse',
- 'preprocess',
- 'rmsimage',
- 'threshold',
- 'islands',
- 'gausfit',
- 'wavelet_atrous',
- 'shapelets',
- 'gaul2srl',
- 'spectralindex',
- 'polarisation',
- 'make_residimage',
- 'psf_vary',
- 'outlist',
- 'cleanup']
- prev_opts = img._prev_opts
- if prev_opts is None:
- return img, default_chain
- new_opts = img.opts.to_dict()
-
- # Set the hidden options, which should include any option whose change
- # should not trigger a process_image action
- hidden_opts = img.opts.get_names(group='hidden')
- hidden_opts.append('advanced_opts')
- hidden_opts.append('flagging_opts')
- hidden_opts.append('multichan_opts')
- hidden_opts.append('output_opts')
-
- # Define lists of options for each Op. Some of these can be defined
- # using the "group" parameter of each option.
- #
- # Op_readimage()
- readimage_opts = ['filename', 'beam', 'trim_box', 'frequency',
- 'beam_spectrum', 'frequency_sp']
-
- # Op_collapse()
- collapse_opts = img.opts.get_names(group='multichan_opts')
- collapse_opts.append('polarisation_do')
- collapse_opts += readimage_opts
-
- # Op_preprocess()
- preprocess_opts = ['kappa_clip', 'polarisation_do']
- preprocess_opts += collapse_opts
-
- # Op_rmsimage()
- rmsimage_opts = ['rms_box', 'rms_box_bright', 'adaptive_rms_box',
- 'mean_map', 'rms_map', 'adaptive_thresh', 'rms_box_bright']
- rmsimage_opts += preprocess_opts
-
- # Op_threshold()
- threshold_opts = ['thresh', 'thresh_pix', 'thresh_isl']
- threshold_opts += rmsimage_opts
-
- # Op_islands()
- islands_opts = threshold_opts
- islands_opts.append('minpix_isl')
-
- # Op_gausfit()
- gausfit_opts = ['verbose_fitting']
- gausfit_opts += islands_opts
- gausfit_opts += img.opts.get_names(group='flagging_opts')
-
- # Op_wavelet_atrous()
- wavelet_atrous_opts = img.opts.get_names(group='atrous_do')
- wavelet_atrous_opts.append('atrous_do')
- wavelet_atrous_opts += gausfit_opts
-
- # Op_shapelets()
- shapelets_opts = img.opts.get_names(group='shapelet_do')
- shapelets_opts.append('shapelet_do')
- shapelets_opts += islands_opts
-
- # Op_gaul2srl()
- gaul2srl_opts = ['group_tol', 'group_by_isl', 'group_method']
- gaul2srl_opts += gausfit_opts
- gaul2srl_opts += wavelet_atrous_opts
-
- # Op_spectralindex()
- spectralindex_opts = img.opts.get_names(group='spectralindex_do')
- spectralindex_opts.append('spectralindex_do')
- spectralindex_opts += gaul2srl_opts
-
- # Op_polarisation()
- polarisation_opts = img.opts.get_names(group='polarisation_do')
- polarisation_opts.append('polarisation_do')
- polarisation_opts += gaul2srl_opts
-
- # Op_make_residimage()
- make_residimage_opts = ['fittedimage_clip']
- make_residimage_opts += gausfit_opts
- make_residimage_opts += wavelet_atrous_opts
- make_residimage_opts += shapelets_opts
-
- # Op_psf_vary()
- psf_vary_opts = img.opts.get_names(group='psf_vary_do')
- psf_vary_opts.append('psf_vary_do')
- psf_vary_opts += gaul2srl_opts
-
- # Op_outlist() and Op_cleanup() are always done.
-
- # Find whether new opts differ from previous opts (and are not hidden
- # opts, which should not be checked). If so, found = True and we reset
- # the relevant image parameters and add the relevant Op to the Op_chain.
- re_run = False
- found = False
- for k, v in prev_opts.iteritems():
- if v != new_opts[k] and k not in hidden_opts:
- re_run = True
- if k in readimage_opts:
- if hasattr(img, 'use_io'): del img.use_io
- if hasattr(img, 'image_arr'): del img.image_arr
- while 'readimage' in img.completed_Ops:
- img.completed_Ops.remove('readimage')
- found = True
- if k in collapse_opts:
- if hasattr(img, 'mask_arr'): del img.mask_arr
- if hasattr(img, 'ch0_arr'): del img.ch0_arr
- while 'collapse' in img.completed_Ops:
- img.completed_Ops.remove('collapse')
- found = True
- if k in preprocess_opts:
- while 'preprocess' in img.completed_Ops:
- img.completed_Ops.remove('preprocess')
- found = True
- if k in rmsimage_opts:
- if hasattr(img, 'rms_arr'): del img.rms_arr
- if hasattr(img, 'mean_arr'): del img.mean_arr
- if hasattr(img, 'rms_Q_arr'): del img.rms_Q_arr
- if hasattr(img, 'mean_Q_arr'): del img.mean_Q_arr
- if hasattr(img, 'rms_U_arr'): del img.rms_U_arr
- if hasattr(img, 'mean_U_arr'): del img.mean_U_arr
- if hasattr(img, 'rms_V_arr'): del img.rms_V_arr
- if hasattr(img, 'mean_V_arr'): del img.mean_V_arr
- if hasattr(img, '_adapt_rms_isl_pos'): del img._adapt_rms_isl_pos
- while 'rmsimage' in img.completed_Ops:
- img.completed_Ops.remove('rmsimage')
- found = True
- if k in threshold_opts:
- while 'threshold' in img.completed_Ops:
- img.completed_Ops.remove('threshold')
- found = True
- if k in islands_opts:
- if hasattr(img, 'islands'): del img.islands
- while 'islands' in img.completed_Ops:
- img.completed_Ops.remove('islands')
- found = True
- if k in gausfit_opts:
- if hasattr(img, 'sources'): del img.sources
- if hasattr(img, 'dsources'): del img.dsources
- if hasattr(img, 'gaussians'): del img.gaussians
- while 'gausfit' in img.completed_Ops:
- img.completed_Ops.remove('gausfit')
- found = True
- if k in wavelet_atrous_opts:
- if hasattr(img, 'atrous_gaussians'): del img.atrous_gaussians
- if hasattr(img, 'islands'): del img.islands
- if hasattr(img, 'sources'): del img.sources
- if hasattr(img, 'dsources'): del img.dsources
- if hasattr(img, 'gaussians'): del img.gaussians
- while 'islands' in img.completed_Ops:
- img.completed_Ops.remove('islands')
- while 'gausfit' in img.completed_Ops:
- img.completed_Ops.remove('gausfit')
- while 'wavelet_atrous' in img.completed_Ops:
- img.completed_Ops.remove('wavelet_atrous')
- found = True
- if k in shapelets_opts:
- while 'shapelets' in img.completed_Ops:
- img.completed_Ops.remove('shapelets')
- found = True
- if k in gaul2srl_opts:
- while 'gaul2srl' in img.completed_Ops:
- img.completed_Ops.remove('gaul2srl')
- found = True
- if k in spectralindex_opts:
- while 'spectralindex' in img.completed_Ops:
- img.completed_Ops.remove('spectralindex')
- found = True
- if k in polarisation_opts:
- while 'polarisation' in img.completed_Ops:
- img.completed_Ops.remove('polarisation')
- found = True
- if k in make_residimage_opts:
- if hasattr(img, 'resid_gaus_arr'): del img.resid_gaus_arr
- if hasattr(img, 'model_gaus_arr'): del img.model_gaus_arr
- if hasattr(img, 'resid_shap_arr'): del img.resid_shap_arr
- if hasattr(img, 'model_shap_arr'): del img.model_shap_arr
- while 'make_residimage' in img.completed_Ops:
- img.completed_Ops.remove('make_residimage')
- found = True
- if k in psf_vary_opts:
- while 'psf_vary' in img.completed_Ops:
- img.completed_Ops.remove('psf_vary')
- found = True
- if not found:
- break
-
- # If nothing has changed, ask if user wants to re-run
- if not found and not re_run:
- prompt = "Analysis appears to be up-to-date. Force reprocessing (y/n)? "
- answ = raw_input_no_history(prompt)
- while answ.lower() not in ['y', 'n', 'yes', 'no']:
- answ = raw_input_no_history(prompt)
- if answ.lower() in ['y', 'yes']:
- re_run = True # Force re-run
- else:
- return img, None
-
- # If a changed option is not in any of the above lists,
- # force a re-run of all Ops.
- if not found:
- del img.completed_Ops
- if hasattr(img, 'use_io'): del img.use_io
- if hasattr(img, 'image_arr'): del img.image_arr
- if hasattr(img, 'mask_arr'): del img.mask_arr
- if hasattr(img, 'ch0_arr'): del img.ch0_arr
- if hasattr(img, 'rms_arr'): del img.rms_arr
- if hasattr(img, 'mean_arr'): del img.mean_arr
- if hasattr(img, 'rms_Q_arr'): del img.rms_Q_arr
- if hasattr(img, 'mean_Q_arr'): del img.mean_Q_arr
- if hasattr(img, 'rms_U_arr'): del img.rms_U_arr
- if hasattr(img, 'mean_U_arr'): del img.mean_U_arr
- if hasattr(img, 'rms_V_arr'): del img.rms_V_arr
- if hasattr(img, 'mean_V_arr'): del img.mean_V_arr
- if hasattr(img, 'islands'): del img.islands
- if hasattr(img, 'sources'): del img.sources
- if hasattr(img, 'dsources'): del img.dsources
- if hasattr(img, 'gaussians'): del img.gaussians
- if hasattr(img, 'atrous_gaussians'): del img.atrous_gaussians
- if hasattr(img, 'resid_gaus_arr'): del img.resid_gaus_arr
- if hasattr(img, 'model_gaus_arr'): del img.model_gaus_arr
- if hasattr(img, 'resid_shap_arr'): del img.resid_shap_arr
- if hasattr(img, 'model_shap_arr'): del img.model_shap_arr
- if hasattr(img, '_adapt_rms_isl_pos'): del img._adapt_rms_isl_pos
- return img, Op_chain
-
- while 'outlist' in img.completed_Ops:
- img.completed_Ops.remove('outlist')
- while 'cleanup' in img.completed_Ops:
- img.completed_Ops.remove('cleanup')
- for completed_Op in img.completed_Ops:
- if completed_Op in Op_names:
- Op_indx = Op_names.index(completed_Op)
- Op_names.pop(Op_indx)
- Op_chain.pop(Op_indx)
-
- return img, Op_chain
-
-def load_pars(filename):
- """Load parameters from a save file or dictionary.
-
- If a file is given, it must be a pickled opts dictionary.
-
- filename - name of options file to load or a dictionary of opts.
- Returns None (and original error) if no file can be loaded successfully.
- """
- from image import Image
- import mylogger
- try:
- import cPickle as pickle
- except ImportError:
- import pickle
-
- # First, check if input is a dictionary
- if isinstance(filename, dict):
- timg = Image(filename)
- return timg, None
- else:
- try:
- pkl_file = open(filename, 'rb')
- pars = pickle.load(pkl_file)
- pkl_file.close()
- timg = Image(pars)
- print "--> Loaded parameters from file '" + filename + "'."
- return timg, None
- except Exception, err:
- return None, err
-
-def save_pars(img, savefile=None, quiet=False):
- """Save parameters to a file.
-
- The save file is a "pickled" opts dictionary.
- """
- try:
- import cPickle as pickle
- except ImportError:
- import pickle
- import tc
- import sys
-
- if savefile is None or savefile == '':
- savefile = img.opts.filename + '.pybdsm.sav'
-
- # convert opts to dictionary
- pars = img.opts.to_dict()
- output = open(savefile, 'wb')
- pickle.dump(pars, output)
- output.close()
- if not quiet:
- print "--> Saved parameters to file '" + savefile + "'."
-
-def list_pars(img, opts_list=None, banner=None, use_groups=True):
- """Lists all parameters for the Image object.
-
- opts_list - a list of the parameter names to list;
- if None, all parameters are used.
- banner - banner text to place at top of listing.
- use_groups - whether to use the group information for each
- parameter.
- """
- import tc
- import sys
-
- # Get all options as a list sorted by name
- opts = img.opts.to_list()
-
- # Filter list
- if opts_list is not None:
- opts_temp = []
- for o in opts:
- if o[0] in opts_list:
- opts_temp.append(o)
- opts = opts_temp
-
- # Move filename, infile, outfile to front of list
- for o in opts:
- if o[0] == 'filename' or o[0] == 'infile' or o[0] == 'outfile':
- opts.remove(o)
- opts.insert(0, o)
-
- # Now group options with the same "group" together.
- if use_groups:
- opts = group_opts(opts)
-
- # Finally, print options, values, and doc strings to screen
- print_opts(opts, img, banner=banner)
-
-
-def set_pars(img, **kwargs):
- """Set parameters using arguments instead of using a dictionary.
-
- Allows partial names for parameters as long as they are unique. Parameters
- are set to default values if par = ''.
- """
- import re
- import sys
- from image import Image
-
- # Enumerate all options
- opts = img.opts.get_names()
-
- # Check that parameters are valid options and are unique
- full_key = []
- for i, key in enumerate(kwargs):
- chk_key = checkpars(opts, key)
- if chk_key == []:
- raise RuntimeError("Input parameter '" + key + "' not recognized.")
- if len(chk_key) > 1 and key not in opts:
- raise RuntimeError("Input parameter '" + key + "' matches to more than one "\
- "possible parameter:\n " + "\n ".join(chk_key))
- if key in opts:
- full_key.append(key)
- else:
- full_key.append(chk_key[0])
-
- # Build options dictionary
- pars = {}
- for i, key in enumerate(kwargs):
- if kwargs[key] == '':
- temp_img = Image({'filename':''})
- opt_names = temp_img.opts.get_names()
- for k in opt_names:
- if key == k:
- kwargs[key] = temp_img.opts.__getattribute__(k)
- pars.update({full_key[i]: kwargs[key]})
-
- # Finally, set the options
- img.opts.set_opts(pars)
-
-
-def group_opts(opts):
- """Sorts options by group (as defined in opts.py).
-
- Returns a list of options, with suboptions arranged in a list inside the
- main list and directly following the main options. Options belonging to the
- "hidden" group are excluded from the returned list (as defined in opts.py).
- """
- groups = []
- gp = []
- for i in range(len(opts)):
- grp = opts[i][1].group()
- if grp is not None and grp not in groups:
- groups.append(opts[i][1].group())
-
- groups.sort()
-
- # Now, make a list for each group with its options. Don't include
- # "hidden" options, as they should never by seen by the user.
- for g in groups:
- g_list = []
- for i in range(len(opts)):
- if isinstance(opts[i], tuple):
- if g == str(opts[i][1].group()):
- g_list.append(opts[i])
- for gs in g_list:
- opts.remove(gs)
-
- for i in range(len(opts)):
- if g == str(opts[i][0]) and g != 'hidden':
- opts.insert(i+1, g_list)
- break
- return opts
-
-
-def print_opts(grouped_opts_list, img, banner=None):
- """Print options to screen.
-
- Options can be sorted by group (defined in opts.py) previously defined by
- group_opts. Output of grouped items is suppressed if parent option is
- False. The layout is as follows:
-
- [20 spaces par name with ...] = [at least 49 spaces for value]
- [at least 49 spaces for doc]
-
- When more than one line is required for the doc, the next line is:
-
- [25 blank spaces][at least 47 spaces for doc]
-
- As in casapy, print non-defaults in blue, options with suboptions in
- 47m and suboptions in green. Option Values are printed in bold, to help
- to distinguish them from the descriptions. NOTE: in iTerm, one needs
- to set the bold color in the profiles to white, as it defaults to red,
- which is a bit hard on the eyes in this case.
- """
- from image import Image
- import os
- import functions as func
-
- termy, termx = func.getTerminalSize() # note: returns row, col -> y, x
- minwidth = 28 # minimum width for parameter names and values
-
- # Define colors for output
- dc = '\033[1;34m' # Blue: non-default option text color
- ec = '\033[0;47m' # expandable option text color
- sc = '\033[0;32m' # Green: suboption text color
- nc = '\033[0m' # normal text color
- ncb = '\033[1m' # normal text color bold
-
- if banner is not None:
- print banner
- spcstr = ' ' * minwidth # spaces string for second or later lines
- infix = nc + ': ' + nc # infix character used to separate values from comments
- print '=' * termx # division string for top of parameter listing
- for indx, o in enumerate(grouped_opts_list):
- if isinstance(o, tuple):
- # Print main options, which are always tuples, before printing
- # suboptions (if any).
- k = o[0]
- v = o[1]
- val = img.opts.__getattribute__(k)
- v1 = v2 = ''
- if val == v._default:
- # value is default
- v1 = ncb
- v2 = nc
- else:
- # value is non-default
- v1 = dc
- v2 = nc
- if isinstance(val, str):
- valstr = v1 + repr(val) + v2
- if k == 'filename':
- # Since we can check whether filename is valid,
- # do so here and print in red if not.
- if not os.path.exists(val):
- valstr = '\033[31;1m' + repr(val) + nc
- width_par_val = max(minwidth, len(k) + len(str(val)) + 5)
- else:
- if isinstance(val, float):
- val = round_float(val)
- if isinstance(val, tuple):
- val = round_tuple(val)
- valstr = v1 + str(val) + v2
- width_par_val = max(minwidth, len(k) + len(str(val)) + 4)
- width_desc = max(termx - width_par_val - 3, 44)
- # Get the option description text from the doc string, which
- # is defined in opts.py. By convention, print_opts will only
- # show the short description; help('option_name') will
- # print both the short and long description. The versions
- # are separated in the doc string by '\n', which is split
- # on here:
- desc_text = wrap(str(v.doc()).split('\n')[0], width_desc)
- fmt = '%' + str(minwidth) + 's' + infix + '%44s'
-
- # Now loop over lines of description
- if indx < len(grouped_opts_list)-1:
- # Here we check if next entry in options list is a tuple or a
- # list. If it is a list, then the current option has
- # suboptions and should be in the ec color. Since we check the
- # next option, we can't do this if we let indx go to the end.
- if isinstance(grouped_opts_list[indx+1], tuple):
- parvalstr = nc + k + nc + ' ..'
- else:
- parvalstr = ec + k + nc + ' ..'
- else:
- # Since this is the last entry in the options list and is a
- # tuple, it cannot be an expandable option, so make it nc color
- parvalstr = nc + k + nc + ' ..'
- if "'" in valstr:
- len_without_formatting = len(k) + len(str(val)) + 5
- else:
- len_without_formatting = len(k) + len(str(val)) + 4
- for i in range(len_without_formatting, minwidth):
- parvalstr += '.'
- parvalstr += ' ' + valstr
- if "'" not in valstr:
- parvalstr += ' '
- for dt_indx, dt in enumerate(desc_text):
- if dt_indx == 0:
- print fmt % (parvalstr.ljust(minwidth), dt.ljust(44))
- else:
- print nc + spcstr + ' %44s' % dt.ljust(44)
- else:
- # Print suboptions, indented 2 spaces from main options in sc color
- parent_opt = grouped_opts_list[indx-1]
- parent_val = img.opts.__getattribute__(parent_opt[0])
- if parent_val == True:
- for og in o:
- k = og[0]
- v = og[1]
- val = img.opts.__getattribute__(k)
- v1 = v2 = ''
- if val == v._default:
- # value is default
- v1 = ncb
- v2 = nc
- else:
- # value is non-default
- v1 = dc
- v2 = nc
- if isinstance(val, str):
- valstr = v1 + repr(val) + v2
- width_par_val = max(minwidth, len(k) + len(str(val)) + 7)
- else:
- if isinstance(val, float):
- val = round_float(val)
- if k == 'beam_spectrum' and val is not None:
- val = round_list_of_tuples(val)
- if k == 'frequency_sp' and val is not None:
- val = round_list(val)
- valstr = v1 + str(val) + v2
- width_par_val = max(minwidth, len(k) + len(str(val)) + 6)
- width_desc = max(termx - width_par_val - 3, 44)
- desc_text = wrap(str(v.doc()).split('\n')[0], width_desc)
- fmt = ' ' + '%' + str(minwidth) + 's' + infix + '%44s'
- parvalstr = sc + k + nc + ' ..'
- if "'" in valstr:
- len_without_formatting = len(k) + len(str(val)) + 7
- else:
- len_without_formatting = len(k) + len(str(val)) + 6
- for i in range(len_without_formatting, minwidth):
- parvalstr += '.'
- parvalstr += ' ' + valstr
- if "'" not in valstr:
- parvalstr += ' '
- for dt_indx, dt in enumerate(desc_text):
- if dt_indx == 0:
- print fmt % (parvalstr.ljust(minwidth-2), dt.ljust(44))
- else:
- print nc + spcstr + ' %44s' % dt.ljust(44)
-
-
-def wrap(text, width=80):
- """Wraps text to given width and returns list of lines."""
- lines = []
- for paragraph in text.split('\n'):
- line = []
- len_line = 0
- for word in paragraph.split(' '):
- word.strip()
- len_word = len(word)
- if len_line + len_word <= width:
- line.append(word)
- len_line += len_word + 1
- else:
- lines.append(' '.join(line))
- line = [word]
- len_line = len_word + 1
- lines.append(' '.join(line))
- return lines
-
-
-def checkpars(lines, regex):
- """Checks that parameters are unique"""
- import re
- result = []
- for l in lines:
- match = re.match(regex,l)
- if match:
- result += [l]
- return result
-
-
-def in_ipython():
- """Checks if interpreter is IPython."""
- try:
- __IPYTHON__
- except NameError:
- return False
- else:
- return True
-
-
-def raw_input_no_history(prompt):
- """Removes user input from readline history."""
- import readline
- input = raw_input(prompt)
- if input != '':
- readline.remove_history_item(readline.get_current_history_length()-1)
- return input
-
-
-# The following functions just make the printing of
-# parameters look better
-def round_tuple(val):
- valstr_list = []
- for v in val:
- vstr = '%s' % (round(v, 5))
- if len(vstr) > 7:
- vstr = '%.5f' % (v,)
- valstr_list.append(vstr)
- valstr = '(' + ','.join(valstr_list) + ')'
- return valstr
-
-def round_float(val):
- vstr = '%s' % (round(val, 5))
- if len(vstr) > 7 and val < 1e3:
- vstr = '%.5f' % (val,)
- elif len(vstr) > 7 and val >= 1e3:
- vstr = '%.2e' % (val,)
- return vstr
-
-def round_list(val):
- valstr_list = []
- for v in val:
- valstr_list.append('%.2e' % (v,))
- valstr = '[' + ','.join(valstr_list) + ']'
- return valstr
-
-def round_list_of_tuples(val):
- valstr_list = []
- valstr_list_tot = []
- for l in val:
- for v in l:
- vstr = '%s' % (round(v, 5))
- if len(vstr) > 7:
- vstr = '%.5f' % (v,)
- valstr_list.append(vstr)
- valstr = '(' + ','.join(valstr_list) + ')'
- valstr_list_tot.append(valstr)
- valstr = '[' + ','.join(valstr_list_tot) + ']'
- return valstr
-
-# The following functions give convenient access to the output functions in
-# output.py
-def export_image(img, outfile=None, img_format='fits', pad_image = False,
- img_type='gaus_resid', mask_dilation=0, clobber=False):
- """Write an image to a file. Returns True if successful, False if not.
-
- outfile - name of resulting file; if None, file is
- named automatically.
- img_type - type of image to export; see below
- img_format - format of resulting file: 'fits' or 'casa'
- incl_wavelet - include wavelet Gaussians in model
- and residual images?
- clobber - overwrite existing file?
-
- The following images may be exported:
- 'ch0' - image used for source detection
- 'rms' - rms map image
- 'mean' - mean map image
- 'pi' - polarized intensity image
- 'gaus_resid' - Gaussian model residual image
- 'gaus_model' - Gaussian model image
- 'shap_resid' - Shapelet model residual image
- 'shap_model' - Shapelet model image
- 'psf_major' - PSF major axis FWHM image (FWHM in arcsec)
- 'psf_minor' - PSF minor axis FWHM image (FWHM in arcsec)
- 'psf_pa' - PSF position angle image (degrees east of north)
- 'psf_ratio' - PSF peak-to-total flux ratio (in units of 1/beam)
- 'psf_ratio_aper' - PSF peak-to-aperture flux ratio (in units of 1/beam)
- 'island_mask' - Island mask image (0 = outside island, 1 = inside island)
- """
- import os
- import functions as func
- from const import fwsig
- import mylogger
-
- mylog = mylogger.logging.getLogger("PyBDSM."+img.log+"ExportImage")
-
- # First some checking:
- if not 'gausfit' in img.completed_Ops and 'gaus' in img_type:
- print '\033[91mERROR\033[0m: Gaussians have not been fit. Please run process_image first.'
- return False
- elif not 'shapelets' in img.completed_Ops and 'shap' in img_type:
- print '\033[91mERROR\033[0m: Shapelets have not been fit. Please run process_image first.'
- return False
- elif not 'polarisation' in img.completed_Ops and 'pi' in img_type:
- print '\033[91mERROR\033[0m: Polarization properties have not been calculated. Please run process_image first.'
- return False
- elif not 'psf_vary' in img.completed_Ops and 'psf' in img_type:
- print '\033[91mERROR\033[0m: PSF variations have not been calculated. Please run process_image first.'
- return False
- elif not 'collapse' in img.completed_Ops and 'ch0' in img_type:
- print '\033[91mERROR\033[0m: ch0 image has not been calculated. Please run process_image first.'
- return False
- elif not 'rmsimage' in img.completed_Ops and ('rms' in img_type or 'mean' in img_type):
- print '\033[91mERROR\033[0m: Mean and rms maps have not been calculated. Please run process_image first.'
- return False
- elif not 'make_residimage' in img.completed_Ops and ('resid' in img_type or 'model' in img_type):
- print '\033[91mERROR\033[0m: Residual and model maps have not been calculated. Please run process_image first.'
- return False
- format = img_format.lower()
- if (format in ['fits', 'casa']) == False:
- print '\033[91mERROR\033[0m: img_format must be "fits" or "casa"'
- return False
- filename = outfile
- if filename is None or filename == '':
- filename = img.imagename + '_' + img_type + '.' + format
- if os.path.exists(filename) and clobber == False:
- print '\033[91mERROR\033[0m: File exists and clobber = False.'
- return False
- if format == 'fits':
- use_io = 'fits'
- if format == 'casa':
- use_io = 'rap'
- bdir = ''
- try:
- if img_type == 'ch0':
- func.write_image_to_file(use_io, filename,
- img.ch0_arr, img, bdir, pad_image,
- clobber=clobber)
- elif img_type == 'rms':
- func.write_image_to_file(use_io, filename,
- img.rms_arr, img, bdir, pad_image,
- clobber=clobber)
- elif img_type == 'mean':
- func.write_image_to_file(use_io, filename,
- img.mean_arr, img, bdir, pad_image,
- clobber=clobber)
- elif img_type == 'pi':
- func.write_image_to_file(use_io, filename,
- img.ch0_pi_arr, img, bdir, pad_image,
- clobber=clobber)
- elif img_type == 'psf_major':
- func.write_image_to_file(use_io, filename,
- img.psf_vary_maj_arr*fwsig, img, bdir, pad_image,
- clobber=clobber)
- elif img_type == 'psf_minor':
- func.write_image_to_file(use_io, filename,
- img.psf_vary_min_arr*fwsig, img, bdir, pad_image,
- clobber=clobber)
- elif img_type == 'psf_pa':
- func.write_image_to_file(use_io, filename,
- img.psf_vary_pa_arr, img, bdir, pad_image,
- clobber=clobber)
- elif img_type == 'psf_ratio':
- func.write_image_to_file(use_io, filename,
- img.psf_vary_ratio_arr, img, bdir, pad_image,
- clobber=clobber)
- elif img_type == 'psf_ratio_aper':
- func.write_image_to_file(use_io, filename,
- img.psf_vary_ratio_aper_arr, img, bdir, pad_image,
- clobber=clobber)
- elif img_type == 'gaus_resid':
- im = img.resid_gaus_arr
- func.write_image_to_file(use_io, filename,
- im, img, bdir, pad_image,
- clobber=clobber)
- elif img_type == 'gaus_model':
- im = img.model_gaus_arr
- func.write_image_to_file(use_io, filename,
- im, img, bdir, pad_image,
- clobber=clobber)
- elif img_type == 'shap_resid':
- func.write_image_to_file(use_io, filename,
- img.resid_shap_arr, img, bdir, pad_image,
- clobber=clobber)
- elif img_type == 'shap_model':
- func.write_image_to_file(use_io, filename,
- img.model_shap_arr, img, bdir, pad_image,
- clobber=clobber)
- elif img_type == 'island_mask':
- import numpy as N
- import scipy.ndimage as nd
- island_mask_bool = img.pyrank + 1 > 0
- if mask_dilation > 0:
- # Dilate the mask by specified number of iterations
- island_mask_bool = nd.binary_dilation(island_mask_bool,
- iterations=mask_dilation)
- # Perform a binary closing to remove small holes/gaps. The
- # structure array is chosen to be about the size of the
- # beam (assuming a normally sampled psf), so that holes/gaps
- # smaller than the beam are removed.
- pbeam = int(round(img.beam2pix(img.beam)[0] * 1.5))
- island_mask_bool = nd.binary_closing(island_mask_bool,
- structure=N.ones((pbeam, pbeam)))
-
- # Check for telescope, needed for CASA clean masks
- if img._telescope is None:
- print '\033[91mWARNING\033[0m: Telescope is unknown. Mask may not work correctly in CASA.'
- island_mask = N.array(island_mask_bool, dtype=N.float32)
- func.write_image_to_file(use_io, filename,
- island_mask, img, bdir, pad_image,
- clobber=clobber, is_mask=True)
- else:
- print "\n\033[91mERROR\033[0m: img_type not recognized."
- return False
- if filename == 'SAMP':
- print '--> Image sent to SMAP hub'
- else:
- print '--> Wrote file ' + repr(filename)
- if use_io == 'rap':
- # remove the temporary fits file used as a pyrap template
- import os
- os.remove(filename+'.fits')
-
- return True
- except RuntimeError, err:
- # Catch and log error
- mylog.error(str(err))
-
- # Re-throw error if the user is not in the interactive shell
- if img._is_interactive_shell:
- return False
- else:
- raise
- except KeyboardInterrupt:
- mylogger.userinfo(mylog, "\n\033[31;1mAborted\033[0m")
- return False
-
-
-def write_catalog(img, outfile=None, format='bbs', srcroot=None, catalog_type='gaul',
- bbs_patches=None, incl_chan=False, incl_empty=False, clobber=False,
- force_output=False, correct_proj=True, bbs_patches_mask=None):
- """Write the Gaussian, source, or shapelet list to a file. Returns True if
- successful, False if not.
-
- filename - name of resulting file; if None, file is
- named automatically. If 'SAMP', table is sent to a samp hub
- (must be running already).
- catalog_type - type of catalog
- "gaul" - Gaussian list
- "srl" - Source list
- "shap" - Shapelet list ("fits" format only)
- format - format of output list. Supported formats are:
- "fits" - FITS binary table
- "ascii" - ASCII text file
- "bbs" - BBS sky model (Gaussian list only)
- "ds9" - ds9 region file
- "star" - AIPS STAR file (Gaussian list only)
- "kvis" - kvis file (Gaussian list only)
- "sagecal" - SAGECAL file (Gaussian list only)
- srcroot - root for source and patch names (BBS/ds9 only);
- if None, the srcroot is chosen automatically
- bbs_patches - type of patches to use:
- None - no patches
- "gaussian" - each Gaussian gets its own patch
- "single" - all Gaussians are put into a single
- patch
- "source" - sources are grouped by source into patches
- "mask" - use a Boolean mask to define the patches
- bbs_patches_mask - file name of mask file if bbs_patches="mask"
- incl_chan - Include fluxes for each channel?
- incl_empty - Include islands without any valid Gaussians (source list only)?
- sort_by - Property to sort output list by:
- "flux" - sort by total integrated flux, largest first
- "indx" - sort by Gaussian and island or source index, smallest first
- force_output - Force the creation of a catalog, even if it is empty
- correct_proj - Correct source parameters for image projection effects (BBS only)?
- clobber - Overwrite existing file?
- """
- import output
-
- # First some checking:
- if not 'gausfit' in img.completed_Ops:
- print '\033[91mERROR\033[0m: Image has not been fit. Please run process_image first.'
- return False
- if catalog_type == 'shap' and not 'shapelets' in img.completed_Ops:
- print '\033[91mERROR\033[0m: Image has not been decomposed into shapelets. Please run process_image first.'
- return False
- if catalog_type == 'srl' and not 'gaul2srl' in img.completed_Ops:
- print '\033[91mERROR\033[0m: Gaussians have not been grouped into sources. Please run process_image first.'
- return False
- format = format.lower()
- patch = bbs_patches
- filename = outfile
- if isinstance(patch, str):
- patch = patch.lower()
- if format not in ['fits', 'ascii', 'bbs', 'ds9', 'star',
- 'kvis', 'sagecal', 'csv', 'casabox']:
- print '\033[91mERROR\033[0m: format must be "fits", '\
- '"ascii", "ds9", "star", "kvis", "csv", "casabox", or "bbs"'
- return False
- if patch not in [None, 'gaussian', 'single', 'source', 'mask']:
- print '\033[91mERROR\033[0m: patch must be None, '\
- '"gaussian", "source", "single", or "mask"'
- return False
- if patch == 'mask':
- if bbs_patches_mask is None:
- print '\033[91mERROR\033[0m: if patch is "mask", bbs_patches_mask must be set to the file name of the mask file'
- return False
- if (catalog_type in ['gaul', 'srl', 'shap']) == False:
- print '\033[91mERROR\033[0m: catalog_type must be "gaul", '\
- '"srl", or "shap"'
- return False
- if catalog_type == 'shap' and format != 'fits':
- print "\033[91mERROR\033[0m: Only format = 'fits' is supported with shapelet output."
- return False
- if (len(img.sources) == 0 and not incl_empty) or (len(img.sources) == 0 and len(img.dsources) == 0 and incl_empty):
- if not force_output:
- print 'No sources were found in the image. Output file not written.'
- return False
- if filename == '':
- filename = None
-
- # Now go format by format and call appropriate function
- if filename == 'samp' or filename == 'SAMP':
- import tempfile
- import functions as func
- import os
- if not hasattr(img,'samp_client'):
- s, private_key = func.start_samp_proxy()
- img.samp_client = s
- img.samp_key = private_key
-
- # Broadcast fits table to SAMP Hub
- tfile = tempfile.NamedTemporaryFile(delete=False)
- filename = output.write_fits_list(img, filename=tfile.name,
- incl_chan=incl_chan, incl_empty=incl_empty,
- clobber=True, objtype=catalog_type)
- table_name = 'PyBDSM '+ catalog_type + ' table'
- if catalog_type == 'srl':
- img.samp_srl_table_url = 'file://' + os.path.abspath(tfile.name)
- if catalog_type == 'gaul':
- img.samp_gaul_table_url = 'file://' + os.path.abspath(tfile.name)
- func.send_fits_table(img.samp_client, img.samp_key, table_name, tfile.name)
- print '--> Table sent to SMAP hub'
- return True
-
- if format == 'fits':
- filename = output.write_fits_list(img, filename=filename,
- incl_chan=incl_chan, incl_empty=incl_empty,
- clobber=clobber, objtype=catalog_type)
- if filename is None:
- print '\033[91mERROR\033[0m: File exists and clobber = False.'
- return False
- else:
- print '--> Wrote FITS file ' + repr(filename)
- return True
- if format == 'ascii' or format == 'csv':
- filename = output.write_ascii_list(img, filename=filename,
- incl_chan=incl_chan, incl_empty=incl_empty,
- sort_by='index', format = format,
- clobber=clobber, objtype=catalog_type)
- if filename is None:
- print '\033[91mERROR\033[0m: File exists and clobber = False.'
- return False
- else:
- print '--> Wrote ASCII file ' + repr(filename)
- return True
- if format == 'bbs':
- if catalog_type != 'gaul':
- print "\033[91mERROR\033[0m: Only catalog_type = 'gaul' is supported with BBS files."
- return False
- filename = output.write_bbs_gaul(img, filename=filename,
- srcroot=srcroot, incl_empty=incl_empty,
- patch=patch, correct_proj=correct_proj,
- sort_by='flux',
- clobber=clobber)
- if filename is None:
- print '\033[91mERROR\033[0m: File exists and clobber = False.'
- return False
- else:
- print '--> Wrote BBS sky model ' + repr(filename)
- return True
- if format == 'sagecal':
- if catalog_type != 'gaul':
- print "\033[91mERROR\033[0m: Only catalog_type = 'gaul' is supported with Sagecal files."
- return False
- filename = output.write_lsm_gaul(img, filename=filename,
- srcroot=srcroot, incl_empty=incl_empty,
- patch=patch,
- sort_by='flux',
- clobber=clobber)
- if filename is None:
- print '\033[91mERROR\033[0m: File exists and clobber = False.'
- return False
- else:
- print '--> Wrote Sagecal lsm file ' + repr(filename)
- return True
- if format == 'ds9':
- filename = output.write_ds9_list(img, filename=filename,
- srcroot=srcroot, incl_empty=incl_empty,
- clobber=clobber, objtype=catalog_type)
- if filename is None:
- print '\033[91mERROR\033[0m: File exists and clobber = False.'
- return False
- else:
- print '--> Wrote ds9 region file ' + repr(filename)
- return True
- if format == 'star':
- if catalog_type != 'gaul':
- print "\033[91mERROR\033[0m: Only catalog_type = 'gaul' is supported with star files."
- return False
- filename = output.write_star(img, filename=filename,
- clobber=clobber)
- if filename is None:
- print '\033[91mERROR\033[0m: File exists and clobber = False.'
- return False
- else:
- print '--> Wrote AIPS STAR file ' + repr(filename)
- return True
- if format == 'kvis':
- if catalog_type != 'gaul':
- print "\033[91mERROR\033[0m: Only catalog_type = 'gaul' is supported with kvis files."
- return False
- filename = output.write_kvis_ann(img, filename=filename,
- clobber=clobber)
- if filename is None:
- print '\033[91mERROR\033[0m: File exists and clobber=False.'
- return False
- else:
- print '--> Wrote kvis file ' + repr(filename)
- return True
- if format == 'casabox':
- filename = output.write_casa_gaul(img, filename=filename,
- incl_empty=incl_empty, clobber=clobber)
- if filename is None:
- print '\033[91mERROR\033[0m: File exists and clobber=False.'
- else:
- print '--> Wrote CASA clean box file ' + filename
-
-def add_break_to_logfile(logfile):
- f = open(logfile, 'a')
- f.write('\n' + '='*72 + '\n')
- f.close()
diff --git a/CEP/PyBDSM/src/python/islands.py b/CEP/PyBDSM/src/python/islands.py
deleted file mode 100644
index 5f845ee6924717e0283c0bda9d44ff7fb9c7d9ce..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/python/islands.py
+++ /dev/null
@@ -1,416 +0,0 @@
-"""Module islands.
-
-Defines operation Op_islands which does island detection.
-Current implementation uses scipy.ndimage operations for island detection.
-While it's implemented to work for images of arbitrary dimensionality,
-the bug in the current version of scipy (0.6) often causes crashes
-(or just wrong results) for 3D inputs.
-
-If this (scipy.ndimage.label) isn't fixed by the time we need 3D source
-extraction, one will have to adopt my old pixel-runs algorithm for 3D data.
-Check out islands.py rev. 1362 from repository for it.
-"""
-
-import numpy as N
-import scipy.ndimage as nd
-from image import *
-import mylogger
-try:
- from astropy.io import fits as pyfits
-except ImportError, err:
- import pyfits
-import functions as func
-from output import write_islands
-from readimage import Op_readimage
-from preprocess import Op_preprocess
-from rmsimage import Op_rmsimage
-from threshold import Op_threshold
-from collapse import Op_collapse
-
-nisl = Int(doc="Total number of islands detected")
-
-class Op_islands(Op):
- """Detect islands of emission in the image
-
- All detected islands are stored in the list img.islands,
- where each individual island is represented as an instance
- of class Island.
-
- The option to detect islands on a different "detection"
- image is also available. This option is useful for example
- when a primary beam correction is used -- it is generally
- better to detect sources on the uncorrected image, but
- to measure them on the corrected image.
-
- Prerequisites: module rmsimage should be run first.
- """
- def __call__(self, img):
- mylog = mylogger.logging.getLogger("PyBDSM."+img.log+"Islands")
- opts = img.opts
-
- minsize = opts.minpix_isl
- if minsize is None:
- minsize = int(img.pixel_beamarea()/3.0) # 1/3 of beam area in pixels
- if minsize < 6:
- minsize = 6 # Need at least 6 pixels to obtain good fits
- mylogger.userinfo(mylog, "Minimum number of pixels per island", '%i' %
- minsize)
- img.minpix_isl = minsize
-
- if opts.detection_image != '':
- # Use a different image for island detection. The detection
- # image and the measurement image must have the same shape
- # and be registered. Otherwise, one could reproject the
- # detection image using, e.g., the Kapteyn package.
- #
- # First, set up up an Image object and run a limited
- # op_chain.
- from . import _run_op_list
- mylogger.userinfo(mylog, "\nDetermining islands from detection image")
-
- det_chain, det_opts = self.setpara_bdsm(img, opts.detection_image)
- det_img = Image(det_opts)
- det_img.log = 'Detection image'
- success = _run_op_list(det_img, det_chain)
- if not success:
- return
-
- # Check that the ch0 images are the same size
- ch0_map = img.ch0_arr
- det_ch0_map = det_img.ch0_arr
- det_shape = det_ch0_map.shape
- ch0_shape = ch0_map.shape
- if det_shape != ch0_shape:
- raise RuntimeError("Detection image shape does not match that of input image.")
-
- # Run through islands and correct the image and rms, mean and max values
- img.island_labels = det_img.island_labels
- corr_islands = []
- mean_map = img.mean_arr
- rms_map = img.rms_arr
- for i, isl in enumerate(det_img.islands):
- islcp = isl.copy(img.pixel_beamarea(), image=ch0_map[isl.bbox], mean=mean_map[isl.bbox], rms=rms_map[isl.bbox])
- islcp.island_id = i
- corr_islands.append(islcp)
- img.islands = corr_islands
- img.nisl = len(img.islands)
- img.pyrank = det_img.pyrank
- img.minpix_isl = det_img.minpix_isl
- mylogger.userinfo(mylog, "\nContinuing processing using primary image")
- else:
- if opts.src_ra_dec is not None:
- mylogger.userinfo(mylog, "Constructing islands at user-supplied source locations")
- img.islands = self.coords_to_isl(img, opts)
- else:
- img.islands = self.ndimage_alg(img, opts)
- img.nisl = len(img.islands)
-
- mylogger.userinfo(mylog, "Number of islands found", '%i' %
- len(img.islands))
-
- ch0_map = img.ch0_arr
- ch0_shape = ch0_map.shape
- pyrank = N.zeros(ch0_shape, dtype=N.int32)
- for i, isl in enumerate(img.islands):
- isl.island_id = i
- pyrank[isl.bbox] += N.invert(isl.mask_active) * (i + 1)
- pyrank -= 1 # align pyrank values with island ids and set regions outside of islands to -1
-
- if opts.output_all: write_islands(img)
- if opts.savefits_rankim:
- func.write_image_to_file(img.use_io, img.imagename + '_pyrank.fits', pyrank, img)
-
- img.pyrank = pyrank
-
- img.completed_Ops.append('islands')
- return img
-
- def ndimage_alg(self, img, opts):
- """Island detection using scipy.ndimage
-
- Use scipy.ndimage.label to detect islands of emission in the image.
- Island is defined as group of tightly connected (8-connectivity
- for 2D images) pixels with emission.
-
- The following cuts are applied:
- - pixel is considered to have emission if it is 'thresh_isl' times
- higher than RMS.
- - Island should have at least 'minsize' active pixels
- - There should be at lease 1 pixel in the island which is 'thresh_pix'
- times higher than noise (peak clip).
-
- Parameters:
- image, mask: arrays with image data and mask
- mean, rms: arrays with mean & rms maps
- thresh_isl: threshold for 'active pixels'
- thresh_pix: threshold for peak
- minsize: minimal acceptable island size
-
- Function returns a list of Island objects.
- """
- ### islands detection
- mylog = mylogger.logging.getLogger("PyBDSM."+img.log+"Islands")
-
- image = img.ch0_arr
- mask = img.mask_arr
- rms = img.rms_arr
- mean = img.mean_arr
- thresh_isl = opts.thresh_isl
- thresh_pix = img.thresh_pix
- clipped_mean = img.clipped_mean
- saverank = opts.savefits_rankim
-
- # act_pixels is true if significant emission
- act_pixels = (image-mean)/thresh_isl >= rms
- if isinstance(mask, N.ndarray):
- act_pixels[mask] = False
-
- # dimension of image
- rank = len(image.shape)
- # generates matrix for connectivity, in this case, 8-conn
- connectivity = nd.generate_binary_structure(rank, rank)
- # labels = matrix with value = (initial) island number
- labels, count = nd.label(act_pixels, connectivity)
- # slices has limits of bounding box of each such island
- slices = nd.find_objects(labels)
- img.island_labels = labels
-
- ### apply cuts on island size and peak value
- pyrank = N.zeros(image.shape, dtype=N.int32)
- res = []
- islid = 0
- for idx, s in enumerate(slices):
- idx += 1 # nd.labels indices are counted from 1
- # number of pixels inside bounding box which are in island
- isl_size = (labels[s] == idx).sum()
- isl_peak = nd.maximum(image[s], labels[s], idx)
- isl_maxposn = tuple(N.array(N.unravel_index(N.nanargmax(image[s]), image[s].shape))+\
- N.array((s[0].start, s[1].start)))
- if (isl_size >= img.minpix_isl) and (isl_peak - mean[isl_maxposn])/thresh_pix > rms[isl_maxposn]:
- isl = Island(image, mask, mean, rms, labels, s, idx, img.pixel_beamarea())
- res.append(isl)
- pyrank[isl.bbox] += N.invert(isl.mask_active)*idx / idx
-
- return res
-
-
- def coords_to_isl(self, img, opts):
- """Construct islands around given coordinates with given size.
-
- Returns a list of island objects.
- """
- mylog = mylogger.logging.getLogger("PyBDSM."+img.log+"Islands")
-
- coords = opts.src_ra_dec # list of RA and Dec tuples
- isl_radius_pix = opts.src_radius_pix
- if isl_radius_pix is None:
- isl_radius_pix = img.beam2pix(img.beam)[0] # twice beam major axis radius at half max (= FWHM)
-
- res = []
- for idx, coord in enumerate(coords):
- idx += 1 # nd.labels indices are counted from 1
- isl_posn_pix = img.sky2pix(coord)
- image = img.ch0_arr
- mask = img.mask_arr
- rms = img.rms_arr
- mean = img.mean_arr
- labels = func.make_src_mask(image.shape,
- isl_posn_pix, isl_radius_pix)
- if img.masked:
- aper_mask = N.where(labels.astype(bool) & ~mask)
- else:
- aper_mask = N.where(labels.astype(bool))
- if N.size(aper_mask) > img.minpix_isl:
- labels[aper_mask] = idx
- s = [slice(max(0, isl_posn_pix[0] - isl_radius_pix - 1),
- min(image.shape[0], isl_posn_pix[0] + isl_radius_pix + 1)),
- slice(max(0, isl_posn_pix[1] - isl_radius_pix - 1),
- min(image.shape[1], isl_posn_pix[1] + isl_radius_pix + 1))]
- isl = Island(image, mask, mean, rms, labels, s, idx,
- img.pixel_beamarea())
- res.append(isl)
- return res
-
-
- def setpara_bdsm(self, img, det_file):
- from types import ClassType, TypeType
-
- chain=[Op_readimage(), Op_collapse(), Op_preprocess, Op_rmsimage(),
- Op_threshold(), Op_islands()]
- opts = img.opts.to_dict()
- opts['filename'] = det_file
- opts['detection_image'] = ''
- opts['polarisation_do'] = False
-
- ops = []
- for op in chain:
- if isinstance(op, (ClassType, TypeType)):
- ops.append(op())
- else:
- ops.append(op)
-
- return ops, opts
-
-
-from image import *
-
-class Island(object):
- """Instances of this class represent islands of emission in the image.
-
- Its primary use is a container for all kinds of data describing island.
- """
- bbox = List(Instance(slice(0), or_none=False),
- doc = "Bounding box of the island")
- origin = List(Float(), doc="Coordinates of lower-left corner")
- image = NArray(doc="Sub-image of the island")
- mask_active = NArray(doc="Mask for just active pixels")
- mask_noisy = NArray(doc="Mask for active pixels and surrounding noise")
- shape = List(Int(), doc="Shape of the island")
- size_active = Int(doc="Number of active pixels in the island")
- mean = Float(doc="Average mean value")
- rms = Float(doc="Average rms")
- total_flux = Float(doc="Total flux from sum of pixels in island")
- total_fluxE = Float(doc="Error on total flux from sum of pixels in island")
- max_value = Float(doc="Maximum value in island")
- island_id = Int(doc="Island id, starting from 0", colname='Isl_id')
- gresid_rms = Float(doc="Rms of residual image of island")
- gresid_mean = Float(doc="Mean of residual image of island")
- connected = Tuple(String(), Int(), doc="'multiple' or 'single' -ly connected, # of holes inside island")
- convex_def = Float(doc="Convex deficiency, with first order correction for edge effect")
- islmean = Float(doc="a constant value to subtract from image before fitting")
-
- def __init__(self, img, mask, mean, rms, labels, bbox, idx,
- beamarea, origin=None, noise_mask=None, copy=False):
- """Create Island instance.
-
- Parameters:
- img, mask, mean, rms: arrays describing image
- labels: labels array from scipy.ndimage
- bbox: slices
- """
- TCInit(self)
-
- if not copy:
- ### we make bbox slightly bigger
- self.oldbbox = bbox
- self.oldidx = idx
- bbox = self.__expand_bbox(bbox, img.shape)
- origin = [b.start for b in bbox] # easier in case ndim > 2
- data = img[bbox]
- bbox_rms_im = rms[bbox]
- bbox_mean_im = mean[bbox]
-
- ### create (inverted) masks
- # Note that mask_active is the island mask; mask_noisy marks only
- # the noisy pixels in the island image. If you want to mask the
- # noisy pixels, set the final mask to:
- # mask = mask_active + mask_noisy
- isl_mask = (labels[bbox] == idx)
- noise_mask = (labels[bbox] == 0)
- N.logical_or(noise_mask, isl_mask, noise_mask)
-
- ### invert masks
- N.logical_not(isl_mask, isl_mask)
- N.logical_not(noise_mask, noise_mask)
- if isinstance(mask, N.ndarray):
- noise_mask[mask[bbox]] = True
- isl_mask[mask[bbox]] = True
- else:
- if origin is None:
- origin = [b.start for b in bbox]
- isl_mask = mask
- if noise_mask is None:
- noise_mask = mask
- data = img
- bbox_rms_im = rms
- bbox_mean_im = mean
- self.oldbbox = bbox
- self.oldidx = idx
-
-
- ### finish initialization
- isl_size = N.sum(~isl_mask)
- self.island_id = idx
- self.bbox = bbox
- self.origin = origin
- self.image = data
- self.mask_active = isl_mask
- self.mask_noisy = noise_mask
- self.shape = data.shape
- self.size_active = isl_size
- self.max_value = N.max(self.image*~self.mask_active)
- in_bbox_and_unmasked = N.where(~N.isnan(bbox_rms_im))
- self.rms = bbox_rms_im[in_bbox_and_unmasked].mean()
- in_bbox_and_unmasked = N.where(~N.isnan(bbox_mean_im))
- self.mean = bbox_mean_im[in_bbox_and_unmasked].mean()
- self.islmean = bbox_mean_im[in_bbox_and_unmasked].mean()
- self.total_flux = N.nansum(self.image[in_bbox_and_unmasked])/beamarea
- pixels_in_isl = N.sum(~N.isnan(self.image[self.mask_active])) # number of unmasked pixels assigned to current island
- self.total_fluxE = func.nanmean(bbox_rms_im[in_bbox_and_unmasked]) * N.sqrt(pixels_in_isl/beamarea) # Jy
- self.border = self.get_border()
-
- def __setstate__(self, state):
- """Needed for multiprocessing"""
- self.mean = state['mean']
- self.rms = state['rms']
- self.image = state['image']
- self.islmean = state['islmean']
- self.mask_active = state['mask_active']
- self.mask_noisy = state['mask_noisy']
- self.size_active = state['size_active']
- self.shape = state['shape']
- self.origin = state['origin']
- self.island_id = state['island_id']
- self.oldidx = state['oldidx']
- self.bbox = state['bbox']
-
- def __getstate__(self):
- """Needed for multiprocessing"""
- state = {}
- state['mean'] = self.mean
- state['rms'] = self.rms
- state['image'] = self.image
- state['islmean'] = self.islmean
- state['mask_active'] = self.mask_active
- state['mask_noisy'] = self.mask_noisy
- state['size_active'] = self.size_active
- state['shape'] = self.shape
- state['origin'] = self.origin
- state['island_id'] = self.island_id
- state['oldidx'] = self.oldidx
- state['bbox'] = self.bbox
- return state
-
- ### do map etc in case of ndim image
- def __expand_bbox(self, bbox, shape):
- """Expand bbox of the image by 1 pixel"""
- def __expand(bbox, shape):
- return slice(max(0, bbox.start - 1), min(shape, bbox.stop + 1))
- return map(__expand, bbox, shape)
-
- def copy(self, pixel_beamarea, image=None, mean=None, rms=None):
- mask = self.mask_active
- noise_mask = self.mask_noisy
- if image is None:
- image = self.image
- if mean is None:
- mean = N.zeros(mask.shape, dtype=N.float32) + self.mean
- if rms is None:
- rms = N.zeros(mask.shape, dtype=N.float32) + self.rms
-
- bbox = self.bbox
- idx = self.oldidx
- origin = self.origin
- return Island(image, mask, mean, rms, None, bbox, idx, pixel_beamarea,
- origin=origin, noise_mask=noise_mask, copy=True)
-
- def get_border(self):
- """ From all valid island pixels, generate the border."""
- mask = ~self.mask_active
- border = N.transpose(N.asarray(N.where(mask - nd.binary_erosion(mask)))) + self.origin
-
- return N.transpose(N.array(border))
-
-
-### Insert attribute for island list into Image class
-Image.islands = List(tInstance(Island), doc="List of islands")
diff --git a/CEP/PyBDSM/src/python/make_residimage.py b/CEP/PyBDSM/src/python/make_residimage.py
deleted file mode 100644
index 57d1b270eeea4f90c0be09c0adfc34ac5d5936c6..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/python/make_residimage.py
+++ /dev/null
@@ -1,222 +0,0 @@
-"""Module make_residimage.
-
-It calculates residual image from the list of gaussians and shapelets
-"""
-
-import numpy as N
-from scipy import stats # for skew and kurtosis
-from image import *
-from shapelets import *
-import mylogger
-
-### Insert attribute into Image class for model image
-Image.resid_gaus = NArray(doc="Residual image calculated from " \
- "extracted gaussians")
-Image.resid_shap = NArray(doc="Residual image calculated from " \
- "shapelet coefficient")
-Image.model_gaus = NArray(doc="Model image calculated from " \
- "extracted gaussians")
-Image.model_shap = NArray(doc="Model image calculated from " \
- "shapelet coefficient")
-
-class Op_make_residimage(Op):
- """Creates an image from the fitted gaussians
- or shapelets.
-
- The resulting model image is stored in the
- resid_gaus or resid_shap attribute.
-
- Prerequisites: module gausfit or shapelets should
- be run first.
- """
-
- def __call__(self, img):
- import functions as func
- from copy import deepcopy as cp
- import os
-
- mylog = mylogger.logging.getLogger("PyBDSM."+img.log+"ResidImage")
- mylog.info("Calculating residual image after subtracting reconstructed gaussians")
- shape = img.ch0_arr.shape
- thresh= img.opts.fittedimage_clip
-
- resid_gaus = cp(img.ch0_arr)
- model_gaus = N.zeros(shape, dtype=N.float32)
- for g in img.gaussians:
- C1, C2 = g.centre_pix
- if hasattr(g, 'wisland_id') and img.waveletimage:
- isl = img.islands[g.wisland_id]
- else:
- isl = img.islands[g.island_id]
- b = self.find_bbox(thresh*isl.rms, g)
-
- bbox = N.s_[max(0, int(C1-b)):min(shape[0], int(C1+b+1)),
- max(0, int(C2-b)):min(shape[1], int(C2+b+1))]
-
- x_ax, y_ax = N.mgrid[bbox]
- ffimg = func.gaussian_fcn(g, x_ax, y_ax)
- resid_gaus[bbox] = resid_gaus[bbox] - ffimg
- model_gaus[bbox] = model_gaus[bbox] + ffimg
-
- # Apply mask to model and resid images
- if hasattr(img, 'rms_mask'):
- mask = img.rms_mask
- else:
- mask = img.mask_arr
- if isinstance(img.mask_arr, N.ndarray):
- pix_masked = N.where(img.mask_arr == True)
- model_gaus[pix_masked] = N.nan
- resid_gaus[pix_masked] = N.nan
-
- img.model_gaus_arr = model_gaus
- img.resid_gaus_arr = resid_gaus
-
- if img.opts.output_all:
- if img.waveletimage:
- resdir = img.basedir + '/wavelet/residual/'
- moddir = img.basedir + '/wavelet/model/'
- else:
- resdir = img.basedir + '/residual/'
- moddir = img.basedir + '/model/'
- if not os.path.exists(resdir): os.makedirs(resdir)
- if not os.path.exists(moddir): os.makedirs(moddir)
- func.write_image_to_file(img.use_io, img.imagename + '.resid_gaus.fits', resid_gaus, img, resdir)
- mylog.info('%s %s' % ('Writing', resdir+img.imagename+'.resid_gaus.fits'))
- func.write_image_to_file(img.use_io, img.imagename + '.model.fits', (img.ch0_arr - resid_gaus), img, moddir)
- mylog.info('%s %s' % ('Writing', moddir+img.imagename+'.model_gaus.fits'))
-
- ### residual rms and mean per island
- for isl in img.islands:
- resid = resid_gaus[isl.bbox]
- self.calc_resid_mean_rms(isl, resid, type='gaus')
-
- # Calculate some statistics for the Gaussian residual image
- non_masked = N.where(~N.isnan(img.ch0_arr))
- mean = N.mean(resid_gaus[non_masked], axis=None)
- std_dev = N.std(resid_gaus[non_masked], axis=None)
- skew = stats.skew(resid_gaus[non_masked], axis=None)
- kurt = stats.kurtosis(resid_gaus[non_masked], axis=None)
- stat_msg = "Statistics of the Gaussian residual image:\n"
- stat_msg += " mean: %.3e (Jy/beam)\n" % mean
- stat_msg += " std. dev: %.3e (Jy/beam)\n" % std_dev
- stat_msg += " skew: %.3f\n" % skew
- stat_msg += " kurtosis: %.3f" % kurt
- mylog.info(stat_msg)
-
- # Now residual image for shapelets
- if img.opts.shapelet_do:
- mylog.info("Calculating residual image after subtracting reconstructed shapelets")
- shape = img.ch0_arr.shape
- fimg = N.zeros(shape, dtype=N.float32)
-
- for isl in img.islands:
- if isl.shapelet_beta > 0: # make sure shapelet has nonzero scale for this island
- mask=isl.mask_active
- cen=isl.shapelet_centre-N.array(isl.origin)
- basis, beta, nmax, cf = isl.shapelet_basis, isl.shapelet_beta, \
- isl.shapelet_nmax, isl.shapelet_cf
- image_recons=reconstruct_shapelets(isl.shape, mask, basis, beta, cen, nmax, cf)
- fimg[isl.bbox] += image_recons
-
- model_shap = fimg
- resid_shap = img.ch0_arr - fimg
-
- # Apply mask to model and resid images
- if hasattr(img, 'rms_mask'):
- mask = img.rms_mask
- else:
- mask = img.mask_arr
- if isinstance(mask, N.ndarray):
- pix_masked = N.where(mask == True)
- model_shap[pix_masked] = N.nan
- resid_shap[pix_masked] = N.nan
-
- img.model_shap_arr = model_shap
- img.resid_shap_arr = resid_shap
-
- if img.opts.output_all:
- func.write_image_to_file(img.use_io, img.imagename + '.resid_shap.fits', resid_shap, img, resdir)
- mylog.info('%s %s' % ('Writing ', resdir+img.imagename+'.resid_shap.fits'))
-
- ### shapelet residual rms and mean per island
- for isl in img.islands:
- resid = resid_shap[isl.bbox]
- self.calc_resid_mean_rms(isl, resid, type='shap')
-
- # Calculate some statistics for the Shapelet residual image
- non_masked = N.where(~N.isnan(img.ch0_arr))
- mean = N.mean(resid_shap[non_masked], axis=None)
- std_dev = N.std(resid_shap[non_masked], axis=None)
- skew = stats.skew(resid_shap[non_masked], axis=None)
- kurt = stats.kurtosis(resid_shap[non_masked], axis=None)
- mylog.info("Statistics of the Shapelet residual image:")
- mylog.info(" mean: %.3e (Jy/beam)" % mean)
- mylog.info(" std. dev: %.3e (Jy/beam)" % std_dev)
- mylog.info(" skew: %.3f" % skew)
- mylog.info(" kurtosis: %.3f" % kurt)
-
- img.completed_Ops.append('make_residimage')
- return img
-
- def find_bbox(self, thresh, g):
- """Calculate bounding box for gaussian.
-
- This function calculates size of the box for evaluating
- gaussian, so that value of gaussian is smaller than threshold
- outside of the box.
-
- Parameters:
- thres: threshold
- g: Gaussian object
- """
-
- from math import ceil, sqrt, log
- A = g.peak_flux
- S = g.size_pix[0]
- if A == 0.0:
- return ceil(S*1.5)
- if thresh/A >= 1.0 or thresh/A <= 0.0:
- return ceil(S*1.5)
- return ceil(S*sqrt(-2*log(thresh/A)))
-
- def calc_resid_mean_rms(self, isl, resid, type):
- """Inserts mean and rms of residual image into isl, src, and gaussians
-
- type - specifies 'gaus' or 'shap'
- """
- if len(isl.gaul) == 0:
- resid = N.zeros(isl.shape, dtype=N.float32)
-
- ind = N.where(~isl.mask_active)
- resid = resid[ind]
- if type == 'gaus':
- isl.gresid_rms = N.std(resid)
- isl.gresid_mean = N.mean(resid)
- else:
- isl.sresid_rms = N.std(resid)
- isl.sresid_mean = N.mean(resid)
- if hasattr(isl, 'sources'):
- for src in isl.sources:
- if type == 'gaus':
- src.gresid_rms = N.std(resid)
- src.gresid_mean = N.mean(resid)
- else:
- src.sresid_rms = N.std(resid)
- src.sresid_mean = N.mean(resid)
- for g in src.gaussians:
- if type == 'gaus':
- g.gresid_rms = N.std(resid)
- g.gresid_mean = N.mean(resid)
- else:
- g.sresid_rms = N.std(resid)
- g.sresid_mean = N.mean(resid)
- if hasattr(isl, 'dsources'):
- for dsrc in isl.dsources: # Handle dummy sources (if any)
- if type == 'gaus':
- dsrc.gresid_rms = N.std(resid)
- dsrc.gresid_mean = N.mean(resid)
- else:
- dsrc.sresid_rms = N.std(resid)
- dsrc.sresid_mean = N.mean(resid)
-
-
diff --git a/CEP/PyBDSM/src/python/multi_proc.py b/CEP/PyBDSM/src/python/multi_proc.py
deleted file mode 100644
index 597e8fd7c598f75b4919dc38c03ceea0ab3a1513..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/python/multi_proc.py
+++ /dev/null
@@ -1,224 +0,0 @@
-"""Multiprocessing module to handle parallelization.
-
-This module can optionally update a statusbar and can divide tasks
-between cores using weights (so that each core gets a set of tasks with
-the same total weight).
-
-Adapted from a module by Brian Refsdal at SAO, available at AstroPython
-(http://www.astropython.org/snippet/2010/3/Parallel-map-using-multiprocessing).
-
-"""
-import numpy
-_multi = False
-_ncpus = 1
-
-try:
- # May raise ImportError
- import multiprocessing
- _multi = True
-
- # May raise NotImplementedError
- _ncpus = min(multiprocessing.cpu_count(), 8)
-
-except:
- pass
-
-
-__all__ = ('parallel_map',)
-
-
-def worker(f, ii, chunk, out_q, err_q, lock, bar, bar_state):
- """
- A worker function that maps an input function over a
- slice of the input iterable.
-
- :param f : callable function that accepts argument from iterable
- :param ii : process ID
- :param chunk: slice of input iterable
- :param out_q: thread-safe output queue
- :param err_q: thread-safe queue to populate on exception
- :param lock : thread-safe lock to protect a resource
- ( useful in extending parallel_map() )
- :param bar: statusbar to update during fit
- :param bar_state: statusbar state dictionary
- """
- vals = []
-
- # iterate over slice
- for val in chunk:
- try:
- result = f(val)
- except Exception, e:
- err_q.put(e)
- return
-
- vals.append(result)
-
- # update statusbar
- if bar is not None:
- if bar_state['started']:
- bar.pos = bar_state['pos']
- bar.spin_pos = bar_state['spin_pos']
- bar.started = bar_state['started']
- increment = bar.increment()
- bar_state['started'] = bar.started
- bar_state['pos'] += increment
- bar_state['spin_pos'] += increment
- if bar_state['spin_pos'] >= 4:
- bar_state['spin_pos'] = 0
-
- # output the result and task ID to output queue
- out_q.put( (ii, vals) )
-
-
-def run_tasks(procs, err_q, out_q, num):
- """
- A function that executes populated processes and processes
- the resultant array. Checks error queue for any exceptions.
-
- :param procs: list of Process objects
- :param out_q: thread-safe output queue
- :param err_q: thread-safe queue to populate on exception
- :param num : length of resultant array
-
- """
- # function to terminate processes that are still running.
- die = (lambda vals : [val.terminate() for val in vals
- if val.exitcode is None])
-
- try:
- for proc in procs:
- proc.start()
-
- for proc in procs:
- proc.join()
-
- except Exception, e:
- # kill all slave processes on ctrl-C
- die(procs)
- raise e
-
- if not err_q.empty():
- # kill all on any exception from any one slave
- die(procs)
- raise err_q.get()
-
- # Processes finish in arbitrary order. Process IDs double
- # as index in the resultant array.
- results=[None]*num;
- for i in range(num):
- idx, result = out_q.get()
- results[idx] = result
-
- # Remove extra dimension added by array_split
- result_list = []
- for result in results:
- result_list += result
-
- return result_list
-
-
-def parallel_map(function, sequence, numcores=None, bar=None, weights=None):
- """
- A parallelized version of the native Python map function that
- utilizes the Python multiprocessing module to divide and
- conquer a sequence.
-
- parallel_map does not yet support multiple argument sequences.
-
- :param function: callable function that accepts argument from iterable
- :param sequence: iterable sequence
- :param numcores: number of cores to use (if None, all are used)
- :param bar: statusbar to update during fit
- :param weights: weights to use when splitting the sequence
-
- """
- if not callable(function):
- raise TypeError("input function '%s' is not callable" %
- repr(function))
-
- if not numpy.iterable(sequence):
- raise TypeError("input '%s' is not iterable" %
- repr(sequence))
-
- sequence = list(sequence)
- size = len(sequence)
-
- if not _multi or size == 1:
- results = map(function, sequence)
- if bar is not None:
- bar.stop()
- return results
-
-
- # Set default number of cores to use. Try to leave one core free for pyplot.
- if numcores is None:
- numcores = _ncpus - 1
- if numcores > _ncpus - 1:
- numcores = _ncpus - 1
- if numcores < 1:
- numcores = 1
-
- # Returns a started SyncManager object which can be used for sharing
- # objects between processes. The returned manager object corresponds
- # to a spawned child process and has methods which will create shared
- # objects and return corresponding proxies.
- manager = multiprocessing.Manager()
-
- # Create FIFO queue and lock shared objects and return proxies to them.
- # The managers handles a server process that manages shared objects that
- # each slave process has access to. Bottom line -- thread-safe.
- out_q = manager.Queue()
- err_q = manager.Queue()
- lock = manager.Lock()
- bar_state = manager.dict()
- if bar is not None:
- bar_state['pos'] = bar.pos
- bar_state['spin_pos'] = bar.spin_pos
- bar_state['started'] = bar.started
-
- # if sequence is less than numcores, only use len sequence number of
- # processes
- if size < numcores:
- numcores = size
-
- # group sequence into numcores-worth of chunks
- if weights is None or numcores == size:
- # No grouping specified (or there are as many cores as
- # processes), so divide into equal chunks
- sequence = numpy.array_split(sequence, numcores)
- else:
- # Group so that each group has roughly an equal sum of weights
- weight_per_core = numpy.sum(weights)/float(numcores)
- cut_values = []
- temp_sum = 0.0
- for indx, weight in enumerate(weights):
- temp_sum += weight
- if temp_sum > weight_per_core:
- cut_values.append(indx+1)
- temp_sum = weight
- if len(cut_values) > numcores - 1:
- cut_values = cut_values[0:numcores-1]
- sequence = numpy.array_split(sequence, cut_values)
-
- # Make sure there are no empty chunks at the end of the sequence
- while len(sequence[-1]) == 0:
- sequence.pop()
-
- procs = [multiprocessing.Process(target=worker,
- args=(function, ii, chunk, out_q, err_q, lock, bar, bar_state))
- for ii, chunk in enumerate(sequence)]
-
- try:
- results = run_tasks(procs, err_q, out_q, len(sequence))
- if bar is not None:
- if bar.started:
- bar.stop()
- return results
-
- except KeyboardInterrupt:
- for proc in procs:
- if proc.exitcode is None:
- proc.terminate()
- proc.join()
- raise
diff --git a/CEP/PyBDSM/src/python/mylogger.py b/CEP/PyBDSM/src/python/mylogger.py
deleted file mode 100644
index 7196c1fdf4d5a80182a82a719633b138dc26d3b1..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/python/mylogger.py
+++ /dev/null
@@ -1,137 +0,0 @@
-""" WARNING, ERROR, and CRITICAL are always output to screen and to log file.
-INFO and USERINFO always go to the log file. DEBUG goes to log file if debug is
-True. USERINFO goes to screen only if quiet is False.
-
-Use as follows:
-
-mylog = mylogger.logging.getLogger("name")
-
-mylog.info('info') --> print to logfile, but not to screen
-mylog.userinfo(mylog, 'info') --> print to screen (if quiet==False)
- and to logfile
-"""
-import logging
-from socket import gethostname
-import commands
-import time
-import copy
-
-def init_logger(logfilename, quiet=False, debug=False):
- logging.USERINFO = logging.INFO + 1
- logging.addLevelName(logging.USERINFO, 'USERINFO')
- logger = logging.getLogger("PyBDSM")
- logger.setLevel(logging.DEBUG)
-
- # First remove any existing handlers (in case PyBDSM has been run
- # before in this session but the quiet or debug options have changed
- while len(logger.handlers) > 0:
- logger.removeHandler(logger.handlers[0])
-
- # File handlers
- fh = ColorStripperHandler(logfilename)
- if debug:
- # For log file and debug on, print name and levelname
- fh.setLevel(logging.DEBUG)
- fmt1 = MultiLineFormatter('%(asctime)s %(name)-20s:: %(levelname)-8s: '\
- '%(message)s',
- datefmt='%a %d-%m-%Y %H:%M:%S')
- else:
- # For log file and debug off, don't print name and levelname as
- # they have no meaning to the user.
- fh.setLevel(logging.INFO)
- fmt1 = MultiLineFormatter('%(asctime)s:: %(levelname)-8s: %(message)s',
- datefmt='%a %d-%m-%Y %H:%M:%S')
- fh.setFormatter(fmt1)
- logger.addHandler(fh)
-
- # Console handler for warning, error, and critical: format includes levelname
- # ANSI colors are used
- ch = logging.StreamHandler()
- ch.setLevel(logging.WARNING)
- fmt2 = logging.Formatter('\033[31;1m%(levelname)s\033[0m: %(message)s')
- ch.setFormatter(fmt2)
- logger.addHandler(ch)
-
- # Console handler for USERINFO only: format does not include levelname
- # (the user does not need to see the levelname, as it has no meaning to them)
- # ANSI colors are allowed
- chi = logging.StreamHandler()
- chi.addFilter(InfoFilter())
- if quiet:
- # prints nothing, since filter lets only USERINFO through
- chi.setLevel(logging.WARNING)
- else:
- # prints only USERINFO
- chi.setLevel(logging.USERINFO)
- fmt3 = logging.Formatter('%(message)s')
- chi.setFormatter(fmt3)
- logger.addHandler(chi)
-
-class InfoFilter(logging.Filter):
- # Lets only USERINFO through
- def filter(self, rec):
- return rec.levelno == logging.USERINFO
-
-class MultiLineFormatter(logging.Formatter):
- def format(self, record):
- str = logging.Formatter.format(self, record)
- header, footer = str.split(record.message)
- nocolor_header = strip_color(header)
- str = str.replace('\n', '\n' + ' '*len(nocolor_header))
- return str
-
-def userinfo(mylog, desc_str, val_str=''):
- """Writes a nicely formatted string to the log file and console
-
- mylog = logger
- desc_str = description string / message
- val_str = value string
-
- Message is constructed as:
- 'desc_str .... : val_str'
- """
- bc = '\033[1;34m' # Blue
- nc = '\033[0m' # Normal text color
-
- if val_str == '':
- sep = ''
- if desc_str[:1] == '\n':
- bc += '\n'
- desc_str = desc_str[1:]
- desc_str = bc + '--> ' + desc_str + nc
- else:
- sep = ' : '
- if len(desc_str) < 40:
- desc_str += ' '
- if len(desc_str) < 40:
- while len(desc_str) < 41:
- desc_str += '.'
- else:
- while len(desc_str) < 41:
- desc_str += ' '
- mylog.log(logging.USERINFO, desc_str+sep+val_str)
-
-
-class ColorStripperHandler(logging.FileHandler):
- def emit(self, record):
- """Strips ANSI color codes from file stream"""
- myrecord = copy.copy(record)
- nocolor_msg = strip_color(myrecord.msg)
- myrecord.msg = nocolor_msg
- logging.FileHandler.emit(self, myrecord)
-
-def strip_color(msg):
- """Strips specific ANSI color codes from an input string
-
- The color codes are hard-coded to those used above
- in userinfo() and in WARNING, ERROR, and CRITICAL.
- """
- nocolor_msg = ''
- a = msg.split('\033[1;34m')
- for b in a:
- c = b.split('\033[0m')
- for d in c:
- e = d.split('\033[31;1m')
- for f in e:
- nocolor_msg += f
- return nocolor_msg
diff --git a/CEP/PyBDSM/src/python/opts.py b/CEP/PyBDSM/src/python/opts.py
deleted file mode 100644
index eafe25fbb93e030cca36ad174258218ef5b9b084..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/python/opts.py
+++ /dev/null
@@ -1,1490 +0,0 @@
-"""PyBDSM options
-
-Options are essentially user-controllable parameters passed into PyBDSM
-operations, and allow for end-users to control the exact details of how
-calculations are done.
-
-The doc string should give a short description of the option, followed by a
-line break ('\n') then a long, detailed description. The short description can
-then be split off using "str(v.doc()).split('\n')[0]".
-
-The group string can be used to group suboptions under a parent option. The
-group string should be the name of the parent option, which must be Bool
-(except for the "hidden" group, which will suppress listing of the option; the
-option can still be set as normal).
-
-In general it's better to specify newly added options directly in this file, so
-one can oversee them all. But it's also possible to extend it at run-time, and
-under some circumstances (e.g. pybdsm installed system-wide, and there is no
-way to modify this file) this might be the only option to do so. An example of
-such extension follows:
-
-==== file newmodule.py ====
-from image import Op
-
-class Op_new_op(Op):
- ## do something useful here
- ## we need to add option my_new_opt
- pass
-
-## this will extend Opts class at runtime and ensure that
-## type-checking works properly.
-Opts.my_new_opt = Float(33, doc="docstring")
-"""
-import sys
-from tc import Int, Float, Bool, String, Tuple, Enum, \
- Option, NArray, Instance, tInstance, List, Any, TCInit, tcError
-
-class Opts(object):
- """Class Opts -- user-controllable parameters."""
- advanced_opts = Bool(False,
- doc = "Show advanced options")
- atrous_do = Bool(False,
- doc = "Decompose Gaussian residual image "\
- "into multiple scales\n"\
- "If True, then the Gaussian-subtracted "\
- "residual image is decomposed into multiple "\
- "scales using an a-trous wavelet transform.\n"\
- "This option is most useful when there is "\
- "significant extended emission in the image. "\
- "If the image contains only point sources, "\
- "it is best to set this to Fasle.")
- beam = Option(None, Tuple(Float(), Float(), Float()),
- doc = "FWHM of restoring beam. Specify as (maj, "\
- "min, pos ang E of N) in degrees. "\
- "E.g., beam = (0.06, 0.02, 13.3). None => "\
- "get from header\n"\
- "For more than one channel, use the beam_spectrum "\
- "parameter. "\
- "If the beam is not given "\
- "by the user, then it is looked for in the "\
- "image header. If not found, then an error "\
- "is raised. PyBDSM will not work without "\
- "knowledge of the restoring beam.")
- filename = String(doc = "Input image file name\n"\
- "The input image can be a FITS or CASA 2-, "\
- "3-, or 4-D cube.")
- flagging_opts = Bool(False,
- doc = "Show options for Gaussian flagging\n"\
- "Gaussians which are likely in error "\
- "(e.g., very small or very large Gaussians) "\
- "are flagged according to a number of criteria, "\
- "which the user may control. "\
- "Flags are cumulative (i.e., if multiple "\
- "flagging criteria are met, the respective "\
- "flag values are added to produce the final "\
- "flag value). Flag values are defined as follows:\n"\
- "If flag_minsnr: flag + 1\n"\
- "If flag_maxsnr: flag + 2\n"\
- "If flag_bordersize: flag + 4 (x) or 8 (y)\n"\
- "If flag_maxsize_isl: flag + 16 (x) or 32 (y)\n"\
- "If flag_maxsize_bm: flag + 64\n"\
- "If flag_minsize_bm: flag + 128\n"\
- "If flag_maxsize_fwhm: flag + 256")
- frequency = Option(None, Float(),
- doc = "Frequency in Hz of input image. "\
- "E.g., frequency = 74e6. None => get from header.\n"\
- "For more than one channel, use the frequency_sp "\
- "parameter. If the frequency is not given "\
- "by the user, then it is looked for in the "\
- "image header. If not found, then an error "\
- "is raised. PyBDSM will not work without "\
- "knowledge of the frequency.")
- interactive = Bool(False,
- doc = "Use interactive mode\n"\
- "In interactive mode, plots are displayed at "\
- "various stages of the processing so that "\
- "the user may check the progress of the fit.\n"\
- "First, plots of the rms and mean background images are "\
- "displayed along with the islands found, before "\
- "fitting of Gaussians takes place. The user should "\
- "verify that the islands and maps are reasonable "\
- "before preceding.\n"\
- "Next, if atrous_do is True, the fits to each "\
- "wavelet scale are shown. The wavelet fitting "\
- "may be truncated at the current scale if "\
- "desired.\nLastly, the final results are shown.")
- mean_map = Enum('default', 'zero', 'const', 'map',
- doc = "Background mean map: 'default' => calc whether "\
- "to use or not, 'zero' => 0, 'const' => "\
- "clipped mean, 'map' => use 2-D map\n"\
- "This parameter determines "\
- "how the background mean map is computed "\
- "and how it is used further.\nIf 'const', then "\
- "the value of the clipped "\
- "mean of the entire image (set by the kappa_clip "\
- "option) is used as the "\
- "background mean map.\nIf 'zero', then a value "\
- "of zero is used.\nIf 'map', then "\
- "the 2-dimensional mean map is computed and used. "\
- "The resulting mean map is largely determined by "\
- "the value of the rms_box parameter (see the "\
- "rms_box parameter for more information).\nIf "\
- "'default', then PyBDSM will attempt to "\
- "determine automatically whether to use "\
- "a 2-dimensional map or a constant one as "\
- "follows. First, "\
- "the image is assumed to be confused if "\
- "bmpersrc_th < 25 or the ratio of the "\
- "clipped mean to rms (clipped mean/clipped rms) "\
- "is > 0.1, else the image is not confused. "\
- "Next, the mean map is checked to "\
- "see if its spatial variation is significant. If "\
- "so, then a 2-D map is used and, if not, "\
- "then the mean map is set to either 0.0 or a "\
- "constant depending on whether the image is "\
- "thought to be confused or not.\nGenerally, "\
- "'default' works well. However, if there is "\
- "significant extended emission in the image, "\
- "it is often necessary to force the use of a "\
- "constant mean map using either 'const' or "\
- "'mean'.")
- multichan_opts = Bool(False,
- doc = "Show options for multi-channel "\
- "images")
- output_opts = Bool(False,
- doc = "Show output options")
- polarisation_do = Bool(False,
- doc = "Find polarisation properties\n"\
- "First, if pi_fit = True, source detection is done on the polarized intensity "\
- "(PI) image and sources not detected in "\
- "the Stokes I image are identified. The thresholds for island "\
- "detection can be controlled using the pi_thresh_isl and "\
- "pi_thresh_pix parameters.\n"\
- "Next, for any such PI-only sources, "\
- "plus all sources detected in the Stokes I image, "\
- "the flux densities in each of the other Stokes images are found. "\
- "Flux densities are calculated by fitting for the normalization of the Gaussians "\
- "found from the Stokes I or PI images."\
- "Lastly, the polarisation fraction and angle for each source "\
- "are calculated.\n"\
- "For linearly polarised emission, the signal and noise "\
- "add vectorially, giving a Rice distribution "\
- "(Vinokur 1965) instead of a Gaussian one. To correct "\
- "for this, a bias is estimated and removed from the "\
- "polarisation fraction using the same method used for the "\
- "NVSS catalog (see ftp://ftp.cv.nrao.edu/pub/nvss/catalog.ps). "\
- "Errors on the linear and total polarisation fractions "\
- "and polarisation angle are estimated using the debiased "\
- "polarised flux density and standard error propagation. See "\
- "Sparks & Axon (1999) for a more detailed treatment.")
- psf_vary_do = Bool(False,
- doc = "Calculate PSF variation across image")
- rm_do = Bool(False,
- doc = "Find rotation measure properties",
- group = 'hidden')
- rms_box = Option(None, Tuple(Int(), Int()),
- doc = "Box size, step size for rms/mean map "\
- "calculation. Specify as (box, step) in "\
- "pixels. E.g., rms_box = (40, 10) => box "\
- "of 40x40 pixels, step of 10 pixels. "\
- "None => calculate inside program\n"\
- "This is a tuple of two integers and is probably the "\
- "most important input parameter for PyBDSM. The first "\
- "integer, boxsize, is the size of the 2-D sliding box "\
- "for calculating the rms and mean over the entire image. "\
- "The second, stepsize, is the number of pixels by which "\
- "this box is moved for the next measurement. If None, "\
- "then suitable values are calculated internally.\n"\
- "In general, it is best to choose a box size that "\
- "corresponds to the typical scale of artifacts in the "\
- "image, such as those that are common around bright "\
- "sources. Too small of a box size will effectively "\
- "raise the local rms near a source so much that a "\
- "source may not be fit at all; too large a box size "\
- "can result in underestimates of the rms due to "\
- "oversmoothing. A step size of 1/3 "\
- "to 1/4 of the box size usually works well.\n"\
- "If adaptive_rms_box is True, the rms_box parameter "\
- "sets the large-scale box size that is used far "\
- "from bright sources.")
- rms_map = Enum(None, True, False,
- doc = "Background rms map: True => "\
- "use 2-D rms map; False => use constant rms; " \
- "None => calculate inside program\n"\
- "If True, then the 2-D background rms image is "\
- "computed and used. If False, then a constant value is "\
- "assumed (use rms_value to force the rms to a specific "\
- "value). If None, then the 2-D rms image is calculated, and "\
- "if the variation is statistically significant then it "\
- "is taken, else a constant value is assumed. The rms image "\
- "used for each channel in computing the spectral index "\
- "follows what was done for the channel-collapsed image.\n"\
- "Generally, None works well. However, if there is "\
- "significant extended emission in the image, "\
- "it is often necessary to force the use of a "\
- "constant rms map by setting rms_map = False.")
- shapelet_do = Bool(False,
- doc = "Decompose islands into shapelets\n"\
- "If True, then each island is decomposed using shapelets, "\
- "However, at the moment, output of the shapelet parameters "\
- "is not supported.")
- spectralindex_do = Bool(False,
- doc = "Calculate spectral indices (for multi-channel image)\n"\
- "If True, then for a multi-channel image, spectral indices "\
- "are calculated for all Gaussians and sources which are "\
- "detected in the channel-collapsed image.\nFrequencies "\
- "can be specified manually using frequency_sp.")
- thresh = Enum(None, "hard", "fdr",
- doc = "Type of thresholding: " \
- "None => calculate inside program, 'fdr' => use "\
- "false detection rate algorithm, 'hard' => "\
- "use sigma clipping\nIf thresh = 'hard', "\
- "then a hard threshold is assumed, given by thresh_pix. "\
- "If thresh = 'fdr', then the False Detection Rate algorithm of "\
- "Hancock et al. (2002) is used to calculate the value of "\
- "thresh_pix. If thresh is None, then the false detection "\
- "probability is first calculated, and if the number of false "\
- "source pixels is more than fdr_ratio times the estimated "\
- "number of true source pixels, then the 'fdr' threshold "\
- "option is chosen, else the 'hard' threshold option is "\
- "chosen.")
- thresh_isl = Float(3,
- doc = "Threshold for the island boundary in number of sigma "\
- "above the mean. Determines extent of island used for fitting\n"\
- "This parameter determines the region to which fitting "\
- "is done. A higher value will produce smaller islands, "\
- "and hence smaller regions that are considered in the "\
- "fits. A lower value will produce larger islands. "\
- "Use the thresh_pix parameter to set the detection "
- "threshold for sources. Generally, thresh_isl should "\
- "be lower than thresh_pix.\n"
- "Only regions "\
- "above the absolute threshold will be used. "\
- "The absolute threshold is calculated as abs_thr = "\
- "mean + thresh_isl * rms. Use the mean_map "\
- "and rms_map parameters to control the way "\
- "the mean and rms are determined.")
- thresh_pix = Float(5,
- doc = "Source detection threshold: threshold for the "\
- "island peak in number of sigma "\
- "above the mean. If "\
- "false detection rate thresholding is used, "\
- "this value is ignored and thresh_pix is "\
- "calculated inside the program\n"\
- "This parameter sets the overall detection threshold "\
- "for islands (i.e. thresh_pix = 5 will find all sources "\
- "with peak flux densities per beam of 5-sigma or greater). Use the "\
- "thresh_isl parameter to control how much of each island "\
- "is used in fitting. Generally, thresh_pix should be larger "\
- "than thresh_isl.\n"
- "Only islands "\
- "with peaks above the absolute threshold will be used. "\
- "The absolute threshold is calculated as abs_thr = "\
- "mean + thresh_pix * rms. Use the mean_map "\
- "and rms_map parameters to control the way "\
- "the mean and rms are determined.")
- adaptive_rms_box = Bool(False,
- doc = "Use adaptive rms_box when determining rms and "\
- "mean maps\n"\
- "If True, the rms_box is reduced in size near "\
- "bright sources and enlarged far from them. "\
- "This scaling attempts to account for possible "\
- "strong artifacts around bright sources while "\
- "still acheiving accurate background rms and "\
- "mean values when extended sources are present.\n"\
- "This option is generally slower than non-"\
- "adaptive scaling.\n"\
- "Use the rms_box parameter to set the large-"\
- "scale rms_box and the rms_box_bright parameter "\
- "to set the small-scale rms_box. The threshold "\
- "for bright sources can be set with the "\
- "adaptive_thresh parameter.")
-
-
- #--------------------------------ADVANCED OPTIONS--------------------------------
- split_isl = Bool(True,
- doc = "Split island if it is too large, has a large "\
- "convex deficiency and it opens well.\n"\
- "If it doesn't open well, then isl.mean = "\
- "isl.clipped_mean, and is taken for fitting. "\
- "Splitting, if needed, is always done for "\
- "wavelet images",
- group = 'advanced_opts')
- splitisl_maxsize = Float(50.0,
- doc = "If island size in beam area is more than this, "\
- "consider splitting island. Min value is 50",
- group = 'advanced_opts')
- splitisl_size_extra5 = Float(0.1,
- doc = "Fraction of island area for 5x5 opening to "\
- "be used.\nWhen deciding to split an island, "\
- "if the smallest extra sub islands while opening "\
- "with a 5x5 footprint add up to at least this "\
- "fraction of the island area, and if the largest "\
- "sub island is less than 75% the size of the "\
- "largest when opened with a 3x3 footprint, a "\
- "5x5 opening is taken.",
- group = 'hidden')
- splitisl_frac_bigisl3 = Float(0.8,
- doc = "Fraction of island area for 3x3 opening to "\
- "be used.\nWhen deciding to split an island, "\
- "if the largest sub island when opened with a "\
- "3x3 footprint is less than this fraction of the "\
- "island area, then a 3x3 opening is considered.",
- group = 'hidden')
- peak_fit = Bool(True,
- doc = "Find and fit peaks of large islands iteratively\n"\
- "When enabled, PyBDSM will identify and "\
- "fit peaks of emission in "\
- "large islands iteratively (the size of islands for which "\
- "peak fitting is done is controlled with the "\
- "peak_maxsize option), using a maximum of 10 "\
- "Gaussians per iteration. Enabling this option will "\
- "generally speed up fitting, but may result in "\
- "somewhat higher residuals.",
- group = 'advanced_opts')
- peak_maxsize = Float(30.0,
- doc = "If island size in beam area is more than this, "\
- "attempt to fit peaks iteratively (if "\
- "peak_fit = True). Min value is 30",
- group = 'advanced_opts')
- fdr_alpha = Float(0.05,
- doc = "Alpha for FDR algorithm for thresholds\n"\
- "If thresh is 'fdr', then the estimate of fdr_alpha "\
- "(see Hancock et al. 2002 for details) is stored "\
- "in this parameter.",
- group = "advanced_opts")
- fdr_ratio = Float(0.1,
- doc = "For thresh = None; " \
- "if #false_pix / #source_pix < fdr_ratio, " \
- "thresh = 'hard' else thresh = 'fdr'",
- group = "advanced_opts")
- kappa_clip = Option(None, Float(),
- doc = "Kappa for clipped mean and rms. None => calculate "\
- "inside program\n"\
- "The value of this is the factor used for Kappa-alpha "\
- "clipping, as in AIPS. For an image with few source "\
- "pixels added on to (Gaussian) noise pixels, the "\
- "dispersion of the underlying noise will need to be "\
- "determined. This is done iteratively, whereby the actual "\
- "dispersion is first computed. Then, all pixels whose "\
- "value exceeds kappa clip times this rms are excluded and "\
- "the rms is computed again. This process is repeated until "\
- "no more pixels are excluded. For well behaved noise "\
- "statistics, this process will converge to the true noise "\
- "rms with a value for this parameter ~3-5. A large "\
- "fraction of source pixels, less number of pixels in total, "\
- "or significant non-gaussianity of the underlying noise "\
- "will all lead to non-convergence.",
- group = "advanced_opts")
- bmpersrc_th = Option(None, Float(),
- doc = "Theoretical estimate of number of beams " \
- "per source. None => calculate inside program\n"\
- "Its value is calculated inside the program if its "\
- "value is given as None as N/[n*(alpha-1)], where N "\
- "is the total number of pixels in the image, n is "\
- "the number of pixels in the image whose value is "\
- "greater than 5 times the clipped rms, and alpha is "\
- "the slope of the differential source counts "\
- "distribution, assumed to be 2.5. The value of "\
- "bmpersrc_th is used to estimate the average separation "\
- "in pixels between two sources, which in turn is used "\
- "to estimate the boxsize for calculating the background "\
- "rms and mean images. In addition, if the value is below "\
- "25 (or the ratio of clipped mean to clipped rms of the "\
- "image is greater than 0.1), the image is assumed to be "\
- "confused and hence the background mean is put to zero.",
- group = "advanced_opts")
- spline_rank = Enum(3, 1, 2, 4,
- doc = "Rank of the interpolating function for rms/mean map\n"\
- "This is an integer and is the order of the interpolating "\
- "spline function to interpolate the background rms and "\
- "mean map over the entire image.",
- group = "advanced_opts")
- minpix_isl = Option(None, Int(),
- doc = "Minimum number of pixels with emission per island "\
- "(minimum is 6 pixels). "\
- "None -> calculate inside program\n"\
- "This is an integer and is the minimum number of pixels "\
- "in an island for "\
- "the island to be included. If None, the number of "\
- "pixels is set to 1/3 of the area of an unresolved source "\
- "using the beam and pixel size information in the "\
- "image header. It is set to 6 pixels for all "\
- "wavelet images.",
- group = "advanced_opts")
- rms_value = Option(None, Float(),
- doc = "Value of constant rms in "\
- "Jy/beam to use if rms_map = False. "\
- "None => calculate inside program",
- group = "advanced_opts")
- aperture = Option(None, Float(),
- doc = "Radius of aperture in pixels inside which aperture fluxes are measured "\
- "for each source. None => no aperture fluxes measured\n" \
- "This is a float and sets the radius (in pixels) inside "\
- "which the aperture flux is measured for each source. "\
- "Depending on the value of aperture_posn, the aperture is centered either "\
- "on the centroid or the peak of the source. Errors are calculated "\
- "from the mean of the rms map inside the aperture.",
- group = "advanced_opts")
- aperture_posn = Enum('centroid', 'peak',
- doc = "Position the aperture (if aperture is not None) on: "\
- "'centroid' or 'peak' of the source.\n"\
- "This parameter determines how the aperture is "\
- "positioned relative to the source. If 'centroid', "\
- "the aperture is centered on the source centroid. If "\
- "'peak', the aperture is centered on the source peak. "\
- "If aperture=None (i.e., no aperture radius is specified), "\
- "this parameter is ignored.",
- group = "advanced_opts")
- src_ra_dec = Option(None, List(Tuple(Float(), Float())),
- doc = "List of source positions at which fitting is done. "\
- "E.g., src_ra_dec = [(197.1932, 47.9188), (196.5573, 42.4852)].\n"\
- "This parameter defines the center positions at which "\
- "fitting will be done. The size of the region used for "\
- "the fit is given by the src_radius_pix parameter. "\
- "Positions should be given as a list of RA and Dec, "\
- "in degrees, one set per source. These positions will "\
- "override the normal island finding module.",
- group = "advanced_opts")
- src_radius_pix = Option(None, Float(),
- doc = "Radius of the island (if src_ra_dec is not None) in pixels. "\
- "None => radius is set to the FWHM of the beam major axis.\n"\
- "This parameter determines the size of the region used "\
- "to fit the source positions specified by the src_ra_dec "\
- "parameter.",
- group = "advanced_opts")
- ini_gausfit = Enum('default', 'simple', 'nobeam',
- doc = "Initial guess for Gaussian "\
- "parameters: 'default', 'simple', or 'nobeam'\n"\
- "These are three different ways of estimating the initial "\
- "guess for fitting of Gaussians to an island of emission.\n"\
- "If 'default', the number of Gaussians is "\
- "estimated from the number of peaks in the island. An initial "\
- "guess is made for the parameters of these Gaussians before "\
- "final fitting is done. This method should produce the best "\
- "results when there are no large sources present.\n"\
- "If 'simple', the maximum allowable number of Gaussians per island "\
- "is set to 25, and no initial guess for the gaussian parameters "\
- "is made.\nLastly, the 'nobeam' method is similar to the "\
- "'default' method, but no information about the beam is "\
- "used. This method is best used when source sizes are "\
- "expected to be very different from the beam and is generally "\
- "slower than the other methods.\n"\
- "For wavelet images, the value used for the original "\
- "image is used for wavelet order j <= 3 and 'nobeam' for "\
- "higher orders.",
- group = "advanced_opts")
- ini_method = Enum('intensity', 'curvature',
- doc = "Method by which inital guess for fitting of Gaussians "\
- "is chosen: 'intensity' or 'curvature'\n"\
- "If 'intensity', the inital guess described in the help for "\
- "the ini_gausfit parameter is calculated using the intensity "\
- "(ch0) image. If 'curvature', it is done using the curvature "\
- "map (see Hancock et al. 2012).",
- group = "advanced_opts")
- fix_to_beam = Bool(False,
- doc = "Fix major and minor axes and PA of Gaussians to beam?\n"\
- "If True, then during fitting the major and minor axes "\
- "and PA of the Gaussians are fixed to the beam. Only the "\
- "amplitude and position are fit. If False, all parameters "\
- "are fit.",
- group = "advanced_opts")
- fittedimage_clip = Float(0.1,
- doc = "Sigma for clipping Gaussians " \
- "while creating fitted image\n"\
- "When the residual image is being made after Gaussian "\
- "decomposition, the model images for each fitted Gaussian "\
- "are constructed up to a size 2b, such that the amplitude "\
- "of the Gaussian falls to a value of fitted_image_clip times "\
- "the local rms, b pixels from the peak.",
- group = "advanced_opts")
- check_outsideuniv = Bool(False,
- doc = "Check for pixels outside the "\
- "universe\n"\
- "If True, then the coordinate of each pixel is examined "\
- "to check if it is outside the universe, which may "\
- "happen when, e.g., an all sky image is made with SIN "\
- "projection (commonly done at LOFAR earlier). When found, "\
- "these pixels are blanked (since imaging software do not "\
- "do this on their own). Note that this process takes a "\
- "lot of time, as every pixel is checked in case weird "\
- "geometries and projections are used",
- group = "advanced_opts")
- trim_box = Option(None, Tuple(Float(), Float(), Float(), Float()),
- doc = "Do source detection on only a part of the image. "\
- "Specify as (xmin, xmax, ymin, ymax) in pixels. "\
- "E.g., trim_box = (120, 840, 15, 895). None => "\
- "use entire image",
- group = "advanced_opts")
- stop_at = Enum(None, 'isl', 'read',
- doc = "Stops after: 'isl' = island finding step or "\
- "'read' = image reading step",
- group = "advanced_opts")
- group_by_isl = Bool(False,
- doc = "Group all Gaussians in each island into a single "\
- "source\n"\
- "If True, all Gaussians in the island belong to a "\
- "single source. If False, grouping is controlled "\
- "by the group_tol parameter.",
- group = "advanced_opts")
- group_method = Enum('intensity', 'curvature',
- doc = "Group Gaussians into sources using 'intensity' map "\
- "or 'curvature' map\n"\
- "Gaussians are deemed to be a part of "\
- "the same source if: 1. no pixel on the line joining "\
- "the centers of any pair of Gaussians has a (Gaussian-"\
- "reconstructed) value less than the island threshold, and "\
- "2. the centers are separated by a distance less than "\
- "half the sum of their FWHMs along the line joining them.\n"\
- "If 'curvature', the above comparisons are done on the "\
- "curature map (see Hancock et al. 2012). If 'intensity', "\
- "the comparisons are done on the intensity map.",
- group = "advanced_opts")
- group_tol = Float(1.0,
- doc = "Tolerance for grouping of Gaussians into sources: "\
- "larger values will result in larger sources\n"\
- "Sources are created by "\
- "grouping nearby Gaussians as follows: (1) If the minimum "\
- "value between two Gaussians in an island is more than "\
- "group_tol * thresh_isl * rms_clip, "\
- "and (2) if the centres are seperated by a distance less "\
- "than 0.5*group_tol of the sum of their fwhms along the "\
- "PA of the line joining them, they belong to the "\
- "same island.",
- group = "advanced_opts")
- blank_limit = Option(None, Float(),
- doc = "Limit in Jy/beam below which pixels are blanked. "\
- "None => no such blanking is done\n"\
- "All pixels in the ch0 image with a value less than the "\
- "specified limit and with at least 4 neighboring pixels "\
- "with values also less than this limit are blanked. "\
- "If None, any such pixels are left unblanked. "\
- "Pixels with a value of NaN are always blanked.",
- group = "advanced_opts")
- detection_image = String(doc = "Detection image file name used only for detecting "\
- "islands of emission. Source measurement is still done "\
- "on the main image\n"\
- "The detection image can be a FITS or CASA 2-, "\
- "3-, or 4-D cube. The detection image and the main"\
- "image must have the same size and be registered.",
- group = "advanced_opts")
- do_mc_errors = Bool(False,
- doc = "Estimate uncertainties for 'M'-type sources using Monte "\
- "Carlo method\n"\
- "If True, uncertainties on the sizes and "\
- "positions of 'M'-type sources "\
- "due to uncertainties in the constituent Gaussians are "\
- "estimated using a Monte Carlo technique. These "\
- "uncertainties are added in quadrature with those "\
- "calculated using Condon (1997). If False, "\
- "these uncertainties are ignored, and errors are "\
- "calculated using Condon (1997) only.\n"\
- "Enabling this option will result in longer run "\
- "times if many 'M'-type sources are present, but "\
- "should give better estimates of the uncertainites, "
- "particularly for complex sources composed of many "\
- "Gaussians.",
- group = "advanced_opts")
- ncores = Option(None, Int(),
- doc = "Number of cores to use during fitting, None => "\
- "use all\n"\
- "Sets the number of cores to use during fitting.",
- group = "advanced_opts")
- do_cache = Bool(False,
- doc = "Cache internally derived images to disk\n" \
- "This option controls whether internally "\
- "derived images are stored in memory or are "\
- "cached to disk. Caching can reduce the amount "\
- "of memory used, and is therefore useful when "\
- "analyzing large images.",
- group = "advanced_opts")
-
- #--------------------------------ADAPTIVE RMS_BOX OPTIONS--------------------------------
- rms_box_bright = Option(None, Tuple(Int(), Int()),
- doc = "Box size, step size for rms/mean map "\
- "calculation near bright sources. Specify as (box, step) in "\
- "pixels. None => calculate inside program\n"\
- "This parameter sets the box and step sizes "\
- "to use near bright sources (determined by the "\
- "adaptive_thresh parameter). The large-scale "\
- "box size is set with the rms_box parameter.",
- group = "adaptive_rms_box")
- adaptive_thresh = Option(None, Float(),
- doc = "Sources with pixels "\
- "above adaptive_thresh*clipped_rms will be considered as "\
- "bright sources (i.e., with potential artifacts). "\
- "Minimum is 10.0. "\
- "None => calculate inside program\n"\
- "This parameter sets the SNR above which "\
- "sources may be affected by strong artifacts "\
- "Sources that meet the SNR threshold will use the "\
- "small-scale rms_box (which helps to exclude artifacts) "\
- "if their sizes at a threshold of 10.0 is less "\
- "than 25 beam areas.\n"
- "If None, the threshold is varied from 500 "\
- "to 50 to attempt to obtain at least 5 candidate "\
- "bright sources.",
- group = "adaptive_rms_box")
-
- #--------------------------------A-TROUS OPTIONS--------------------------------
- atrous_jmax = Int(0,
- doc = 'Max allowed wavelength order, 0 => calculate '\
- 'inside program\n'\
- 'This is an integer which is the maximum order of '\
- 'the a-trous wavelet decomposition. If 0 (or <0 or '\
- '>15), then the value is determined within the '\
- 'program. The value of this parameter is then '\
- 'estimated as the (lower) rounded off value of '\
- 'ln[(nm-l)/(l-1) + 1]/ln2 + 1 where nm is the '\
- 'minimum of the residual image size (n, m) in pixels '\
- 'and l is the length of the filter a-trous lpf (see '\
- 'the atrous_lpf parameter for more info).\nA sensible '\
- 'value of jmax is such that the size of the kernel is '\
- 'not more than 3-4 times smaller than the smallest image '\
- 'dimension.',
- group = "atrous_do")
- atrous_lpf = Enum('b3', 'tr',
- doc = "Low pass filter, either 'b3' or "\
- "'tr', for B3 spline or Triangle\n"\
- "This is the low pass filter, which can be "\
- "either the B3 spline or the Triangle function, which "\
- "is used to generate the a-trous wavelets. The B3 "\
- "spline is [1, 4, 6, 4, 1] and the triangle is "\
- "[1, 2, 1], normalised so that the sum is unity. The "\
- "lengths of the filters are hence 5 and 3 respectively.",
- group = "atrous_do")
- atrous_bdsm_do = Bool(True,
- doc = "Perform source extraction on each wavelet "\
- "scale\n"\
- "If True, fitting is done on each wavelet scale "\
- "(or sum of scales if atrous_sum is True). If False, "\
- "no fitting is done.",
- group = "atrous_do")
- atrous_orig_isl = Bool(False,
- doc = "Restrict wavelet Gaussians to islands found "\
- "in original image\n"\
- "If True, all wavelet Gaussians must lie within "\
- "the boundaries of islands found in the original "\
- "image. If False, new islands that are found only in "\
- "the wavelet images are included in the final "\
- "fit.",
- group = "atrous_do")
- atrous_sum = Bool(True,
- doc = "Fit to the sum of remaining wavelet scales\n"\
- "If True, fitting is done on an image that is the sum "\
- "of the remaining wavelet scales. Using the sum will "\
- "generally result in improved signal. If False, "\
- "fitting is done on only the wavelet scale under "\
- "consideration.",
- group = "atrous_do")
- use_scipy_fft = Bool(True,
- doc = "Use fast SciPy FFT for convolution\n"\
- "If True, the SciPy FFT function will be used instead "\
- "of the custom version. The SciPy version is much "\
- "faster but also uses much more memory.",
- group = "atrous_do")
-
- #--------------------------------FLAGGING OPTIONS--------------------------------
- flag_smallsrc = Bool(False,
- doc = "Flag sources smaller than "\
- "flag_minsize_bm times beam area\n"\
- "If True, "\
- "then fitted Gaussians whose size is less than "\
- "flag_minsize_bm times the synthesized beam area are "\
- "flagged. When "\
- "combining Gaussians into sources, an "\
- "error is raised if a 2x2 box with the peak of "\
- "the Gaussian does not have all four pixels "\
- "belonging to the source. Usually this means "\
- "that the Gaussian is an artifact or has a very "\
- "small size. \nIf False, then if either of the sizes "\
- "of the fitted Gaussian is zero, then the "\
- "Gaussian is flagged.\nIf the image is barely Nyquist "\
- "sampled, this flag is best set to False. This "\
- "flag is automatically set to False while "\
- "decomposing wavelet images into Gaussians. ",
- group = "flagging_opts")
- flag_minsnr = Float(0.6,
- doc = "Flag Gaussian if peak is less than flag_minsnr "\
- "times thresh_pix times local rms\n"\
- "Any fitted Gaussian whose peak is less than "\
- "flag_minsnr times thresh_pix times the local rms "\
- "is flagged. The flag value is increased by 1.",
- group = "flagging_opts")
- flag_maxsnr = Float(1.5,
- doc = "Flag Gaussian if peak is greater than "\
- "flag_maxsnr times image value at the peak\n"\
- "Any fitted Gaussian whose peak is greater than "\
- "flag_maxsnr times the image value at the peak "\
- "is flagged. The flag value is increased by 2.",
- group = "flagging_opts")
- flag_maxsize_isl = Float(2.0,
- doc = "Flag Gaussian if x, y bounding box "\
- "around sigma-contour is factor times island bbox\n"\
- "Any fitted Gaussian whose maximum x-dimension is "\
- "larger than flag_maxsize_isl times the x-dimension "\
- "of the island (and likewise for the y-dimension) is "\
- "flagged. The flag value is increased by 16 (for x) "\
- "and 32 (for y).",
- group = "flagging_opts")
- flag_maxsize_fwhm = Float(0.5,
- doc = "Flag Gaussian if fwhm-contour times factor extends beyond island\n"\
- "Any fitted Gaussian whose contour of flag_maxsize_fwhm times the fwhm "\
- "falls outside the island is "\
- "flagged. The flag value is increased by 256.",
- group = "flagging_opts")
- flag_bordersize = Int(0,
- doc = "Flag Gaussian if centre is outside border "\
- "- flag_bordersize pixels\n"\
- "Any fitted Gaussian whose centre is border pixels "\
- "outside the island bounding box is flagged. The flag "\
- "value is increased by 4 (for x) and 8 (for y).",
- group = "flagging_opts")
- flag_maxsize_bm = Float(25.0,
- doc = "Flag Gaussian if area greater than "\
- "flag_maxsize_bm times beam area\n"\
- "Any fitted "\
- "Gaussian whose size is greater than flag_maxsize_"\
- "bm times the synthesized beam is flagged. The "\
- "flag value is increased by 64.",
- group = "flagging_opts")
- flag_minsize_bm = Float(0.7,
- doc = "Flag Gaussian if flag_smallsrc = True "\
- "and area smaller than flag_minsize_bm times "\
- "beam area\n"\
- "If flag_smallsrc is "\
- "True, then any fitted Gaussian whose size "\
- "is less than flag_maxsize_bm times the "\
- "synthesized beam is flagged. The Gaussian "\
- "flag is increased by 128.",
- group = "flagging_opts")
-
-
- #-----------------------------MULTICHANNEL OPTIONS--------------------------------
- beam_spectrum = Option(None, List(Tuple(Float(), Float(), Float())),
- doc = "FWHM of synthesized beam per channel. Specify as "\
- "[(bmaj_ch1, bmin_ch1, bpa_ch1), (bmaj_ch2, "\
- "bmin_ch2, bpa_ch2), etc.] in degrees. E.g., "\
- "beam_spectrum = [(0.01, 0.01, 45.0), (0.02, "\
- "0.01, 34.0)] for two channels. None => all "\
- "equal to beam\n"\
- "If None, then the channel-dependent "\
- "restoring beam is either assumed to be a constant or "\
- "to scale with frequency, depending on whether the "\
- "parameter beam_sp_derive is False or True.",
- group = "multichan_opts")
- frequency_sp = Option(None, List(Float()),
- doc = "Frequency in Hz of channels in input image when "\
- "more than one channel is present. "\
- "E.g., frequency_sp = [74e6, 153e6]. "\
- "None => get from header\n"\
- "If the frequency is not given "\
- "by the user, then it is looked for in the "\
- "image header. If not found, then an error "\
- "is raised. PyBDSM will not work without the "\
- "knowledge of the frequency.",
- group = "multichan_opts")
- beam_sp_derive = Bool(False,
- doc = "If True and beam_spectrum is None, then "\
- "assume header beam is for median frequency and scales "\
- "with frequency for channels\n"\
- "If True and the parameter beam_spectrum is None, then "\
- "we assume that the beam in the header is for the median "\
- "frequency of the image cube and scale accordingly to "\
- "calculate the beam per channel. If False, then a "\
- "constant value of the beam is taken instead.",
- group = "multichan_opts")
- collapse_mode = Enum('average', 'single',
- doc = "Collapse method: 'average' "\
- "or 'single'. Average channels or take single "\
- "channel to perform source detection on\n"\
- "This parameter determines whether, when multiple "\
- "channels are present, the source extraction is "\
- "done on a single channel or an average of many "\
- "channels.",
- group = 'multichan_opts')
- collapse_ch0 = Int(0,
- doc = "Number of the channel for source extraction, "\
- "if collapse_mode = 'single', starting from 0",
- group = 'multichan_opts')
- collapse_av = List(None,
- doc = "List of channels to average if collapse_mode "\
- "= 'average', starting from 0. E.g., collapse_av "\
- "= [0, 1, 5]. [] => all\n"\
- "This parameter is a list of channels to be averaged "\
- "to produce the continuum image for performing source "\
- "extraction, if collapse_mode is 'average'. If the "\
- "value is an empty list ([]), then all channels are used. Else, the "\
- "value is a Python list of channel numbers, starting "\
- "from 0 (i.e., the first channel has number 0, the "\
- "second has number 1, etc.).",
- group = 'multichan_opts')
- collapse_wt = Enum('unity', 'rms',
- doc = "Weighting: 'unity' or 'rms'. "\
- "Average channels with weights = 1 or 1/rms_clip^2 if " \
- "collapse_mode = 'average'\n"\
- "When collapse_mode is 'average', then if this value "\
- "is 'unity', the channels given by collapse_av are "\
- "averaged with unit weights and if 'rms', then they "\
- "are averaged with weights which are inverse square "\
- "of the clipped rms of each channel image.",
- group = 'multichan_opts')
-
-
- #-----------------------------OUTPUT OPTIONS--------------------------------
- plot_islands = Bool(False,
- doc = 'Make separate plots of each island during '\
- 'fitting (for large images, this may take '\
- 'a long time and a lot of memory)',
- group = "output_opts")
- plot_allgaus = Bool(False,
- doc = 'Make a plot of all Gaussians at the end',
- group = "output_opts")
- output_all = Bool(False,
- doc = "Write out all files automatically to directory "\
- "'filename_pybdsm'",
- group = "output_opts")
- opdir_overwrite = Enum('overwrite', 'append',
- doc = "'overwrite'/'append': If output_all=True, "\
- "delete existing "\
- "files or append a new directory",
- group = "output_opts")
- bbs_patches = Enum(None, 'single', 'gaussian', 'source', 'mask',
- doc = "For BBS format, type of patch to use: None "\
- "=> no patches. "\
- "'single' => all Gaussians in one patch. "\
- "'gaussian' => each Gaussian gets its own "\
- "patch. 'source' => all Gaussians belonging "\
- "to a single source are grouped into one patch. "\
- "'mask' => use mask file specified by bbs_patches_mask\n"\
- "When the Gaussian catalogue is written as a "\
- "BBS-readable sky file, this determines whether "\
- "all Gaussians are in a single patch, there are "\
- "no patches, all Gaussians for a given source "\
- "are in a separate patch, each Gaussian gets "\
- "its own patch, or a mask image is used to define "\
- "the patches.\n"\
- "If you wish to have patches defined by island, "\
- "then set group_by_isl = True (under advanced_opts) "\
- "before fitting to force all Gaussians in an "\
- "island to be in a single source. Then set "\
- "bbs_patches='source' when writing the catalog.",
- group = "output_opts")
- bbs_patches_mask = Option(None, String(),
- doc = "Name of the mask file (of same size as input "\
- "image) that defines the patches if bbs_patches "\
- "= 'mask'\nA mask file may be used to define the "\
- "patches in the output BBS sky model. The mask "\
- "image should be 1 inside the patches and 0 "\
- "elsewhere and should be the same size as the "\
- "input image (before any trim_box is applied). Any "\
- "Gaussians that fall outside of the patches "\
- "will be ignored and will not appear in the "\
- "output sky model.",
- group = "output_opts")
- solnname = Option(None, String(),
- doc = "Name of the run, to be prepended "\
- "to the name of the output directory. E.g., "\
- "solname='Run_1'",
- group = "output_opts")
- indir = Option(None, String(),
- doc = "Directory of input FITS files. None => get "\
- "from filename",
- group = "output_opts")
- savefits_residim = Bool(False,
- doc = "Save residual image as fits file",
- group = "output_opts")
- savefits_rmsim = Bool(False,
- doc = "Save background rms image as fits file",
- group = "output_opts")
- savefits_meanim = Bool(False,
- doc = "Save background mean image as fits file",
- group = "output_opts")
- savefits_rankim = Bool(False,
- doc = "Save island rank image as fits file",
- group = "output_opts")
- savefits_normim = Bool(False,
- doc = "Save norm image as fits file",
- group = "output_opts")
- print_timing = Bool(False,
- doc = "Print basic timing information",
- group = "output_opts")
- verbose_fitting = Bool(False,
- doc = "Print out extra information " \
- "during fitting",
- group = "output_opts")
- quiet = Bool(False,
- doc = "Suppress text output to screen. Output is "\
- "still sent to the log file as usual",
- group = "output_opts")
-
-
- #------------------------POLARISATION OPTIONS------------------------------
- pi_fit = Bool(True,
- doc = "Check the polarized intesity (PI) image for "\
- "sources not found in Stokes I\n"\
- "If True, the polarized intensity image is "\
- "searched for sources not present in the Stokes "\
- "I image. If any such sources are found, they are "\
- "added to the the Stokes I source lists. Use the "\
- "pi_thresh_pix and pi_thresh_isl parameters to "\
- "control island detection in the PI image.",
- group = "polarisation_do")
- pi_thresh_isl = Option(None, Float(),
- doc = "Threshold for PI island boundary in number of sigma "\
- "above the mean. None => use thresh_isl\n"\
- "This parameter determines the region to which fitting "\
- "is done in the polarized intensity (PI) image. "\
- "A higher value will produce smaller islands, "\
- "and hence smaller regions that are considered in the "\
- "fits. A lower value will produce larger islands. "\
- "Use the pi_thresh_pix parameter to set the detection "
- "threshold for sources. Generally, pi_thresh_isl should "\
- "be lower than pi_thresh_pix.",
- group = "polarisation_do")
- pi_thresh_pix = Option(None, Float(),
- doc = "Source detection threshold for PI image: threshold for the "\
- "island peak in number of sigma "\
- "above the mean. None => use thresh_pix\n"\
- "This parameter sets the overall detection threshold "\
- "for islands in the polarized intensity (PI) image "\
- "(i.e. pi_thresh_pix = 5 will find all sources "\
- "with peak flux densities per beam of 5-sigma or greater). Use the "\
- "pi_thresh_isl parameter to control how much of each island "\
- "is used in fitting. Generally, pi_thresh_pix should be larger "\
- "than pi_thresh_isl.",
- group = "polarisation_do")
-
-
- #-----------------------------PSF VARY OPTIONS--------------------------------
- psf_generators = Enum('calibrators', 'field',
- doc = "PSF generators: 'calibrators' or 'field'\n"\
- " If 'calibrator', only one source is taken per "\
- "facet, and sources between psf_snrtop and maximum "\
- "SNR are primary Voronoi generators. If 'field', "\
- "all sources between psf_snrbot and psf_snrtop are "\
- "secondary generators to be used in tessellating. "\
- "Currently, the 'field' option is not implemented.",
- group = "hidden")
- psf_nsig = Float(3.0,
- doc = "Kappa for clipping within each bin\n"\
- "When constructing a set of 'unresolved' sources "\
- "for psf estimation, the (clipped) median, rms and "\
- "mean of major and minor axis sizes of Gaussians versus "\
- "SNR within each bin is calculated using kappa = "\
- "psf_nsig.",
- group = "psf_vary_do")
- psf_over = Int(2,
- doc = "Factor of nyquist sample for binning bmaj, "\
- "etc. vs SNR",
- group = "psf_vary_do")
- psf_kappa2 = Float(2.0,
- doc = "Kappa for clipping for analytic fit\n"\
- "When iteratively arriving at a statistically "\
- "probable set of 'unresolved' sources, the fitted "\
- "major and minor axis sizes versus SNR are binned "\
- "and fitted with analytical functions. Those "\
- "Gaussians which are within psf_kappa2 times "\
- "the fitted rms from the fitted median are then "\
- "considered 'unresolved' and are used further to "\
- "estimate the PSFs.",
- group = "psf_vary_do")
- psf_smooth = Option(None, Float(),
- doc = "Size of Gaussian to use for smoothing of "\
- "interpolated images in arcsec. None => no "\
- "smoothing",
- group = "psf_vary_do")
- psf_snrcut = Float(10.0,
- doc = "Minimum SNR for statistics\n"\
- "Only Gaussians with SNR greater than this are "\
- "considered for processing. The minimum value is 5.0",
- group = "psf_vary_do")
- psf_snrtop = Float(0.15,
- doc = "Fraction of SNR > snrcut as primary generators\n"\
- "If psf_generators is 'calibrator', then the peak "\
- "pixels of Gaussians which are the psf_snrtop "\
- "fraction of SNR are taken as Voronoi generators. If "\
- "psf_generators is 'field', then peak pixels of "\
- "Gaussians which are between psf_snrbot and psf_snrtop "\
- "fraction of the highest SNR are taken.",
- group = "psf_vary_do")
- psf_snrbot = Float(0.20,
- doc = "Fraction of SNR > snrcut as all generators\n"\
- "If psf_generators is 'field', then all sources which "\
- "are between a fraction psf_snrbot and a fraction "\
- "psf_snrtop of the highest SNR Gaussians are taken as "\
- "Voronoi generators. That is, for a value of 0.2, the "\
- "top 20% (in terms of SNR) of Gaussians are taken.",
- group = "hidden")
- psf_snrcutstack = Float(15.0,
- doc = "Unresolved sources with higher SNR "\
- "taken for stacked psfs\n"\
- "Only Gaussians with SNR greater than this are used for "\
- "estimating psf images in each tile.",
- group = "psf_vary_do")
- psf_gencode = Enum('list', 'file',
- doc = "'list'/'file': Take primary "\
- "gens from Gaussian list or file\n"\
- "This is a string which can be either of 'list' or "\
- "'file' (default is 'list'; 'file' not implemented "\
- "yet). If psf_generators is 'calibrators', then the "\
- "generators used for Voronoi tessellation of the "\
- "image are either taken from a file if psf gencode is "\
- "'file' or are determined from the data if psf gencode "\
- "is 'list' (see psf_snrcut and psf_snrtop). The maximum "\
- "pixel for each source is used as the generator. For "\
- "'file' to be used, a list of good sources whose "\
- "psfs are believed to close to theoretical (e.g. strong "\
- "calibrators) need to be supplied with the metadata.",
- group = "hidden")
- psf_primarygen = String('',
- doc = "Filename for primary gens if psf_gencode='file'\n"\
- "This is the filename with the generators if psf_gencode "\
- "is 'file'. This is not yet implemented.",
- group = "hidden")
- psf_itess_method = Int(0,
- doc = "0 = normal, 1 = 0 + round, 2 = LogSNR, "\
- "3 = SqrtLogSNR\n"\
- "This is an integer which can be 0, 1, 2 or 3 "\
- "(default is 0), which corresponds to a tessellation "\
- "method. "\
- "If 0, 2 or 3, then the weights used for Voronoi "\
- "tessellation are unity, log(SNR) and sqrt[log(SNR)] where "\
- "SNR is the signal to noise ratio of the generator "\
- "in a tile. If 1, then the image is tessellated such "\
- "that each tile has smooth boundaries instead of straight "\
- "lines, using pixel-dependent weights.",
- group = "psf_vary_do")
- psf_tess_sc = Enum('s', 'c',
- doc = "('s')imple/('c')omplicated - normal "\
- "or approximate (fuzzy)\n"\
- "If 's', then each pixel can only belong to one Voronoi "\
- "tile. If 'c', then we do a fuzzy tessellation where border "\
- "pixels can belong to more than one tile. However, we do "\
- "not yet process the result of fuzzy tessellation and hence "\
- "it is advisable to use 's'.",
- group = "hidden")
- psf_tess_fuzzy = Float(0.05,
- doc = "Fraction of overlap for fuzzy tessellation\n"\
- "If psf_tess_sc is 'c', then this determines the fraction "\
- "of overlap between adjacent tiles for fuzzy tessellation.",
- group = "hidden")
- psf_use_shap = Bool(False,
- doc = "Use shapelets for PSF variation",
- group = "hidden")
-
- psf_high_snr = Option(None, Float(),
- doc = "SNR above which all sources are taken to be unresolved. "\
- "E.g., psf_high_snr = 20.0. None => no such selection is made\n"\
- "Gaussians with SNR greater than this are "\
- "used to determine the PSF variation, even if they are deemed "\
- "to be resolved. This corrects for the unreliability at high SNRs in the "\
- "algorithm used to find unresolved sources. The minimum value is 20.0",
- group = "psf_vary_do")
- psf_stype_only = Bool(True,
- doc = "Restrict sources to "\
- "be only of type 'S'",
- group = "psf_vary_do")
- psf_stype_only = Bool(True,
- doc = "Restrict sources to "\
- "be only of type 'S'",
- group = "psf_vary_do")
- psf_fwhm = Option(None, Tuple(Float(), Float(), Float()),
- doc = "FWHM of the PSF. Specify as (maj, "\
- "min, pos ang E of N) in degrees. "\
- "E.g., psf_fwhm = (0.06, 0.02, 13.3). None => "\
- "estimate from image\n"\
- "If the size of the PSF is specified with this option, "\
- "the PSF and its variation acrosss the image are "\
- "assumed to be constant and are not estimated "\
- "from the image. Instead, all sources "\
- "are deconvolved with the specified PSF.",
- group = "psf_vary_do")
-
-
- #-----------------------------SHAPELET OPTIONS--------------------------------
- shapelet_basis = Enum("cartesian", "polar",
- doc = "Basis set for shapelet decomposition: "\
- "'cartesian' or 'polar'\n"\
- "If shapelet decomposition is done, this determines "\
- "the type of shapelet basis used. Currently however, "\
- "only cartesian is supported.",
- group = "shapelet_do")
- shapelet_fitmode = Enum("fit", None,
- doc = "Calculate shapelet coeff's by fitting ('fit') "\
- "or integrating (None)\n"\
- "If shapelet do is True, then this determines the "\
- "method of calculating shapelet coefficients. If None, "\
- "then these are calculated by integrating (actually, "\
- "by summing over pixels, which introduces errors due to "\
- "discretisation). If 'fit', then the coefficients are "\
- "found by least-squares fitting of the shapelet basis "\
- "functions to the image.",
- group = "shapelet_do")
- shapelet_gresid = Bool(False,
- doc = "Use Gaussian residual image for shapelet "\
- "decomposition?\n"\
- "If True, then the shapelet decomposition is done "\
- "on the Gaussian residual image rather that the "\
- "ch0 image.",
- group = "shapelet_do")
-
- #-------------------------SPECTRAL INDEX OPTIONS--------------------------------
- flagchan_rms = Bool(True,
- doc = "Flag channels before (averaging and) "\
- "extracting spectral index, if their rms is "\
- "more than 5 (clipped) sigma outside the median "\
- "rms over all channels, but only if <= 10% of "\
- "channels\n"\
- "If True, then the clipped rms and median (r and m) "\
- "of the clipped rms of each channel is calculated. "\
- "Those channels whose clipped rms is greater than "\
- "4r away from m are flagged prior to averaging and "\
- "calculating spectral indices from the image cube. "\
- "However, these channels are flagged only if the "\
- "total number of these bad channels does not exceed "\
- "10% of the total number of channels themselves.",
- group = "spectralindex_do")
- flagchan_snr = Bool(True,
- doc = "Flag channels that do not meet SNR criterion "\
- "set by specind_snr\n"\
- "If True, then channels (after averaging if needed) "\
- "will be flagged and will not be used during fitting.",
- group = "spectralindex_do")
- specind_maxchan = Int(0,
- doc = "Maximum number of channels to average for "\
- "a given source when when attempting to meet target SNR. "\
- "1 => no averaging; 0 => no maximum\n"\
- "If spectralindex_do is True, then for a given source, "\
- "if the flux densities in each channel are below a threshold, "\
- "then this determines the maximum number of channels to "\
- "average.",
- group = "spectralindex_do")
- specind_snr = Float(3.0,
- doc = "Target SNR to use when fitting power law. If "\
- "there is insufficient SNR, neighboring channels "\
- "are averaged to attempt to obtain the target SNR. "\
- "Channels with SNRs below this will be flagged if "\
- "flagchan_snr = True\n"\
- "The maximum allowable number of channels to average "\
- "is determined by the specind_maxchan parameter.",
- group = "spectralindex_do")
-
- #-------------------------HIDDEN OPTIONS--------------------------------
- debug = Bool(False,
- doc = "Print debug info to the logfile",
- group = "hidden")
- outfile = Option(None, String(),
- doc = "Output file name. None => file is named "\
- "automatically; 'SAMP' => send to SAMP hub "\
- "(e.g., to TOPCAT, ds9, or Aladin)",
- group = 'hidden')
- broadcast = Bool(False,
- doc = "Broadcast Gaussian and source IDs and "\
- "coordinates to SAMP hub when a Gaussian is "\
- "clicked?\nNote that for the "\
- "IDs to be useful, a catalog must have been sent "\
- "to the SAMP hub previously using the write_catalog "\
- "task (with outfile = 'SAMP').",
- group = 'hidden')
- clobber = Bool(False,
- doc = "Overwrite existing file?",
- group = 'hidden')
- format = Enum('fits', 'ds9', 'ascii', 'bbs', 'star', 'kvis', 'sagecal', 'csv', 'casabox',
- doc = "Format of output catalog: 'bbs', "\
- "'ds9', 'fits', 'star', 'kvis', 'ascii', 'csv', 'casabox', or 'sagecal'\n"\
- "The following formats are supported:\n"\
- "'bbs' - BlackBoard Selfcal sky model format "\
- "(Gaussian list only)\n"\
- "'ds9' - ds9 region format\n"\
- "'fits' - FITS catalog format, readable by many "\
- "software packages, including IDL, TOPCAT, Python, "\
- "fv, Aladin, etc.\n"\
- "'star' - AIPS STAR format (Gaussian list only)\n"\
- "'kvis' - kvis format (Gaussian list only)\n"\
- "'ascii' - simple text file\n"\
- "'sagecal' - SAGECAL format (Gaussian list only)\n"\
- "Catalogues with the 'fits' and 'ascii' formats "\
- "include all available information (see headers "\
- "of the output file for column definitions). The "\
- "other formats include only a subset of the full "\
- "information.",
- group = 'hidden')
- srcroot = Option(None, String(),
- doc = "Root name for entries in the output catalog "\
- "(BBS format only). None => use image file name",
- group = 'hidden')
- incl_chan = Bool(False,
- doc = "Include flux densities from each channel "\
- "(if any)?",
- group = 'hidden')
- incl_empty = Bool(False,
- doc = "Include islands without any valid Gaussians "\
- "(source list only)?\n"\
- "If True, islands for which Gaussian fitting "\
- "failed will be included in the output catalog. "\
- "In these cases, the source IDs "\
- "are negative.",
- group = 'hidden')
- force_output = Bool(False,
- doc = "Force creation of output file, even if the "\
- "catalog is empty?\n"\
- "If True, the output catalog will be created, "\
- "even if there are no sources. In this case, "\
- "the catalog will have a header but no entries.",
- group = 'hidden')
- catalog_type = Enum('srl', 'gaul', 'shap',
- doc = "Type of catalog to write: 'gaul' - Gaussian "\
- "list, 'srl' - source list (formed "\
- "by grouping Gaussians), 'shap' - shapelet "\
- "list (FITS format only)",
- group = 'hidden')
- correct_proj = Bool(True,
- doc = "Correct source parameters for image projection (BBS format only)?\n"\
- "If True, the source parameters in the output catalog will be "\
- "corrected for first-order projection effects. If False, "\
- "no correction is done. In this case, the position angle "\
- "is relative to the +y axis, NOT true north, and source sizes "\
- "are calculated assuming a constant pixel scale (equal to the "
- "scale at the image center).\n "\
- "If True, the position angle and source size "\
- "are corrected using the average pixel size and "
- "angle offset (between the +y axis and north) at "\
- "the location of the source center.",
- group = 'hidden')
- img_format = Enum('fits', 'casa',
- doc = "Format of output image: 'fits' or 'casa'",
- group = 'hidden')
- img_type = Enum('gaus_resid', 'shap_resid', 'rms', 'mean', 'gaus_model',
- 'shap_model', 'ch0', 'pi', 'psf_major', 'psf_minor',
- 'psf_pa', 'psf_ratio', 'psf_ratio_aper', 'island_mask',
- doc = "Type of image to export: 'gaus_resid', "\
- "'shap_resid', 'rms', 'mean', 'gaus_model', "\
- "'shap_model', 'ch0', 'pi', 'psf_major', "\
- "'psf_minor', 'psf_pa', 'psf_ratio', 'psf_ratio_aper', "\
- "'island_mask'\nThe following images "\
- "can be exported:\n"\
- "'ch0' - image used for source detection\n"\
- "'rms' - rms map image\n"\
- "'mean' - mean map image\n"\
- "'pi' - polarized intensity image\n"\
- "'gaus_resid' - Gaussian model residual image\n"\
- "'gaus_model' - Gaussian model image\n"\
- "'shap_resid' - Shapelet model residual image\n"\
- "'shap_model' - Shapelet model image\n"\
- "'psf_major' - PSF major axis FWHM image (FWHM in arcsec)\n"\
- "'psf_minor' - PSF minor axis FWHM image (FWHM in arcsec)\n"\
- "'psf_pa' - PSF position angle image (degrees east of north)\n"\
- "'psf_ratio' - PSF peak-to-total flux ratio (in units of 1/beam)\n"\
- "'psf_ratio_aper' - PSF peak-to-aperture flux ratio (in units of 1/beam)\n"\
- "'island_mask' - Island mask image (0 = outside island, 1 = inside island)",
- group = 'hidden')
- mask_dilation = Int(0,
- doc = "Number of iterations to use for island-mask dilation. "\
- "0 => no dilation\nThis option determines the number of "\
- "dilation iterations to use when making the island mask. "\
- "More iterations implies larger masked regions (one iteration "\
- "expands the size of features in the mask by one pixel in all "\
- "directions). After dilation, a closing operation is performed "\
- "(using a structure array the size of the beam) to remove gaps "\
- "and holes in the mask that are smaller than the beam.",
- group = "hidden")
- pad_image = Bool(False,
- doc = "Pad image (with zeros) to original size\nIf True, the output "\
- "image is padded to be the same size as the original "\
- "image (without any trimming defined by the trim_box "\
- "parameter). If False, the output image will have the "\
- "size specified by the trim_box parameter.",
- group = "hidden")
- ch0_image = Bool(True,
- doc = "Show the ch0 image. This is the image used for "\
- "source detection",
- group = "hidden")
- rms_image = Bool(True,
- doc = "Show the background rms image",
- group = "hidden")
- mean_image = Bool(True,
- doc = "Show the background mean image",
- group = "hidden")
- ch0_islands = Bool(True,
- doc = "Show the ch0 image with islands and Gaussians "\
- "(if any) overplotted",
- group = "hidden")
- ch0_flagged = Bool(False,
- doc = "Show the ch0 image with flagged Gaussians "\
- "(if any) overplotted",
- group = "hidden")
- gresid_image = Bool(True,
- doc = "Show the Gaussian residual image",
- group = "hidden")
- sresid_image = Bool(False,
- doc = "Show the shapelet residual image",
- group = "hidden")
- gmodel_image = Bool(True,
- doc = "Show the Gaussian model image",
- group = "hidden")
- smodel_image = Bool(False,
- doc = "Show the shapelet model image",
- group = "hidden")
- pi_image = Bool(False,
- doc = "Show the polarized intensity image",
- group = "hidden")
- source_seds = Bool(False,
- doc = "Plot the source SEDs and best-fit spectral "\
- "indices (if image was processed with "\
- "spectralindex_do = True). "\
- "Sources may be chosen by ID with the 'c' key "\
- "or, if ch0_islands = True, by picking a source with "\
- "the mouse",
- group = "hidden")
- psf_major = Bool(False,
- doc = "Show the PSF major axis variation (values are "\
- "FWHM in arcsec)",
- group = "hidden")
- psf_minor = Bool(False,
- doc = "Show the FWHM of PSF minor axis variation (values are "\
- "FWHM in arcsec)",
- group = "hidden")
- psf_pa = Bool(False,
- doc = "Show the PSF position angle variation (values are "\
- "angle E from N in degrees)",
- group = "hidden")
-
-
- def __init__(self, values = None):
- """Build an instance of Opts and (possibly)
- initialize some variables.
-
- Parameters:
- values: dictionary of key->value for initialization
- of variables
- """
- TCInit(self)
- if values is not None:
- self.set_opts(values)
-
- def _parse_string_as_bool(self, bool_string):
- """
- 'private' function performing parse of a string containing
- a bool representation as defined in the parameter set/otdb
- implementation
- """
- true_chars = ['t', 'T', 'y', 'Y', '1']
- false_chars = ['f', 'F', 'n', 'N', '0']
- if bool_string[0] in true_chars:
- return True
- if bool_string[0] in false_chars:
- return False
-
- raise tcError(
- "Supplied string cannot be parsed as a bool: {0}".format(bool_string))
-
-
- def set_opts(self, opts):
- """Set multiple variables at once.
-
- opts should be dictionary of name->value
- """
- opts = dict(opts)
- for k, v in opts.iteritems():
- try:
- # Fix for lofar parameter set integration:
- # If the attribute is a bool, test if it is a string.
- # and then try to parse it
- if hasattr(self, k):
- if isinstance(self.__getattribute__(k), bool):
- if isinstance(v, bool) or v is None:
- # just enter the bool into the parameter
- pass
- elif isinstance(v, basestring):
- # Try parse it as a parameter set bool string
- v = self._parse_string_as_bool(v)
- else:
- # raise error
- raise tcError("unknown type for bool variable")
- if v == "none":
- v = None
- self.__setattr__(k, v)
- except tcError, e:
- # Catch and re-raise as a RuntimeError
- raise RuntimeError(
- 'Parameter "{0}" is not defined properly. \n {1}'.format(k
- , str(e)))
-
-
- def set_default(self, opt_names = None):
- """Set one or more opts to default value.
-
- opt_names should be a list of opt names as strings, but can be
- a string of a single opt name.
-
- If None, set all opts to default values."""
- if opt_names is None:
- TCInit(self)
- else:
- if isinstance(opt_names, str):
- opt_names = [opt_names]
- for k in opt_names:
- if isinstance(k, str):
- self.__delattr__(k)
-
- def info(self):
- """Pretty-print current values of options"""
- import tc
- ## enumerate all options
- opts = self.to_list()
- res = ""
- fmt = "%20s = %5s ## %s\n"
-
- for k, v in opts:
- res += fmt % (k, str(self.__getattribute__(k)),
- str(v.doc()).split('\n')[0])
-
- return res
-
- def to_list(self, group=None):
- """Returns a sorted list of (name, TC object) tuples for all opts.
-
- If the group name is specified, only opts that belong to that group
- are returned.
- """
- import tc
- opts_list = []
- for k, v in self.__class__.__dict__.iteritems():
- if isinstance(v, tc.TC):
- if group is not None:
- if v.group() == group:
- opts_list.append((k, v))
- else:
- opts_list.append((k, v))
- opts_list = sorted(opts_list)
- return opts_list
-
- def to_dict(self):
- """Returns a dictionary of names and values for all opts."""
- import tc
- opts_dict = {}
- for k, v in self.__class__.__dict__.iteritems():
- if isinstance(v, tc.TC):
- opts_dict.update({k: self.__getattribute__(k)})
- return opts_dict
-
- def get_names(self, group=None):
- """Returns a sorted list of names for all opts.
-
- If the group name is specified, only opts that belong to that group
- are returned.
- """
- import tc
- opts_list = []
- for k, v in self.__class__.__dict__.iteritems():
- if isinstance(v, tc.TC):
- if group is not None:
- if v.group() == group:
- opts_list.append(k)
- else:
- opts_list.append(k)
- opts_list = sorted(opts_list)
- return opts_list
-
- def __setstate__(self, state):
- self.set_opts(state)
-
- def __getstate__(self):
- import tc
- state = {}
- for k, v in self.__class__.__dict__.iteritems():
- if isinstance(v, tc.TC):
- state.update({k: self.__getattribute__(k)})
- return state
diff --git a/CEP/PyBDSM/src/python/output.py b/CEP/PyBDSM/src/python/output.py
deleted file mode 100644
index b3433e94fc9cae98f975cba27a6c3175073a5794..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/python/output.py
+++ /dev/null
@@ -1,1247 +0,0 @@
-"""Module output.
-
-Defines functions that write the results of source detection in a
-variety of formats. These are then used as methods of Image objects
-and/or are called by the outlist operation if output_all is True.
-"""
-from image import Op
-
-class Op_outlist(Op):
- """Write out list of Gaussians
-
- All available output lists are generated atm.
- """
- def __call__(self, img):
- if img.opts.output_all:
- import os
- if len(img.gaussians) > 0:
- dir = img.basedir + '/catalogues/'
- if not os.path.exists(dir):
- os.makedirs(dir)
- self.write_bbs(img, dir)
- self.write_lsm(img, dir)
- self.write_gaul(img, dir)
- self.write_srl(img, dir)
- self.write_aips(img, dir)
- self.write_kvis(img, dir)
- self.write_ds9(img, dir, objtype='gaul')
- self.write_ds9(img, dir, objtype='srl')
- self.write_gaul_FITS(img, dir)
- self.write_srl_FITS(img, dir)
- if not os.path.exists(img.basedir + '/misc/'):
- os.makedirs(img.basedir + '/misc/')
- self.write_opts(img, img.basedir + '/misc/')
- self.save_opts(img, img.basedir + '/misc/')
- img.completed_Ops.append('outlist')
-
- def write_bbs(self, img, dir):
- """ Writes the gaussian list as a bbs-readable file"""
- prefix = ''
- if 'bbsprefix' in img.extraparams:
- prefix = img.extraparams['bbsprefix']+'_'
- if 'bbsname' in img.extraparams:
- name = img.extraparams['bbsname']
- else:
- name = img.imagename
- fname = dir + name + '.sky_in'
-
- # Write Gaussian list
- write_bbs_gaul(img, filename=fname, srcroot=img.opts.srcroot,
- patch=img.opts.bbs_patches, sort_by='flux',
- clobber=True, incl_empty=img.opts.incl_empty,
- correct_proj=img.opts.correct_proj)
-
- def write_lsm(self, img, dir):
- """ Writes the gaussian list as an SAGECAL file"""
- fname = dir + img.imagename + '.lsm'
- write_lsm_gaul(img, filename=fname, sort_by='indx',
- clobber=True,
- incl_empty=img.opts.incl_empty)
-
- def write_gaul(self, img, dir):
- """ Writes the gaussian list as an ASCII file"""
- fname = dir + img.imagename + '.gaul'
- write_ascii_list(img, filename=fname, sort_by='indx',
- clobber=True, objtype='gaul',
- incl_empty=img.opts.incl_empty)
-
- def write_srl(self, img, dir):
- """ Writes the source list as an ASCII file"""
- fname = dir + img.imagename + '.srl'
- write_ascii_list(img, filename=fname, sort_by='indx',
- clobber=True, objtype='srl',
- incl_empty=img.opts.incl_empty)
-
- def write_aips(self, img, dir):
- """ Writes the gaussian list an AIPS STAR file"""
- fname = dir + img.imagename + '.star'
- write_star(img, filename=fname, sort_by='indx',
- clobber=True)
-
- def write_kvis(self, img, dir):
- """ Writes the gaussian list as a kvis file"""
- fname = dir + img.imagename + '.kvis.ann'
- write_kvis_ann(img, filename=fname, sort_by='indx',
- clobber=True)
-
- def write_ds9(self, img, dir, objtype='gaul'):
- """ Writes the gaussian list as a ds9 region file"""
- fname = dir + img.imagename + '.' + objtype + '.ds9.reg'
- write_ds9_list(img, filename=fname, srcroot=img.opts.srcroot,
- clobber=True, deconvolve=False, objtype=objtype,
- incl_empty=img.opts.incl_empty,)
-
- def write_gaul_FITS(self, img, dir):
- """ Writes the gaussian list as FITS binary table"""
- fname = dir + img.imagename+'.gaul.FITS'
- write_fits_list(img, filename=fname, sort_by='indx',
- clobber=True, objtype='gaul',
- incl_empty=img.opts.incl_empty,)
-
- def write_srl_FITS(self, img, dir):
- """ Writes the source list as FITS binary table"""
- fname = dir + img.imagename+'.srl.FITS'
- write_fits_list(img, filename=fname, sort_by='indx',
- clobber=True, objtype='srl',
- incl_empty=img.opts.incl_empty,)
-
- def write_shap_FITS(self, img, dir):
- """ Writes the shapelet list as a FITS file"""
- fname = dir + img.imagename + '.shap.FITS'
- write_fits_list(img, filename=fname, sort_by='indx',
- clobber=True, objtype='shap')
-
- def write_opts(self, img, dir):
- """ Writes input parameters to a text file."""
- import inspect
- import types
- import mylogger
-
- mylog = mylogger.logging.getLogger("PyBDSM."+img.log+"Output")
- fname = 'parameters_used'
- f = open(dir+fname, 'w')
- mylog.info('Writing '+dir+fname)
- for attr in inspect.getmembers(img.opts):
- if attr[0][0] != '_':
- if isinstance(attr[1], (int, str, bool, float, types.NoneType, tuple, list)):
- f.write('%-40s' % attr[0])
- f.write(repr(attr[1])+'\n')
-
- # Also print the values derived internally. They are all stored
- # in img with the same name (e.g., img.opts.beam --> img.beam)
- if hasattr(img, attr[0]):
- used = img.__getattribute__(attr[0])
- if used != attr[1] and isinstance(used, (int, str, bool, float,
- types.NoneType, tuple,
- list)):
- f.write('%-40s' % ' Value used')
- f.write(repr(used)+'\n')
- f.close()
-
- def save_opts(self, img, dir):
- """ Saves input parameters to a PyBDSM save file."""
- import interface
- import mylogger
-
- mylog = mylogger.logging.getLogger("PyBDSM."+img.log+"Output")
- fname = 'parameters.sav'
- mylog.info('Writing '+dir+fname)
- interface.save_pars(img, dir+fname, quiet=True)
-
-
-def ra2hhmmss(deg):
- """Convert RA coordinate (in degrees) to HH MM SS"""
-
- from math import modf
- if deg < 0:
- deg += 360.0
- #raise RuntimeError("Negative RA")
- x, hh = modf(deg/15.)
- x, mm = modf(x*60)
- ss = x*60
-
- return (int(hh), int(mm), ss)
-
-def dec2ddmmss(deg):
- """Convert DEC coordinate (in degrees) to DD MM SS"""
-
- from math import modf
- sign = (-1 if deg < 0 else 1)
- x, dd = modf(abs(deg))
- x, ma = modf(x*60)
- sa = x*60
-
- return (int(dd), int(ma), sa, sign)
-
-def B1950toJ2000(Bcoord):
- """ Precess using Aoki et al. 1983. Same results as NED to ~0.2asec """
- from math import sin, cos, pi, sqrt, asin, acos
- import numpy as N
-
- rad = 180.0/pi
- ra, dec = Bcoord
-
- A = N.array([-1.62557e-6, -0.31919e-6, -0.13843e-6])
- M = N.array([[0.9999256782, 0.0111820609, 0.00485794], [-0.0111820610, 0.9999374784, -0.0000271474], \
- [-0.0048579477, -0.0000271765, 0.9999881997]])
-
- r0=N.zeros(3)
- r0[0]=cos(dec/rad)*cos(ra/rad)
- r0[1]=cos(dec/rad)*sin(ra/rad)
- r0[2]=sin(dec/rad)
-
- r0A=N.sum(r0*A)
- r1=r0-A+r0A*r0
- r = N.sum(M.transpose()*r1, axis = 1)
-
- rscal = sqrt(N.sum(r*r))
- decj=asin(r[2]/rscal)*rad
-
- d1=r[0]/rscal/cos(decj/rad)
- d2=r[1]/rscal/cos(decj/rad)
- raj=acos(d1)*rad
- if d2 < 0.0: raj = 360.0 - raj
-
- Jcoord = [raj, decj]
- return Jcoord
-
-def write_bbs_gaul(img, filename=None, srcroot=None, patch=None,
- incl_primary=True, sort_by='flux',
- clobber=False, incl_empty=False, correct_proj=True):
- """Writes Gaussian list to a BBS sky model"""
- import numpy as N
- from const import fwsig
- import mylogger
- import os
-
- mylog = mylogger.logging.getLogger("PyBDSM.write_gaul")
- if int(img.equinox) != 2000 and int(img.equinox) != 1950:
- mylog.warning('Equinox of input image is not J2000 or B1950. '\
- 'Sky model may not be appropriate for BBS.')
- if int(img.equinox) == 1950:
- mylog.warning('Equinox of input image is B1950. Coordinates '\
- 'will be precessed to J2000.')
-
- outl, outn, patl = list_and_sort_gaussians(img, patch=patch,
- root=srcroot, sort_by=sort_by)
- outstr_list = make_bbs_str(img, outl, outn, patl, incl_empty=incl_empty,
- correct_proj=correct_proj)
-
- if filename is None:
- filename = img.imagename + '.sky_in'
- if os.path.exists(filename) and clobber == False:
- return None
- mylog.info('Writing ' + filename)
- f = open(filename, 'w')
- for s in outstr_list:
- f.write(s)
- f.close()
- return filename
-
-
-def write_lsm_gaul(img, filename=None, srcroot=None, patch=None,
- incl_primary=True, sort_by='flux',
- clobber=False, incl_empty=False):
- """Writes Gaussian list to a SAGECAL lsm sky model"""
- import numpy as N
- from const import fwsig
- import mylogger
- import os
-
- mylog = mylogger.logging.getLogger("PyBDSM.write_gaul")
- if int(img.equinox) != 2000 and int(img.equinox) != 1950:
- mylog.warning('Equinox of input image is not J2000 or B1950. '\
- 'Sky model may not be appropriate for Sagecal.')
- if int(img.equinox) == 1950:
- mylog.warning('Equinox of input image is B1950. Coordinates '\
- 'will be precessed to J2000.')
-
- outl, outn, patl = list_and_sort_gaussians(img, patch=patch,
- root=srcroot, sort_by=sort_by)
- outstr_list = make_lsm_str(img, outl, outn, incl_empty=incl_empty)
-
- if filename is None:
- filename = img.imagename + '.lsm'
- if os.path.exists(filename) and clobber == False:
- return None
- mylog.info('Writing ' + filename)
- f = open(filename, 'w')
- for s in outstr_list:
- f.write(s)
- f.close()
- return filename
-
-
-def write_ds9_list(img, filename=None, srcroot=None, deconvolve=False,
- clobber=False, incl_empty=False, objtype='gaul'):
- """Writes Gaussian list to a ds9 region file"""
- import numpy as N
- from const import fwsig
- import mylogger
- import os
-
- mylog = mylogger.logging.getLogger("PyBDSM."+img.log+"Output")
- if objtype == 'gaul':
- outl, outn, patl = list_and_sort_gaussians(img, patch=None)
- elif objtype == 'srl':
- root = img.parentname
- outl = [img.sources]
- if incl_empty:
- # Append the dummy sources for islands without any unflagged Gaussians
- outl[0] += img.dsources
- outn = []
- for src in img.sources:
- outn.append(root + '_i' + str(src.island_id) + '_s' +
- str(src.source_id))
- if incl_empty:
- # Append the dummy sources for islands without any unflagged Gaussians
- for dsrc in img.dsources:
- outn.append(root + '_i' + str(dsrc.island_id) + '_s' +
- str(dsrc.source_id))
- outn = [outn]
- outstr_list = make_ds9_str(img, outl, outn, deconvolve=deconvolve, objtype=objtype, incl_empty=incl_empty)
- if filename is None:
- filename = img.imagename + '.' + objtype + '.reg'
- if os.path.exists(filename) and clobber == False:
- return None
- mylog.info('Writing ' + filename)
- f = open(filename, "w")
- for s in outstr_list:
- f.write(s)
- f.close()
- return filename
-
-
-def write_ascii_list(img, filename=None, sort_by='indx', format = 'ascii',
- incl_chan=False, incl_empty=False, clobber=False, objtype='gaul'):
- """Writes Gaussian list to an ASCII file"""
- import mylogger
- import os
-
- mylog = mylogger.logging.getLogger("PyBDSM."+img.log+"Output")
- if objtype == 'gaul':
- outl, outn, patl = list_and_sort_gaussians(img, patch=None, sort_by=sort_by)
- elif objtype == 'srl':
- outl = [img.sources]
- if incl_empty:
- # Append the dummy sources for islands without any unflagged Gaussians
- outl[0] += img.dsources
- outstr_list = make_ascii_str(img, outl, objtype=objtype, incl_chan=incl_chan,
- incl_empty=incl_empty, format=format)
- if filename is None:
- if objtype == 'gaul':
- filename = img.imagename + '.gaul'
- elif objtype == 'srl':
- filename = img.imagename + '.srl'
- if os.path.exists(filename) and clobber == False:
- return None
- mylog.info('Writing ' + filename)
- f = open(filename, "w")
- for s in outstr_list:
- f.write(s)
- f.close()
- return filename
-
-
-def write_casa_gaul(img, filename=None, incl_empty=False, clobber=False):
- """Writes a clean box file for use in casapy"""
- import mylogger
- import os
-
- mylog = mylogger.logging.getLogger("PyBDSM."+img.log+"Output")
- outl, outn, patl = list_and_sort_gaussians(img, patch=None)
- outstr_list = make_casa_str(img, outl)
- if filename is None:
- filename = img.imagename + '.box'
- if os.path.exists(filename) and clobber == False:
- return None
- mylog.info('Writing ' + filename)
- f = open(filename, "w")
- for s in outstr_list:
- f.write(s)
- f.close()
- return filename
-
-
-def write_fits_list(img, filename=None, sort_by='index', objtype='gaul',
- incl_chan=False, incl_empty=False, clobber=False):
- """ Write as FITS binary table.
- """
- import mylogger
- from distutils.version import StrictVersion
- try:
- from astropy.io import fits as pyfits
- use_header_update = False
- use_from_columns = True
- except ImportError, err:
- import pyfits
- if StrictVersion(pyfits.__version__) < StrictVersion('3.1'):
- use_header_update = True
- use_from_columns = False
- else:
- use_header_update = False
- use_from_columns = True
- import os
- import numpy as N
- from _version import __version__, __revision__
-
- mylog = mylogger.logging.getLogger("PyBDSM."+img.log+"Output")
- if objtype == 'gaul':
- outl, outn, patl = list_and_sort_gaussians(img, patch=None, sort_by=sort_by)
- elif objtype == 'srl':
- outl = [img.sources]
- if incl_empty:
- # Append the dummy sources for islands without any unflagged Gaussians
- outl[0] += img.dsources
- elif objtype == 'shap':
- outl = [img.islands]
-
- nmax = 0
- if objtype == 'shap':
- # loop over shapelets and get maximum size of coefficient matrix
- for isl in outl[0]:
- if isl.shapelet_nmax > nmax:
- nmax = isl.shapelet_nmax
- nmax += 1
-
- if img.opts.aperture is not None:
- incl_aper = True
- else:
- incl_aper = False
- if len(outl[0]) > 0:
- cvals, cnames, cformats, cunits = make_output_columns(outl[0][0], fits=True,
- objtype=objtype,
- incl_spin=img.opts.spectralindex_do,
- incl_chan=incl_chan,
- incl_pol=img.opts.polarisation_do,
- incl_aper=incl_aper,
- incl_empty=incl_empty,
- nmax=nmax, nchan=img.nchan)
- out_list = make_fits_list(img, outl, objtype=objtype, nmax=nmax, incl_empty=incl_empty)
- col_list = []
- for ind, col in enumerate(out_list):
- list1 = pyfits.Column(name=cnames[ind], format=cformats[ind],
- unit=cunits[ind], array=N.array(out_list[ind]))
- col_list.append(list1)
- if len(col_list) == 0:
- col_list = [pyfits.Column(name='Blank', format='1J')]
-
- if use_from_columns:
- tbhdu = pyfits.BinTableHDU.from_columns(col_list)
- else:
- tbhdu = pyfits.new_table(col_list)
-
- if objtype == 'gaul':
- tbhdu.header.add_comment('Gaussian list for '+img.filename)
- elif objtype == 'srl':
- tbhdu.header.add_comment('Source list for '+img.filename)
- elif objtype == 'shap':
- tbhdu.header.add_comment('Shapelet list for '+img.filename)
- tbhdu.header.add_comment('Generated by PyBDSM version %s (LOFAR revision %s)'
- % (__version__, __revision__))
- freq = "%.5e" % img.frequency
- tbhdu.header.add_comment('Reference frequency of the detection ("ch0") image: %s Hz' % freq)
- tbhdu.header.add_comment('Equinox : %s' % img.equinox)
- if use_header_update:
- tbhdu.header.update('INIMAGE', img.filename, 'Filename of image')
- tbhdu.header.update('FREQ0', float(freq), 'Reference frequency')
- tbhdu.header.update('EQUINOX', img.equinox, 'Equinox')
- else:
- tbhdu.header['INIMAGE'] = (img.filename, 'Filename of image')
- tbhdu.header['FREQ0'] = (float(freq), 'Reference frequency')
- tbhdu.header['EQUINOX'] = (img.equinox, 'Equinox')
- if filename is None:
- filename = img.imagename + '.' + objtype + '.fits'
- if os.path.exists(filename) and clobber == False:
- return None
- mylog.info('Writing ' + filename)
- tbhdu.writeto(filename, clobber=True)
- return filename
-
-
-def write_kvis_ann(img, filename=None, sort_by='indx',
- clobber=False):
- import mylogger
- import os
-
- mylog = mylogger.logging.getLogger("PyBDSM."+img.log+"Output")
- if filename is None:
- filename = img.imagename + '.kvis.ann'
- if os.path.exists(filename) and clobber == False:
- return None
- f = open(filename, 'w')
- mylog.info('Writing '+filename)
- f.write("### KVis annotation file\n\n")
- f.write("color green\n\n")
-
- outl, outn, patl = list_and_sort_gaussians(img, patch=None, sort_by=sort_by)
- for g in outl[0]:
- iidx = g.island_id
- # kvis does not correct for postion-dependent angle or pixel scale
- # for region files, so we must use the uncorrected values
- ra, dec = g.centre_sky
- shape = g.size_sky_uncorr
-
- str = 'text %10.5f %10.5f %d\n' % \
- (ra, dec, iidx)
- f.write(str)
- str = 'ellipse %10.5f %10.5f %10.7f %10.7f %10.4f\n' % \
- (ra, dec, shape[0], shape[1], shape[2])
- f.write(str)
- f.close()
- return filename
-
-
-def write_star(img, filename=None, sort_by='indx',
- clobber=False):
- from output import ra2hhmmss, dec2ddmmss
- import mylogger
- import os
-
- mylog = mylogger.logging.getLogger("PyBDSM."+img.log+"Output")
- if filename is None:
- filename = img.imagename + '.star'
- if os.path.exists(filename) and clobber == False:
- return None
- f = open(filename, 'w')
- mylog.info('Writing '+filename)
-
- outl, outn, patl = list_and_sort_gaussians(img, patch=None, sort_by=sort_by)
-
- for g in outl[0]:
- A = g.peak_flux
- ra, dec = g.centre_sky
- shape = g.size_sky_uncorr
- ### convert to canonical representation
- ra = ra2hhmmss(ra)
- dec= dec2ddmmss(dec)
- decsign = ('-' if dec[3] < 0 else '+')
-
- str = '%2i %2i %6.3f ' \
- '%c%2i %2i %6.3f ' \
- '%9.4f %9.4f %7.2f ' \
- '%2i %13.7f %10s\n' % \
- (ra[0], ra[1], ra[2],
- decsign, dec[0], dec[1], dec[2],
- shape[0]*3600, shape[1]*3600, shape[2],
- 4, A, '')
-
- f.write(str)
- f.close()
- return filename
-
-
-def make_bbs_str(img, glist, gnames, patchnames, objtype='gaul',
- incl_empty=False, correct_proj=True):
- """Makes a list of string entries for a BBS sky model."""
- from output import ra2hhmmss
- from output import dec2ddmmss
- import numpy as N
-
- outstr_list = []
- freq = "%.5e" % img.frequency
-
- if len(patchnames) == 0:
- # Handle empty list: just write default header
- outstr_list.append("format = Name, Type, Ra, Dec, I, Q, U, V, "\
- "MajorAxis, MinorAxis, Orientation, "\
- "ReferenceFrequency='"+freq+"', "\
- "SpectralIndex='[]'\n\n")
- elif patchnames[0] is None:
- outstr_list.append("format = Name, Type, Ra, Dec, I, Q, U, V, "\
- "MajorAxis, MinorAxis, Orientation, "\
- "ReferenceFrequency='"+freq+"', "\
- "SpectralIndex='[]'\n\n")
- else:
- outstr_list.append("format = Name, Type, Patch, Ra, Dec, I, Q, U, V, "\
- "MajorAxis, MinorAxis, Orientation, "\
- "ReferenceFrequency='"+freq+"', "\
- "SpectralIndex='[]'\n\n")
- if objtype == 'shap':
- patchname_last = ''
- for pindx, patch_name in enumerate(patchnames): # loop over patches
- if patch_name is not None and patch_name != patchname_last:
- outstr_list.append(', , ' + patch_name + ', 00:00:00, +00.00.00\n')
- patchname_last = patch_name
- names_in_patch = gnames[pindx]
- if patch_name is None:
- outstr_list.append(src_name + sep + stype + sep + sra + sep +
- sdec + sep + total + sep + Q_flux + sep +
- U_flux + sep + V_flux + sep +
- deconvstr + sep + freq + sep +
- '[' + specin + ']\n')
- else:
- outstr_list.append(src_name + sep + stype + sep + patch_name +
- sep + sra + sep + sdec + sep + total + sep +
- Q_flux + sep + U_flux + sep + V_flux + sep +
- deconvstr + sep + freq + sep +
- '[' + specin + ']\n')
- else:
- patchname_last = ''
- for pindx, patch_name in enumerate(patchnames): # loop over patches
- if patch_name is not None and patch_name != patchname_last:
- outstr_list.append(', , ' + patch_name + ', 00:00:00, +00.00.00\n')
- patchname_last = patch_name
- gaussians_in_patch = glist[pindx]
- names_in_patch = gnames[pindx]
- for gindx, g in enumerate(gaussians_in_patch):
- if g.gaus_num >= 0 or (g.gaus_num < 0 and incl_empty):
- src_name = names_in_patch[gindx]
- ra, dec = g.centre_sky
- if img.equinox == 1950:
- ra, dec = B1950toJ2000([ra, dec])
- ra = ra2hhmmss(ra)
- sra = str(ra[0]).zfill(2)+':'+str(ra[1]).zfill(2)+':'+str("%.6f" % (ra[2])).zfill(6)
- dec = dec2ddmmss(dec)
- decsign = ('-' if dec[3] < 0 else '+')
- sdec = decsign+str(dec[0]).zfill(2)+'.'+str(dec[1]).zfill(2)+'.'+str("%.6f" % (dec[2])).zfill(6)
- total = str("%.3e" % (g.total_flux))
- if correct_proj:
- deconv = g.deconv_size_sky
- else:
- deconv = g.deconv_size_sky_uncorr
- if deconv[0] == 0.0 and deconv[1] == 0.0:
- stype = 'POINT'
- deconv[2] = 0.0
- else:
- stype = 'GAUSSIAN'
- deconv1 = str("%.5e" % (deconv[0]*3600.0))
- deconv2 = str("%.5e" % (deconv[1]*3600.0))
- deconv3 = str("%.5e" % (deconv[2]))
- deconvstr = deconv1 + ', ' + deconv2 + ', ' + deconv3
- specin = '-0.8'
- if 'spectralindex' in img.completed_Ops:
- if g.spec_indx is not None and N.isfinite(g.spec_indx):
- specin = str("%.3e" % (g.spec_indx))
- sep = ', '
- if img.opts.polarisation_do:
- Q_flux = str("%.3e" % (g.total_flux_Q))
- U_flux = str("%.3e" % (g.total_flux_U))
- V_flux = str("%.3e" % (g.total_flux_V))
- else:
- Q_flux = '0.0'
- U_flux = '0.0'
- V_flux = '0.0'
- if patch_name is None:
- outstr_list.append(src_name + sep + stype + sep + sra + sep +
- sdec + sep + total + sep + Q_flux + sep +
- U_flux + sep + V_flux + sep +
- deconvstr + sep + freq + sep +
- '[' + specin + ']\n')
- else:
- outstr_list.append(src_name + sep + stype + sep + patch_name +
- sep + sra + sep + sdec + sep + total + sep +
- Q_flux + sep + U_flux + sep + V_flux + sep +
- deconvstr + sep + freq + sep +
- '[' + specin + ']\n')
- else:
- outstr_list.pop()
- return outstr_list
-
-
-def make_bbs_shapeletfiles(img):
- """Makes a list of string entries for a BBS sky model.
-
- Shapelet format:
- ra dec
- N Beta # N is dimension of array
- 0 cf
- 1 cf
- ...
-
- column major
- """
- from output import ra2hhmmss
- from output import dec2ddmmss
- import numpy as N
-
- for isl in img.islands:
- basis = isl.shapelet_basis
- nmax = isl.shapelet_nmax
- cf = isl.shapelet_cf
- beta = isl.shapelet_beta
- center = isl.shapelet_centre
- ra, dec = img.pix2sky(center)
- ra = ra2hhmmss(ra)
- sra = str(ra[0]).zfill(2)+' '+str(ra[1]).zfill(2)+' '+str("%.3f" % (ra[2])).zfill(6)
- dec = dec2ddmmss(dec)
- decsign = ('-' if dec[3] < 0 else '+')
- sdec = decsign+str(dec[0]).zfill(2)+' '+str(dec[1]).zfill(2)+' '+str("%.3f" % (dec[2])).zfill(6)
-
- ra_dec_string = sra + ' ' + sdec + ' \n'
- outstr_list = [ra_dec_string]
- outstr_list.append(str(nmax) + ' ' + str(beta) + '\n')
- cf.transpose # transpose so that we can access array in column-major way
- for entry in cf.flatten():
- outstr_list.append(str(entry) + '\n')
-
- f = open(shap_name[i], "w")
- for s in outstr_list:
- f.write(s)
- f.close()
- return filename
-
-
-def make_lsm_str(img, glist, gnames, incl_empty=False):
- """Makes a list of string entries for a SAGECAL sky model."""
- from output import ra2hhmmss
- from output import dec2ddmmss
- from const import fwsig
- import numpy as N
- from _version import __version__, __revision__
-
- outstr_list = ["# SAGECAL sky model\n"]
- freq = "%.5e" % img.frequency
- outstr_list.append('# Generated by PyBDSM version %s (LOFAR revision %s)\n'
- % (__version__, __revision__))
- outstr_list.append("# Name | RA (hr,min,sec) | DEC (deg,min,sec) | I | Q | U | V | SI | RM | eX | eY | eP | freq0\n\n")
- for gindx, g in enumerate(glist[0]):
- if g.gaus_num >= 0 or (g.gaus_num < 0 and incl_empty):
- src_name = gnames[0][gindx]
- ra, dec = g.centre_sky
- if img.equinox == 1950:
- ra, dec = B1950toJ2000([ra, dec])
- ra = ra2hhmmss(ra)
- sra = str(ra[0]).zfill(2)+' '+str(ra[1]).zfill(2)+' '+str("%.6f" % (ra[2])).zfill(6)
- dec = dec2ddmmss(dec)
- decsign = ('-' if dec[3] < 0 else '+')
- sdec = decsign+str(dec[0]).zfill(2)+' '+str(dec[1]).zfill(2)+' '+str("%.6f" % (dec[2])).zfill(6)
- total = str("%.3e" % (g.total_flux))
- deconv = g.deconv_size_sky
- if deconv[0] == 0.0 and deconv[1] == 0.0:
- sname = 'P' + src_name
- deconv[2] = 0.0
- else:
- sname = 'G' + src_name
- # Make sure Gaussian is not 1-D, as SAGECAL cannot handle these
- if deconv[0] < 1e-5:
- deconv[0] = 1e-5
- if deconv[1] < 1e-5 :
- deconv[1] = 1e-5
- # The following conversions taken from the SABECAL script "convert_skymodel.py"
- deconv1 = str("%.5e" % (deconv[0]*N.pi/180.0/2.0))
- deconv2 = str("%.5e" % (deconv[1]*N.pi/180.0/2.0))
- deconv3 = str("%.5e" % (N.pi/2-(N.pi-deconv[2]/180.0*N.pi)))
- deconvstr = deconv1 + ' ' + deconv2 + ' ' + deconv3
- specin = '-0.8'
- if 'spectralindex' in img.completed_Ops:
- if g.spec_indx is not None and N.isfinite(g.spec_indx):
- specin = str("%.3e" % (g.spec_indx))
- sep = ' '
- if img.opts.polarisation_do:
- Q_flux = str("%.3e" % g.total_flux_Q)
- U_flux = str("%.3e" % g.total_flux_U)
- V_flux = str("%.3e" % g.total_flux_V)
- else:
- Q_flux = '0.0'
- U_flux = '0.0'
- V_flux = '0.0'
- outstr_list.append(sname + sep + sra + sep +
- sdec + sep + total + sep + Q_flux + sep +
- U_flux + sep + V_flux + sep +
- specin + sep + '0' + sep + deconvstr + sep +
- freq + sep + '\n')
- return outstr_list
-
-
-def make_ds9_str(img, glist, gnames, deconvolve=False, objtype='gaul', incl_empty=False):
- """Makes a list of string entries for a ds9 region file."""
- outstr_list = []
- freq = "%.5e" % img.frequency
- if img.equinox is None:
- equinox = 'fk5'
- else:
- if int(img.equinox) == 2000:
- equinox = 'fk5'
- elif int(img.equinox) == 1950:
- equinox = 'fk4'
- else:
- mylog.warning('Equinox of input image is not J2000 or B1950. '\
- 'Regions may not be correct.')
- equinox = 'fk5'
-
- outstr_list.append('# Region file format: DS9 version 4.0\nglobal color=green '\
- 'font="helvetica 10 normal" select=1 highlite=1 edit=1 '\
- 'move=1 delete=1 include=1 fixed=0 source\n'+equinox+'\n')
-
- for gindx, g in enumerate(glist[0]):
- if objtype == 'gaul':
- objid = g.gaus_num
- else:
- objid = g.source_id
- if objid >= 0 or (objid < 0 and incl_empty):
- src_name = gnames[0][gindx]
- if objtype == 'gaul':
- ra, dec = g.centre_sky
- else:
- ra, dec = g.posn_sky_centroid
-
- # ds9 does not correct for postion-dependent angle or pixel scale
- # for region files, so we must use the uncorrected values
- if deconvolve:
- deconv = g.deconv_size_sky_uncorr
- else:
- deconv = g.size_sky_uncorr
- if deconv[0] == 0.0 and deconv[1] == 0.0:
- stype = 'POINT'
- deconv[2] = 0.0
- region = 'point(' + str(ra) + ',' + str(dec) + \
- ') # point=cross width=2 text={' + src_name + '}\n'
- else:
- # ds9 can't handle 1-D Gaussians, so make sure they are 2-D
- if deconv[0] < 1.0/3600.0: deconv[0] = 1.0/3600.0
- if deconv[1] < 1.0/3600.0: deconv[1] = 1.0/3600.0
- stype = 'GAUSSIAN'
- region = 'ellipse(' + str(ra) + ',' + str(dec) + ',' + \
- str(deconv[0]*3600.0) + '",' + str(deconv[1]*3600.0) + \
- '",' + str(deconv[2]+90.0) + ') # text={' + src_name + '}\n'
- outstr_list.append(region)
- return outstr_list
-
-
-def make_ascii_str(img, glist, objtype='gaul', format='ascii', incl_empty=False,
- incl_chan=False):
- """Makes a list of string entries for an ascii region file."""
- from _version import __version__, __revision__
- outstr_list = []
- freq = "%.5e" % img.frequency
-
- if objtype == 'gaul':
- outstr_list.append('# Gaussian list for '+img.filename+'\n')
- elif objtype == 'srl':
- outstr_list.append('# Source list for '+img.filename+'\n')
- outstr_list.append('# Generated by PyBDSM version %s (LOFAR revision %s)\n'
- % (__version__, __revision__))
- outstr_list.append('# Reference frequency of the detection ("ch0") image: %s Hz\n' % freq)
- outstr_list.append('# Equinox : %s \n\n' % img.equinox)
- val_list = []
- if img.opts.aperture is not None:
- incl_aper = True
- else:
- incl_aper = False
-
- for i, g in enumerate(glist[0]):
- cvals, cnames, cformats, cunits = make_output_columns(g, fits=False,
- objtype=objtype,
- incl_spin=img.opts.spectralindex_do,
- incl_chan=incl_chan,
- incl_pol=img.opts.polarisation_do,
- incl_aper=incl_aper,
- incl_empty=incl_empty,
- nchan=img.nchan)
- if cvals is not None:
- cformats[-1] += "\n"
- if format == 'ascii':
- if i == 0:
- outstr_list.append("# " + " ".join(cnames) + "\n")
- outstr_list.append(" ".join(cformats) % tuple(cvals))
- else:
- if i == 0:
- outstr_list.append("# " + ", ".join(cnames) + "\n")
- outstr_list.append(", ".join(cformats) % tuple(cvals))
- return outstr_list
-
-
-def make_fits_list(img, glist, objtype='gaul', nmax=30, incl_empty=False,
- incl_chan=False):
- import functions as func
-
- out_list = []
- if img.opts.aperture is not None:
- incl_aper = True
- else:
- incl_aper = False
- for g in glist[0]:
- cvals, ext1, ext2, ext3 = make_output_columns(g, fits=True, objtype=objtype,
- incl_spin=img.opts.spectralindex_do,
- incl_chan=incl_chan,
- incl_pol=img.opts.polarisation_do,
- incl_aper=incl_aper,
- incl_empty=incl_empty,
- nmax=nmax, nchan=img.nchan)
- if cvals is not None:
- out_list.append(cvals)
- out_list = func.trans_gaul(out_list)
- return out_list
-
-
-def make_casa_str(img, glist):
- """Makes a list of string entries for a casa region file."""
- import functions as func
- outstr_list = ['#CRTFv0 CASA Region Text Format version 0\n']
- sep = ' '
- scale = 2.0 # scale box to 2 times FWHM of Gaussian
- for gindx, g in enumerate(glist[0]):
- x, y = g.centre_pix
- ellx, elly = func.drawellipse(g)
- blc = [min(ellx), min(elly)]
- trc = [max(ellx), max(elly)]
-
- blc[0] -= (x - blc[0]) * scale
- blc[1] -= (y - blc[1]) * scale
- trc[0] += (trc[0] - x) * scale
- trc[1] += (trc[1] - y) * scale
-
- blc_sky = img.pix2sky(blc)
- trc_sky = img.pix2sky(trc)
-
- blc_sky_str = convert_radec_str(blc_sky[0], blc_sky[1])
- trc_sky_str = convert_radec_str(trc_sky[0], trc_sky[1])
-
- # Format is: box [ [<blcx>, <blcy>], [<trcx>, <trcy>] ]
- # Note that we use gindx rather than g.gaus_num so that
- # all Gaussians will have a unique id, even if wavelet
- # Gaussians are included.
- outstr_list.append('box [[' + ', '.join(blc_sky_str) + '], [' +
- ', '.join(trc_sky_str) + ']] coord=J2000\n')
- return outstr_list
-
-
-def write_islands(img):
- import numpy as N
- import os
-
- ### write out island properties for reference since achaar doesnt work.
- filename = img.basedir + '/misc/'
- if not os.path.exists(filename): os.makedirs(filename)
- filename = filename + 'island_file'
-
- if img.j == 0:
- f = open(filename, 'w')
- f.write('Wavelet# Island_id bbox origin shape mask_active mask_noisy size_active mean rms max_value ngaul gresid_mean '+\
- 'gresid_rms resid_rms resid_mean nsource \n')
- else:
- f = open(filename, 'a')
-
- for isl in img.islands:
- f.write('%5i %5i %5i %5i %5i %5i %5i %5i %5i %5i %10i %10i %10i %.3e %.3e %.3e %5i %.3e %.3e %5i \n' \
- % (img.j, isl.island_id, isl.bbox[0].start, isl.bbox[0].stop, isl.bbox[1].start, isl.bbox[1].stop, \
- isl.origin[0], isl.origin[1], isl.shape[0], isl.shape[1], N.sum(~isl.mask_active), N.sum(~isl.mask_noisy), \
- isl.size_active, isl.mean, isl.rms, isl.max_value, len(isl.gaul), isl.gresid_mean, isl.gresid_rms, \
- len(isl.sources)))
-
- f.close()
-
-
-def get_src(src_list, srcid):
- """Returns the source for srcid or None if not found"""
- for src in src_list:
- if src.source_id == srcid:
- return src
- return None
-
-
-def convert_radec_str(ra, dec):
- """Takes ra, dec in degrees and returns BBS/CASA strings"""
- ra = ra2hhmmss(ra)
- sra = str(ra[0]).zfill(2)+':'+str(ra[1]).zfill(2)+':'+str("%.3f" % (ra[2])).zfill(6)
- dec = dec2ddmmss(dec)
- decsign = ('-' if dec[3] < 0 else '+')
- sdec = decsign+str(dec[0]).zfill(2)+'.'+str(dec[1]).zfill(2)+'.'+str("%.3f" % (dec[2])).zfill(6)
- return sra, sdec
-
-
-def list_and_sort_gaussians(img, patch=None, root=None,
- sort_by='index'):
- """Returns sorted lists of Gaussians and their names and patch names.
-
- patch - can be "single", "gaussian", "source", or None
-
- Returns (outlist, outnames, patchnames)
- outlist is [[g1, g2, g3], [g4], ...]
- outnames is [['root_i2_s1_g1', 'root_i2_s1_g2', 'root_i2_s1_g3'], ...]
- patchnames is ['root_patch_s1', 'root_patch_s2', ...]
-
- The names are root_iXX_sXX_gXX (or wXX_iXX_sXX_gXX for wavelet Gaussians)
- """
- import numpy as N
- import functions as func
-
- # Define lists
- if root is None:
- root = img.parentname
- gauslist = []
- gausname = []
- outlist = []
- outnames = []
- patchnames = []
- patchnames_sorted = []
- gausflux = [] # fluxes of Gaussians
- gausindx = [] # indices of Gaussians
- patchflux = [] # total flux of each patch
- patchindx = [] # indices of sources
- patchnums = [] # number of patch from mask
-
- # If a mask image is to be used to define patches, read it in and
- # make a rank image from it
- use_mask = False
- if patch not in ['single', 'gaussian', 'source', None]:
- mask_file = img.opts.bbs_patches_mask
- patches_mask, hdr = func.read_image_from_file(mask_file, img, img.indir)
- use_mask = True
- act_pixels = patches_mask[0,0]
- rank = len(act_pixels.shape)
- import scipy.ndimage as nd
- connectivity = nd.generate_binary_structure(rank, rank)
- mask_labels, count = nd.label(act_pixels, connectivity)
-
- src_list = img.sources
- for src in src_list:
- for g in src.gaussians:
- gauslist.append(g)
- gausflux.append(g.total_flux)
- gausindx.append(g.gaus_num)
- jstr = '_w' + str(g.jlevel)
- gausname.append(root + jstr + '_i' + str(src.island_id) + '_s' +
- str(src.source_id) + '_g' + str(g.gaus_num))
- if patch == 'gaussian':
- outlist.append(gauslist)
- outnames.append(gausname)
- patchnames.append(root + '_patch' + jstr + '_g' + str(g.gaus_num))
- patchflux.append(N.sum(gausflux))
- patchindx.append(g.gaus_num)
- gauslist = [] # reset for next Gaussian
- gausname = []
- gausflux = []
- gausindx = []
- if use_mask:
- patchnums.append(mask_labels[g.centre_pix[0], g.centre_pix[1]])
-
-
- if patch == 'source':
- sorted_gauslist = list(gauslist)
- sorted_gausname = list(gausname)
- if sort_by == 'flux':
- # Sort Gaussians by flux within each source
- indx = range(len(gausflux))
- indx.sort(lambda x,y: cmp(gausflux[x],gausflux[y]), reverse=True)
- elif sort_by == 'index':
- # Sort Gaussians by index within each source
- indx = range(len(gausindx))
- indx.sort(lambda x,y: cmp(gausindx[x],gausindx[y]), reverse=False)
- else:
- # Unrecognized property --> Don't sort
- indx = range(len(gausindx))
- for i, si in enumerate(indx):
- sorted_gauslist[i] = gauslist[si]
- sorted_gausname[i] = gausname[si]
-
- outlist.append(sorted_gauslist)
- outnames.append(sorted_gausname)
- patchnames.append(root + '_patch' + '_s' + str(src.source_id))
- patchflux.append(N.sum(gausflux))
- patchindx.append(src.source_id)
- gauslist = [] # reset for next source
- gausname = []
- gausflux = []
-
- if use_mask:
- unique_patch_ids = set(patchnums)
-
- # Check if there is a patch with id = 0. If so, this means there were
- # some Gaussians that fell outside of the regions in the patch
- # mask file.
- if 0 in unique_patch_ids:
- import mylogger
- mylog = mylogger.logging.getLogger("PyBDSM.write_gaul")
- mylog.warning('Some sources fall outside of the regions '
- 'defined in the mask file. These sources are not '
- 'included in the output sky model.')
- for p in unique_patch_ids:
- if p != 0:
- in_patch = N.where(patchnums == p)
- outlist.append(N.array(gauslist)[in_patch].tolist())
- outnames.append(N.array(gausname)[in_patch].tolist())
- patchnames.append('patch_'+str(p))
- patchflux.append(N.sum(N.array(gausflux)[in_patch]))
- patchindx.append(p)
-
- # Sort
- if patch == 'single' or patch is None:
- outlist = [list(gauslist)]
- outlist_sorted = [list(gauslist)]
- outnames = [list(gausname)]
- outnames_sorted = [list(gausname)]
- if patch == 'single':
- patchnames = [root + '_patch']
- else:
- patchnames = [None]
- if sort_by == 'flux':
- # Sort by Gaussian flux
- indx = range(len(gauslist))
- indx.sort(lambda x,y: cmp(gausflux[x],gausflux[y]), reverse=True)
- elif sort_by == 'index':
- # Sort by Gaussian index
- indx = range(len(gausindx))
- indx.sort(lambda x,y: cmp(gausindx[x],gausindx[y]), reverse=False)
- else:
- # Unrecognized property --> Don't sort
- indx = range(len(gausindx))
- for i, si in enumerate(indx):
- outlist_sorted[0][i] = outlist[0][si]
- outnames_sorted[0][i] = outnames[0][si]
- patchnames_sorted = list(patchnames)
- else:
- outlist_sorted = list(outlist)
- outnames_sorted = list(outnames)
- patchnames_sorted = list(patchnames)
- if sort_by == 'flux':
- # Sort by patch flux
- indx = range(len(patchflux))
- indx.sort(lambda x,y: cmp(patchflux[x],patchflux[y]), reverse=True)
- elif sort_by == 'index':
- # Sort by source index
- indx = range(len(patchindx))
- indx.sort(lambda x,y: cmp(patchindx[x],patchindx[y]), reverse=False)
- else:
- # Unrecognized property --> Don't sort
- indx = range(len(gausindx))
-
- for i, si in enumerate(indx):
- outlist_sorted[i] = outlist[si]
- outnames_sorted[i] = outnames[si]
- patchnames_sorted[i] = patchnames[si]
-
- return (outlist_sorted, outnames_sorted, patchnames_sorted)
-
-def make_output_columns(obj, fits=False, objtype='gaul', incl_spin=False,
- incl_chan=False, incl_pol=False, incl_aper=False,
- incl_empty=False, nmax=30, nchan=1):
- """Returns a list of column names, formats, and units for Gaussian, Source, or Shapelet"""
- import numpy as N
-
- # First, define a list of columns in order desired, using the names of
- # the attributes of the object
- if objtype == 'gaul':
- names = ['gaus_num', 'island_id', 'source_id', 'jlevel',
- 'centre_sky', 'centre_skyE', 'total_flux',
- 'total_fluxE', 'peak_flux', 'peak_fluxE',
- 'centre_pix', 'centre_pixE', 'size_sky', 'size_skyE',
- 'size_sky_uncorr', 'size_skyE_uncorr',
- 'deconv_size_sky', 'deconv_size_skyE',
- 'deconv_size_sky_uncorr', 'deconv_size_skyE_uncorr',
- 'total_flux_isl', 'total_flux_islE', 'rms',
- 'mean', 'gresid_rms', 'gresid_mean',
- 'code']
- elif objtype == 'srl':
- if incl_aper:
- infix = ['aperture_flux', 'aperture_fluxE']
- else:
- infix = []
- names = ['source_id', 'island_id', 'posn_sky_centroid',
- 'posn_sky_centroidE', 'total_flux',
- 'total_fluxE',
- 'peak_flux_max', 'peak_flux_maxE'] + infix + \
- ['posn_sky_max', 'posn_sky_maxE',
- 'posn_pix_centroid', 'posn_pix_centroidE', 'posn_pix_max',
- 'posn_pix_maxE',
- 'size_sky', 'size_skyE',
- 'size_sky_uncorr', 'size_skyE_uncorr',
- 'deconv_size_sky', 'deconv_size_skyE',
- 'deconv_size_sky_uncorr', 'deconv_size_skyE_uncorr',
- 'total_flux_isl', 'total_flux_islE',
- 'rms_isl', 'mean_isl', 'gresid_rms',
- 'gresid_mean', 'code']
- elif objtype == 'shap':
- names = ['island_id', 'shapelet_posn_sky', 'shapelet_posn_skyE',
- 'shapelet_basis', 'shapelet_beta', 'shapelet_nmax', 'shapelet_cf']
- else:
- print 'Object type unrecongnized.'
- return (None, None, None, None)
- if incl_spin:
- names += ['spec_indx', 'e_spec_indx']
- if incl_chan:
- names += ['specin_flux', 'specin_fluxE', 'specin_freq']
- if incl_pol:
- names += ['total_flux_Q', 'total_fluxE_Q', 'total_flux_U', 'total_fluxE_U',
- 'total_flux_V', 'total_fluxE_V', 'lpol_fraction', 'lpol_fraction_loerr',
- 'lpol_fraction_hierr', 'cpol_fraction', 'cpol_fraction_loerr',
- 'cpol_fraction_hierr', 'tpol_fraction', 'tpol_fraction_loerr',
- 'tpol_fraction_hierr', 'lpol_angle', 'lpol_angle_err']
- cnames = []
- cformats = []
- cunits = []
- cvals = []
- skip_next = False
- for n, name in enumerate(names):
- if hasattr(obj, name):
- if name in ['specin_flux', 'specin_fluxE', 'specin_freq']:
- # As these are variable length lists, they must
- # (unfortunately) be treated differently.
- val = obj.__getattribute__(name)
- colname = obj.__class__.__dict__[name]._colname
- units = obj.__class__.__dict__[name]._units
- for i in range(nchan):
- if i < len(val):
- cvals.append(val[i])
- cnames.append(colname[0]+'_ch'+str(i+1))
- cunits.append(units[0])
- else:
- cvals.append(N.NaN)
- cnames.append(colname[0]+'_ch'+str(i+1))
- cunits.append(units[0])
- else:
- if not skip_next:
- val = obj.__getattribute__(name)
- colname = obj.__class__.__dict__[name]._colname
- units = obj.__class__.__dict__[name]._units
- if units is None:
- units = ' '
- if isinstance(val, list):
- # This is a list, so handle it differently. We assume the next
- # entry will have the errors, and they are interleaved to be
- # in the order (val, error).
- next_name = names[n+1]
- val_next = obj.__getattribute__(next_name)
- colname_next = obj.__class__.__dict__[next_name]._colname
- units_next = obj.__class__.__dict__[next_name]._units
- if units_next is None:
- units_next = ' '
- for i in range(len(val)):
- cvals.append(val[i])
- cvals.append(val_next[i])
- cnames.append(colname[i])
- cnames.append(colname_next[i])
- cunits.append(units[i])
- cunits.append(units_next[i])
- skip_next = True
- elif isinstance(val, N.ndarray):
- # This is a numpy array, so flatten it
- tarr = val.flatten()
- tarr2 = N.resize(tarr, nmax**2)
- tarr2[tarr.shape[0]:] = N.NaN
- cvals.append(tarr2)
- cnames.append(colname)
- cunits.append(units)
- else:
- cvals.append(val)
- cnames.append(colname)
- cunits.append(units)
- else:
- skip_next = False
-
- for i, v in enumerate(cvals):
- if fits:
- if isinstance(v, int):
- cformats.append('J')
- if isinstance(v, float):
- cformats.append('D')
- if isinstance(v, str):
- cformats.append('A')
- if isinstance(v, N.ndarray):
- cformats.append('%iD' % (nmax**2,))
- else:
- if isinstance(v, int):
- cformats.append('%4d')
- if isinstance(v, float):
- cformats.append('%.14f')
- if isinstance(v, str):
- cformats.append('%4s')
-
- if objtype == 'gaul':
- if obj.gaus_num < 0 and not incl_empty:
- return (None, cnames, cformats, cunits)
- if objtype == 'srl':
- if obj.source_id < 0 and not incl_empty:
- return (None, cnames, cformats, cunits)
- return (cvals, cnames, cformats, cunits)
diff --git a/CEP/PyBDSM/src/python/plotresults.py b/CEP/PyBDSM/src/python/plotresults.py
deleted file mode 100644
index 19a8aab73be2d4daf9c7a36b811a189f6f6c0f58..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/python/plotresults.py
+++ /dev/null
@@ -1,736 +0,0 @@
-"""Plotting module
-
-This module is used to display fits results.
-"""
-from image import *
-from . import has_pl
-if has_pl:
- import matplotlib.pyplot as pl
- import matplotlib.cm as cm
- import matplotlib.patches as mpatches
- from matplotlib.widgets import Button
- from matplotlib.patches import Ellipse
- from matplotlib.lines import Line2D
- from matplotlib import collections
-from math import log10
-import functions as func
-from const import fwsig
-import os
-import numpy as N
-
-
-def plotresults(img, ch0_image=True, rms_image=True, mean_image=True,
- ch0_islands=True, gresid_image=True, sresid_image=False,
- gmodel_image=True, smodel_image=False, pyramid_srcs=False,
- source_seds=False, ch0_flagged=False, pi_image=False,
- psf_major=False, psf_minor=False, psf_pa=False, broadcast=False):
- """Show the results of a fit."""
- global img_ch0, img_rms, img_mean, img_gaus_mod, img_shap_mod
- global img_gaus_resid, img_shap_resid, pixels_per_beam, pix2sky
- global vmin, vmax, vmin_cur, vmax_cur, ch0min, ch0max, img_pi
- global low, fig, images, src_list, srcid_cur, sky2pix, markers
- global img_psf_maj, img_psf_min, img_psf_pa, do_broadcast, samp_client
- global samp_key, samp_gaul_table_url, samp_srl_table_url
-
- if not has_pl:
- print "\033[31;1mWARNING\033[0m: Matplotlib not found. Plotting is disabled."
- return
- if hasattr(img, 'samp_client'):
- samp_client = img.samp_client
- samp_key = img.samp_key
- if hasattr(img, 'samp_srl_table_url'):
- samp_srl_table_url = img.samp_srl_table_url
- else:
- samp_srl_table_url = None
- if hasattr(img, 'samp_gaul_table_url'):
- samp_gaul_table_url = img.samp_gaul_table_url
- else:
- samp_gaul_table_url = None
- else:
- samp_clent = None
- samp_key = None
- samp_srl_table_url = None
- samp_gaul_table_url = None
- do_broadcast = broadcast
-
- # Define the images. The images are used both by imshow and by the
- # on_press() and coord_format event handlers
- pix2sky = img.pix2sky
- sky2pix = img.sky2pix
- gfactor = 2.0 * N.sqrt(2.0 * N.log(2.0))
- pixels_per_beam = 2.0 * N.pi * (img.beam2pix(img.beam)[0]
- * img.beam2pix(img.beam)[1]) / gfactor**2
-
- # Construct lists of images, titles, etc.
- images = []
- titles = []
- names = []
- markers = []
- img_gaus_mod = None # default needed for key press event
- img_shap_mod = None # default needed for key press event
- if ch0_image:
- img_ch0 = img.ch0_arr
- images.append(img_ch0)
- titles.append('Original (ch0) Image\n(arbitrary logarithmic scale)')
- names.append('ch0')
- if ch0_islands:
- img_ch0 = img.ch0_arr
- images.append(img_ch0)
- if hasattr(img, 'ngaus'):
- if hasattr(img, 'ch0_pi_arr'):
- ch0_str = 'Islands (hatched boundaries; red = PI only) and\nGaussians'
- else:
- ch0_str = 'Islands (hatched boundaries) and\nGaussians'
- if hasattr(img, 'atrous_gaussians'):
- ch0_str += ' (red = wavelet)'
- titles.append(ch0_str)
- else:
- titles.append('Islands (hatched boundaries)')
- names.append('ch0')
- if ch0_flagged:
- if not hasattr(img, 'ngaus'):
- print 'Image was not fit with Gaussians. Skipping display of flagged Gaussians.'
- else:
- img_ch0 = img.ch0_arr
- images.append(img_ch0)
- titles.append('Flagged Gaussians')
- names.append('ch0')
- if pi_image:
- if not hasattr(img, 'ch0_pi_arr'):
- print 'Polarization module not run. Skipping PI image.'
- else:
- img_pi = img.ch0_pi_arr
- images.append(img_pi)
- titles.append('Polarized Intensity Image')
- names.append('ch0_pi')
- if rms_image:
- img_rms = img.rms_arr
- images.append(img_rms)
- titles.append('Background rms Image')
- names.append('rms')
- if gresid_image:
- if not hasattr(img, 'ngaus'):
- print 'Image was not fit with Gaussians. Skipping residual Gaussian image.'
- else:
- img_gaus_resid = img.resid_gaus_arr
- images.append(img_gaus_resid)
- titles.append('Gaussian Residual Image')
- names.append('gaus_resid')
- if gmodel_image:
- if not hasattr(img, 'ngaus'):
- print 'Image was not fit with Gaussians. Skipping model Gaussian image.'
- else:
- img_gaus_mod = img.model_gaus_arr
- images.append(img_gaus_mod)
- titles.append('Gaussian Model Image')
- names.append('gaus_mod')
- if mean_image:
- img_mean = img.mean_arr
- images.append(img_mean)
- titles.append('Background mean Image')
- names.append('mean')
- if sresid_image:
- if img.opts.shapelet_do == False:
- print 'Image was not decomposed into shapelets. Skipping residual shapelet image.'
- else:
- img_shap_resid = img.ch0_arr - img.model_shap_arr
- images.append(img_shap_resid)
- titles.append('Shapelet Residual Image')
- names.append('shap_resid')
- if smodel_image:
- if img.opts.shapelet_do == False:
- print 'Image was not decomposed into shapelets. Skipping model shapelet image.'
- else:
- img_shap_mod = img.model_shap_arr
- images.append(img_shap_mod)
- titles.append('Shapelet Model Image')
- names.append('shap_mod')
- if source_seds:
- if img.opts.spectralindex_do == False:
- print 'Source SEDs were not fit. Skipping source SED plots.'
- else:
- src_list = img.sources
- sed_src = get_src(src_list, 0)
- if sed_src is None:
- print 'No sources found. Skipping source SED plots.'
- else:
- images.append('seds')
- titles.append('')
- names.append('seds')
- srcid_cur = 0
- if pyramid_srcs:
- if img.opts.atrous_do == False:
- print 'Image was not decomposed into wavelets. Skipping wavelet images.'
- else:
- # Get the unique j levels and store them. Only make subplots for
- # occupied j levels
- print 'Pyramidal source plots not yet supported.'
-# j_list = []
-# for p in img.pyrsrcs:
-# for l in p.jlevels:
-# j_list.append(l)
-# j_set = set(j_list)
-# j_with_gaus = list(j_set)
-# index_first_waveplot = len(images)
-# for i in range(len(j_with_gaus)):
-# images.append('wavelets')
-# names.append('pyrsrc'+str(i))
- if psf_major or psf_minor or psf_pa:
- if img.opts.psf_vary_do == False:
- print 'PSF variation not calculated. Skipping PSF variation images.'
- else:
- if psf_major:
- img_psf_maj = img.psf_vary_maj_arr*fwsig
- images.append(img_psf_maj)
- titles.append('PSF Major Axis FWHM (pixels)')
- names.append('psf_maj')
- if psf_minor:
- img_psf_min = img.psf_vary_min_arr*fwsig
- images.append(img_psf_min)
- titles.append('PSF Minor Axis FWHM (pixels)')
- names.append('psf_min')
- if psf_pa:
- img_psf_pa = img.psf_vary_pa_arr
- images.append(img_psf_pa)
- titles.append('PSF Pos. Angle FWhM (degrees)')
- names.append('psf_pa')
-
- if images == []:
- print 'No images to display.'
- return
-
- im_mean = img.clipped_mean
- im_rms = img.clipped_rms
- if img.resid_gaus is None:
- low = 1.1*abs(img.min_value)
- else:
- low = N.max([1.1*abs(img.min_value),1.1*abs(N.nanmin(img.resid_gaus))])
- if low <= 0.0:
- low = 1E-6
- vmin_est = im_mean - im_rms*5.0 + low
- if vmin_est <= 0.0:
- vmin = N.log10(low)
- else:
- vmin = N.log10(vmin_est)
- vmax = N.log10(im_mean + im_rms*30.0 + low)
- ch0min = vmin
- ch0max = N.log10(img.max_value + low)
- vmin_cur = vmin
- vmax_cur = vmax
- origin = 'lower'
- colours = ['m', 'b', 'c', 'g', 'y', 'k'] # reserve red ('r') for wavelets
- styles = ['-', '-.', '--']
- print '=' * 72
- print 'NOTE -- With the mouse pointer in plot window:'
- print ' Press "i" ........ : Get integrated flux densities and mean rms'
- print ' values for the visible portion of the image'
- print ' Press "m" ........ : Change min and max scaling values'
- print ' Press "n" ........ : Show / hide island IDs'
- print ' Press "0" ........ : Reset scaling to default'
- if 'seds' in images:
- print ' Press "c" ........ : Change source for SED plot'
- if ch0_islands and hasattr(img, 'ngaus'):
- print ' Click Gaussian ... : Print Gaussian and source IDs (zoom_rect mode, '
- print ' toggled with the "zoom" button and indicated in '
- print ' the lower right corner, must be off)'
- if 'seds' in images:
- print ' The SED plot will also show the chosen source.'
- print '_' * 72
-
- if len(images) > 1:
- numx = 2
- else:
- numx = 1
- numy = int(N.ceil(float(len(images))/float(numx)))
- fig = pl.figure(figsize=(max(15, 10.0*float(numy)/float(numx)), 10.0))
- fig.canvas.set_window_title('PyBDSM Fit Results for '+ img.filename)
- gray_palette = cm.gray
- gray_palette.set_bad('k')
-
- for i, image in enumerate(images):
- if image != 'wavelets' and image != 'seds':
- if i == 0:
- cmd = 'ax' + str(i+1) + ' = pl.subplot(' + str(numx) + \
- ', ' + str(numy) + ', ' + str(i+1) + ')'
- else:
- cmd = 'ax' + str(i+1) + ' = pl.subplot(' + str(numx) + \
- ', ' + str(numy) + ', ' + str(i+1) + ', sharex=ax1' + \
- ', sharey=ax1)'
- exec cmd
- if 'PSF' in titles[i]:
- im = image
- else:
- im = N.log10(image + low)
- if 'Islands' in titles[i]:
- island_offsets_x = []
- island_offsets_y = []
- border_color = []
- ax = pl.gca()
- for iisl, isl in enumerate(img.islands):
- xb, yb = isl.border
- if hasattr(isl, '_pi'):
- for c in range(len(xb)):
- border_color.append('r')
- else:
- for c in range(len(xb)):
- border_color.append('#afeeee')
- island_offsets_x += xb.tolist()
- island_offsets_y += yb.tolist()
- marker = ax.text(N.max(xb)+2, N.max(yb), str(isl.island_id),
- color='#afeeee', clip_on=True)
- marker.set_visible(not marker.get_visible())
- markers.append(marker)
- # draw the gaussians with one colour per source or island
- # (if gaul2srl was not run)
- if hasattr(img, 'nsrc'):
- nsrc = len(isl.sources)
- for isrc in range(nsrc):
- col = colours[isrc % 6]
- style = styles[isrc/6 % 3]
- src = isl.sources[isrc]
- for g in src.gaussians:
- if hasattr(g, 'valid'):
- valid = g.valid
- else:
- valid = True
- if g.jlevel == 0 and valid and g.gaus_num >= 0:
- gidx = g.gaus_num
- e = Ellipse(xy=g.centre_pix, width=g.size_pix[0],
- height=g.size_pix[1], angle=g.size_pix[2]+90.0)
- ax.add_artist(e)
- e.set_picker(3)
- e.set_clip_box(ax.bbox)
- e.set_facecolor(col)
- e.set_alpha(0.5)
- e.gaus_id = gidx
- e.src_id = src.source_id
- e.jlevel = g.jlevel
- e.isl_id = g.island_id
- e.tflux = g.total_flux
- e.pflux = g.peak_flux
- e.centre_sky = g.centre_sky
- if len(img.islands) > 0:
- island_offsets = zip(N.array(island_offsets_x), N.array(island_offsets_y))
- isl_borders = collections.AsteriskPolygonCollection(4, offsets=island_offsets, color=border_color,
- transOffset=ax.transData, sizes=(10.0,))
- ax.add_collection(isl_borders)
-
- if hasattr(img, 'gaussians'):
- for atrg in img.gaussians:
- if atrg.jlevel > 0 and atrg.gaus_num >= 0:
- col = 'r'
- style = '-'
- gidx = atrg.gaus_num
- e = Ellipse(xy=atrg.centre_pix, width=atrg.size_pix[0], height=atrg.size_pix[1], angle=atrg.size_pix[2]+90.0)
- ax.add_artist(e)
- e.set_picker(3)
- e.set_clip_box(ax.bbox)
- e.set_edgecolor(col)
- e.set_facecolor('none')
- e.set_alpha(0.8)
- e.gaus_id = gidx
- e.src_id = atrg.source_id
- e.jlevel = atrg.jlevel
- e.isl_id = atrg.island_id
- e.tflux = atrg.total_flux
- e.pflux = atrg.peak_flux
- e.centre_sky = atrg.centre_sky
-
- if 'Flagged' in titles[i]:
- for iisl, isl in enumerate(img.islands):
- ax = pl.gca()
- style = '-'
- for ig, g in enumerate(isl.fgaul):
- col = colours[ig % 6]
- ellx, elly = func.drawellipse(g)
- gline, = ax.plot(ellx, elly, color = col,
- linestyle = style, picker=3)
- gline.flag = g.flag
-
- if 'PSF' in titles[i]:
- cmd = 'ax' + str(i+1) + ".imshow(N.transpose(im), origin=origin, "\
- "interpolation='nearest', cmap=gray_palette)"
- else:
- cmd = 'ax' + str(i+1) + ".imshow(N.transpose(im), origin=origin, "\
- "interpolation='nearest',vmin=vmin, vmax=vmax, cmap=gray_palette)"
- exec cmd
- cmd = 'ax' + str(i+1) + '.format_coord = format_coord_'+names[i]
- exec cmd
- pl.title(titles[i])
- elif image == 'seds':
- cmd = 'ax' + str(i+1) + ' = pl.subplot(' + str(numx) + \
- ', ' + str(numy) + ', ' + str(i+1) + ')'
- exec cmd
- ax = pl.gca()
- plot_sed(sed_src, ax)
-
- elif image == 'wavelets':
- if i == index_first_waveplot:
- for j in range(len(j_with_gaus)):
- cmd = 'ax' + str(j+i+1) + ' = pl.subplot(' + str(numx) + \
- ', ' + str(numy) + ', ' + str(j+i+1) + ', sharex=ax1, '+\
- 'sharey=ax1)'
- exec cmd
- pl.title('Pyramidal Sources for\nWavelet Scale J = ' +
- str(j_with_gaus[j]))
- for pyr in img.pyrsrcs:
- for iisl, isl in enumerate(pyr.islands):
- jj = pyr.jlevels[iisl]
- jindx = j_with_gaus.index(jj)
- col = colours[pyr.pyr_id % 6]
- ind = N.where(~isl.mask_active)
- cmd = "ax" + str(jindx + index_first_waveplot + 1) + \
- ".plot(ind[0]+isl.origin[0], "\
- "ind[1]+isl.origin[1], '.', color=col)"
- exec cmd
-
- fig.canvas.mpl_connect('key_press_event', on_press)
- fig.canvas.mpl_connect('pick_event', on_pick)
- pl.show()
- pl.close('all')
-
-
-def on_pick(event):
- global images, srcid_cur, samp_client, samp_key, do_broadcast, samp_gaul_table_url, samp_srl_table_url
- g = event.artist
- if hasattr(g, 'gaus_id'):
- gaus_id = g.gaus_id
- src_id = g.src_id
- isl_id = g.isl_id
- tflux = g.tflux
- pflux = g.pflux
- wav_j = g.jlevel
- if wav_j == 0:
- print 'Gaussian #' + str(gaus_id) + ' (in src #' + str(src_id) + \
- ', isl #' + str(isl_id) + '): F_tot = ' + str(round(tflux,4)) + \
- ' Jy, F_peak = ' + str(round(pflux,4)) + ' Jy/beam'
- else:
- print 'Gaussian #' + str(gaus_id) + ' (in src #' + str(src_id) + \
- ', isl #' + str(isl_id) + ', wav #' + str(wav_j) + \
- '): F_tot = ' + str(round(tflux,3)) + ' Jy, F_peak = ' + \
- str(round(pflux,4)) + ' Jy/beam'
-
- # Transmit src_id, gaus_id, and coordinates to SAMP Hub (if we are connected)
- if do_broadcast and samp_key is not None:
- if samp_gaul_table_url is not None:
- func.send_highlight_row(samp_client, samp_key, samp_gaul_table_url, gaus_id)
- if samp_srl_table_url is not None:
- func.send_highlight_row(samp_client, samp_key, samp_srl_table_url, src_id)
- func.send_coords(samp_client, samp_key, g.centre_sky)
-
- # Change source SED
- # First check that SEDs are being plotted and that the selected Gaussian
- # is from the zeroth wavelet image
- has_sed = False
- if 'seds' in images and wav_j == 0:
- has_sed = True
- if not has_sed:
- return
- ax_indx = images.index('seds')
- sed_src = get_src(src_list, src_id)
- if srcid_cur == src_id:
- return
- srcid_cur = src_id
- axes_list = fig.get_axes()
- for axindx, ax in enumerate(axes_list):
- if images[axindx] == 'seds':
- plot_sed(sed_src, ax)
- else:
- print 'Flagged Gaussian (flag = ' + str(g.flag) + '; use "' + \
- "help 'flagging_opts'" + '" for flag meanings)'
-
- pl.draw()
-
-
-def on_press(event):
- """Handle keypresses"""
- from interface import raw_input_no_history
- import numpy
-
- global img_ch0, img_rms, img_mean, img_gaus_mod, img_shap_mod
- global pixels_per_beam, vmin, vmax, vmin_cur, vmax_cur, img_pi
- global ch0min, ch0max, low, fig, images, src_list, srcid_cur
- global markers
- if event.key == '0':
- print 'Resetting limits to defaults (%.4f -- %.4f Jy/beam)' \
- % (pow(10, vmin)-low,
- pow(10, vmax)-low)
- axes_list = fig.get_axes()
- for axindx, ax in enumerate(axes_list):
- if images[axindx] != 'wavelets' and images[axindx] != 'seds':
- im = ax.get_images()[0]
- im.set_clim(vmin, vmax)
- vmin_cur = vmin
- vmax_cur = vmax
- pl.draw()
- if event.key == 'm':
- # Modify scaling
- # First check that there are images to modify
- has_image = False
- for im in images:
- if isinstance(im, numpy.ndarray):
- has_image = True
- if not has_image:
- return
- minscl = 'a'
- while isinstance(minscl, str):
- try:
- if minscl == '':
- minscl = pow(10, vmin_cur) - low
- break
- minscl = float(minscl)
- except ValueError:
- prompt = "Enter min value (current = %.4f Jy/beam) : " % (pow(10, vmin_cur)-low,)
- try:
- minscl = raw_input_no_history(prompt)
- except RuntimeError:
- print 'Sorry, unable to change scaling.'
- return
- minscl = N.log10(minscl + low)
- maxscl = 'a'
- while isinstance(maxscl, str):
- try:
- if maxscl == '':
- maxscl = pow(10, vmax_cur) - low
- break
- maxscl = float(maxscl)
- except ValueError:
- prompt = "Enter max value (current = %.4f Jy/beam) : " % (pow(10, vmax_cur)-low,)
- try:
- maxscl = raw_input_no_history(prompt)
- except RuntimeError:
- print 'Sorry, unable to change scaling.'
- return
- maxscl = N.log10(maxscl + low)
- if maxscl <= minscl:
- print 'Max value must be greater than min value!'
- return
- axes_list = fig.get_axes()
- for axindx, ax in enumerate(axes_list):
- if images[axindx] != 'wavelets' and images[axindx] != 'seds':
- im = ax.get_images()[0]
- im.set_clim(minscl, maxscl)
- vmin_cur = minscl
- vmax_cur = maxscl
- pl.draw()
- if event.key == 'c':
- # Change source SED
- # First check that SEDs are being plotted
- has_sed = False
- if 'seds' in images:
- has_sed = True
- if not has_sed:
- return
- srcid = 'a'
- while isinstance(srcid, str):
- try:
- if srcid == '':
- srcid = srcid_cur
- break
- srcid = int(srcid)
- except ValueError:
- prompt = "Enter source ID (current = %i) : " % (srcid_cur,)
- try:
- srcid = raw_input_no_history(prompt)
- except RuntimeError:
- print 'Sorry, unable to change source.'
- return
- ax_indx = images.index('seds')
- sed_src = get_src(src_list, srcid)
- if sed_src is None:
- print 'Source not found!'
- return
- srcid_cur = srcid
- axes_list = fig.get_axes()
- for axindx, ax in enumerate(axes_list):
- if images[axindx] == 'seds':
- plot_sed(sed_src, ax)
- pl.draw()
- if event.key == 'i':
- # Print info about visible region
- has_image = False
- axes_list = fig.get_axes()
- # Get limits of visible region
- for axindx, ax in enumerate(axes_list):
- if images[axindx] != 'wavelets' and images[axindx] != 'seds':
- xmin, xmax = ax.get_xlim()
- ymin, ymax = ax.get_ylim()
- has_image = True
- break
- if not has_image:
- return
- if xmin < 0:
- xmin = 0
- if xmax > img_ch0.shape[0]:
- xmax = img_ch0.shape[0]
- if ymin < 0:
- ymin = 0
- if ymax > img_ch0.shape[1]:
- ymax = img_ch0.shape[1]
- flux = N.nansum(img_ch0[xmin:xmax, ymin:ymax])/pixels_per_beam
- mask = N.isnan(img_ch0[xmin:xmax, ymin:ymax])
- num_pix_unmasked = float(N.size(N.where(mask == False), 1))
- mean_rms = N.nansum(img_rms[xmin:xmax, ymin:ymax])/num_pix_unmasked
- mean_map_flux = N.nansum(img_mean[xmin:xmax, ymin:ymax])/pixels_per_beam
- if img_gaus_mod is None:
- gaus_mod_flux = 0.0
- else:
- gaus_mod_flux = N.nansum(img_gaus_mod[xmin:xmax, ymin:ymax])/pixels_per_beam
- print 'Visible region (%i:%i, %i:%i) :' % (xmin, xmax, ymin, ymax)
- print ' ch0 flux density from sum of pixels ... : %f Jy'\
- % (flux,)
- print ' Background mean map flux density ...... : %f Jy'\
- % (mean_map_flux,)
- print ' Gaussian model flux density ........... : %f Jy'\
- % (gaus_mod_flux,)
- if img_shap_mod is not None:
- shap_mod_flux = N.nansum(img_shap_mod[xmin:xmax, ymin:ymax])/pixels_per_beam
- print ' Shapelet model flux density ........... : %f Jy'\
- % (shap_mod_flux,)
- print ' Mean rms (from rms map) ............... : %f Jy/beam'\
- % (mean_rms,)
- if event.key == 'n':
- # Show/Hide island numbers
- if markers:
- for marker in markers:
- marker.set_visible(not marker.get_visible())
- pl.draw()
-
-# The following functions add ra, dec and flux density to the
-# coordinates in the lower-right-hand corner of the figure window.
-# Since each axis needs its own function (to return its particular
-# flux), we need a separate function for each subplot.
-def format_coord_ch0(x, y):
- """Custom coordinate format for ch0 image"""
- global img_ch0
- im = img_ch0
- coord_str = make_coord_str(x, y, im)
- return coord_str
-
-def format_coord_ch0_pi(x, y):
- """Custom coordinate format for ch0 image"""
- global img_pi
- im = img_pi
- coord_str = make_coord_str(x, y, im)
- return coord_str
-
-def format_coord_rms(x, y):
- """Custom coordinate format for rms image"""
- global img_rms
- im = img_rms
- coord_str = make_coord_str(x, y, im)
- return coord_str
-
-def format_coord_mean(x, y):
- """Custom coordinate format for mean image"""
- global img_mean
- im = img_mean
- coord_str = make_coord_str(x, y, im)
- return coord_str
-
-def format_coord_gaus_mod(x, y):
- """Custom coordinate format for Gaussian model image"""
- global img_gaus_mod
- im = img_gaus_mod
- coord_str = make_coord_str(x, y, im)
- return coord_str
-
-def format_coord_shap_mod(x, y):
- """Custom coordinate format for shapelet model image"""
- global img_shap_mod
- im = img_shap_mod
- coord_str = make_coord_str(x, y, im)
- return coord_str
-
-def format_coord_gaus_resid(x, y):
- """Custom coordinate format for Gaussian residual image"""
- global img_gaus_resid
- im = img_gaus_resid
- coord_str = make_coord_str(x, y, im)
- return coord_str
-
-def format_coord_shap_resid(x, y):
- """Custom coordinate format for shapelet residual image"""
- global img_shap_resid
- im = img_shap_resid
- coord_str = make_coord_str(x, y, im)
- return coord_str
-
-def format_coord_psf_maj(x, y):
- """Custom coordinate format for PSF major image"""
- global img_psf_maj
- im = img_psf_maj
- coord_str = make_coord_str(x, y, im, unit='arcsec')
- return coord_str
-
-def format_coord_psf_min(x, y):
- """Custom coordinate format for PSF minor image"""
- global img_psf_min
- im = img_psf_min
- coord_str = make_coord_str(x, y, im, unit='arcsec')
- return coord_str
-
-def format_coord_psf_pa(x, y):
- """Custom coordinate format for PSF pos. ang. image"""
- global img_psf_pa
- im = img_psf_pa
- coord_str = make_coord_str(x, y, im, unit='degrees')
- return coord_str
-
-def xy_to_radec_str(x, y):
- """Converts x, y in image coords to a sexigesimal string"""
- from output import ra2hhmmss, dec2ddmmss
- global pix2sky
- ra, dec = pix2sky([x, y])
-
- ra = ra2hhmmss(ra)
- sra = str(ra[0]).zfill(2)+':'+str(ra[1]).zfill(2)+':'+str("%.1f" % (ra[2])).zfill(3)
- dec = dec2ddmmss(dec)
- decsign = ('-' if dec[3] < 0 else '+')
- sdec = decsign+str(dec[0]).zfill(2)+':'+str(dec[1]).zfill(2)+':'+str("%.1f" % (dec[2])).zfill(3)
- return sra, sdec
-
-
-def make_coord_str(x, y, im, unit='Jy/beam'):
- """Makes the x, y, ra, dec, flux string"""
- rastr, decstr = xy_to_radec_str(x, y)
- col = int(x + 0.5)
- row = int(y + 0.5)
- numcols, numrows = im.shape
- if col >= 0 and col < numcols\
- and row >= 0 and row < numrows:
- z = im[col, row]
- return 'x=%1.1f, y=%1.1f, RA=%s, Dec=%s, F=%+1.4f %s' % (x, y, rastr, decstr, z, unit)
- else:
- return 'x=%1.1f, y=%1.1f' % (x, y)
-
-def plot_sed(src, ax):
- """Plots the SED for source 'src' to axis 'ax'"""
- global sky2pix
- global fig
- ax.cla()
- norm = src.spec_norm
- spin = src.spec_indx
- espin = src.e_spec_indx
- y = N.array(src.specin_flux)
- ey = N.array(src.specin_fluxE)
- x = N.array(src.specin_freq)
- ax.errorbar(N.log10(x/1e6), N.log10(y), yerr=ey/y, fmt='bo')
- ax.plot(N.log10(x/1e6), N.log10(norm)+N.log10(x/src.specin_freq0)*spin,
- '-g', label="alpha = %.2f" % (spin,))
- pos = sky2pix(src.posn_sky_centroid)
- xpos = int(pos[0])
- ypos = int(pos[1])
- pl.title('SED of source #'+str(src.source_id)+'\n'
- +'(x = '+str(xpos)+', y = '+str(ypos)+')')
- pl.xlabel('log Frequency (MHz)')
- pl.ylabel('log Flux Density (Jy)')
- pl.legend()
-
-
-def get_src(src_list, srcid):
- """Returns the source for srcid or None if not found"""
- for src in src_list:
- if src.source_id == srcid:
- return src
- return None
diff --git a/CEP/PyBDSM/src/python/polarisation.py b/CEP/PyBDSM/src/python/polarisation.py
deleted file mode 100644
index 3acb45a459b1743c607ff87399b3400d8fc4a2a2..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/python/polarisation.py
+++ /dev/null
@@ -1,630 +0,0 @@
-"""Module polarisation.
-
-This module finds the Q, U, and V fluxes, the total, linear, and circular
-polarisation fractions and the linear polarisation angle of each source identified
-by gaul2srl. The position angle is defined from North, with positive angles
-towards East.
-
-"""
-
-from image import *
-from islands import *
-from gausfit import Gaussian
-from gaul2srl import *
-from preprocess import Op_preprocess
-from rmsimage import Op_rmsimage
-from threshold import Op_threshold
-from islands import Op_islands
-from gausfit import Op_gausfit
-
-from gaul2srl import Op_gaul2srl
-from make_residimage import Op_make_residimage
-from const import fwsig
-import mylogger
-import numpy as N
-import functions as func
-import statusbar
-
-### Insert polarization attributes into Gaussian and Source classes
-Gaussian.total_flux_Q = Float(doc="Total flux density (Jy), Stokes Q", colname='Total_Q',
- units='Jy')
-Gaussian.total_fluxE_Q = Float(doc="Error in total flux density (Jy), Stokes Q", colname='E_Total_Q',
- units='Jy')
-Gaussian.total_flux_U = Float(doc="Total flux density (Jy), Stokes U", colname='Total_U',
- units='Jy')
-Gaussian.total_fluxE_U = Float(doc="Error in total flux density (Jy), Stokes U", colname='E_Total_U',
- units='Jy')
-Gaussian.total_flux_V = Float(doc="Total flux density (Jy), Stokes V", colname='Total_V',
- units='Jy')
-Gaussian.total_fluxE_V = Float(doc="Error in total flux density (Jy), Stokes V", colname='E_Total_V',
- units='Jy')
-Gaussian.lpol_fraction = Float(doc="Linear polarisation fraction",
- colname='Linear_Pol_frac', units=None)
-Gaussian.lpol_fraction_loerr = Float(doc="Linear polarisation fraction low error",
- colname='Elow_Linear_Pol_frac', units=None)
-Gaussian.lpol_fraction_hierr = Float(doc="Linear polarisation fraction high error",
- colname='Ehigh_Linear_Pol_frac', units=None)
-Gaussian.cpol_fraction = Float(doc="Circular polarisation fraction",
- colname='Circ_Pol_Frac', units=None)
-Gaussian.cpol_fraction_loerr = Float(doc="Circular polarisation fraction low error",
- colname='Elow_Circ_Pol_Frac', units=None)
-Gaussian.cpol_fraction_hierr = Float(doc="Circular polarisation fraction high error",
- colname='Ehigh_Circ_Pol_Frac', units=None)
-Gaussian.tpol_fraction = Float(doc="Total polarisation fraction",
- colname='Total_Pol_Frac', units=None)
-Gaussian.tpol_fraction_loerr = Float(doc="Total polarisation fraction low error",
- colname='Elow_Total_Pol_Frac', units=None)
-Gaussian.tpol_fraction_hierr = Float(doc="Total polarisation fraction high error",
- colname='Ehigh_Total_Pol_Frac', units=None)
-Gaussian.lpol_angle = Float(doc="Polarisation angle (deg from North towards East)",
- colname='Linear_Pol_Ang', units='deg')
-Gaussian.lpol_angle_err = Float(doc="Polarisation angle error (deg)",
- colname='E_Linear_Pol_Ang', units='deg')
-
-Source.total_flux_Q = Float(doc="Total flux density (Jy), Stokes Q", colname='Total_Q',
- units='Jy')
-Source.total_fluxE_Q = Float(doc="Error in total flux density (Jy), Stokes Q", colname='E_Total_Q',
- units='Jy')
-Source.total_flux_U = Float(doc="Total flux density (Jy), Stokes U", colname='Total_U',
- units='Jy')
-Source.total_fluxE_U = Float(doc="Error in total flux density (Jy), Stokes U", colname='E_Total_U',
- units='Jy')
-Source.total_flux_V = Float(doc="Total flux density (Jy), Stokes V", colname='Total_V',
- units='Jy')
-Source.total_fluxE_V = Float(doc="Error in total flux density (Jy), Stokes V", colname='E_Total_V',
- units='Jy')
-Source.lpol_fraction = Float(doc="Linear polarisation fraction",
- colname='Linear_Pol_frac', units=None)
-Source.lpol_fraction_loerr = Float(doc="Linear polarisation fraction low error",
- colname='Elow_Linear_Pol_frac', units=None)
-Source.lpol_fraction_hierr = Float(doc="Linear polarisation fraction high error",
- colname='Ehigh_Linear_Pol_frac', units=None)
-Source.cpol_fraction = Float(doc="Circular polarisation fraction",
- colname='Circ_Pol_Frac', units=None)
-Source.cpol_fraction_loerr = Float(doc="Circular polarisation fraction low error",
- colname='Elow_Circ_Pol_Frac', units=None)
-Source.cpol_fraction_hierr = Float(doc="Circular polarisation fraction high error",
- colname='Ehigh_Circ_Pol_Frac', units=None)
-Source.tpol_fraction = Float(doc="Total polarisation fraction",
- colname='Total_Pol_Frac', units=None)
-Source.tpol_fraction_loerr = Float(doc="Total polarisation fraction low error",
- colname='Elow_Total_Pol_Frac', units=None)
-Source.tpol_fraction_hierr = Float(doc="Total polarisation fraction high error",
- colname='Ehigh_Total_Pol_Frac', units=None)
-Source.lpol_angle = Float(doc="Polarisation angle (deg from North towards East)",
- colname='Linear_Pol_Ang', units='deg')
-Source.lpol_angle_err = Float(doc="Polarisation angle error (deg)",
- colname='E_Linear_Pol_Ang', units='deg')
-
-class Op_polarisation(Op):
- """ Finds the flux in each Stokes and calculates the polarisation fraction
- and angle.
-
- Fluxes are calculated by summing all nonmasked pixels assigned to
- the Gaussian. If a pixel contains contributions from two or more
- Gaussians, its flux is divided between the Gaussians by the ratio of
- fluxes that they contribute to the pixel. Errors on the fluxes are
- derived by summing the same pixels in the rms maps in quadrature.
- The results are stored in the Gaussian and Source structures.
-
- Fits are also done to the polarized intensity (PI) image to
- determine if there are any islands of emission that lie outside
- those found in the I image. If there are, they are fit and the
- process above is done for them too.
-
- For linearly polarised emission, the signal and noise add
- vectorially, giving a Rice distribution (Vinokur 1965) instead of a
- Gaussian one. To correct for this, a bias is estimated and removed
- from the polarisation fraction using the same method used for the
- NVSS catalog (see ftp://ftp.cv.nrao.edu/pub/nvss/catalog.ps). Errors
- on the linear and total polarisation fractions and polarisation
- angle are estimated using the debiased polarised flux and standard
- error propagation. See Sparks & Axon (1999) for a more detailed
- treatment.
-
- Prerequisites: module gaul2srl should be run first."""
-
- def __call__(self, img):
- mylog = mylogger.logging.getLogger("PyBDSM."+img.log+"Polarisatn")
- if img.opts.polarisation_do:
- mylog.info('Extracting polarisation properties for all sources')
- pols = ['I', 'Q', 'U', 'V']
-
- # Run gausfit and gual2srl on PI image to look for polarized sources
- # undetected in I
- fit_PI = img.opts.pi_fit
- n_new = 0
- ch0_pi = N.sqrt(img.ch0_Q_arr**2 + img.ch0_U_arr**2)
- img.ch0_pi_arr = ch0_pi
-
- if fit_PI:
- from . import _run_op_list
- mylogger.userinfo(mylog, "\nChecking PI image for new sources")
-
- mask = img.mask_arr
- minsize = img.opts.minpix_isl
-
- # Set up image object for PI image.
- pi_chain, pi_opts = self.setpara_bdsm(img)
- pimg = Image(pi_opts)
- pimg.beam = img.beam
- pimg.pixel_beam = img.pixel_beam
- pimg.pixel_beamarea = img.pixel_beamarea
- pimg.log = 'PI.'
- pimg.pix2beam = img.pix2beam
- pimg.beam2pix = img.beam2pix
- pimg.pix2gaus = img.pix2gaus
- pimg.gaus2pix = img.gaus2pix
- pimg.pix2sky = img.pix2sky
- pimg.sky2pix = img.sky2pix
- pimg.pix2coord = img.pix2coord
- pimg.wcs_obj = img.wcs_obj
- pimg.mask_arr = mask
- pimg.masked = img.masked
- pimg.ch0_arr = ch0_pi
- pimg._pi = True
-
- success = _run_op_list(pimg, pi_chain)
- if not success:
- return
-
- img.pi_islands = pimg.islands
- img.pi_gaussians = pimg.gaussians
- img.pi_sources = pimg.sources
-
- # Now check for new sources in the PI image that are not
- # found in the Stokes I image. If any new sources are found,
- # adjust their IDs to follow after those found in I.
- new_isl = []
- new_src = []
- new_gaus = []
- n_new_src = 0
- isl_id = img.islands[-1].island_id
- src_id = img.sources[-1].source_id
- gaus_id = img.gaussians[-1].gaus_num
- for pi_isl in pimg.islands:
- new_sources = []
- for pi_src in pi_isl.sources:
- if img.pyrank[int(img.sky2pix(pi_src.posn_sky_max)[0]),
- int(img.sky2pix(pi_src.posn_sky_max)[1])] == -1:
- src_id += 1
- pi_src._pi = True
- pi_src.island_id = isl_id
- pi_src.source_id = src_id
- pi_src.spec_indx = N.NaN
- pi_src.e_spec_indx = N.NaN
- pi_src.spec_norm = N.NaN
- pi_src.specin_flux = [N.NaN]
- pi_src.specin_fluxE = [N.NaN]
- pi_src.specin_freq = [N.NaN]
- pi_src.specin_freq0 = N.NaN
- new_sources.append(pi_src)
- new_src.append(pi_src)
- n_new_src += 1
- for g in pi_src.gaussians:
- gaus_id += 1
- new_gaus.append(g)
- g.gaus_num = gaus_id
- if len(new_sources) > 0:
- isl_id += 1
- pi_isl.sources = new_sources
- pi_isl.island_id = isl_id
- pi_isl._pi = True
- new_isl.append(pi_isl)
-
- n_new = len(new_isl)
- mylogger.userinfo(mylog, "New sources found in PI image", '%i (%i total)' %
- (n_new, img.nsrc+n_new))
-
- if n_new > 0:
- img.islands += new_isl
- img.sources += new_src
- img.gaussians += new_gaus
- img.nsrc += n_new_src
- renumber_islands(img)
-
- bar = statusbar.StatusBar('Calculating polarisation properties .... : ', 0, img.nsrc)
- if img.opts.quiet == False:
- bar.start()
-
- for isl in img.islands:
- isl_bbox = isl.bbox
- ch0_I = img.ch0_arr[isl_bbox]
- ch0_Q = img.ch0_Q_arr[isl_bbox]
- ch0_U = img.ch0_U_arr[isl_bbox]
- ch0_V = img.ch0_V_arr[isl_bbox]
- ch0_images = [ch0_I, ch0_Q, ch0_U, ch0_V]
-
- for i, src in enumerate(isl.sources):
- # For each source, assume the morphology does not change
- # across the Stokes cube. This assumption allows us to fit
- # the Gaussians of each source to each Stokes image by
- # simply fitting only the overall normalizations of the
- # individual Gaussians.
- #
- # First, fit all source Gaussians to each Stokes image:
- x, y = N.mgrid[isl_bbox]
- gg = src.gaussians
- fitfix = N.ones(len(gg)) # fit only normalization
- srcmask = isl.mask_active
- total_flux = N.zeros((4, len(fitfix)), dtype=N.float32) # array of fluxes: N_Stokes x N_Gaussians
- errors = N.zeros((4, len(fitfix)), dtype=N.float32) # array of fluxes: N_Stokes x N_Gaussians
-
- for sind, image in enumerate(ch0_images):
- if (sind==0 and hasattr(src, '_pi')) or sind > 0: # Fit I only for PI sources
- p, ep = func.fit_mulgaus2d(image, gg, x, y, srcmask, fitfix)
- for ig in range(len(fitfix)):
- center_pix = (p[ig*6 + 1], p[ig*6 + 2])
- bm_pix = N.array([img.pixel_beam()[0], img.pixel_beam()[1], img.pixel_beam()[2]])
- total_flux[sind, ig] = p[ig*6]*p[ig*6+3]*p[ig*6+4]/(bm_pix[0]*bm_pix[1])
- p = N.insert(p, N.arange(len(fitfix))*6+6, total_flux[sind])
- if sind > 0:
- rms_img = img.__getattribute__('rms_'+pols[sind]+'_arr')
- else:
- rms_img = img.rms_arr
- if len(rms_img.shape) > 1:
- rms_isl = rms_img[isl.bbox].mean()
- else:
- rms_isl = rms_img
- errors[sind] = func.get_errors(img, p, rms_isl)[6]
-
- # Now, assign fluxes to each Gaussian.
- src_flux_I = 0.0
- src_flux_Q = 0.0
- src_flux_U = 0.0
- src_flux_V = 0.0
- src_flux_I_err_sq = 0.0
- src_flux_Q_err_sq = 0.0
- src_flux_U_err_sq = 0.0
- src_flux_V_err_sq = 0.0
-
- for ig, gaussian in enumerate(src.gaussians):
- flux_I = total_flux[0, ig]
- flux_I_err = abs(errors[0, ig])
- flux_Q = total_flux[1, ig]
- flux_Q_err = abs(errors[1, ig])
- flux_U = total_flux[2, ig]
- flux_U_err = abs(errors[2, ig])
- flux_V = total_flux[3, ig]
- flux_V_err = abs(errors[3, ig])
-
- if hasattr(src, '_pi'):
- gaussian.total_flux = flux_I
- gaussian.total_fluxE = flux_I_err
- gaussian.total_flux_Q = flux_Q
- gaussian.total_flux_U = flux_U
- gaussian.total_flux_V = flux_V
- gaussian.total_fluxE_Q = flux_Q_err
- gaussian.total_fluxE_U = flux_U_err
- gaussian.total_fluxE_V = flux_V_err
-
- if hasattr(src, '_pi'):
- src_flux_I += flux_I
- src_flux_I_err_sq += flux_I_err**2
- src_flux_Q += flux_Q
- src_flux_U += flux_U
- src_flux_V += flux_V
- src_flux_Q_err_sq += flux_Q_err**2
- src_flux_U_err_sq += flux_U_err**2
- src_flux_V_err_sq += flux_V_err**2
-
- # Calculate and store polarisation fractions and angle for each Gaussian in the island
- # For this we need the I flux, which we can just take from g.total_flux and src.total_flux
- flux_I = gaussian.total_flux
- flux_I_err = gaussian.total_fluxE
- stokes = [flux_I, flux_Q, flux_U, flux_V]
- stokes_err = [flux_I_err, flux_Q_err, flux_U_err, flux_V_err]
-
- lpol_frac, lpol_frac_loerr, lpol_frac_hierr = self.calc_lpol_fraction(stokes, stokes_err) # linear pol fraction
- lpol_ang, lpol_ang_err = self.calc_lpol_angle(stokes, stokes_err) # linear pol angle
- cpol_frac, cpol_frac_loerr, cpol_frac_hierr = self.calc_cpol_fraction(stokes, stokes_err) # circular pol fraction
- tpol_frac, tpol_frac_loerr, tpol_frac_hierr = self.calc_tpol_fraction(stokes, stokes_err) # total pol fraction
-
- gaussian.lpol_fraction = lpol_frac
- gaussian.lpol_fraction_loerr = lpol_frac_loerr
- gaussian.lpol_fraction_hierr = lpol_frac_hierr
- gaussian.cpol_fraction = cpol_frac
- gaussian.cpol_fraction_loerr = cpol_frac_loerr
- gaussian.cpol_fraction_hierr = cpol_frac_hierr
- gaussian.tpol_fraction = tpol_frac
- gaussian.tpol_fraction_loerr = tpol_frac_loerr
- gaussian.tpol_fraction_hierr = tpol_frac_hierr
- gaussian.lpol_angle = lpol_ang
- gaussian.lpol_angle_err = lpol_ang_err
-
- # Store fluxes for each source in the island
- if hasattr(src, '_pi'):
- src.total_flux = src_flux_I
- src.total_fluxE = N.sqrt(src_flux_I_err_sq)
- src.total_flux_Q = src_flux_Q
- src.total_flux_U = src_flux_U
- src.total_flux_V = src_flux_V
- src.total_fluxE_Q = N.sqrt(src_flux_Q_err_sq)
- src.total_fluxE_U = N.sqrt(src_flux_U_err_sq)
- src.total_fluxE_V = N.sqrt(src_flux_V_err_sq)
-
- # Calculate and store polarisation fractions and angle for each source in the island
- # For this we need the I flux, which we can just take from g.total_flux and src.total_flux
- src_flux_I = src.total_flux
- src_flux_I_err = src.total_fluxE
- stokes = [src_flux_I, src_flux_Q, src_flux_U, src_flux_V]
- stokes_err = [src_flux_I_err, N.sqrt(src_flux_Q_err_sq), N.sqrt(src_flux_U_err_sq), N.sqrt(src_flux_V_err_sq)]
-
- lpol_frac, lpol_frac_loerr, lpol_frac_hierr = self.calc_lpol_fraction(stokes, stokes_err) # linear pol fraction
- lpol_ang, lpol_ang_err = self.calc_lpol_angle(stokes, stokes_err) # linear pol angle
- cpol_frac, cpol_frac_loerr, cpol_frac_hierr = self.calc_cpol_fraction(stokes, stokes_err) # circular pol fraction
- tpol_frac, tpol_frac_loerr, tpol_frac_hierr = self.calc_tpol_fraction(stokes, stokes_err) # total pol fraction
-
- src.lpol_fraction = lpol_frac
- src.lpol_fraction_loerr = lpol_frac_loerr
- src.lpol_fraction_hierr = lpol_frac_hierr
- src.cpol_fraction = cpol_frac
- src.cpol_fraction_loerr = cpol_frac_loerr
- src.cpol_fraction_hierr = cpol_frac_hierr
- src.tpol_fraction = tpol_frac
- src.tpol_fraction_loerr = tpol_frac_loerr
- src.tpol_fraction_hierr = tpol_frac_hierr
- src.lpol_angle = lpol_ang
- src.lpol_angle_err = lpol_ang_err
- if bar.started:
- bar.increment()
- bar.stop()
- img.completed_Ops.append('polarisation')
-
- ####################################################################################
- def calc_lpol_fraction(self, stokes, err):
- """ Calculate linear polarisation fraction and error from:
- stokes = [I, Q, U, V] and err = [Ierr, Qerr, Uerr, Verr]
-
- """
- I, Q, U, V = stokes
- Ierr, Qerr, Uerr, Verr = err
- QUerr = N.mean([Qerr, Uerr])
- stokes_lpol = [I, Q, U, 0.0]
- err_lpol = [Ierr, Qerr, Uerr, 0.0]
-
- lfrac, loerr, uperr, Iup, Qup, Uup, Vup = self.estimate_err_frac_with_limits(stokes_lpol, err_lpol)
-
- # If all are detections, debias and use error propagation instead
- if not Iup and not Qup and not Uup:
- lpol = N.sqrt(Q**2 + U**2)
- lpol_debiased = self.debias(lpol, QUerr) # debias (to first order)
- if lpol_debiased > 0.0:
- lfrac = lpol_debiased / I
- dlfrac = lfrac * N.sqrt((Ierr/I)**2 + (Q*Qerr/lpol_debiased**2)**2 + (U*Uerr/lpol_debiased**2)**2)
- else:
- # if debiased fraction is consistent with zero, estimate a ballpark error with biased value
- lfrac = 0.0
- lpolsq = Q**2 + U**2
- dlfrac = N.sqrt(lpolsq) / I * N.sqrt((Ierr/I)**2 + (Q*Qerr/lpolsq)**2 + (U*Uerr/lpolsq)**2)
- loerr = dlfrac
- uperr = dlfrac
-
- lfrac, loerr, uperr = self.check_frac(lfrac, loerr, uperr)
- return lfrac, loerr, uperr
-
-
- ####################################################################################
- def calc_cpol_fraction(self, stokes, err):
- """ Calculate circular polarisation fraction and error from:
- stokes = [I, Q, U, V] and err = [Ierr, Qerr, Uerr, Verr]
-
- """
- I, Q, U, V = stokes
- Ierr, Qerr, Uerr, Verr = err
- stokes_cpol = [I, 0.0, 0.0, V]
- err_cpol = [Ierr, 0.0, 0.0, Verr]
-
- cfrac, loerr, uperr, Iup, Qup, Uup, Vup = self.estimate_err_frac_with_limits(stokes_cpol, err_cpol)
-
- # If all are detections, debias and use error propagation instead
- if not Iup and not Vup:
- cfrac = abs(V) / I
- dcfrac = cfrac * N.sqrt((Ierr/I)**2 + (Verr/V)**2)
- loerr = dcfrac
- uperr = dcfrac
-
- cfrac, loerr, uperr = self.check_frac(cfrac, loerr, uperr)
- return cfrac, loerr, uperr
-
-
- ####################################################################################
- def calc_tpol_fraction(self, stokes, err):
- """ Calculate total polarisation fraction and error from:
- stokes = [I, Q, U, V] and err = [Ierr, Qerr, Uerr, Verr]
-
- """
- I, Q, U, V = stokes
- Ierr, Qerr, Uerr, Verr = err
- QUerr = N.mean([Qerr, Uerr])
-
- tfrac, loerr, uperr, Iup, Qup, Uup, Vup = self.estimate_err_frac_with_limits(stokes, err)
-
- # If all are detections, debias and use error propagation instead
- if not Iup and not Qup and not Uup and not Vup:
- lpol = N.sqrt(Q**2 + U**2)
- lpol_debiased = self.debias(lpol, QUerr)
- tpol_debiased = N.sqrt(Q**2 + U**2 + V**2) - (lpol - lpol_debiased) # debias (to first order)
- if tpol_debiased > 0.0:
- tfrac = tpol_debiased / I
- dtfrac = tfrac * N.sqrt((Ierr/I)**2 + (Q*Qerr/tpol_debiased**2)**2 + (U*Uerr/tpol_debiased**2)**2 + (V*Verr/tpol_debiased**2)**2)
- else:
- # if debiased fraction is consistent with zero, estimate a ballpark error with biased value
- tfrac = 0.0
- tpolsq = Q**2 + U**2 + V**2
- dtfrac = N.sqrt(tpolsq) / I * N.sqrt((Ierr/I)**2 + (Q*Qerr/tpolsq)**2 + (U*Uerr/tpolsq)**2 + (V*Verr/tpolsq)**2)
- loerr = dtfrac
- uperr = dtfrac
-
- tfrac, loerr, uperr = self.check_frac(tfrac, loerr, uperr)
- return tfrac, loerr, uperr
-
-
- ####################################################################################
- def calc_lpol_angle(self, stokes, err, sig=3.0):
- """ Calculate linear polarisation angle and error (in degrees) from:
- stokes = [I, Q, U, V] and err = [Ierr, Qerr, Uerr, Verr]
-
- """
- I, Q, U, V = stokes
- Ierr, Qerr, Uerr, Verr = err
- if abs(Q) < sig*abs(Qerr) and abs(U) < sig*abs(Uerr):
- return 0.0, 0.0
-
- ang = 0.5 * N.arctan2(U, Q) * 180.0 / N.pi
- dang = 0.5 / (1.0 + (U/Q)**2) * N.sqrt((Uerr/Q)**2 + (U*Qerr/Q**2)**2) * 180.0 / N.pi
-
- return ang, dang
-
-
- ####################################################################################
- def debias(self, pflux, QUerr):
- """ Debiases the linearly polarised flux using the same method
- used for the NVSS catalog (see ftp://ftp.cv.nrao.edu/pub/nvss/catalog.ps).
-
- """
- data_table=N.array([[1.253,1.2530], [1.256,1.1560], [1.266,1.0660], [1.281,0.9814],
- [1.303,0.9030], [1.330,0.8304], [1.364,0.7636], [1.402,0.7023],
- [1.446,0.6462], [1.495,0.5951], [1.549,0.5486], [1.606,0.5064],
- [1.668,0.4683], [1.734,0.4339], [1.803,0.4028], [1.875,0.3749],
- [1.950,0.3498], [2.027,0.3273], [2.107,0.3070], [2.189,0.2888],
- [2.272,0.2724], [2.358,0.2576], [2.444,0.2442], [2.532,0.2321],
- [2.621,0.2212], [2.711,0.2112], [2.802,0.2021], [2.894,0.1938],
- [2.986,0.1861], [3.079,0.1791], [3.173,0.1726], [3.267,0.1666],
- [3.361,0.1610], [3.456,0.1557], [3.551,0.1509], [3.646,0.1463],
- [3.742,0.1420], [3.838,0.1380], [3.934,0.1342], [4.031,0.1306]])
-
- pnorm = pflux / QUerr
- if pnorm <= data_table[0,0]:
- bias = data_table[0,1]
- else:
- if pnorm >= data_table[-1,0]:
- bias = 1.0 / (2.0 * pnorm) + 1.0 / (8.0 * pnorm**3)
- pnorm = pnorm - bias
- bias = 1.0 / (2.0 * pnorm) + 1.0 / (8.0 * pnorm**3)
- else:
- bias = N.interp(pnorm, data_table[:,0], data_table[:,1])
-
- pflux_debiased = pflux - bias * QUerr
-
- return pflux_debiased
-
- def check_frac(self, frac, loerr, uperr):
- if frac < 0.0:
- frac = 0.0
- if frac > 1.0:
- frac = 1.0
- if loerr < 0.0:
- loerr = frac
- if frac + uperr > 1.0:
- uperr = 1.0 - frac
- return frac, loerr, uperr
-
- ####################################################################################
- def setpara_bdsm(self, img):
- from types import ClassType, TypeType
-
- chain = [Op_preprocess, Op_rmsimage(), Op_threshold(), Op_islands(),
- Op_gausfit(), Op_gaul2srl(), Op_make_residimage()]
-
- opts = img.opts.to_dict()
- if img.opts.pi_thresh_isl is not None:
- opts['thresh_isl'] = img.opts.pi_thresh_isl
- if img.opts.pi_thresh_pix is not None:
- opts['thresh_pix'] = img.opts.pi_thresh_pix
- opts['thresh'] = 'hard'
- opts['polarisation_do'] = False
- opts['filename'] = ''
- opts['detection_image'] = ''
-
- ops = []
- for op in chain:
- if isinstance(op, (ClassType, TypeType)):
- ops.append(op())
- else:
- ops.append(op)
-
- return ops, opts
-
- def estimate_err_frac_with_limits(self, stokes, err, sig=3.0):
- """Estimate reasonable errors on polarization fraction when upper
- limits are present.
-
- """
- I, Q, U, V = stokes
- Ierr, Qerr, Uerr, Verr = err
-
- Iup = False
- Qup = False
- Uup = False
- Vup = False
-
- if abs(I) < sig * abs(Ierr):
- Iup = True
- if abs(Q) < sig * abs(Qerr):
- Q = 0.0
- Qup = True
- if abs(U) < sig * abs(Uerr):
- U = 0.0
- Uup = True
- if abs(V) < sig * abs(Verr):
- V = 0.0
- Vup = True
-
- pol = N.sqrt(Q**2 + U**2 + V**2)
- frac = pol / I
- if frac < 0.0:
- frac = 0.0
- if frac > 1.0:
- frac = 1.0
-
- if Iup:
- if Qup and Uup and Vup:
- frac = 0.0
- loerr = 0.0
- uperr = 1.0
- else:
- loerr = frac - N.sqrt((abs(Q) - Qerr)**2 + (abs(U) - Uerr)**2 + (abs(V) - Verr)**2) / abs(Ierr)
- uperr = 1.0 - frac
- else:
- loerr = frac - N.sqrt((abs(Q) - Qerr)**2 + (abs(U) - Uerr)**2 + (abs(V) - Verr)**2) / (I + Ierr)
- uperr = N.sqrt((abs(Q) + Qerr)**2 + (abs(U) + Uerr)**2 + (abs(V) + Verr)**2) / (I - Ierr) - frac
-
- if loerr < 0.0:
- loerr = frac
- if frac + uperr > 1.0:
- uperr = 1.0 - frac
-
- return frac, loerr, uperr, Iup, Qup, Uup, Vup
-
-
- def double_bbox(self, bbox, shape):
- """Expand bbox of the island by factor of 2
-
- bbox is isl.bbox
- shape is img.shape
- """
- def expand(bbox, shape):
- bbox_width = (bbox.stop - bbox.start)/2.0
- return slice(max(0, bbox.start - bbox_width), min(shape, bbox.stop + bbox_width))
- return map(expand, bbox, shape)
-
-
-def renumber_islands(img):
- """Renumbers island_ids (after, e.g., removing one)
-
- Also renumbers the pyrank image.
- """
- for i, isl in enumerate(img.islands):
- isl.island_id = i
- for g in isl.gaul:
- g.island_id = i
- for dg in isl.dgaul:
- dg.island_id = i
- if i == 0:
- img.pyrank[isl.bbox] = N.invert(isl.mask_active) - 1
- else:
- img.pyrank[isl.bbox] = N.invert(isl.mask_active) * isl.island_id - isl.mask_active
- gaussian_list = [g for isl in img.islands for g in isl.gaul]
- img.gaussians = gaussian_list
-
diff --git a/CEP/PyBDSM/src/python/preprocess.py b/CEP/PyBDSM/src/python/preprocess.py
deleted file mode 100644
index 4b65f7b173ea3b788f3fd37c8cd8091ebaeef35a..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/python/preprocess.py
+++ /dev/null
@@ -1,196 +0,0 @@
-"""Module preprocess
-
-Calculates some basic statistics of the image and sets up processing
-parameters for PyBDSM.
-"""
-
-import numpy as N
-import _cbdsm
-from image import *
-from math import pi, sqrt, log
-import const
-import functions as func
-import mylogger
-
-### Insert attributes into Image class
-Image.raw_mean = Float(doc="Unclipped image mean")
-Image.raw_rms = Float(doc="Unclipped image rms")
-Image.clipped_mean = Float(doc="Clipped image mean")
-Image.clipped_rms = Float(doc="Clipped image rms")
-Image.clipped_mean_QUV = List(Float(), doc="Clipped image mean for Q, U, V")
-Image.clipped_rms_QUV = List(Float(), doc="Clipped image rms for Q, U, V")
-Image.blankpix = Int(doc="Number of blanked pixels")
-Image.noutside_univ = Int(doc="Number of blanked pixels")
-
-Image.maxpix_coord = Tuple(Int(), Int(),
- doc="Coordinates of maximal pixel in the image")
-Image.minpix_coord = Tuple(Int(), Int(),
- doc="Coordinates of minimal pixel in the image")
-Image.max_value = Float(doc="Maximal pixel in the image")
-Image.min_value = Float(doc="Minimal pixel in the image")
-Image.omega = Float(doc="Solid angle covered by the image")
-confused = String(doc = 'confused image or not')
-
-class Op_preprocess(Op):
- """Preprocessing -- calculate some basic statistics and set
- processing parameters. Should assume that pixels outside the universe
- are blanked in QC ? """
-
- def __call__(self, img):
- mylog = mylogger.logging.getLogger("PyBDSM."+img.log+"Preprocess")
- bstat = func.bstat
- if img.opts.kappa_clip is None:
- kappa = -img.pixel_beamarea()
- else:
- kappa = img.opts.kappa_clip
-
- if img.opts.polarisation_do:
- pols = ['I', 'Q', 'U', 'V']
- ch0images = [img.ch0_arr, img.ch0_Q_arr, img.ch0_U_arr, img.ch0_V_arr]
- img.clipped_mean_QUV = []
- img.clipped_rms_QUV = []
- else:
- pols = ['I'] # assume I is always present
- ch0images = [img.ch0_arr]
-
- if hasattr(img, 'rms_mask'):
- mask = img.rms_mask
- else:
- mask = img.mask_arr
- opts = img.opts
-
- for ipol, pol in enumerate(pols):
- image = ch0images[ipol]
-
- ### basic stats
- mean, rms, cmean, crms, cnt = bstat(image, mask, kappa)
- if cnt > 198: cmean = mean; crms = rms
- if pol == 'I':
- if func.approx_equal(crms, 0.0, rel=None):
- raise RuntimeError('Clipped rms appears to be zero. Check for regions '\
- 'with values of 0 and\nblank them (with NaNs) '\
- 'or use trim_box to exclude them.')
- img.raw_mean = mean
- img.raw_rms = rms
- img.clipped_mean= cmean
- img.clipped_rms = crms
- mylog.info('%s %.4f %s %.4f %s ' % ("Raw mean (Stokes I) = ", mean*1000.0, \
- 'mJy and raw rms = ',rms*1000.0, 'mJy'))
- mylog.info('%s %.4f %s %s %.4f %s ' % ("sigma clipped mean (Stokes I) = ", cmean*1000.0, \
- 'mJy and ','sigma clipped rms = ',crms*1000.0, 'mJy'))
- else:
- img.clipped_mean_QUV.append(cmean)
- img.clipped_rms_QUV.append(crms)
- mylog.info('%s %s %s %.4f %s %s %.4f %s ' % ("sigma clipped mean (Stokes ", pol, ") = ", cmean*1000.0, \
- 'mJy and ','sigma clipped rms = ',crms*1000.0, 'mJy'))
-
- image = img.ch0_arr
- # Check if pixels are outside the universe
- if opts.check_outsideuniv:
- mylogger.userinfo(mylog, "Checking for pixels outside the universe")
- noutside_univ = self.outside_univ(img)
- img.noutside_univ = noutside_univ
- frac_blank = round(float(noutside_univ)/float(image.shape[0]*image.shape[1]),3)
- mylogger.userinfo(mylog, "Number of additional pixels blanked", str(noutside_univ)
- +' ('+str(frac_blank*100.0)+'%)')
- else:
- noutside_univ = 0
-
- # If needed, (re)mask the image
- if noutside_univ > 0:
- mask = N.isnan(img.ch0_arr)
- masked = mask.any()
- img.masked = masked
- if masked:
- img.mask_arr = mask
- img.blankpix = N.sum(mask)
-
-
- ### max/min pixel value & coordinates
- shape = image.shape[0:2]
- if mask is not None:
- img.blankpix = N.sum(mask)
- if img.blankpix == 0:
- max_idx = image.argmax()
- min_idx = image.argmin()
- else:
- max_idx = N.nanargmax(image)
- min_idx = N.nanargmin(image)
-
- img.maxpix_coord = N.unravel_index(max_idx, shape)
- img.minpix_coord = N.unravel_index(min_idx, shape)
- img.max_value = image.flat[max_idx]
- img.min_value = image.flat[min_idx]
-
- ### Solid angle of the image
- cdelt = N.array(img.wcs_obj.acdelt[:2])
- img.omega = N.product(shape)*abs(N.product(cdelt))/(180.*180./pi/pi)
-
- ### Total flux in ch0 image
- if 'atrous' in img.filename or img._pi or img.log == 'Detection image':
- # Don't do this estimate for atrous wavelet images
- # or polarized intensity image,
- # as it doesn't give the correct flux. Also, ignore
- # the flux in the detection image, as it's likely
- # wrong (e.g., not corrected for the primary beam).
- img.ch0_sum_jy = 0
- else:
- im_flux = N.nansum(image)/img.pixel_beamarea() # Jy
- img.ch0_sum_jy = im_flux
- mylogger.userinfo(mylog, 'Flux from sum of (non-blank) pixels',
- '%.3f Jy' % (im_flux,))
-
- ### if image seems confused, then take background mean as zero instead
- alpha_sourcecounts = 2.5 # approx diff src count slope. 2.2?
- if opts.bmpersrc_th is None:
- if mask is not None:
- unmasked = N.where(~img.mask_arr)
- n = (image[unmasked] >= 5.*crms).sum()
- else:
- n = (image >= 5.*crms).sum()
- if n <= 0:
- n = 1
- mylog.info('No pixels in image > 5-sigma.')
- mylog.info('Taking number of pixels above 5-sigma as 1.')
- img.bmpersrc_th = N.product(shape)/((alpha_sourcecounts-1.)*n)
- mylog.info('%s %6.2f' % ('Estimated bmpersrc_th = ', img.bmpersrc_th))
- else:
- img.bmpersrc_th = opts.bmpersrc_th
- mylog.info('%s %6.2f' % ('Taking default bmpersrc_th = ', img.bmpersrc_th))
-
- confused = False
- if opts.mean_map == 'default':
- if opts.bmpersrc_th <= 25. or cmean/crms >= 0.1:
- confused = True
- img.confused = confused
- mylog.info('Parameter confused is '+str(img.confused))
-
- img.completed_Ops.append('preprocess')
- return img
-
- def outside_univ(self,img):
- """ Checks if a pixel is outside the universe and is not blanked,
- and blanks it. (fits files written by CASA dont do this). """
-
- noutside = 0
- n, m = img.ch0_arr.shape
- for i in range(n):
- for j in range(m):
- out = False
- err = ''
- pix1 = (i,j)
- try:
- skyc = img.pix2sky(pix1)
- pix2 = img.sky2pix(skyc)
- if abs(pix1[0]-pix2[0]) > 0.5 or abs(pix1[1]-pix2[1]) > 0.5: out=True
- except RuntimeError, err:
- pass
- if out or ("8" in str(err)):
- noutside += 1
- ch0 = img.ch0_arr
- ch0[pix1] = float("NaN")
- img.ch0_arr = ch0
- return noutside
-
-
-
diff --git a/CEP/PyBDSM/src/python/psf_vary.py b/CEP/PyBDSM/src/python/psf_vary.py
deleted file mode 100644
index 5add24151f9c70591d2d13742597f735d4a75b15..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/python/psf_vary.py
+++ /dev/null
@@ -1,1067 +0,0 @@
-
-import numpy as N
-from image import *
-import mylogger
-from copy import deepcopy as cp
-from . import has_pl
-if has_pl:
- import matplotlib.pyplot as pl
-import scipy
-import scipy.signal as S
-import _cbdsm
-import functions as func
-import _pytesselate as _pytess
-import shapelets as sh
-from scipy.optimize import leastsq
-import nat
-from math import *
-import statusbar
-from const import fwsig
-import multi_proc as mp
-import itertools
-
-
-class Op_psf_vary(Op):
- """Computes variation of psf across the image """
-
- def __call__(self, img):
-
- if img.opts.psf_vary_do:
- mylog = mylogger.logging.getLogger("PyBDSM."+img.log+"Psf_Vary")
- mylogger.userinfo(mylog, '\nEstimating PSF variations')
- opts = img.opts
- dir = img.basedir + '/misc/'
- plot = False # debug figures
- image = img.ch0_arr
-
- try:
- from astropy.io import fits as pyfits
- old_pyfits = False
- except ImportError, err:
- from distutils.version import StrictVersion
- import pyfits
- if StrictVersion(pyfits.__version__) < StrictVersion('2.2'):
- old_pyfits = True
- else:
- old_pyfits = False
-
- if old_pyfits:
- mylog.warning('PyFITS version is too old: psf_vary module skipped')
- return
-
- if opts.psf_fwhm is not None:
- # User has specified a constant PSF to use, so skip PSF fitting/etc.
- psf_maj = opts.psf_fwhm[0] # FWHM in deg
- psf_min = opts.psf_fwhm[1] # FWHM in deg
- psf_pa = opts.psf_fwhm[2] # PA in deg
- mylogger.userinfo(mylog, 'Using constant PSF (major, minor, pos angle)',
- '(%.5e, %.5e, %s) degrees' % (psf_maj, psf_maj,
- round(psf_pa, 1)))
- else:
- # Use did not specify a constant PSF to use, so estimate it
- over = 2
- generators = opts.psf_generators; nsig = opts.psf_nsig; kappa2 = opts.psf_kappa2
- snrtop = opts.psf_snrtop; snrbot = opts.psf_snrbot; snrcutstack = opts.psf_snrcutstack
- gencode = opts.psf_gencode; primarygen = opts.psf_primarygen; itess_method = opts.psf_itess_method
- tess_sc = opts.psf_tess_sc; tess_fuzzy= opts.psf_tess_fuzzy
- bright_snr_cut = opts.psf_high_snr
- s_only = opts.psf_stype_only
- if opts.psf_snrcut < 5.0:
- mylogger.userinfo(mylog, "Value of psf_snrcut too low; increasing to 5")
- snrcut = 5.0
- else:
- snrcut = opts.psf_snrcut
- img.psf_snrcut = snrcut
- if opts.psf_high_snr is not None:
- if opts.psf_high_snr < 10.0:
- mylogger.userinfo(mylog, "Value of psf_high_snr too low; increasing to 10")
- high_snrcut = 10.0
- else:
- high_snrcut = opts.psf_high_snr
- else:
- high_snrcut = opts.psf_high_snr
- img.psf_high_snr = high_snrcut
-
- wtfns=['unity', 'roundness', 'log10', 'sqrtlog10']
- if 0 <= itess_method < 4: tess_method=wtfns[itess_method]
- else: tess_method='unity'
-
- ### now put all relevant gaussian parameters into a list
- ngaus = img.ngaus
- nsrc = img.nsrc
- num = N.zeros(nsrc, dtype=N.int32)
- peak = N.zeros(nsrc)
- xc = N.zeros(nsrc)
- yc = N.zeros(nsrc)
- bmaj = N.zeros(nsrc)
- bmin = N.zeros(nsrc)
- bpa = N.zeros(nsrc)
- code = N.array(['']*nsrc);
- rms = N.zeros(nsrc)
- src_id_list = []
- for i, src in enumerate(img.sources):
- src_max = 0.0
- for gmax in src.gaussians:
- # Take only brightest Gaussian per source
- if gmax.peak_flux > src_max:
- src_max = gmax.peak_flux
- g = gmax
- num[i] = i
- peak[i] = g.peak_flux
- xc[i] = g.centre_pix[0]
- yc[i] = g.centre_pix[1]
- bmaj[i] = g.size_pix[0]
- bmin[i] = g.size_pix[1]
- bpa[i] = g.size_pix[2]
- code[i] = img.sources[g.source_id].code
- rms[i] = img.islands[g.island_id].rms
- gauls = (num, peak, xc, yc, bmaj, bmin, bpa, code, rms)
- tr_gauls = self.trans_gaul(gauls)
-
- # takes gaussians with code=S and snr > snrcut.
- if s_only:
- tr = [n for n in tr_gauls if n[1]/n[8]>snrcut and n[7] == 'S']
- else:
- tr = [n for n in tr_gauls if n[1]/n[8]>snrcut]
- g_gauls = self.trans_gaul(tr)
-
- # computes statistics of fitted sizes. Same as psfvary_fullstat.f in fBDSM.
- bmaj_a, bmaj_r, bmaj_ca, bmaj_cr, ni = _cbdsm.bstat(bmaj, None, nsig)
- bmin_a, bmin_r, bmin_ca, bmin_cr, ni = _cbdsm.bstat(bmin, None, nsig)
- bpa_a, bpa_r, bpa_ca, bpa_cr, ni = _cbdsm.bstat(bpa, None, nsig)
-
- # get subset of sources deemed to be unresolved. Same as size_ksclip_wenss.f in fBDSM.
- flag_unresolved = self.get_unresolved(g_gauls, img.beam, nsig, kappa2, over, img.psf_high_snr, plot)
- if len(flag_unresolved) == 0:
- mylog.warning('Insufficient number of sources to determine PSF variation.\nTry changing the PSF options or specify a (constant) PSF with the "psf_fwhm" option')
- return
-
- # see how much the SNR-weighted sizes of unresolved sources differ from the synthesized beam.
- wtsize_beam_snr = self.av_psf(g_gauls, img.beam, flag_unresolved)
-
- # filter out resolved sources
- tr_gaul = self.trans_gaul(g_gauls)
- tr = [n for i, n in enumerate(tr_gaul) if flag_unresolved[i]]
- g_gauls = self.trans_gaul(tr)
- mylogger.userinfo(mylog, 'Number of unresolved sources', str(len(g_gauls[0])))
-
- # get a list of voronoi generators. vorogenS has values (and not None) if generators='field'.
- vorogenP, vorogenS = self.get_voronoi_generators(g_gauls, generators, gencode, snrcut, snrtop, snrbot, snrcutstack)
- mylogger.userinfo(mylog, 'Number of generators for PSF variation', str(len(vorogenP[0])))
- if len(vorogenP[0]) < 3:
- mylog.warning('Insufficient number of generators')
- return
-
- mylogger.userinfo(mylog, 'Tesselating image')
- # group generators into tiles
- tile_prop = self.edit_vorogenlist(vorogenP, frac=0.9)
-
- # tesselate the image
- volrank, vorowts = self.tesselate(vorogenP, vorogenS, tile_prop, tess_method, tess_sc, tess_fuzzy, \
- generators, gencode, image.shape)
- if opts.output_all:
- func.write_image_to_file(img.use_io, img.imagename + '.volrank.fits', volrank, img, dir)
-
- tile_list, tile_coord, tile_snr = tile_prop
- ntile = len(tile_list)
- bar = statusbar.StatusBar('Determining PSF variation ............... : ', 0, ntile)
- mylogger.userinfo(mylog, 'Number of tiles for PSF variation', str(ntile))
-
- # For each tile, calculate the weighted averaged psf image. Also for all the sources in the image.
- cdelt = list(img.wcs_obj.acdelt[0:2])
- factor=3.
- psfimages, psfcoords, totpsfimage, psfratio, psfratio_aper = self.psf_in_tile(image, img.beam, g_gauls, \
- cdelt, factor, snrcutstack, volrank, tile_prop, plot, img)
- npsf = len(psfimages)
-
- if opts.psf_use_shap:
- if opts.psf_fwhm is None:
- # use totpsfimage to get beta, centre and nmax for shapelet decomposition. Use nmax=5 or 6
- mask=N.zeros(totpsfimage.shape, dtype=bool)
- (m1, m2, m3)=func.moment(totpsfimage, mask)
- betainit=sqrt(m3[0]*m3[1])*2.0 * 1.4
- tshape = totpsfimage.shape
- cen = N.array(N.unravel_index(N.argmax(totpsfimage), tshape))+[1,1]
- cen = tuple(cen)
- nmax = 12
- basis = 'cartesian'
- betarange = [0.5,sqrt(betainit*max(tshape))]
- beta, error = sh.shape_varybeta(totpsfimage, mask, basis, betainit, cen, nmax, betarange, plot)
- if error == 1: print ' Unable to find minimum in beta'
-
- # decompose all the psf images using the beta from above
- nmax=12; psf_cf=[]
- for i in range(npsf):
- psfim = psfimages[i]
- cf = sh.decompose_shapelets(psfim, mask, basis, beta, cen, nmax, mode='')
- psf_cf.append(cf)
- if img.opts.quiet == False:
- bar.increment()
- bar.stop()
-
- # transpose the psf image list
- xt, yt = N.transpose(tile_coord)
- tr_psf_cf = N.transpose(N.array(psf_cf))
-
- # interpolate the coefficients across the image. Ok, interpolate in scipy for
- # irregular grids is crap. doesnt even pass through some of the points.
- # for now, fit polynomial.
- compress = 100.0
- x, y = N.transpose(psfcoords)
- if len(x) < 3:
- mylog.warning('Insufficient number of tiles to do interpolation of PSF variation')
- return
-
- psf_coeff_interp, xgrid, ygrid = self.interp_shapcoefs(nmax, tr_psf_cf, psfcoords, image.shape, \
- compress, plot)
-
- psfshape = psfimages[0].shape
- skip = 5
- aa = self.create_psf_grid(psf_coeff_interp, image.shape, xgrid, ygrid, skip, nmax, psfshape, \
- basis, beta, cen, totpsfimage, plot)
- img.psf_images = aa
- else:
- if opts.psf_fwhm is None:
- if ntile < 4:
- mylog.warning('Insufficient number of tiles to do interpolation of PSF variation')
- return
- else:
- # Fit stacked PSFs with Gaussians and measure aperture fluxes
- bm_pix = N.array([img.pixel_beam()[0]*fwsig, img.pixel_beam()[1]*fwsig, img.pixel_beam()[2]])
- psf_maj = N.zeros(npsf)
- psf_min = N.zeros(npsf)
- psf_pa = N.zeros(npsf)
- if img.opts.quiet == False:
- bar.start()
- for i in range(ntile):
- psfim = psfimages[i]
- mask = N.zeros(psfim.shape, dtype=bool)
- x_ax, y_ax = N.indices(psfim.shape)
- maxv = N.max(psfim)
- p_ini = [maxv, (psfim.shape[0]-1)/2.0*1.1, (psfim.shape[1]-1)/2.0*1.1, bm_pix[0]/fwsig*1.3,
- bm_pix[1]/fwsig*1.1, bm_pix[2]*2]
- para, ierr = func.fit_gaus2d(psfim, p_ini, x_ax, y_ax, mask)
- ### first extent is major
- if para[3] < para[4]:
- para[3:5] = para[4:2:-1]
- para[5] += 90
- ### clip position angle
- para[5] = divmod(para[5], 180)[1]
-
- psf_maj[i] = para[3]
- psf_min[i] = para[4]
- posang = para[5]
- while posang >= 180.0:
- posang -= 180.0
- psf_pa[i] = posang
-
- if img.opts.quiet == False:
- bar.increment()
- bar.stop()
-
- # Interpolate Gaussian parameters
- if img.aperture is None:
- psf_maps = [psf_maj, psf_min, psf_pa, psfratio]
- else:
- psf_maps = [psf_maj, psf_min, psf_pa, psfratio, psfratio_aper]
- nimgs = len(psf_maps)
- bar = statusbar.StatusBar('Interpolating PSF images ................ : ', 0, nimgs)
- if img.opts.quiet == False:
- bar.start()
- map_list = mp.parallel_map(func.eval_func_tuple,
- itertools.izip(itertools.repeat(self.interp_prop),
- psf_maps, itertools.repeat(psfcoords),
- itertools.repeat(image.shape)), numcores=opts.ncores,
- bar=bar)
- if img.aperture is None:
- psf_maj_int, psf_min_int, psf_pa_int, psf_ratio_int = map_list
- else:
- psf_maj_int, psf_min_int, psf_pa_int, psf_ratio_int, psf_ratio_aper_int = map_list
-
- # Smooth if desired
- if img.opts.psf_smooth is not None:
- sm_scale = img.opts.psf_smooth / img.pix2beam([1.0, 1.0, 0.0])[0] / 3600.0 # pixels
- if img.opts.aperture is None:
- psf_maps = [psf_maj_int, psf_min_int, psf_pa_int, psf_ratio_int]
- else:
- psf_maps = [psf_maj_int, psf_min_int, psf_pa_int, psf_ratio_int, psf_ratio_aper_int]
- nimgs = len(psf_maps)
- bar = statusbar.StatusBar('Smoothing PSF images .................... : ', 0, nimgs)
- if img.opts.quiet == False:
- bar.start()
- map_list = mp.parallel_map(func.eval_func_tuple,
- itertools.izip(itertools.repeat(self.blur_image),
- psf_maps, itertools.repeat(sm_scale)), numcores=opts.ncores,
- bar=bar)
- if img.aperture is None:
- psf_maj_int, psf_min_int, psf_pa_int, psf_ratio_int = map_list
- else:
- psf_maj_int, psf_min_int, psf_pa_int, psf_ratio_int, psf_ratio_aper_int = map_list
-
- # Make sure all smoothed, interpolated images are ndarrays
- psf_maj_int = N.array(psf_maj_int)
- psf_min_int = N.array(psf_min_int)
- psf_pa_int = N.array(psf_pa_int)
- psf_ratio_int = N.array(psf_ratio_int)
- if img.aperture is None:
- psf_ratio_aper_int = N.zeros(psf_maj_int.shape, dtype=N.float32)
- else:
- psf_ratio_aper_int = N.array(psf_ratio_aper_int, dtype=N.float32)
-
- # Blank with NaNs if needed
- mask = img.mask_arr
- if isinstance(mask, N.ndarray):
- pix_masked = N.where(mask == True)
- psf_maj_int[pix_masked] = N.nan
- psf_min_int[pix_masked] = N.nan
- psf_pa_int[pix_masked] = N.nan
- psf_ratio_int[pix_masked] = N.nan
- psf_ratio_aper_int[pix_masked] = N.nan
-
- # Store interpolated images. The major and minor axis images are
- # the sigma in units of arcsec, the PA image in units of degrees east of
- # north, the ratio images in units of 1/beam.
- img.psf_vary_maj_arr = psf_maj_int * img.pix2beam([1.0, 1.0, 0.0])[0] * 3600.0 # sigma in arcsec
- img.psf_vary_min_arr = psf_min_int * img.pix2beam([1.0, 1.0, 0.0])[0] * 3600.0 # sigma in arcsec
- img.psf_vary_pa_arr = psf_pa_int
- img.psf_vary_ratio_arr = psf_ratio_int # in 1/beam
- img.psf_vary_ratio_aper_arr = psf_ratio_aper_int # in 1/beam
-
- if opts.output_all:
- func.write_image_to_file(img.use_io, img.imagename + '.psf_vary_maj.fits', img.psf_vary_maj_arr*fwsig, img, dir)
- func.write_image_to_file(img.use_io, img.imagename + '.psf_vary_min.fits', img.psf_vary_min_arr*fwsig, img, dir)
- func.write_image_to_file(img.use_io, img.imagename + '.psf_vary_pa.fits', img.psf_vary_pa_arr, img, dir)
- func.write_image_to_file(img.use_io, img.imagename + '.psf_vary_ratio.fits', img.psf_vary_ratio_arr, img, dir)
- func.write_image_to_file(img.use_io, img.imagename + '.psf_vary_ratio_aper.fits', img.psf_vary_ratio_aper_arr, img, dir)
-
- # Loop through source and Gaussian lists and deconvolve the sizes using appropriate beam
- bar2 = statusbar.StatusBar('Correcting deconvolved source sizes ..... : ', 0, img.nsrc)
- if img.opts.quiet == False:
- bar2.start()
- for src in img.sources:
- src_pos = img.sky2pix(src.posn_sky_centroid)
- src_pos_int = (int(src_pos[0]), int(src_pos[1]))
- gaus_c = img.gaus2pix(src.size_sky, src.posn_sky_centroid)
- if opts.psf_fwhm is None:
- gaus_bm = [psf_maj_int[src_pos_int]*fwsig, psf_min_int[src_pos_int]*fwsig, psf_pa_int[src_pos_int]]
- else:
- # Use user-specified constant PSF instead
- gaus_bm = img.beam2pix(opts.psf_fwhm)
- gaus_dc, err = func.deconv2(gaus_bm, gaus_c)
- src.deconv_size_sky = img.pix2gaus(gaus_dc, src_pos)
- src.deconv_size_skyE = [0.0, 0.0, 0.0]
- for g in src.gaussians:
- gaus_c = img.gaus2pix(g.size_sky, src.posn_sky_centroid)
- gaus_dc, err = func.deconv2(gaus_bm, gaus_c)
- g.deconv_size_sky = img.pix2gaus(gaus_dc, g.centre_pix)
- g.deconv_size_skyE = [0.0, 0.0, 0.0]
- if img.opts.quiet == False:
- bar2.spin()
- if img.opts.quiet == False:
- bar2.increment()
- bar2.stop()
- img.completed_Ops.append('psf_vary')
-
-##################################################################################################
-
- def trans_gaul(self, q):
- " transposes a tuple of .gaul values "
- y=[]
- for i in range(len(q[0])):
- elem=[]
- for j in range(len(q)):
- elem.append(q[j][i])
- y.append(elem)
- return y
-
-##################################################################################################
-
- def bindata(self, over, num): #ptpbin,nbin,ptplastbin, same as get_bins in fBDSM.
-
- if num <= 100: ptpbin=num/5
- if num > 100: ptpbin=num/10
- if num > 1000: ptpbin=num/20
- if ptpbin % 2 == 1: ptpbin=ptpbin+1
- if num < 10: ptpbin=num
- ptpbin = float(ptpbin) # cast to float to avoid integer division errors
- nbin=int((num-ptpbin)/(ptpbin/over)+1)
- ptplastbin=int((num-1)-(nbin-1)*ptpbin/over)
- nbin=nbin+1
-
- return ptpbin, nbin, ptplastbin
-
-##################################################################################################
- def bin_and_stats_ny(self, x,y,over,ptpbin,nbin,ptplastbin,nsig):
- import math
-
- n1=N.array(range(nbin))+1 # bin number
- n2=N.array([ptpbin]*nbin); n2[nbin-2]=ptplastbin; n2[nbin-1]=ptpbin/over
- n3=N.array([ptpbin]*nbin, dtype=float); n3[nbin-1]=float(over)*(len(x)-ptpbin/2)/(nbin-1)
- xval=N.zeros(nbin)
- meany=N.zeros(nbin); stdy=N.zeros(nbin); mediany=N.zeros(nbin)
- for i in range(nbin):
- lb=round(1+(n1[i]-1)*n3[i]/over+(1-1))-1 # -1 for python indexing
- ub=round(1+(n1[i]-1)*n3[i]/over+(n2[i]-1))-1 # -1 for python indexing
- x1=x[lb:ub+1]; y1=y[lb:ub+1]
-
- # do calcmedianclip2vec.f for code=YYN
- if len(x1) > 0 and len(y1) > 0:
- nout=100; niter=0
- while nout>0 and niter<6:
- med1=N.median(y1[:])
- med2=10.**(N.median(N.log10(x1[:])))
- medstd=0 # calcmedianstd.f
- for j in y1: medstd += (j-med1)*(j-med1)
- medstd=math.sqrt(medstd/len(y1)) #
- av1=N.mean(y1); std1=func.std(y1)
- av2=N.mean(x1); std2=func.std(x1)
- # get_medianclip_vec2
- z=N.transpose([x1, y1])
- z1=N.transpose([n for n in z if abs(n[1]-med1)<=nsig*medstd])
- nout=len(x1)-len(z1[0])
- x1=z1[0]; y1=z1[1];
- niter+=1
- xval[i]=med2;
- meany[i]=av1; stdy[i]=std1; mediany[i]=med1
-
- if stdy[nbin-1]/mediany[nbin-1] > stdy[nbin-2]/mediany[nbin-2]:
- stdy[nbin-1]=stdy[nbin-2]/mediany[nbin-2]*mediany[nbin-1]
- return xval, meany, stdy, mediany
-
-##################################################################################################
- def LM_fit(self, x, y, err, funct, order=0):
- if funct == func.poly:
- p0=N.array([y[N.argmax(x)]] + [0]*order)
- if funct == func.wenss_fit:
- p0=N.array([y[N.argmax(x)]] + [1.])
- res=lambda p, x, y, err: (y-funct(p, x))/err
- (p, flag)=leastsq(res, p0, args=(x, y, err))
- return p
-
-##################################################################################################
-
- def fit_bins_func(self, x,y,over,ptpbin,nbin,ptplastbin,nsig): # sub_size_ksclip
- import math
-
- (xval,meany,stdy,medy)=self.bin_and_stats_ny(x,y,over,ptpbin,nbin,ptplastbin,nsig)
- yfit=stdy/medy
- err=N.array([1.]*nbin)
- if ptplastbin > 0:
- err[nbin-2]=err[0]*math.sqrt(1.0*ptpbin/ptplastbin)
- err[nbin-1]=err[0]*math.sqrt(1.0*ptpbin*over/ptplastbin)
-
- i=0
- while i<nbin-4 and (N.all(N.sort(yfit[i:i+4])[::-1] == yfit[i:i+4]) == False):
- i+=1
- if i==nbin-4: sind=0
- else: sind=i-1
- if sind < 1:
- sind = 0
- if sind > 0.25*nbin:
- sind=int(round(0.25*nbin))-1
-
- s_c=self.LM_fit(xval[sind:],yfit[sind:],err[sind:], func.wenss_fit)
-
- err[:]=1.
- s_cm=self.LM_fit(N.log10(xval),medy,err,func.poly, order=1)
- if len(xval) >= 3:
- s_dm=self.LM_fit(N.log10(xval),medy,err,func.poly, order=2)
- else:
- s_dm = (N.array([s_cm[0], s_cm[1], 0.0]), 0)
-
- if ptpbin<75: s_dm=N.append(s_cm[:], [0.])
- return s_c, s_dm
-
-##################################################################################################
- def get_unresolved(self, g_gauls, beam, nsig, kappa2, over, bright_snr_cut=20.0, plot=False):
- """"Gets subset of unresolved sources
-
- Also flags as unresolved all sources with SNRs above
- bright_cut_snr, since fitting below is unreliable for bright
- sources.
- """
-
- num=len(g_gauls[0])
- if num < 10:
- # Too few sources to do fitting
- return []
- b1=N.asarray(g_gauls[4])/(beam[0]*3600.)
- b2=N.asarray(g_gauls[5])/(beam[1]*3600.)
- s1=N.asarray(g_gauls[1])/N.array(g_gauls[8])
- snr=N.array(s1)
- index=snr.argsort()
- snr=snr[index]
- nmaj=N.array(b1)[index]
- nmin=N.array(b2)[index]
-
-# if plot: pl.figure()
- f_sclip=N.zeros((2,num), dtype=bool)
- for idx, nbeam in enumerate([nmaj, nmin]):
- xarr=N.copy(snr)
- yarr=N.copy(nbeam)
- niter=0; nout=num; noutold=nout*2
- while niter<10 and nout >0.75*num:
- (ptpbin, nbin, ptplastbin)=self.bindata(over,nout) # get_bins in fBDSM
- (s_c,s_dm) = self.fit_bins_func(xarr,yarr,over,ptpbin,nbin,ptplastbin,nsig) # size_ksclip_wenss in fBDSM
- noutold = len(xarr)
- z = N.transpose([xarr, yarr, s_dm[0]+s_dm[1]*N.log10(xarr)+s_dm[2]*(N.log10(xarr)**2.), \
- N.sqrt(s_c[0]*s_c[0]+s_c[1]*s_c[1]/(xarr*xarr)) ])
- z1 = N.transpose([n for n in z if abs(n[1]-n[2])/(n[2]*n[3])<kappa2]) # sub_size_wenss_getnum in fBDSM
- if len(z1) == 0:
- break
- nout = len(z1[0])
- niter += 1
- xarr = z1[0]; yarr = z1[1]; # end of sub_size_wenss_getnum
- if noutold == nout: break
-
- # flag in the 'unresolved' sources. returns flag array, True ==> unresolved
- logsnr=N.log10(snr)
- dumr = N.sqrt(s_c[0]*s_c[0]+s_c[1]*s_c[1]/(snr*snr))
- med = s_dm[0]+s_dm[1]*logsnr+s_dm[2]*(logsnr*logsnr)
- f_sclip[idx] = N.abs((nbeam-med)/(med*dumr)) < N.array([kappa2]*num)
- f_s = f_sclip[0]*f_sclip[1]
-
- # Add bright sources
- if bright_snr_cut is not None:
- if bright_snr_cut < 20.0:
- bright_snr_cut = 20.0
- bright_srcs = N.where(snr >= bright_snr_cut)
- if len(bright_srcs[0]) > 0:
- f_s[bright_srcs] = True
-
- # now make plots
-# if plot:
-# bb=[b1, b2]
-# pl.subplot(211+idx)
-# pl.semilogx(s1, bb[idx], 'og')
-# f0=f_sclip[idx][index.argsort()]
-# sf=[n for i, n in enumerate(s1) if f0[i]]
-# b1f=[n for i, n in enumerate(bb[idx]) if f0[i]]
-# pl.semilogx(sf, b1f, 'or')
-# pl.semilogx(snr,med,'-')
-# pl.semilogx(snr,med+med*dumr*(N.array([kappa2]*num)),'-')
-# pl.semilogx(snr,med-med*dumr*(N.array([kappa2]*num)),'-')
-# pl.title(' axis ' + str(idx))
-#
- return f_s[index.argsort()]
-
-##################################################################################################
- def av_psf(self, g_gauls, beam, flag):
- """ calculate how much the SNR-weighted sizes of unresolved sources differs from the
- synthesized beam. Same as av_psf.f in fBDSM."""
- from math import sqrt
-
- bmaj = N.asarray(g_gauls[4])
- bmin = N.asarray(g_gauls[5])
- bpa = N.asarray(g_gauls[6])
- wt = N.asarray(g_gauls[1])/N.asarray(g_gauls[8])
- flagwt = wt*flag
- sumwt = N.sum(flagwt)
- w1 = N.sum(flagwt*flagwt)
- wtavbm = N.array([N.sum(bmaj*flagwt), N.sum(bmin*flagwt), N.sum(bpa*flagwt)])/sumwt
- dumrar = N.array([N.sum(bmaj*bmaj*flagwt), N.sum(bmin*bmin*flagwt), N.sum(bpa*bpa*flagwt)])
- dd = sumwt*sumwt-w1
- wtstdbm = N.sqrt((dumrar - wtavbm*wtavbm*sumwt)*sumwt/dd)
-
- avpa = N.sum(bpa*flagwt-180.0*flagwt*N.array(bpa >= 90))/sumwt
- stdpa = N.sum(bpa*flagwt+(180.0*180.0-360.0*bpa)*flagwt*N.array(bpa >= 90))
- stdpa = sqrt(abs((stdpa-avpa*avpa*sumwt)*sumwt/dd))
- if stdpa < wtstdbm[2]:
- wtstdbm[2] = stdpa
- wtavbm[2] = avpa
-
- return (wtavbm - N.array([beam[0]*3600.0, beam[1]*3600.0, beam[2]]))/wtstdbm
-
-##################################################################################################
- def get_voronoi_generators(self, g_gauls, generators, gencode, snrcut, snrtop, snrbot, snrcutstack):
- """This gets the list of all voronoi generators. It is either the centres of the brightest
- sources, or is imported from metadata (in future)."""
- from math import sqrt
-
- num=len(g_gauls[0])
- snr=N.asarray(g_gauls[1])/N.asarray(g_gauls[8])
-
- index=snr.argsort()
- snr_incr = snr[index]
- snr = snr_incr[::-1]
- x = N.asarray(g_gauls[2])[index]
- y = N.asarray(g_gauls[3])[index]
-
- cutoff = 0
- if generators == 'calibrators' or generators == 'field':
- if gencode != 'file':
- gencode = 'list'
- if gencode == 'list':
- cutoff = int(round(num*(snrtop)))
- if cutoff > len(snr):
- cutoff = len(snr)
- # Make sure we don't fall below snrcutstack (SNR cut for stacking of PSFs), since
- # it makes no sense to make tiles with generators that fall below this cut.
- if snr[cutoff-1] < snrcutstack:
- cutoff = num - snr_incr.searchsorted(snrcutstack)
-
- if generators == 'calibrators':
- if gencode == 'file':
- raise NotImplementedError, "gencode=file not yet implemented."
-
- x1 = x.tolist()
- y1 = y.tolist()
- x1.reverse()
- y1.reverse()
- snr1 = snr.tolist()
- vorogenP = N.asarray([x1[0:cutoff], y1[0:cutoff], snr1[0:cutoff]])
-
- vorogenS = None
-
- return vorogenP, vorogenS
-
-##################################################################################################
- def edit_vorogenlist(self, vorogenP, frac):
- """ Edit primary voronoi generator list. Each tile has a tile centre and can
- have more than one generator to be averaged. tile_list is a list of arrays, indexed
- by the tile number and each array is an array of numbers in the ngen list which are
- the generators in that tile. xtile, ytile and snrtile are arrays of length number_of_tiles
- and have x,y,snr of each tile. Group together generators
- if closer than a fraction of dist to third closest."""
-
- xgen, ygen, snrgen = vorogenP
- flag = N.zeros(len(xgen))
- coord=N.array([xgen,ygen]).transpose()
- tile_list = []
- tile_coord = []; tile_snr = []
- for i in range(len(xgen)):
- dist = N.array(map(lambda t: func.dist_2pt(coord[i], t), coord))
- indi = N.argsort(dist)
- sortdist = dist[indi]
- if sortdist[1] < frac * sortdist[2]: # first is the element itself
- if flag[indi[1]] + flag[i] == 0: # not already deleted from other pair
- tile_list.append([i, indi[1]])
- tile_coord.append((coord[i]*snrgen[i]+coord[indi[1]]*snrgen[indi[1]])/(snrgen[i]+snrgen[indi[1]]))
- tile_snr.append(snrgen[i]+snrgen[indi[1]])
- flag[i] = 1
- flag[indi[1]] = 1
- else:
- if len(dist) > 3:
- if sortdist[1]+sortdist[2] < 2.0*frac*sortdist[3]: # for 3 close-by sources
- in1=indi[1]
- in2=indi[2]
- if flag[in1]+flag[in2]+flag[i] == 0: # not already deleted from others
- tile_list.append([i, in1, in2])
- tile_coord.append((coord[i]*snrgen[i]+coord[in1]*snrgen[in1]+coord[in2]*snrgen[in2]) \
- /(snrgen[i]+snrgen[in1]+snrgen[in2]))
- tile_snr.append(snrgen[i]+snrgen[in1]+snrgen[in2])
- flag[i] = 1
- flag[in1] = 1
- flag[in2] = 1
- else:
- tile_list.append([i])
- tile_coord.append(coord[i])
- tile_snr.append(snrgen[i])
-
- # Assign any leftover generators
- for i in range(len(xgen)):
- if flag[i] == 0:
- tile_list.append([i])
- tile_coord.append(coord[i])
- tile_snr.append(snrgen[i])
-
- return tile_list, tile_coord, tile_snr
-
-##################################################################################################
- def tess_simple(self, vorogenP, wts, tess_sc, tess_fuzzy, shape):
- """ Simple tesselation """
-
- xgen, ygen, snrgen = vorogenP
- volrank = _pytess.pytess_simple(shape[0], shape[1], xgen, ygen, snrgen, \
- wts, tess_fuzzy, tess_sc)
-
- return volrank
-
-##################################################################################################
- def tess_roundness(self, vorogenP, tess_sc, tess_fuzzy, shape):
- """ Tesselation, modified to make the tiles more round. """
-
- xgen, ygen, snrgen = vorogenP
- volrank = _pytess.pytess_roundness(shape[0], shape[1], xgen, ygen, snrgen, \
- tess_fuzzy, tess_sc)
-
- return volrank
-
-##################################################################################################
- def pixintile(self, tilecoord, pixel, tess_method, wts, tess_sc, tess_fuzzy):
- """ This has routines to find out which tile a given pixel belongs to. """
-
- if tess_method == 'roundness':
- #tilenum = pytess_roundness(tilecoord, pixel, wts, tess_sc, tess_fuzzy)
- print " Not yet implemented !!!! "
- return 0
- else:
- xgen, ygen = tilecoord
- xgen = N.asarray(xgen)
- ygen = N.asarray(ygen)
- ngen = len(xgen)
- i,j = pixel
- dist = N.sqrt((i-xgen)*(i-xgen)+(j-ygen)*(j-ygen))/wts
- minind = dist.argmin()
-
- if tess_sc == 's':
- tilenum=minind
- else:
- print " Not yet implemented !!!! "
-
- return tilenum
-
-##################################################################################################
- def tesselate(self, vorogenP, vorogenS, tile_prop, tess_method, tess_sc, tess_fuzzy, generators, gencode, shape):
- """ Various ways of tesselating. If generators='calibrator', no need to tesselate, just get
- modified list based on very nearby sources. If generators='field' then tesselate. The image
- is tesselated based on tile_prop. """
-
- wtfn={'unity' : lambda x : N.ones(len(x)), \
- 'log10' : N.log10, \
- 'sqrtlog10' : lambda x : N.sqrt(N.log10(x)), \
- 'roundness' : N.array}
-
- tile_list, tile_coord, tile_snr = tile_prop
- xt = self.trans_gaul(tile_coord)[0]
- yt = self.trans_gaul(tile_coord)[1]
- vorogenT = xt, yt, tile_snr
-
- wt_fn = wtfn[tess_method]
- wts = wt_fn(tile_snr)
-
- if tess_method == 'roundness':
- volrank = self.tess_roundness(vorogenT, tess_sc, tess_fuzzy, shape)
- else:
- volrank = self.tess_simple(vorogenT, wts, tess_sc, tess_fuzzy, shape)
-
- return volrank, wts
-
-##################################################################################################
- def edit_tile(self, ltnum, g_gauls, flag_unresolved, snrcutstack, volrank, tile_prop, tess_sc, \
- tess_fuzzy, wts, tess_method, plot):
- """ Looks at tiles with no (or one) unresolved source inside it and deletes it and recomputes
- the tiling. For now, does not recompute since we wont use the rank for those pixels anyway."""
-
- if ltnum > 1: raise NotImplementedError, "NOT YET IMPLEMENTED FOR LTNUM>1"
-
- tile_list, tile_coord, tile_snr = tile_prop
- tr_gaul = self.trans_gaul(g_gauls)
- tr=[n for i, n in enumerate(tr_gaul) if flag_unresolved[i] and n[1]/n[8] >= snrcutstack]
- ntile = len(tile_list)
- ngenpertile=N.zeros(ntile)
- for itile in range(ntile):
- tile_gauls = [n for n in tr if volrank[int(round(n[2])),int(round(n[3]))]-1 \
- == itile]
- ngenpertile[itile]=len(tile_gauls)
- new_n = N.sum(ngenpertile >= ltnum)
-
- # prepare list of good tiles to pass to pixintile
- goodtiles = N.array(N.where(ngenpertile >= ltnum)[0])
- new_n = len(goodtiles)
- tile_coord_n = [n for i,n in enumerate(tile_coord) if i in goodtiles]
- wts_n = [n for i,n in enumerate(wts) if i in goodtiles]
-
- r2t = N.zeros(ntile, dtype=int)
- entry = -1
- for itile in range(ntile):
- if ngenpertile[itile] >= ltnum:
- r2t[itile] = itile
- else:
- pixel = tile_coord[itile]
- tilenum = self.pixintile(self.trans_gaul(tile_coord_n), pixel, tess_method, wts_n, tess_sc, tess_fuzzy)
- r2t[itile] = tilenum
- for itile in range(new_n):
- num = N.sum(r2t == itile)
- if num == 0:
- minarr = -999
- while minarr != itile:
- arr = N.where(r2t > itile)[0]
- minarr = r2t[arr].min()-1
- for i in arr: r2t[i]=r2t[i]-1
-
- n_tile_list = []; n_tile_coord = []; n_tile_snr = []
- for itile in range(new_n):
- ind = N.where(r2t == itile)[0]; ind1 = []
- for i in ind: ind1 = ind1 + tile_list[i]
- n_tile_list.append(ind1)
- snrs = N.array([tile_snr[i] for i in ind])
- coords = N.array([tile_coord[i] for i in ind])
- n_tile_snr.append(N.sum(snrs))
- n_tile_coord.append(N.sum([snrs[i]*coords[i] for i in range(len(snrs))], 0)/N.sum(snrs))
-
- ngenpertile=N.zeros(new_n)
- for itile in range(new_n):
- tile_gauls = [n for n in tr if r2t[volrank[int(round(n[2])),int(round(n[3]))]-1] \
- == itile]
- ngenpertile[itile]=len(tile_gauls)
- tile_prop = n_tile_list, n_tile_coord, n_tile_snr
-
- return ngenpertile, tile_prop, r2t
-
-##################################################################################################
- def stackpsf(self, image, beam, g_gauls, wts, cdelt, factor):
- """ Stacks all the images of sources in the gaussian list gauls from image, out to
- a factor times the beam size. Currently the mask is for the whole image but need to
- modify it for masks for each gaussian. These gaussians are supposed to be relatively
- isolated unresolved sources. Cut out an image a big bigger than facXbeam and imageshift
- to nearest half pixel and then add.
-
- Does not handle masks etc well at all. Masks for image for blanks, masks for \
- islands, etc."""
-
- gxcens_pix = g_gauls[2]
- gycens_pix = g_gauls[3]
- peak = g_gauls[1]
-
- psfimsize = int(round(max(beam[0], beam[1])/max(cdelt[0], cdelt[1]) * factor)) # fac X fwhm; fac ~ 2
- psfimage = N.zeros((psfimsize, psfimsize), dtype=N.float32)
- cs2=cutoutsize2 = int(round(psfimsize*(1. + 2./factor)/2.)) # size/2. factor => to avoid edge effects etc
- cc = cutoutcen_ind=[cs2, cs2]
- cpsf=cen_psf_ind = N.array([int(round(psfimsize))/2]*2)
- wt=0.
-
- num=len(gxcens_pix)
- for isrc in range(num): # MASK !!!!!!!!!!!
- wt += wts[isrc]
- gcp=N.array([gxcens_pix[isrc], gycens_pix[isrc]])
- gcen_ind=gcp-1
- rc=rcen_ind = N.asarray(N.round(gcen_ind), dtype=int)
- shift=cc-(gcen_ind-(rc-cs2))
- cutimage = image[rc[0]-cs2:rc[0]+cs2,rc[1]-cs2:rc[1]+cs2]
- if len(cutimage.shape) == 3: cutimage=cutimage[:,:,0]
- if 0 not in cutimage.shape:
- if sum(sum(N.isnan(cutimage))) == 0:
- im_shift = func.imageshift(cutimage, shift)
- im_shift = im_shift/peak[isrc]*wts[isrc]
- subim_shift = im_shift[cc[0]-cpsf[0]:cc[0]-cpsf[0]+psfimsize,cc[1]-cpsf[1]:cc[1]-cpsf[1]+psfimsize]
- if subim_shift.shape == psfimage.shape:
- # Check shapes, as they can differ if source is near edge of image.
- # If they do differ, don't use that source (may be distorted).
- psfimage += subim_shift
- psfimage = psfimage/wt
-
- return psfimage
-
-##################################################################################################
- def psf_in_tile(self, image, beam, g_gauls, cdelt, factor, snrcutstack, volrank, \
- tile_prop, plot, img):
- """ For each tile given by tile_prop, make a list of all gaussians in the constituent tesselations
- and pass it to stackpsf with a weight for each gaussian, to calculate the average psf per tile.
-
- Should define weights inside a tile to include closure errors """
- mylog = mylogger.logging.getLogger("PyBDSM."+img.log+"Psf_Vary")
-
- tile_list, tile_coord, tile_snr = tile_prop
- tr_gaul = self.trans_gaul(g_gauls)
- tr=[n for i, n in enumerate(tr_gaul)]# if n[1]/n[8] >= snrcutstack]
- ntile = len(tile_list)
- psfimages = []
- psfcoords = []
- psfratio = [] # ratio of peak flux to total flux
- psfratio_aper = [] # ratio of peak flux to aperture flux
- srcpertile = N.zeros(ntile)
- snrpertile = N.zeros(ntile)
- xt, yt = N.transpose(tile_coord)
-
- if plot:
- pl.figure(None)
- colours=['b','g','r','c','m','y','k']*(len(xt)/7+1)
- pl.axis([0.0, image.shape[0], 0.0, image.shape[1]])
- pl.title('Tesselated image with tile centres and unresolved sources')
- for i in range(ntile):
- pl.plot([xt[i]], [yt[i]], 'D'+colours[i])
- pl.text(xt[i], yt[i], str(i))
-
- for itile in range(ntile):
- tile_gauls = [n for n in tr if volrank[int(round(n[2])),int(round(n[3]))]-1 \
- == itile]
- t_gauls = self.trans_gaul(tile_gauls)
- srcpertile[itile] = len(tile_gauls)
- if plot:
- pl.plot(t_gauls[2], t_gauls[3], 'x'+'k', mew=1.3)#colours[itile])
- for i, ig in enumerate(t_gauls[2]):
- xx=[xt[itile], ig]
- yy=[yt[itile], t_gauls[3][i]]
- pl.plot(xx,yy,'-'+colours[itile])
- wts = N.asarray(t_gauls[1])/N.asarray(t_gauls[8]) # wt is SNR
- snrpertile[itile] = sum(wts)
- mylog.info('PSF tile #%i (center = %i, %i): %i unresolved sources, SNR = %.1f' %
- (itile, xt[itile], yt[itile], srcpertile[itile], snrpertile[itile]))
- a = self.stackpsf(image, beam, t_gauls, wts, cdelt, factor)
- psfimages.append(a)
- psfcoords.append([sum(N.asarray(t_gauls[2])*wts)/sum(wts), sum(N.asarray(t_gauls[3])*wts)/sum(wts)])
-
- # Find peak/total flux ratio for sources in tile. If an aperture is given,
- # use the aperture flux as well.
- # t_gauls[0] is source_id
- src_ratio = []
- src_wts = []
- src_ratio_aper = []
- src_wts_aper = []
- for gt in tile_gauls:
- src = img.sources[gt[0]]
- if img.aperture is not None:
- src_ratio_aper.append(src.peak_flux_max / src.aperture_flux)
- src_wts_aper.append(src.total_flux / src.aperture_fluxE)
- src_ratio.append(src.peak_flux_max / src.total_flux)
- src_wts.append(src.total_flux / src.total_fluxE)
- if img.aperture is not None:
- psfratio_aper.append(sum(N.asarray(src_ratio_aper)*src_wts_aper)/sum(src_wts_aper))
- else:
- psfratio_aper.append(0.0)
- psfratio.append(sum(N.asarray(src_ratio)*src_wts)/sum(src_wts))
-
- totpsfimage = psfimages[0]*snrpertile[0]
- for itile in range(1,ntile):
- totpsfimage += psfimages[itile]*snrpertile[itile]
- totpsfimage = totpsfimage/sum(snrpertile)
-
- if plot:
- pl.imshow(N.transpose(volrank), origin='lower', interpolation='nearest'); pl.colorbar()
-
- if plot:
- pl.figure(None)
- pl.clf()
- ax = pl.subplot(1,1,1)
- pax = ax.get_position()
- start = N.array((pax.xmin, pax.ymin))
- stop = N.array((pax.xmax, pax.ymax))
- plaxis = pl.axis([0, image.shape[0], 0, image.shape[1]])
- pl.title('Stacked psf for each tile')
- for itile in range(ntile):
- im=psfimages[itile]
- sz=0.07
- spt = int(round(snrpertile[itile]*10))/10.
- titl='n='+str(int(round(srcpertile[itile])))+'; SNR='+str(spt)
- posn=[psfcoords[itile][0], psfcoords[itile][1]]
- normposn=N.array(stop-start, dtype=float)/N.array(image.shape[0:2])*posn+start
- a=pl.axes([normposn[0]-sz/2., normposn[1]-sz/2., sz, sz])
- pl.contour(im,15)
- pl.title(titl, fontsize='small')
- pl.setp(a, xticks=[], yticks=[])
- pl.show()
-
- return psfimages, psfcoords, totpsfimage, psfratio, psfratio_aper
-
-
-##################################################################################################
- def interp_shapcoefs(self, nmax, tr_psf_cf, psfcoords, imshape, compress, plot):
- """Interpolate using natgrid.
-
- Check to see if variation is significant.
- """
- x, y = N.transpose(psfcoords)
- index = [(i,j) for i in range(nmax+1) for j in range(nmax+1-i)]
- xi=x
- yi=y
- xo=N.arange(0.0,round(imshape[0]), round(compress))
- yo=N.arange(0.0,round(imshape[1]), round(compress))
- rgrid=nat.Natgrid(xi,yi,xo,yo)
- p={}
- for coord in index:
- z = N.array(tr_psf_cf[coord]) # else natgrid cant deal with noncontiguous memory
- p[coord] = rgrid.rgrd(z)
-
-# if plot:
-# for i,coord in enumerate(index):
-# if i % 36 == 0:
-# pl.figure(None)
-# pl.clf()
-# title = 'Interpolated shapelet coefficients'
-# if i>0: title = title+' (cont)'
-# pl.suptitle(title)
-# pl.subplot(6,6,(i%36)+1)
-# pl.title(str(coord))
-# pl.plot(xi/compress, yi/compress, 'xk')
-# pl.imshow(p[coord], interpolation='nearest')
-# pl.colorbar()
-
- return p, xo, yo
-
-##################################################################################################
- def interp_prop(self, prop, psfcoords, imshape, compress=1):
- """Interpolate using natgrid.
-
- Should check to see if variation is significant.
- """
- x, y = N.transpose(psfcoords)
- xi=x
- yi=y
- xo=N.arange(0.0,round(imshape[0]), round(compress))
- yo=N.arange(0.0,round(imshape[1]), round(compress))
- rgrid=nat.Natgrid(xi,yi,xo,yo)
- prop_int = rgrid.rgrd(prop)
- return prop_int
-
-##################################################################################################
- def create_psf_grid(self, psf_coeff_interp, imshape, xgrid, ygrid, skip, nmax, psfshape, basis, beta,
- cen, totpsfimage, plot):
- """ Creates a image with the gridded interpolated psfs. xgrid and ygrid are 1d numpy arrays
- with the x and y coordinates of the grids. """
-
-# if plot:
-# plnum=N.zeros(2)
-# for i in range(2):
-# dum=pl.figure(None)
-# plnum[i]=dum.number
-# pl.clf()
-# if i == 0: pl.suptitle('Gridded psfs')
-# if i == 1: pl.suptitle('Gridded residual psfs')
-# ax = pl.subplot(1,1,1)
-# plaxis = pl.axis([0, imshape[0], 0, imshape[1]])
-# pax = ax.get_position()
-# start = N.array((pax.xmin, pax.ymin))
-# stop = N.array((pax.xmax, pax.ymax))
-# sz=0.07
- mask=N.zeros(psfshape, dtype=bool) # right now doesnt matter
- xg=xgrid[::skip+1]
- yg=ygrid[::skip+1]
- index = [(i,j) for i in range(0,len(xgrid),skip+1) for j in range(0,len(ygrid),skip+1)]
- xy = [(i,j) for i in xgrid[::skip+1] for j in ygrid[::skip+1]]
- blah=[]
- for i, coord in enumerate(index):
- maxpsfshape = [0, 0]
- for k in psf_coeff_interp:
- if k[0]+1 > maxpsfshape[0]:
- maxpsfshape[0] = k[0]+1
- if k[1]+1 > maxpsfshape[1]:
- maxpsfshape[1] = k[1]+1
- cf = N.zeros(maxpsfshape)
- for k in psf_coeff_interp:
- cf[k]=psf_coeff_interp[k][coord]
- cf = N.transpose(cf)
- psfgridim = sh.reconstruct_shapelets(psfshape, mask, basis, beta, cen, nmax, cf)
- blah.append(psfgridim)
-
-# if plot:
-# for j in range(2):
-# pl.figure(plnum[j])
-# posn = [xy[i][0], xy[i][1]]
-# normposn =N.array(stop-start, dtype=float)/N.array(imshape[0:2])*posn+start
-# a=pl.axes([normposn[0]-sz/2., normposn[1]-sz/2., sz, sz])
-# if j == 0: pl.contour(psfgridim,15)
-# if j == 1: pl.contour(psfgridim-totpsfimage,15)
-# pl.setp(a, xticks=[], yticks=[])
-# pl.colorbar()
-# if plot:
-# pl.figure(plnum[0])
-# pl.figure(plnum[1])
-#
- return blah
-
-##################################################################################################
- def blur_image(self, im, n, ny=None) :
- """ blurs the image by convolving with a gaussian kernel of typical
- size n. The optional keyword argument ny allows for a different
- size in the y direction.
- """
- from scipy.ndimage import gaussian_filter
-
- sx = n
- if ny is not None:
- sy = ny
- else:
- sy = n
- improc = gaussian_filter(im, [sy, sx])
- return improc
diff --git a/CEP/PyBDSM/src/python/pybdsm.py b/CEP/PyBDSM/src/python/pybdsm.py
deleted file mode 100644
index f5799faf8d2ccbeb8e9810b1948b8766bf648a64..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/python/pybdsm.py
+++ /dev/null
@@ -1,757 +0,0 @@
-"""Interactive PyBDSM shell.
-
-This module initializes the interactive PyBDSM shell, which is a customized
-IPython enviroment. It should be called from the terminal prompt using the
-"pybdsm" shell script or as "python pybdsm.py".
-"""
-import lofar.bdsm
-from lofar.bdsm.image import Image
-import pydoc
-import sys
-import inspect
-
-
-###############################################################################
-# Functions needed only in the custom IPython shell are defined here. Other
-# functions used by both the custom shell and normal Python or IPython
-# environments are defined in interface.py.
-#
-# Before starting the IPython shell, we need to define all the functions and
-# variables that we want in the namespace. Note that we adopt the convention
-# for this UI of using lines of 72 characters max for doc strings and the
-# start-up banner. However, the parameter list will fill the entire available
-# terminal width to consume as few vertical lines as possible.
-global _img
-_img = Image({'filename':''})
-_img._is_interactive_shell = True
-T = True
-F = False
-true = True
-false = False
-
-def inp(cur_cmd=None):
- """List inputs for current task.
-
- If a task is given as an argument, inp sets the current task
- to the given task. If no task is given, inp lists the parameters
- of the current task.
- """
- global _img
- success = _set_pars_from_prompt()
- if not success:
- return
- if cur_cmd is not None:
- if not hasattr(cur_cmd, 'arg_list'):
- print '\033[31;1mERROR\033[0m: not a valid task'
- return
- _set_current_cmd(cur_cmd)
- else:
- if not hasattr(_img, '_current_cmd'):
- print '\033[31;1mERROR\033[0m: no task is set'
- return
- lofar.bdsm.interface.list_pars(_img, opts_list=_img._current_cmd_arg_list,
- banner=_img._current_cmd_desc,
- use_groups=_img._current_cmd_use_groups)
-
-
-def go(cur_cmd=None):
- """Executes the current task.
-
- If a task is given as an argument, go executes the given task,
- even if it is not the current task. The current task is not
- changed in this case.
- """
- global _img
- success = _set_pars_from_prompt()
- if not success:
- return
- if cur_cmd is None:
- if not hasattr(_img, '_current_cmd'):
- print '\033[31;1mERROR\033[0m: no task is set'
- return
- cur_cmd = _img._current_cmd
- if not hasattr(cur_cmd, 'arg_list'):
- print '\033[31;1mERROR\033[0m: not a valid task'
- return
- cur_cmd()
-
-
-def default(cur_cmd=None):
- """Resets all parameters for a task to their default values.
-
- If a task name is given (e.g., "default show_fit"), the
- parameters for that task are reset. If no task name is
- given, the parameters of the current task are reset.
- """
- global _img
- if cur_cmd is None:
- if not hasattr(_img, '_current_cmd'):
- print '\033[31;1mERROR\033[0m: no task is set'
- return
- cur_cmd = _img._current_cmd
-
- if hasattr(cur_cmd, 'arg_list'):
- opts_list = cur_cmd.arg_list
- else:
- print '\033[31;1mERROR\033[0m: not a valid task'
- return
- _img.opts.set_default(opts_list)
- _replace_vals_in_namespace(opt_names=opts_list)
-
-
-def tget(filename=None):
- """Load processing parameters from a parameter save file.
-
- A file name may be given (e.g., "tget 'savefile.sav'"), in which case the
- parameters are loaded from the file specified. If no file name is given,
- the parameters are loaded from the file 'pybdsm.last' if it exists.
-
- Normally, the save file is created by the tput command (try "help tput"
- for more info).
-
- The save file is a "pickled" python dictionary which can be loaded into
- python and edited by hand. See the pickle module for more information.
- Below is an example of how to edit a save file by hand:
-
- BDSM [1]: import pickle
- BDSM [2]: with open('savefile.sav', 'r') as savefile:
- BDSM [3]: pars = pickle.load(savefile)
- BDSM [4]: pars['rms_box'] = (80, 20) --> change rms_box parameter
- BDSM [5]: with open('savefile.sav', 'w') as savefile:
- BDSM [6]: pickle.dump(pars, savefile) --> save changes
-
- """
- try:
- import cPickle as pickle
- except ImportError:
- import pickle
- import os
-
- global _img
-
- # Check whether user has given a task name as input (as done in casapy).
- # If so, reset filename to None.
- if hasattr(filename, 'arg_list'):
- filename = None
-
- if filename is None or filename == '':
- if os.path.isfile('pybdsm.last'):
- filename = 'pybdsm.last'
- else:
- print '\033[31;1mERROR\033[0m: No file name given and '\
- '"pybdsm.last" not found.\nPlease specify a file to load.'
- return
-
- if os.path.isfile(filename):
- try:
- pkl_file = open(filename, 'rb')
- pars = pickle.load(pkl_file)
- pkl_file.close()
- _img.opts.set_opts(pars)
- _replace_vals_in_namespace()
- print "--> Loaded parameters from file '" + filename + "'."
- except:
- print "\033[31;1mERROR\033[0m: Could not read file '" + \
- filename + "'."
- else:
- print "\033[31;1mERROR\033[0m: File '" + filename + "' not found."
-
-
-def tput(filename=None, quiet=False):
- """Save processing parameters to a file.
-
- A file name may be given (e.g., "tput 'savefile.sav'"), in which case the
- parameters are saved to the file specified. If no file name is given, the
- parameters are saved to the file 'pybdsm.last'. The saved parameters can
- be loaded using the tget command (try "help tget" for more info).
-
- The save file is a "pickled" python dictionary which can be loaded into
- python and edited by hand. See the pickle module for more information.
- Below is an example of how to edit a save file by hand:
-
- BDSM [1]: import pickle
- BDSM [2]: with open('savefile.sav', 'r') as savefile:
- BDSM [3]: pars = pickle.load(savefile)
- BDSM [4]: pars['rms_box'] = (80, 20) --> change rms_box parameter
- BDSM [5]: with open('savefile.sav', 'w') as savefile:
- BDSM [6]: pickle.dump(pars, savefile) --> save changes
-
- """
- try:
- import cPickle as pickle
- except ImportError:
- import pickle
-
- global _img
- success = _set_pars_from_prompt()
- if not success:
- return
- if filename is None or filename == '':
- filename = 'pybdsm.last'
-
- # convert opts to dictionary
- pars = _img.opts.to_dict()
- output = open(filename, 'wb')
- pickle.dump(pars, output)
- output.close()
- if not quiet:
- print "--> Saved parameters to file '" + filename + "'."
-
-
-def _set_pars_from_prompt():
- """Gets parameters and value and stores them in _img.
-
- To do this, we extract all the valid parameter names
- and values from the f_locals directory. Then, use
- set_pars() to set them all.
-
- Returns True if successful, False if not.
- """
- global _img
- f = sys._getframe(len(inspect.stack())-1)
- f_dict = f.f_locals
-
- # Check through all possible options and
- # build options dictionary
- opts = _img.opts.to_dict()
- user_entered_opts = {}
- for k, v in opts.iteritems():
- if k in f_dict:
- if f_dict[k] == '':
- # Set option to default value in _img and namespace
- _img.opts.set_default(k)
- f_dict[k] = _img.opts.__getattribute__(k)
- user_entered_opts.update({k: f_dict[k]})
-
- # Finally, set the options
- try:
- _img.opts.set_opts(user_entered_opts)
- return True
- except RuntimeError, err:
- # If an opt fails to set, replace its value in the namespace
- # with its current value in _img. Then print error so user knows.
- err_msg = str(err)
- err_msg_trim = err_msg.split('(')[0]
- indx1 = err_msg_trim.find('"') + 1
- indx2 = err_msg_trim.find('"', indx1)
- k = err_msg_trim[indx1:indx2]
- orig_opt_val = opts[k]
- f_dict[k] = orig_opt_val
- print '\033[31;1mERROR\033[0m: ' + err_msg_trim + \
- '\nResetting to previous value.'
- return False
-
-
-def _replace_vals_in_namespace(opt_names=None):
- """Replaces opt values in the namespace with the ones in _img.
-
- opt_names - list of option names to replace (can be string if only one)
- """
- global _img
- f = sys._getframe(len(inspect.stack())-1)
- f_dict = f.f_locals
- if opt_names is None:
- opt_names = _img.opts.get_names()
- if isinstance(opt_names, str):
- opt_names = [opt_names]
- for opt_name in opt_names:
- if opt_name in f_dict:
- f_dict[opt_name] = _img.opts.__getattribute__(opt_name)
-
-
-def _set_current_cmd(cmd):
- """Sets information about current command in img.
-
- This function is used to emulate a casapy interface.
-
- """
- global _img
- cmd_name = cmd.__name__
- doc = cmd.__doc__
- _img._current_cmd = cmd
- _img._current_cmd_name = cmd_name
- _img._current_cmd_desc = cmd_name.upper() + ': ' + doc.split('\n')[0]
- _img._current_cmd_arg_list = cmd.arg_list
- _img._current_cmd_use_groups = cmd.use_groups
-
-
-###############################################################################
-# Next, we define the tasks such that they may be called directly by
-# the user if so desired. These functions simply pass on the user-
-# specified arguments to the appropriate Image method. Here we also
-# define the detailed doc strings used by help, and, after each task
-# definition, we define its list of arguments and whether it should
-# use the opts 'group' attribute, both needed when inp is called. If
-# a new parameter is added to a task, it needs to be added to opts.py
-# and to the list of arguments for the task below (the "arg_list")
-# attribute.
-def process_image(**kwargs):
- """Find and measure sources in an image.
-
- There are many possible parameters and options for process_image. Use
- "inp process_image" to list them. To get more information about a
- parameter, use help. E.g.,
-
- > help 'rms_box'
-
- When process_image is executed, PyBDSM performs the following steps in
- order:
-
- 1. Reads in the image.
-
- 2. Calculates basic statistics of the image and stores them in the Image
- object. Calculates sensible values of processing parameters and stores
- them. First calculates mean and rms, with and without (3-sigma)
- clipping, min and max pixel and values, solid angle. Hereafter, rms
- indicates the 3-sigma clipped measure. Next, the number of beams per
- source is calculated (see help on algorithms for details), using a
- sensible estimate of boxsize and stepsize (which can be set using the
- rms_box parameter). Finally, the thresholds are set. They can either be
- hard-thresholded (by the user or set as 5-sigma for pixel threshold and
- 3-sigma for island boundaries internally) or can be calculated using the
- False Detection Rate (FDR) method using an user defined value for
- alpha. If the user does not specify whether hard thresholding or FDR
- should be applied, one or the other is chosen internally based on the
- ratio of expected false pixels and true pixels (the choice is written
- out in the log file).
-
- 3. Calculates rms image. 3-sigma clipped rms and mean are calculated
- inside boxes of size boxsize in steps of stepsize. Intermediate values
- are calculated using bilinear interpolation (it was seen that bicubic
- spline did not yield appreciably better results but is also
- available). Depending on the resulting statistics (see help on
- algorithms for details), we either adopt the rms image or a constant rms
- in the following analysis.
-
- 4. Identifies islands of contiguous emission. First all pixels greater
- than the pixel threshold are identified (and sorted by descending flux
- order). Next, starting from each of these pixels, all contiguous pixels
- (defined by 8-connectivity, i.e., the surrounding eight pixels) higher
- than the island boundary threshold are identified as belonging to one
- island, accounting properly for overlaps of islands.
-
- 5. Fit multiple gaussians and/or shapelets to each island. For each
- island, the subimages of emission and rms are cut out. The number of
- multiple gaussians to be fit can be determined by three different
- methods (see help on algorithms for details). With initial guesses
- corresponding to these peaks, gaussians are simultaneously fit to the
- island using the Levenberg-Marqhardt algorithm. Sensible criteria for bad
- solutions are defined. If multiple gaussians are fit and one of them is
- a bad solution then the number of gaussians is decreased by one and fit
- again, till all solutions in the island are good (or zero in number, in
- which case its flagged). After the final fit to the island, the
- deconvolved size is computed assuming the theoretical beam and the
- statistics in the source area and in the island are computed and
- stored. Errors on each of the fitted parameters are computed using the
- formulae in Condon (1997). Finally all good solutions are written into
- the gaussian catalog as an ascii and binary file. If shapelets are
- required, the program calculates optimal nmax, beta and the centre, and
- stores these and the shapelet coefficients in a file.
-
- """
- global _img
- success = _set_pars_from_prompt()
- if not success:
- return
- # Save current command, as it might be overwritten when process
- # is called by the user directly and is not the current command.
- cur_cmd = _img._current_cmd
-
- # Run process. Note that process automatically picks up options
- # from the Image object, so we don't need to get_task_kwargs as
- # we do for the other tasks.
- success = _img.process(**kwargs)
-
- # Now restore parameters and save to pybdsm.last
- if success:
- _set_current_cmd(cur_cmd)
- tput(quiet=True)
-
-task_list = _img.opts.get_names()
-process_image.arg_list = task_list
-process_image.use_groups = True
-
-
-def show_fit(**kwargs):
- """Show results of fit.
-
- Selected plots are displayed to give the user a quick overview of the
- results of the fit. The plots may be zoomed, saved to a file, etc. using
- the controls at the bottom of the plot window.
-
- In addition, the following commands are available:
- Press "i" ........ : Get integrated flux densities and mean rms
- values for the visible portion of the image
- Press "m" ........ : Change min and max scaling values
- Press "n" ........ : Show / hide island IDs
- Press "0" ........ : Reset scaling to default
- Press "c" ........ : Change source for SED plot
- Click Gaussian ... : Print Gaussian and source IDs (zoom_rect mode,
- toggled with the "zoom" button and indicated in
- the lower right corner, must be off)
- The SED plot will also show the chosen source.
-
- Parameters: ch0_image, rms_image, mean_image, ch0_islands,
- gresid_image, sresid_image, gmodel_image,
- smodel_image, source_seds, ch0_flagged, pi_image,
- psf_major, psf_minor, psf_pa, broadcast
-
- For more information about a parameter, use help. E.g.,
- > help 'ch0_image'
-
- """
- global _img
- success = _set_pars_from_prompt()
- if not success:
- return
- img_kwargs = _get_task_kwargs(show_fit)
- for k in kwargs:
- # If user enters an argument, use it instead of
- # that in _img
- img_kwargs[k] = kwargs[k]
- try:
- success = _img.show_fit(**img_kwargs)
- if success:
- tput(quiet=True)
- except KeyboardInterrupt:
- print "\n\033[31;1mAborted\033[0m"
-
-show_fit.arg_list = ['ch0_image', 'rms_image', 'mean_image', 'ch0_islands',
- 'gresid_image', 'sresid_image', 'gmodel_image',
- 'smodel_image', 'source_seds', 'ch0_flagged', 'pi_image',
- 'psf_major', 'psf_minor', 'psf_pa', 'broadcast']
-show_fit.use_groups = False
-
-
-def write_catalog(**kwargs):
- """Write the Gaussian, source, or shapelet list to a file.
-
- The lists can be written in a number of formats. The information
- included in the output file varies with the format used. Use
- "help 'format'" for more information.
-
- Parameters: outfile, format, srcroot, bbs_patches, incl_chan, clobber,
- catalog_type, incl_empty, correct_proj, bbs_patches_mask
-
- For more information about a parameter, use help. E.g.,
- > help 'bbs_patches'
-
- """
- global _img
- success = _set_pars_from_prompt()
- if not success:
- return
- img_kwargs = _get_task_kwargs(write_catalog)
- for k in kwargs:
- # If user enters an argument, use it instead of
- # that in _img
- img_kwargs[k] = kwargs[k]
- try:
- success = _img.write_catalog(**img_kwargs)
- if success:
- tput(quiet=True)
- except KeyboardInterrupt:
- print "\n\033[31;1mAborted\033[0m"
-
-write_catalog.arg_list = ['bbs_patches', 'format', 'outfile', 'srcroot',
- 'incl_chan', 'clobber', 'catalog_type', 'incl_empty',
- 'correct_proj', 'bbs_patches_mask']
-write_catalog.use_groups = False
-
-
-def export_image(**kwargs):
- """Write an image to disk.
-
- Parameters: outfile, img_type, img_format, mask_dilation, pad_image, clobber
-
- For more information about a parameter, use help. E.g.,
- > help 'img_type'
-
- """
- global _img
- success = _set_pars_from_prompt()
- if not success:
- return
- img_kwargs = _get_task_kwargs(export_image)
- for k in kwargs:
- # If user enters an argument, use it instead of
- # that in _img
- img_kwargs[k] = kwargs[k]
- try:
- success = _img.export_image(**img_kwargs)
- if success:
- tput(quiet=True)
- except KeyboardInterrupt:
- print "\n\033[31;1mAborted\033[0m"
-
-export_image.arg_list = ['outfile', 'img_type', 'img_format', 'mask_dilation',
- 'pad_image', 'clobber']
-export_image.use_groups = False
-
-
-def _get_task_kwargs(task):
- """Returns dictionary of keyword arguments from _img for the given task."""
- global _img
- arg_list = task.arg_list
- kwargs = {}
- for a in arg_list:
- kwargs.update({a: _img.opts.__getattribute__(a)})
- return kwargs
-
-
-###############################################################################
-# Customize the help system for PyBDSM. The user can type "help task" to get
-# help on a task (it prints the doc string) or "help 'opt'" to get help on
-# a option (it prints the doc string defined in opts.py).
-class bdsmDocHelper(pydoc.Helper):
- def help(self, request):
- global _img
- topbar = '_' * 72 + '\n' # 72-character divider
- if hasattr(request, '__name__'):
- pydoc.pager(topbar + 'Help on ' + pydoc.text.bold(request.__name__)
- + ':\n\n' + pydoc.getdoc(request))
- else:
- opts = _img.opts.__class__.__dict__
- try:
- opt = opts[request]
- desc_list = str(opt.doc()).split('\n')
- desc = '\n\n'.join(desc_list)
- default_val = opt._default
- if isinstance(default_val, str):
- valstr = "'" + default_val + "'"
- else:
- valstr = str(default_val)
- default_val_text = 'Default value: ' + valstr
- if opt.group() is not None and opt.group() != 'hidden':
- group_text = '\nBelongs to group: ' + opt.group()
- else:
- group_text = ''
- desc_text = lofar.bdsm.interface.wrap(desc, 72)
- desc_text = '\n'.join(desc_text)
- pydoc.pager(topbar + 'Help on the ' + pydoc.text.bold(request)
- + ' parameter:\n\n' + default_val_text
- + group_text
- + '\n\n' + desc_text)
- except(KeyError):
- print "Parameter '" + request + "' not recognized."
-pydoc.help = bdsmDocHelper(sys.stdin, sys.stdout)
-
-
-###############################################################################
-# Now run the IPython shell with this namespace and a customized autocompleter.
-# The custom autocompleter is below. It adds task, command, and option names and
-# a few common values to ipython's autocompleter. It also adds files in the
-# local directory when they might be needed (but only if the user has started
-# to enter a string -- this behavior is to help avoid entering filenames as
-# non-strings; this is also done for the help autocomplete).
-def _opts_completer(self, event):
- """ Returns a list of strings with possible completions."""
- import os
- import glob
- from lofar.bdsm.image import Image
- img = Image({'filename':''})
- opts = img.opts.get_names()
-
- # Split the command entered by user when TAB was pressed
- # and check for up to three components (from e.g. "par = val",
- # which gives cmd1 = "par", cmd2 = "=", and cmd3 = "val")
- cmd1 = (event.line).rsplit(None)[0]
- if len((event.line).rsplit(None)) > 1:
- cmd2 = (event.line).rsplit(None)[1]
- else:
- cmd2 = ''
- if len((event.line).rsplit(None)) > 2:
- cmd3 = (event.line).rsplit(None)[2]
- else:
- cmd3 = ''
-
- # First, check to see if user has entered a parameter name
- # and an equals sign. If so, check parameter type. If Enum
- # or Option, match only to the allowable values.
- # Allowable values are available from v._type.values if v is
- # type Enum (v has no attribute _type.values if not).
- if "=" in cmd1 or "=" in cmd2:
- par_vals = []
- if "=" in cmd1:
- cmd3 = cmd1.split('=')[1]
- cmd1 = cmd1.split('=')[0]
- if cmd1 in opts:
- from lofar.bdsm.tc import tcEnum, tcOption
- v = img.opts.__class__.__dict__[cmd1]
- partype = v._type
- if isinstance(partype, tcOption):
- par_vals = ['None']
- elif isinstance(partype, tcEnum):
- if ('"' in cmd2 or "'" in cmd2 or
- '"' in cmd3 or "'" in cmd3):
- par_vals = v._type.values
- if not isinstance(par_vals, list):
- par_vals = list(par_vals)
- if None in par_vals:
- # Remove None from list
- pindx = par_vals.index(None)
- par_vals.pop(pindx)
- else:
- if None in v._type.values:
- par_vals.append('None')
- if True in v._type.values:
- par_vals.append('True')
- if False in v._type.values:
- par_vals.append('False')
- elif v._default == True or v._default == False:
- par_vals = ['True', 'False']
- if cmd1 == 'filename' or cmd1 == 'outfile':
- if ('"' in cmd2 or "'" in cmd2 or
- '"' in cmd3 or "'" in cmd3):
- # Also add files in current directory
- found = [f.replace('\\','/') for f in glob.glob('*')]
- if len(found) > 0:
- for fnd in found:
- par_vals.append(fnd)
- return par_vals
- elif cmd1 == 'inp' or cmd1 == 'go':
- # Match task names only
- cmds = ['process_image', 'write_catalog', 'export_image', 'show_fit']
- return cmds
- elif cmd1 == 'cd' or cmd1 == 'tput' or cmd1 == 'tget' or '!' in cmd1:
- # Match to files in current directory (force use of ' or " with
- # tput and tget, as filename must be a string).
- files = []
- found = [f.replace('\\','/') for f in glob.glob('*')]
- if len(found) > 0:
- for fnd in found:
- files.append(fnd)
- if cmd1 == 'tput' or cmd1 == 'tget' and not ('"' in cmd2 or
- "'" in cmd2):
- # User has not (yet) started to enter a string, so don't
- # return filenames
- return []
- return files
- elif cmd1 == 'help':
- if '"' in cmd2 or "'" in cmd2:
- # User has started to enter a string:
- # Match to parameter names, as they must be strings
- par_vals = opts
- return par_vals
- else:
- # User has not started to enter a string:
- # Match to commands + tasks only
- cmds = ['process_image', 'write_catalog', 'export_image',
- 'show_fit', 'go', 'inp', 'tget', 'tput', 'default',
- 'changelog']
- return cmds
- else:
- # Match to parameter, task, and command names only
- # Add command names
- opts.append('inp')
- opts.append('go')
- opts.append('tget')
- opts.append('tput')
- opts.append('default')
- opts.append('help')
-
- # Add task names
- opts.append('process_image')
- opts.append('show_fit')
- opts.append('write_catalog')
- opts.append('export_image')
- return opts
-
-# Define the welcome banner to print on startup. Also check if there is a newer
-# version on the STRW ftp server. If there is, print a message to the user
-# asking them to update.
-from lofar.bdsm._version import __version__, __revision__, changelog
-
-# Query the Hamburg Observatory FTP server. Tar file must be named
-# "PyBDSM-version#.tar.gz":
-# e.g., "PyBDSM-1.3.1.tar.gz".
-# Check whether called from the LOFAR CEPI/II/III. If so, skip check.
-import os
-aps_local_val = os.environ.get('APS_LOCAL')
-check_for_newer = True
-if aps_local_val is None and check_for_newer:
- try:
- import ftplib
- from distutils.version import StrictVersion
- f = ftplib.FTP()
- f.connect("ftp.hs.uni-hamburg.de", timeout=2.0)
- f.login()
- file_list = []
- file_list = f.nlst('pub/outgoing/rafferty/PyBDSM')
- f.close()
- ftp_version = ''
- for file in file_list:
- if 'PyBDSM' in file and '.tar.gz' in file:
- ver_start_indx = file.find('-') + 1
- ver_end_indx = file.find('.tar.gz')
- ftp_version = file[ver_start_indx:ver_end_indx]
- if ftp_version == '':
- # No matching files found, continue without message
- pass
- elif StrictVersion(__version__) < StrictVersion(ftp_version):
- print '\n' + '*' * 72
- print "There appears to be a newer version of PyBDSM available at:"
- print " ftp://ftp.hs.uni-hamburg.de/pub/outgoing/rafferty/PyBDSM/"
- print "Please consider updating your installation"
- print '*' * 72
- except:
- pass
-
-divider1 = '=' * 72 + '\n'
-divider2 = '_' * 72 + '\n'
-banner = '\nPyBDSM version ' + __version__ + ' (LOFAR revision ' + \
- __revision__ + ')\n'\
-+ divider1 + 'PyBDSM commands\n'\
-' inp task ............ : Set current task and list parameters\n'\
-" par = val ........... : Set a parameter (par = '' sets it to default)\n"\
-' Autocomplete (with TAB) works for par and val\n'\
-' go .................. : Run the current task\n'\
-' default ............. : Set current task parameters to default values\n'\
-" tput ................ : Save parameter values\n"\
-" tget ................ : Load parameter values\n"\
-'PyBDSM tasks\n'\
-' process_image ....... : Process an image: find sources, etc.\n'\
-' show_fit ............ : Show the results of a fit\n'\
-' write_catalog ....... : Write out list of sources to a file\n'\
-' export_image ........ : Write residual/model/rms/mean image to a file\n'\
-'PyBDSM help\n'\
-' help command/task ... : Get help on a command or task\n'\
-' (e.g., help process_image)\n'\
-" help 'par' .......... : Get help on a parameter (e.g., help 'rms_box')\n"\
-' help changelog ...... : See list of recent changes\n'\
-+ divider2
-
-# Go ahead and set the current task to process_image, so that the user does not
-# need to enter "inp process_image" as the first step (the first task needed
-# after startup will almost always be process_image).
-_set_current_cmd(process_image)
-
-# Now start the ipython shell. Due to (non-backward-compatible) changes in
-# ipython with version 0.11, we must support both versions until 0.11 or
-# greater is in common use.
-try:
- # IPython >= 0.11
- from distutils.version import LooseVersion
- from IPython import __version__ as ipython_version
- if LooseVersion(ipython_version) < LooseVersion('1.0.0'):
- from IPython.frontend.terminal.embed import InteractiveShellEmbed
- else:
- from IPython.terminal.embed import InteractiveShellEmbed
- from IPython.config.loader import Config
- cfg = Config()
- prompt_config = cfg.PromptManager
- if ipython_version == '0.11':
- cfg.InteractiveShellEmbed.prompt_in1 = "BDSM [\#]: "
- else:
- prompt_config.in_template = "BDSM [\#]: "
- cfg.InteractiveShellEmbed.autocall = 2
- ipshell = InteractiveShellEmbed(config=cfg, banner1=banner,
- user_ns=locals())
- ipshell.set_hook('complete_command', _opts_completer, re_key = '.*')
-except ImportError:
- # IPython < 0.11
- from IPython.Shell import IPShellEmbed
- argv = ['-prompt_in1','BDSM [\#]: ','-autocall','2']
- ipshell = IPShellEmbed(argv=argv, banner=banner, user_ns=locals())
- ipshell.IP.set_hook('complete_command', _opts_completer, re_key = '.*')
-ipshell()
diff --git a/CEP/PyBDSM/src/python/readimage.py b/CEP/PyBDSM/src/python/readimage.py
deleted file mode 100644
index d6782a6c2a2351d5def6a2c879daa965d9fd9759..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/python/readimage.py
+++ /dev/null
@@ -1,616 +0,0 @@
-"""Module readimage.
-
-Defines operation Op_readimage which initializes image and WCS
-
-The current implementation tries to reduce input file to 2D if
-possible, as this makes more sense atm. One more important thing
-to note -- in its default configuration pyfits will read data
-in non-native format, so we have to convert it before usage. See
-the read_image_from_file in functions.py for details.
-
-Lastly, wcs and spectal information are stored in the PyWCS
-object img.wcs_obj.
-"""
-
-import numpy as N
-from image import *
-from functions import read_image_from_file
-import mylogger
-import sys
-import shutil
-import tempfile
-
-Image.imagename = String(doc="Identifier name for output files")
-Image.filename = String(doc="Name of input file without extension")
-Image.bbspatchnum = Int(doc="To keep track of patch number for bbs file "\
- "for seperate patches per source")
-Image.frequency = Float(doc="Frequency in the header")
-Image.use_io = String(doc="pyfits or pyrap")
-Image.j = Int(doc="Wavelet order j, 0 for normal run")
-Image.freq_pars = Tuple((0.0, 0.0, 0.0),
- doc="Frequency prarmeters from the header: (crval, cdelt, crpix)")
-Image.waveletimage = Bool(doc="Whether a wavelet transform image of not")
-Image.equinox = Float(2000.0, doc='Equinox of input image from header')
-
-class Op_readimage(Op):
- """Image file loader
-
- Loads image and configures wcslib machinery for it.
- """
- def __call__(self, img):
- import time, os
- mylog = mylogger.logging.getLogger("PyBDSM." + img.log + "Readimage")
-
- if img.opts.filename == '':
- raise RuntimeError('Image file name not specified.')
-
- # Check for trailing "/" in file name (since CASA images are directories).
- # Although the general rule is to not alter the values in opts (only the
- # user should be able to alter these), in this case there is no harm in
- # replacing the file name in opts with the '/' trimmed off.
- if img.opts.filename[-1] == '/':
- img.opts.filename = img.opts.filename[:-1]
-
- # Determine indir if not explicitly given by user (in img.opts.indir)
- if img.opts.indir is None:
- indir = os.path.dirname(img.opts.filename)
- if indir == '':
- indir = './'
- img.indir = indir
- else:
- img.indir = img.opts.indir
-
- # Try to trim common extensions from filename and store various
- # paths
- root, ext = os.path.splitext(img.opts.filename)
- if ext in ['.fits', '.FITS', '.image']:
- fname = root
- elif ext in ['.gz', '.GZ']:
- root2, ext2 = os.path.splitext(root)
- if ext2 in ['.fits', '.FITS', '.image']:
- fname = root2
- else:
- fname = root
- else:
- fname = img.opts.filename
- img.filename = img.opts.filename
- img.parentname = fname
- img.imagename = fname + '.pybdsm'
- img.basedir = './' + fname + '_pybdsm/'
-
- # Read in data and header
- image_file = os.path.basename(img.opts.filename)
- result = read_image_from_file(image_file, img, img.indir)
- if result is None:
- raise RuntimeError("Cannot open file " + repr(image_file) + ". " + img._reason)
- else:
- data, hdr = result
-
- # Check whether caching is to be used. If it is, set up a
- # temporary directory. The temporary directory will be
- # removed automatically upon exit.
- if img.opts.do_cache:
- img.do_cache = True
- else:
- img.do_cache = False
- if img.do_cache:
- mylog.info('Using disk caching.')
- tmpdir = img.parentname+'_tmp'
- if not os.path.exists(tmpdir):
- os.makedirs(tmpdir)
- img._tempdir_parent = TempDir(tmpdir)
- img.tempdir = TempDir(tempfile.mkdtemp(dir=tmpdir))
- import atexit, shutil
- atexit.register(shutil.rmtree, img._tempdir_parent, ignore_errors=True)
- else:
- img.tempdir = None
-
- # Store data and header in img. If polarisation_do = False, only store pol == 'I'
- img.nchan = data.shape[1]
- img.nstokes = data.shape[0]
- mylogger.userinfo(mylog, 'Image size',
- str(data.shape[-2:]) + ' pixels')
- mylogger.userinfo(mylog, 'Number of channels',
- '%i' % data.shape[1])
- mylogger.userinfo(mylog, 'Number of Stokes parameters',
- '%i' % data.shape[0])
- if img.opts.polarisation_do and data.shape[0] == 1:
- img.opts.polarisation_do = False
- mylog.warning('Image has Stokes I only. Polarisation module disabled.')
-
- if img.opts.polarisation_do or data.shape[0] == 1:
- img.image_arr = data
- else:
- img.image_arr = data[0, :].reshape(1, data.shape[1], data.shape[2], data.shape[3])
- img.header = hdr
- img.shape = data.shape
- img.j = 0
-
- ### initialize wcs conversion routines
- self.init_wcs(img)
- self.init_beam(img)
- self.init_freq(img)
- year, code = self.get_equinox(img)
- if year is None:
- mylog.info('Equinox not found in image header. Assuming J2000.')
- img.equinox = 2000.0
- else:
- mylog.info('Equinox of image is %f.' % year)
- img.equinox = year
-
- if img.opts.output_all:
- # Set up directory to write output to
- opdir = img.opts.opdir_overwrite
- if opdir not in ['overwrite', 'append']:
- img.opts.opdir_overwrite = 'append'
- if opdir == 'append':
- mylog.info('Appending output files to directory ' + img.basedir)
- else:
- mylog.info('Overwriting output files (if any) in directory ' + img.basedir)
- if os.path.isdir(img.basedir):
- os.system("rm -fr " + img.basedir + '/*')
- if not os.path.isdir(img.basedir):
- os.makedirs(img.basedir)
-
- # Now add solname (if any) and time to basedir
- if img.opts.solnname is not None:
- img.basedir += img.opts.solnname + '_'
- img.basedir += time.strftime("%d%b%Y_%H.%M.%S")
-
- # Make the final output directory
- if not os.path.isdir(img.basedir):
- os.makedirs(img.basedir)
-
- del data
- img.completed_Ops.append('readimage')
- return img
-
- def init_wcs(self, img):
- """Initialize wcs pixel <=> sky conversion routines.
- """
- from math import pi
- import warnings
-
- hdr = img.header
-
- try:
- from astropy.wcs import WCS
- t = WCS(hdr)
- t.wcs.fix()
- except ImportError, err:
- import warnings
- with warnings.catch_warnings():
- warnings.filterwarnings("ignore",category=DeprecationWarning)
- from pywcs import WCS
- t = WCS(hdr)
- t.wcs.fix()
-
- acdelt = [abs(hdr['cdelt1']), abs(hdr['cdelt2'])]
-
- # Here we define p2s and s2p to allow celestial coordinate
- # transformations. Transformations for other axes (e.g.,
- # spectral) are striped out.
- def p2s(self, xy):
- xy = list(xy)
- for i in range(self.naxis-2):
- xy.append(0)
- if hasattr(self, 'wcs_pix2world'):
- try:
- xy_arr = N.array([xy[0:2]])
- sky = self.wcs_pix2world(xy_arr, 0)
- except:
- xy_arr = N.array([xy])
- sky = self.wcs_pix2world(xy_arr, 0)
- else:
- xy_arr = N.array([xy])
- sky = self.wcs_pix2sky(xy_arr, 0)
- return sky.tolist()[0][0:2]
-
- def s2p(self, rd):
- rd = list(rd)
- for i in range(self.naxis-2):
- rd.append(1) # For some reason, 0 gives nans with astropy in some situations
- if hasattr(self, 'wcs_world2pix'):
- try:
- rd_arr = N.array([rd[0:2]])
- pix = self.wcs_world2pix(rd_arr, 0)
- except:
- rd_arr = N.array([rd])
- pix = self.wcs_world2pix(rd_arr, 0)
- else:
- rd_arr = N.array([rd])
- pix = self.wcs_sky2pix(rd_arr, 0)
- return pix.tolist()[0][0:2]
-
- # Here we define functions to transform Gaussian parameters (major axis,
- # minor axis, pos. angle) from the image plane to the celestial sphere.
- # These transforms are valid only at the Gaussian's center and ignore
- # any change across the extent of the Gaussian.
- def gaus2pix(x, location=None, use_wcs=True):
- """ Converts Gaussian parameters in deg to pixels.
-
- x - (maj [deg], min [deg], pa [deg])
- location - specifies the location in pixels (x, y) for which
- transform is desired
- Input beam angle should be degrees CCW from North.
- The output beam angle is degrees CCW from the +y axis of the image.
- """
- if use_wcs:
- bmaj, bmin, bpa = x
- brot = self.get_rot(img, location) # rotation delta CCW (in degrees) between N and +y axis of image
-
- s1 = self.angdist2pixdist(img, bmaj, bpa, location=location)
- s2 = self.angdist2pixdist(img, bmin, bpa + 90.0, location=location)
- th = bpa + brot
- if s1 < s2:
- s1, s2 = s2, s1
- th += 90.0
- th = divmod(th, 180)[1] ### th lies between 0 and 180
- return (s1, s2, th)
- else:
- return img.beam2pix(x)
-
- def pix2gaus(x, location=None, use_wcs=True):
- """ Converts Gaussian parameters in pixels to deg.
-
- x - (maj [pix], min [pix], pa [deg])
- location - specifies the location in pixels (x, y) for which
- transform is desired
- Input beam angle should be degrees CCW from the +y axis of the image.
- The output beam angle is degrees CCW from North.
- """
- if use_wcs:
- s1, s2, th = x
- if s1 == 0.0 and s2 == 0.0:
- return (0.0, 0.0, 0.0)
- brot = self.get_rot(img, location) # rotation delta CCW (in degrees) between N and +y axis of image
-
- th_rad = th / 180.0 * N.pi
- bmaj = self.pixdist2angdist(img, s1, th, location=location)
- bmin = self.pixdist2angdist(img, s2, th + 90.0, location=location)
- bpa = th - brot
- if bmaj < bmin:
- bmaj, bmin = bmin, bmaj
- bpa += 90.0
- bpa = divmod(bpa, 180)[1] ### bpa lies between 0 and 180
- return (bmaj, bmin, bpa)
- else:
- return img.pix2beam(x)
-
- def pix2coord(pix, location=None, use_wcs=True):
- """Converts size along x and y (in pixels) to size in RA and Dec (in degrees)
-
- Currently, this function is only used to convert errors on x, y position
- to errors in RA and Dec.
- """
- if use_wcs:
- # Account for projection effects
- x, y = pix
- brot = self.get_rot(img, location) # rotation delta CCW (in degrees) between N and +y axis of image
- ra_dist_pix = N.sqrt( (x * N.cos(brot * N.pi / 180.0))**2 + (y * N.sin(brot * N.pi / 180.0))**2 )
- dec_dist_pix = N.sqrt( (x * N.sin(brot * N.pi / 180.0))**2 + (y * N.cos(brot * N.pi / 180.0))**2 )
- s1 = self.pixdist2angdist(img, ra_dist_pix, 90.0 - brot, location=location)
- s2 = self.pixdist2angdist(img, dec_dist_pix, 0.0 - brot, location=location)
- else:
- x, y = pix
- s1 = abs(x * cdelt1)
- s2 = abs(y * cdelt2)
- return (s1, s2)
-
- if hasattr(t, 'wcs_pix2world'):
- instancemethod = type(t.wcs_pix2world)
- else:
- instancemethod = type(t.wcs_pix2sky)
- t.p2s = instancemethod(p2s, t, WCS)
- if hasattr(t, 'wcs_world2pix'):
- instancemethod = type(t.wcs_world2pix)
- else:
- instancemethod = type(t.wcs_sky2pix)
- t.s2p = instancemethod(s2p, t, WCS)
-
- img.wcs_obj = t
- img.wcs_obj.acdelt = acdelt
- img.pix2sky = t.p2s
- img.sky2pix = t.s2p
- img.gaus2pix = gaus2pix
- img.pix2gaus = pix2gaus
- img.pix2coord = pix2coord
-
-
- def init_beam(self, img):
- """Initialize beam parameters, and conversion routines
- to convert beam to/from pixel coordinates"""
- from const import fwsig
- mylog = mylogger.logging.getLogger("PyBDSM.InitBeam")
-
- hdr = img.header
- cdelt1, cdelt2 = img.wcs_obj.acdelt[0:2]
-
- ### define beam conversion routines:
- def beam2pix(x):
- """ Converts beam in deg to pixels. Use when no dependence on
- position is appropriate.
-
- Input beam angle should be degrees CCW from North at image center.
- The output beam angle is degrees CCW from the +y axis of the image.
- """
- bmaj, bmin, bpa = x
- s1 = abs(bmaj / cdelt1)
- s2 = abs(bmin / cdelt2)
- th = bpa
- return (s1, s2, th)
-
- def pix2beam(x):
- """ Converts beam in pixels to deg. Use when no dependence on
- position is appropriate.
-
- Input beam angle should be degrees CCW from the +y axis of the image.
- The output beam angle is degrees CCW from North at image center.
- """
- s1, s2, th = x
- bmaj = abs(s1 * cdelt1)
- bmin = abs(s2 * cdelt2)
- bpa = th
- if bmaj < bmin:
- bmaj, bmin = bmin, bmaj
- bpa += 90.0
- bpa = divmod(bpa, 180)[1] ### bpa lies between 0 and 180
- return [bmaj, bmin, bpa]
-
- def pixel_beam():
- """Returns the beam in sigma units in pixels"""
- pbeam = beam2pix(img.beam)
- return (pbeam[0]/fwsig, pbeam[1]/fwsig, pbeam[2])
-
- def pixel_beamarea():
- """Returns the beam area in pixels"""
- pbeam = beam2pix(img.beam)
- return 1.1331 * pbeam[0] * pbeam[1]
-
- ### Get the beam information from the header
- found = False
- if img.opts.beam is not None:
- beam = img.opts.beam
- else:
- try:
- beam = (hdr['BMAJ'], hdr['BMIN'], hdr['BPA'])
- found = True
- except:
- ### try see if AIPS as put the beam in HISTORY as usual
- for h in hdr.get_history():
- # Check if h is a string or a FITS Card object (long headers are
- # split into Cards as of PyFITS 3.0.4)
- if not isinstance(h, str):
- hstr = h.value
- else:
- hstr = h
- if N.all(['BMAJ' in hstr, 'BMIN' in hstr, 'BPA' in hstr, 'CLEAN' in hstr]):
- try:
- dum, dum, dum, bmaj, dum, bmin, dum, bpa = hstr.split()
- except ValueError:
- try:
- dum, dum, bmaj, dum, bmin, dum, bpa, dum, dum = hstr.split()
- except ValueError:
- break
- beam = (float(bmaj), float(bmin), float(bpa))
- found = True
- if not found: raise RuntimeError("No beam information found in image header.")
-
- ### convert beam into pixels (at image center)
- pbeam = beam2pix(beam)
- pbeam = (pbeam[0] / fwsig, pbeam[1] / fwsig, pbeam[2]) # IN SIGMA UNITS
-
- ### and store it
- img.pix2beam = pix2beam
- img.beam2pix = beam2pix
- img.beam = beam # FWHM size in degrees
- img.pixel_beam = pixel_beam # IN SIGMA UNITS in pixels
- img.pixel_beamarea = pixel_beamarea
- mylogger.userinfo(mylog, 'Beam shape (major, minor, pos angle)',
- '(%.5e, %.5e, %s) degrees' % (beam[0], beam[1],
- round(beam[2], 1)))
-
- def init_freq(self, img):
- """Initialize frequency parameters and store them.
-
- Basically, PyBDSM uses two frequency parameters:
-
- img.frequency - the reference frequency in Hz of the ch0 image
- img.freq_pars - the crval, crpix, and cdelt values for the
- frequency axis in Hz
-
- If the input frequency info (in the WCS) is not in Hz, it is
- converted.
- """
- try:
- from astropy.wcs import WCS
- except ImportError, err:
- import warnings
- with warnings.catch_warnings():
- warnings.filterwarnings("ignore", category=DeprecationWarning)
- from pywcs import WCS
-
- mylog = mylogger.logging.getLogger("PyBDSM.InitFreq")
- if img.opts.frequency_sp is not None and img.image_arr.shape[1] > 1:
- # If user specifies multiple frequencies, then let
- # collapse.py do the initialization
- img.frequency = img.opts.frequency_sp[0]
- img.freq_pars = (0.0, 0.0, 0.0)
- mylog.info('Using user-specified frequencies.')
- elif img.opts.frequency is not None and img.image_arr.shape[1] == 1:
- img.frequency = img.opts.frequency
- img.freq_pars = (img.frequency, 0.0, 0.0)
- mylog.info('Using user-specified frequency.')
- else:
- spec_indx = img.wcs_obj.wcs.spec
- if spec_indx == -1:
- raise RuntimeError('No frequency information found in image header.')
- else:
- # Here we define p2f and f2p to allow pixel to frequency
- # transformations. Transformations for other axes (e.g.,
- # celestial) are striped out.
- #
- # First, convert frequency to Hz if needed:
- img.wcs_obj.wcs.sptr('FREQ-???')
- def p2f(self, spec_pix):
- spec_list = [0] * self.naxis
- spec_list[spec_indx] = spec_pix
- spec_pix_arr = N.array([spec_list])
- if hasattr(self, 'wcs_pix2world'):
- freq = self.wcs_pix2world(spec_pix_arr, 0)
- else:
- freq = self.wcs_pix2sky(spec_pix_arr, 0)
- return freq.tolist()[0][spec_indx]
- def f2p(self, freq):
- freq_list = [0] * self.naxis
- freq_list[spec_indx] = freq
- freq_arr = N.array([freq_list])
- if hasattr(self, 'wcs_world2pix'):
- pix = self.wcs_world2pix(freq_arr, 0)
- else:
- pix = self.wcs_sky2pix(freq_arr, 0)
- return pix.tolist()[0][spec_indx]
- if hasattr(img.wcs_obj, 'wcs_pix2world'):
- instancemethod = type(img.wcs_obj.wcs_pix2world)
- else:
- instancemethod = type(img.wcs_obj.wcs_pix2sky)
- img.wcs_obj.p2f = instancemethod(p2f, img.wcs_obj, WCS)
- if hasattr(img.wcs_obj, 'wcs_world2pix'):
- instancemethod = type(img.wcs_obj.wcs_world2pix)
- else:
- instancemethod = type(img.wcs_obj.wcs_sky2pix)
- img.wcs_obj.f2p = instancemethod(f2p, img.wcs_obj, WCS)
-
- if img.opts.frequency is not None:
- img.frequency = img.opts.frequency
- else:
- img.frequency = img.wcs_obj.p2f(0)
-
- def get_equinox(self, img):
- """Gets the equinox from the header.
-
- Returns float year with code, where code is:
- 1 - EQUINOX, EPOCH or RADECSYS keyword not found in header
- 0 - EQUINOX found as a numeric value
- 1 - EPOCH keyword used for equinox (not recommended)
- 2 - EQUINOX found as 'B1950'
- 3 - EQUINOX found as 'J2000'
- 4 - EQUINOX derived from value of RADECSYS keyword
- 'ICRS', 'FK5' ==> 2000, 'FK4' ==> 1950
- """
- code = -1
- year = None
- hdr = img.header
- if 'EQUINOX' in hdr:
- year = hdr['EQUINOX']
- if isinstance(year, str): # Check for 'J2000' or 'B1950' values
- tst = year[:1]
- if (tst == 'J') or (tst == 'B'):
- year = float(year[1:])
- if tst == 'J': code = 3
- if tst == 'B': code = 2
- else:
- code = 0
- else:
- if 'EPOCH' in hdr: # Check EPOCH if EQUINOX not found
- year = float(hdr['EPOCH'])
- code = 1
- else:
- if 'RADECSYS' in hdr:
- sys = hdr['RADECSYS']
- code = 4
- if sys[:3] == 'ICR': year = 2000.0
- if sys[:3] == 'FK5': year = 2000.0
- if sys[:3] == 'FK4': year = 1950.0
- return year, code
-
- def get_rot(self, img, location=None):
- """Returns CCW rotation angle (in degrees) between N and +y axis of image
-
- location specifies the location in pixels (x, y) for which angle is desired
- """
- if location is None:
- x1 = img.image_arr.shape[2] / 2.0
- y1 = img.image_arr.shape[3] / 2.0
- else:
- x1, y1 = location
- ra, dec = img.pix2sky([x1, y1])
- delta_dec = self.pixdist2angdist(img, 1.0, 0.0, location=[x1, y1]) # approx. size in degrees of 1 pixel
- if dec + delta_dec > 90.0:
- # shift towards south instead
- delta_dec *= -1.0
- x2, y2 = img.sky2pix([ra, dec + delta_dec])
- try:
- rot_ang_rad = N.arctan2(y2-y1, x2-x1) - N.pi / 2.0
- if delta_dec < 0.0:
- rot_ang_rad -= N.pi
- except:
- rot_ang_rad = 0.0
- return rot_ang_rad * 180.0 / N.pi
-
- def angdist2pixdist(self, img, angdist, pa, location=None):
- """Returns the distance in pixels for a given angular distance in degrees
-
- pa - position angle in degrees east of north
- location - x and y location of center
- """
- import functions as func
-
- if location is None:
- x1 = int(img.image_arr.shape[2] / 2.0)
- y1 = int(img.image_arr.shape[3] / 2.0)
- else:
- x1, y1 = location
-
- pa_pix = self.get_rot(img, location)
- x0 = x1 - 10.0 * N.sin( (pa + pa_pix) * N.pi / 180.0 )
- y0 = y1 - 10.0 * N.cos( (pa + pa_pix) * N.pi / 180.0 )
- ra0, dec0 = img.pix2sky([x0, y0])
- x2 = x1 + 10.0 * N.sin( (pa + pa_pix) * N.pi / 180.0 )
- y2 = y1 + 10.0 * N.cos( (pa + pa_pix) * N.pi / 180.0 )
- ra2, dec2 = img.pix2sky([x2, y2])
-
- angdist12 = func.angsep(ra0, dec0, ra2, dec2) # degrees
- pixdist12 = N.sqrt( (x0 - x2)**2 + (y0 - y2)**2 ) # pixels
- if angdist12 > 0.0:
- result = angdist * pixdist12 / angdist12
- if N.isnan(result) or result <= 0.0:
- result = N.mean(img.wcs_obj.acdelt[0:2])
- else:
- result = N.mean(img.wcs_obj.acdelt[0:2])
- return result
-
- def pixdist2angdist(self, img, pixdist, pa, location=None):
- """Returns the angular distance in degrees for a given distance in pixels
-
- pa - position angle in degrees CCW from +y axis
- location - x and y location of center
- """
- import functions as func
-
- if location is None:
- x1 = int(img.image_arr.shape[2] / 2.0)
- y1 = int(img.image_arr.shape[3] / 2.0)
- else:
- x1, y1 = location
-
- x0 = x1 - pixdist / 2.0 * N.sin(pa * N.pi / 180.0)
- y0 = y1 - pixdist / 2.0 * N.cos(pa * N.pi / 180.0)
- ra0, dec0 = img.pix2sky([x0, y0])
- x2 = x1 + pixdist / 2.0 * N.sin(pa * N.pi / 180.0)
- y2 = y1 + pixdist / 2.0 * N.cos(pa * N.pi / 180.0)
- ra2, dec2 = img.pix2sky([x2, y2])
-
- angdist12 = func.angsep(ra0, dec0, ra2, dec2) # degrees
- return angdist12
-
-
-class TempDir(str):
- """Container for temporary directory for image caching.
-
- Directory is deleted when garbage collected/zero references """
- def __del__(self):
- import os
- if os.path.exists(self.__str__()):
- shutil.rmtree(self.__str__())
-
diff --git a/CEP/PyBDSM/src/python/rmsimage.py b/CEP/PyBDSM/src/python/rmsimage.py
deleted file mode 100644
index d810ba17202d26d40d55d416c4c0d867dca19e3d..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/python/rmsimage.py
+++ /dev/null
@@ -1,1009 +0,0 @@
-"""Module rmsimage.
-
-Defines operation Op_rmsimage which calculates mean and
-rms maps.
-
-The current implementation will handle both 2D and 3D images,
-where for 3D case it will calculate maps for each plane (=
-Stokes images).
-"""
-
-import numpy as N
-import scipy.ndimage as nd
-import _cbdsm
-from image import Op, Image, NArray, List
-import const
-import mylogger
-import os
-import functions as func
-import scipy.ndimage as nd
-import multi_proc as mp
-import itertools
-
-
-class Op_rmsimage(Op):
- """Calculate rms & noise maps
-
- Prerequisites: Module preprocess should be run first.
- """
- def __call__(self, img):
- mylog = mylogger.logging.getLogger("PyBDSM."+img.log+"RMSimage")
- mylogger.userinfo(mylog, "Calculating background rms and mean images")
- if img.opts.polarisation_do:
- pols = ['I', 'Q', 'U', 'V']
- ch0_images = [img.ch0_arr, img.ch0_Q_arr, img.ch0_U_arr, img.ch0_V_arr]
- cmeans = [img.clipped_mean] + img.clipped_mean_QUV
- crmss = [img.clipped_rms] + img.clipped_rms_QUV
- else:
- pols = ['I'] # assume I is always present
- ch0_images = [img.ch0_arr]
- cmeans = [img.clipped_mean]
- crmss = [img.clipped_rms]
-
- mask = img.mask_arr
- opts = img.opts
- cdelt = N.array(img.wcs_obj.acdelt[:2])
-
- # Determine box size for rms/mean map calculations.
- # If user specifies rms_box, use it. Otherwise, use either an
- # adaptive binning scheme that shrinks the box near
- # the brightest sources or estimate rms_box from bright sources.
- #
- # The adaptive scheme calculates the rms/mean map
- # at two different scales:
- # 1) using a large rms_box, set by size of largest source
- # 2) using a small rms_box, set by size of largest bright source
- # Then, the rms and mean values at a given point are determined
- # by a weighted average of the values in the maps at the two
- # scales.
- fwsig = const.fwsig
- min_adapt_threshold = 10.0
- if opts.adaptive_thresh is None:
- adapt_thresh = 50.0
- start_thresh = 500.0
- else:
- adapt_thresh = opts.adaptive_thresh
- if adapt_thresh < min_adapt_threshold:
- adapt_thresh = min_adapt_threshold
- opts.adaptive_thresh = min_adapt_threshold
- start_thresh = adapt_thresh
- brightsize = None
- isl_pos = []
- do_adapt = img.opts.adaptive_rms_box
- img.use_rms_map = None
- img.mean_map_type = None
-
- # 'size' of brightest source
- kappa1 = 3.0
- try:
- brightsize = int(round(2.*img.beam[0]/cdelt[0]/fwsig*
- sqrt(2.*log(img.max_value/(kappa1*crms)))))
- except:
- brightsize = int(round(2.*img.beam[0]/cdelt[0]/fwsig))
- mylog.info('Estimated size of brightest source (pixels) = '+str(brightsize))
-
- # Using clipped mean and rms and a starting threshold of 500 sigma,
- # search for bright sources. If fewer than 5 are found, reduce
- # threshold until limit set by adapt_thresh is hit.
- cmean = cmeans[0]
- crms = crmss[0]
- image = ch0_images[0]
- shape = image.shape
- isl_size_bright = []
- isl_area_highthresh = []
- isl_peak = []
- max_isl_brightsize = 0.0
- threshold = start_thresh
- if do_adapt:
- mylogger.userinfo(mylog, "Using adaptive scaling of rms_box")
- while len(isl_size_bright) < 5 and threshold >= adapt_thresh:
- isl_size_bright=[]
- isl_maxposn = []
- act_pixels = (image-cmean)/threshold >= crms
- threshold *= 0.8
- if isinstance(mask, N.ndarray):
- act_pixels[mask] = False
- rank = len(image.shape)
- connectivity = nd.generate_binary_structure(rank, rank)
- labels, count = nd.label(act_pixels, connectivity)
- slices = nd.find_objects(labels)
- for idx, s in enumerate(slices):
- isl_size_bright.append(max([s[0].stop-s[0].start, s[1].stop-s[1].start]))
- size_area = (labels[s] == idx+1).sum()/img.pixel_beamarea()*2.0
- isl_area_highthresh.append(size_area)
- isl_maxposn.append(tuple(N.array(N.unravel_index(N.argmax(image[s]), image[s].shape))+\
- N.array((s[0].start, s[1].start))))
- isl_peak.append(nd.maximum(image[s], labels[s], idx+1))
-
- # Check islands found above at thresh_isl threshold to determine if
- # the bright source is embedded inside a large island or not. If it is,
- # exclude it from the bright-island list. Also find the size of the
- # largest island at this threshold to set the large-scale rms_box
- bright_threshold = threshold
- threshold = 10.0
- act_pixels = (image-cmean)/threshold >= crms
- if isinstance(mask, N.ndarray):
- act_pixels[mask] = False
- rank = len(image.shape)
- connectivity = nd.generate_binary_structure(rank, rank)
- labels, count = nd.label(act_pixels, connectivity)
- slices = nd.find_objects(labels)
- isl_size = []
- isl_size_highthresh = []
- isl_size_lowthresh = []
- isl_snr = []
- thratio = threshold/bright_threshold
- for idx, s in enumerate(slices):
- isl_area_lowthresh = (labels[s] == idx+1).sum()/img.pixel_beamarea()*2.0
- isl_maxposn_lowthresh = tuple(N.array(N.unravel_index(N.argmax(image[s]), image[s].shape))+
- N.array((s[0].start, s[1].start)))
- isl_size += [s[0].stop-s[0].start, s[1].stop-s[1].start]
- if do_adapt and isl_maxposn_lowthresh in isl_maxposn:
- bright_indx = isl_maxposn.index(isl_maxposn_lowthresh)
- if isl_area_lowthresh < 25.0 or isl_area_lowthresh/isl_area_highthresh[bright_indx] < 8.0:
- isl_pos.append(isl_maxposn_lowthresh)
- isl_size_lowthresh.append(max([s[0].stop-s[0].start, s[1].stop-s[1].start]))
- isl_size_highthresh.append(isl_size_bright[bright_indx])
- isl_snr.append(isl_peak[bright_indx]/crms)
-
- if len(isl_size) == 0:
- max_isl_size = 0.0
- else:
- max_isl_size = max(isl_size)
- mylog.info('Maximum extent of largest 10-sigma island using clipped rms (pixels) = '+str(max_isl_size))
- if len(isl_size_highthresh) == 0:
- max_isl_size_highthresh = 0.0
- max_isl_size_lowthresh = 0.0
- else:
- max_isl_size_highthresh = max(isl_size_highthresh)
- max_isl_size_lowthresh = max(isl_size_lowthresh)
- avg_max_isl_size = (max_isl_size_highthresh + max_isl_size_lowthresh) / 2.0
-
- if hasattr(img, '_adapt_rms_isl_pos'):
- isl_pos = img._adapt_rms_isl_pos # set isl_pos to existing value (for wavelet analysis)
- if len(isl_pos) == 0:
- # No bright sources found
- do_adapt = False
- else:
- img._adapt_rms_isl_pos = isl_pos
- min_size_allowed = int(img.pixel_beam()[0]*9.0)
-
- if opts.rms_box is None or (opts.rms_box_bright is None and do_adapt):
- if do_adapt:
- bsize = int(max(brightsize, min_size_allowed, max_isl_size_highthresh*2.0))
- else:
- bsize = int(max(brightsize, min_size_allowed, max_isl_size*2.0))
- bsize2 = int(max(min(image.shape)/10.0, max_isl_size*5.0))
- if bsize < min_size_allowed:
- bsize = min_size_allowed
- if bsize % 10 == 0: bsize += 1
- if bsize2 < min_size_allowed:
- bsize2 = min_size_allowed
- if bsize2 % 10 == 0: bsize2 += 1
- bstep = int(round(min(bsize/3., min(shape)/10.)))
- bstep2 = int(round(min(bsize2/3., min(shape)/10.)))
- if opts.rms_box_bright is None:
- img.rms_box_bright = (bsize, bstep)
- else:
- img.rms_box_bright = opts.rms_box_bright
- if opts.rms_box is None:
- img.rms_box = (bsize2, bstep2)
- else:
- img.rms_box = opts.rms_box
- else:
- if do_adapt:
- img.rms_box_bright = opts.rms_box_bright
- img.rms_box = opts.rms_box
- else:
- img.rms_box_bright = opts.rms_box
- img.rms_box = opts.rms_box
-
- if opts.kappa_clip is None:
- kappa = -img.pixel_beamarea()
- else:
- kappa = img.opts.kappa_clip
-
- if do_adapt:
- map_opts = (kappa, img.rms_box_bright, opts.spline_rank)
- else:
- map_opts = (kappa, img.rms_box, opts.spline_rank)
-
- for ipol, pol in enumerate(pols):
- data = ch0_images[ipol]
- mean = N.zeros(data.shape, dtype=N.float32)
- rms = N.zeros(data.shape, dtype=N.float32)
- if len(pols) > 1:
- pol_txt = ' (' + pol + ')'
- else:
- pol_txt = ''
-
- ## calculate rms/mean maps if needed
- if ((opts.rms_map is not False) or (opts.mean_map not in ['zero', 'const'])) and img.rms_box[0] > min(image.shape)/4.0:
- # rms box is too large - just use constant rms and mean
- self.output_rmsbox_size(img)
- mylogger.userinfo(mylog, 'Size of rms_box larger than 1/4 of image size')
- mylogger.userinfo(mylog, 'Using constant background rms and mean')
- img.use_rms_map = False
- img.mean_map_type = 'const'
- else:
- if (opts.rms_map is not False) or (opts.mean_map not in ['zero', 'const']):
- if len(data.shape) == 2: ## 2d case
- mean, rms = self.calculate_maps(img, data, mean, rms, mask, map_opts, do_adapt=do_adapt,
- bright_pt_coords=isl_pos, rms_box2=img.rms_box,
- logname="PyBDSM."+img.log, ncores=img.opts.ncores)
- elif len(data.shape) == 3: ## 3d case
- if not isinstance(mask, N.ndarray):
- mask = N.zeros(data.shape[0], dtype=bool)
- for i in range(data.shape[0]):
- ## iterate each plane
- mean, rms = self.calculate_maps(img, data[i], mean[i], rms[i], mask[i], map_opts,
- do_adapt=do_adapt, bright_pt_coords=isl_pos,
- rms_box2=img.rms_box, logname="PyBDSM."+img.log,
- ncores=img.opts.ncores)
- else:
- mylog.critical('Image shape not handleable' + pol_txt)
- raise RuntimeError("Can't handle array of this shape" + pol_txt)
- self.output_rmsbox_size(img)
- if do_adapt:
- mylogger.userinfo(mylog, 'Number of sources using small scale', str(len(isl_pos)))
- mylog.info('Background rms and mean images computed' + pol_txt)
-
- ## check if variation of rms/mean maps is significant enough:
- # check_rmsmap() sets img.use_rms_map
- # check_meanmap() sets img.mean_map_type
- if pol == 'I':
- if opts.rms_map is None and img.use_rms_map is None:
- if do_adapt and len(isl_pos) > 0:
- # Always use 2d map if there is at least one bright
- # source and adaptive scaling is desired
- img.use_rms_map = True
- else:
- self.check_rmsmap(img, rms)
- elif opts.rms_map is not None:
- img.use_rms_map = opts.rms_map
- if img.use_rms_map is False:
- mylogger.userinfo(mylog, 'Using constant background rms')
- else:
- mylogger.userinfo(mylog, 'Using 2D map for background rms')
-
- if opts.mean_map == 'default' and img.mean_map_type is None:
- self.check_meanmap(img, rms)
- elif opts.mean_map != 'default':
- img.mean_map_type = opts.mean_map
- if img.mean_map_type != 'map':
- mylogger.userinfo(mylog, 'Using constant background mean')
- else:
- mylogger.userinfo(mylog, 'Using 2D map for background mean')
-
- ## if rms map is insignificant, or rms_map==False use const value
- if img.use_rms_map is False:
- if opts.rms_value is None:
- rms[:] = crmss[ipol]
- else:
- rms[:] = opts.rms_value
- mylogger.userinfo(mylog, 'Value of background rms' + pol_txt,
- '%.5f Jy/beam' % rms[0][0])
- else:
- rms_min = N.nanmin(rms)
- rms_max = N.nanmax(rms)
- mylogger.userinfo(mylog, 'Min/max values of background rms map' + pol_txt,
- '(%.5f, %.5f) Jy/beam' % (rms_min, rms_max))
-
- if img.mean_map_type != 'map':
- if opts.mean_map == 'zero':
- val = 0.0
- else:
- val = img.clipped_mean
- mean[:] = val
- mylogger.userinfo(mylog, 'Value of background mean' + pol_txt,
- str(round(val,5))+' Jy/beam')
- else:
- mean_min = N.nanmin(mean)
- mean_max = N.nanmax(mean)
- mylogger.userinfo(mylog, 'Min/max values of background mean map' + pol_txt,
- '(%.5f, %.5f) Jy/beam' % (mean_min, mean_max))
-
- if pol == 'I':
- # Apply mask to mean_map and rms_map by setting masked values to NaN
- if isinstance(mask, N.ndarray):
- pix_masked = N.where(mask == True)
- mean[pix_masked] = N.nan
- rms[pix_masked] = N.nan
-
- img.mean_arr = mean
- img.rms_arr = rms
-
- if opts.savefits_rmsim or opts.output_all:
- if img.waveletimage:
- resdir = img.basedir + '/wavelet/background/'
- else:
- resdir = img.basedir + '/background/'
- if not os.path.exists(resdir): os.makedirs(resdir)
- func.write_image_to_file(img.use_io, img.imagename + '.rmsd_I.fits', rms, img, resdir)
- mylog.info('%s %s' % ('Writing ', resdir+img.imagename+'.rmsd_I.fits'))
- if opts.savefits_meanim or opts.output_all:
- if img.waveletimage:
- resdir = img.basedir + '/wavelet/background/'
- else:
- resdir = img.basedir + '/background/'
- if not os.path.exists(resdir): os.makedirs(resdir)
- func.write_image_to_file(img.use_io, img.imagename + '.mean_I.fits', mean, img, resdir)
- mylog.info('%s %s' % ('Writing ', resdir+img.imagename+'.mean_I.fits'))
- if opts.savefits_normim or opts.output_all:
- if img.waveletimage:
- resdir = img.basedir + '/wavelet/background/'
- else:
- resdir = img.basedir + '/background/'
- if not os.path.exists(resdir): os.makedirs(resdir)
- zero_pixels = N.where(rms <= 0.0)
- rms_nonzero = rms.copy()
- rms_nonzero[zero_pixels] = N.NaN
- func.write_image_to_file(img.use_io, img.imagename + '.norm_I.fits', (image-mean)/rms_nonzero, img, resdir)
- mylog.info('%s %s' % ('Writing ', resdir+img.imagename+'.norm_I.fits'))
- else:
- img.__setattr__('mean_'+pol+'_arr', mean)
- img.__setattr__('rms_'+pol+'_arr', rms)
-
- img.completed_Ops.append('rmsimage')
- return img
-
- def check_rmsmap(self, img, rms):
- """Calculates the statistics of the rms map and decides, when
- rms_map=None, whether to take the map (if variance
- is significant) or a constant value
- """
- from math import sqrt
-
- mylog = mylogger.logging.getLogger("PyBDSM."+img.log+"Rmsimage.Checkrms ")
- cdelt = img.wcs_obj.acdelt[:2]
- bm = (img.beam[0], img.beam[1])
- fw_pix = sqrt(N.product(bm)/abs(N.product(cdelt)))
- if img.masked:
- unmasked = N.where(~img.mask_arr)
- stdsub = N.std(rms[unmasked])
- maxrms = N.max(rms[unmasked])
- else:
- stdsub = N.std(rms)
- maxrms = N.max(rms)
-
- rms_expect = img.clipped_rms/sqrt(2)/img.rms_box[0]*fw_pix
- mylog.debug('%s %10.6f %s' % ('Standard deviation of rms image = ', stdsub*1000.0, 'mJy'))
- mylog.debug('%s %10.6f %s' % ('Expected standard deviation = ', rms_expect*1000.0, 'mJy'))
- if stdsub > 1.1*rms_expect:
- img.use_rms_map = True
- mylogger.userinfo(mylog, 'Variation in rms image significant')
- else:
- img.use_rms_map = False
- mylogger.userinfo(mylog, 'Variation in rms image not significant')
-
- return img
-
- def check_meanmap(self, img, mean):
- """Calculates the statistics of the mean map and decides, when
- mean_map=None, whether to take the map (if variance
- is significant) or a constant value
- """
- from math import sqrt
-
- mylog = mylogger.logging.getLogger("PyBDSM."+img.log+"Rmsimage.Checkmean ")
- cdelt = img.wcs_obj.acdelt[:2]
- bm = (img.beam[0], img.beam[1])
- fw_pix = sqrt(N.product(bm)/abs(N.product(cdelt)))
- if img.masked:
- unmasked = N.where(~img.mask_arr)
- stdsub = N.std(mean[unmasked])
- maxmean = N.max(mean[unmasked])
- else:
- stdsub = N.std(mean)
- maxmean = N.max(mean)
- rms_expect = img.clipped_rms/img.rms_box[0]*fw_pix
- mylog.debug('%s %10.6f %s' % ('Standard deviation of mean image = ', stdsub*1000.0, 'mJy'))
- mylog.debug('%s %10.6f %s' % ('Expected standard deviation = ', rms_expect*1000.0, 'mJy'))
-
- # For mean map, use a higher threshold than for the rms map, as radio images
- # should rarely, if ever, have significant variations in the mean
- if stdsub > 5.0*rms_expect:
- img.mean_map_type = 'map'
- mylogger.userinfo(mylog, 'Variation in mean image significant')
- else:
- if img.confused:
- img.mean_map_type = 'zero'
- else:
- img.mean_map_type = 'const'
- mylogger.userinfo(mylog, 'Variation in mean image not significant')
-
- return img
-
-
- def calculate_maps(self, img, data, mean, rms, mask, map_opts, do_adapt,
- bright_pt_coords=[], rms_box2=None,
- logname=None, ncores=None):
- """Calls map_2d and checks for problems"""
- mylog = mylogger.logging.getLogger("PyBDSM."+img.log+"Rmsimage.Calcmaps ")
- rms_ok = False
- mylog = mylogger.logging.getLogger("PyBDSM."+img.log+"Rmsimage.Calcmaps ")
- opts = img.opts
- kappa = map_opts[0]
- while not rms_ok:
- self.map_2d(data, mean, rms, mask, *map_opts, do_adapt=do_adapt,
- bright_pt_coords=bright_pt_coords, rms_box2=rms_box2,
- logname=logname, ncores=ncores)
- if N.any(rms < 0.0):
- rms_ok = False
- if (opts.rms_box_bright is None and do_adapt) or (opts.rms_box is None and not do_adapt):
- # Increase box by 20%
- if do_adapt:
- new_width = int(img.rms_box_bright[0]*1.2)
- if new_width == img.rms_box_bright[0]:
- new_width = img.rms_box_bright[0] + 1
- new_step = int(new_width/3.0)
- img.rms_box_bright = (new_width, new_step)
- if img.rms_box_bright[0] > min(img.ch0_arr.shape)/4.0:
- mylogger.userinfo(mylog, 'Size of rms_box_bright larger than 1/4 of image size')
- mylogger.userinfo(mylog, 'Using constant background rms and mean')
- img.use_rms_map = False
- img.rms_box = img.rms_box_bright
- img.mean_map_type = 'const'
- rms_ok = True
- else:
- map_opts = (kappa, img.rms_box_bright, opts.spline_rank)
- else:
- new_width = int(img.rms_box[0]*1.2)
- if new_width == img.rms_box[0]:
- new_width = img.rms_box[0] + 1
- new_step = int(new_width/3.0)
- img.rms_box = (new_width, new_step)
- if img.rms_box[0] > min(img.ch0_arr.shape)/4.0:
- mylogger.userinfo(mylog, 'Size of rms_box larger than 1/4 of image size')
- mylogger.userinfo(mylog, 'Using constant background rms and mean')
- img.use_rms_map = False
- img.mean_map_type = 'const'
- rms_ok = True
- else:
- map_opts = (kappa, img.rms_box, opts.spline_rank)
-
- else:
- # User has specified box size, use order=1 to prevent negatives
- if opts.spline_rank > 1:
- mylog.warning('Negative values found in rms map interpolated with spline_rank = %i' % opts.spline_rank)
- mylog.warning('Using spline_rank = 1 (bilinear interpolation) instead')
- if do_adapt:
- map_opts = (kappa, img.rms_box_bright, 1)
- else:
- map_opts = (kappa, img.rms_box, 1)
- else:
- rms_ok = True
-
- return mean, rms
-
-
- def map_2d(self, arr, out_mean, out_rms, mask=False,
- kappa=3, box=None, interp=1, do_adapt=False,
- bright_pt_coords=None, rms_box2=None, logname='', ncores=None):
- """Calculate mean&rms maps and store them into provided arrays
-
- Parameters:
- arr: 2D array with data
- out_mean, out_rms: 2D arrays where to store calculated maps
- mask: mask
- kappa: clipping value for rms/mean calculations
- box: tuple of (box_size, box_step) for calculating map
- rms_box2 = large-scale box size
- interp: order of interpolating spline used to interpolate
- calculated map
- do_adapt: use adaptive binning
- """
- mask_small = mask
- axes, mean_map1, rms_map1 = self.rms_mean_map(arr, mask_small, kappa, box, ncores)
- ax = map(self.remap_axis, arr.shape, axes)
- ax = N.meshgrid(*ax[-1::-1])
- pt_src_scale = box[0]
- if do_adapt:
- out_rms2 = N.zeros(rms_map1.shape, dtype=N.float32)
- out_mean2 = N.zeros(rms_map1.shape, dtype=N.float32)
- # Generate rms/mean maps on large scale
- box2 = rms_box2
- axes2, mean_map2, rms_map2 = self.rms_mean_map(arr, mask, kappa, box2, ncores)
-
- # Interpolate to get maps on small scale grid
- axes2mod = axes2[:]
- axes2mod[0] = axes2[0]/arr.shape[0]*mean_map1.shape[0]
- axes2mod[1] = axes2[1]/arr.shape[1]*mean_map1.shape[1]
- ax2 = map(self.remap_axis, out_rms2.shape, axes2mod)
- ax2 = N.meshgrid(*ax2[-1::-1])
- nd.map_coordinates(rms_map2, ax2[-1::-1], order=interp, output=out_rms2)
- nd.map_coordinates(mean_map2, ax2[-1::-1], order=interp, output=out_mean2)
- rms_map = out_rms2
- mean_map = out_mean2
-
- # For each bright source, find nearest points and weight them towards
- # the small scale maps.
- xscale = float(arr.shape[0])/float(out_rms2.shape[0])
- yscale = float(arr.shape[1])/float(out_rms2.shape[1])
- scale = [xscale, yscale]
- size = 15
- for bright_pt in bright_pt_coords:
- bbox, src_center = self.make_bright_src_bbox(bright_pt, scale, size, out_rms2.shape)
- bbox_xsize = bbox[0].stop-bbox[0].start
- bbox_ysize = bbox[1].stop-bbox[1].start
- src_center[0] -= bbox[0].start
- src_center[1] -= bbox[1].start
- weights = N.ones((bbox_xsize, bbox_ysize))
-
- # Taper weights to zero where small-scale value is within a factor of
- # 2 of large-scale value. Use distance to center of the box
- # to determine taper value. This tapering prevents the use of the
- # small-scale box beyond the range of artifacts.
- low_vals_ind = N.where(rms_map1[bbox]/out_rms2[bbox] < 2.0)
- if len(low_vals_ind[0]) > 0:
- dist_to_cen = []
- for (x,y) in zip(low_vals_ind[0],low_vals_ind[1]):
- dist_to_cen.append(N.sqrt( (x-src_center[0])**2 +
- (y-src_center[1])**2 ))
- med_dist_to_cen = N.min(dist_to_cen)
- for x in range(bbox_xsize):
- for y in range(bbox_ysize):
- dist_to_cen = N.sqrt( (x-src_center[0])**2 +
- (y-src_center[1])**2 )
- if dist_to_cen >= med_dist_to_cen:
- weights[x,y] = 1.0 - dist_to_cen/N.sqrt(bbox_xsize**2+bbox_ysize**2)*2.0
- rms_map[bbox] = rms_map1[bbox]*weights + out_rms2[bbox]*(1.0-weights)
- mean_map[bbox] = mean_map1[bbox]*weights + out_mean2[bbox]*(1.0-weights)
- else:
- rms_map = rms_map1
- mean_map = mean_map1
-
- # Interpolate to image coords
- mylog = mylogger.logging.getLogger(logname+"Rmsimage")
- nd.map_coordinates(rms_map, ax[-1::-1], order=interp, output=out_rms)
- nd.map_coordinates(mean_map, ax[-1::-1], order=interp, output=out_mean)
-
- # Apply mask to mean_map and rms_map by setting masked values to NaN
- if isinstance(mask, N.ndarray):
- pix_masked = N.where(mask == True)
- out_mean[pix_masked] = N.nan
- out_rms[pix_masked] = N.nan
-
- def rms_mean_map(self, arr, mask=False, kappa=3, box=None, ncores=None):
- """Calculate map of the mean/rms values
-
- Parameters:
- arr: 2D array with data
- mask: mask
- kappa: clipping for calculating rms/mean within each box
- box: box parameters (box_size, box_step)
-
- Returns:
- axes: list of 2 arrays with coordinates of boxes alongside each axis
- mean_map: map of mean values
- rms_map: map of rms values
-
- Description:
- This function calculates clipped mean and rms maps for the array.
- The algorithm is a moving-window algorithm, where mean&rms are
- calculated within a window of a size (box_size * box_size), and the
- window is stepped withing the image by steps of box_steps.
-
- Special care is taken for the borders of the image -- outer borders
- (where box doesn't fit properly) are given one extra round with a box
- applied to the border of the image. Additionally outer values are
- extrapolated to cover whole image size, to simplify further processing.
-
- See also routine 'remap_axes' for 'inverting' axes array
-
- Example:
- for an input image of 100x100 pixels calling rms_mean_map with default
- box parameters (50, 25) will result in the following:
-
- axes = [array([ 0. , 24.5, 49.5, 74.5, 99. ]),
- array([ 0. , 24.5, 49.5, 74.5, 99. ])]
-
- mean_map = <5x5 array>
- rms_map = <5x5 array>
-
- rms_map[1,1] is calculated for arr[0:50, 0:50]
- rms_map[2,1] is calculated for arr[25:75, 0:50]
- ...etc...
- rms_map[0,0] is extrapolated as .5*(rms_map[0,1] + rms_map[1,0])
- rms_map[0,1] is extrapolated as rms_map[1,1]
- """
- mylog = mylogger.logging.getLogger("PyBDSM.RmsMean")
- if box is None:
- box = (50, 25)
- if box[0] < box[1]:
- raise RuntimeError('Box size is less than step size.')
-
- # Some math first: boxcount is number of boxes alongsize each axis,
- # bounds is non-zero for axes which have extra pixels beyond last box
- BS, SS = box
- imgshape = N.array(arr.shape)
-
- # If boxize is less than 10% of image, use simple extrapolation to
- # derive the edges of the mean and rms maps; otherwise, use padded
- # versions of arr and mask to derive the mean and rms maps
- if float(BS)/float(imgshape[0]) < 0.1 and \
- float(BS)/float(imgshape[1]) < 0.1:
- use_extrapolation = True
- else:
- use_extrapolation = False
-
- if use_extrapolation:
- boxcount = 1 + (imgshape - BS)/SS
- bounds = N.asarray((boxcount-1)*SS + BS < imgshape, dtype=int)
- mapshape = 2 + boxcount + bounds
- else:
- boxcount = 1 + imgshape/SS
- bounds = N.asarray((boxcount-1)*SS < imgshape, dtype=int)
- mapshape = boxcount + bounds
- pad_border_size = int(BS/2.0)
- new_shape = (arr.shape[0] + 2*pad_border_size, arr.shape[1]
- + 2*pad_border_size)
- arr_pad = self.pad_array(arr, new_shape)
- if mask is None:
- mask_pad = None
- else:
- mask_pad = self.pad_array(mask, new_shape)
-
- # Make arrays for calculated data
- mean_map = N.zeros(mapshape, dtype=N.float32)
- rms_map = N.zeros(mapshape, dtype=N.float32)
- axes = [N.zeros(len, dtype=N.float32) for len in mapshape]
-
- # Step 1: internal area of the image
- # Make a list of coordinates to send to process_mean_rms_maps()
- coord_list = []
- ind_list = []
- for i in range(boxcount[0]):
- for j in range(boxcount[1]):
- if use_extrapolation:
- coord_list.append((i+1, j+1))
- else:
- coord_list.append((i, j))
- ind_list.append([i*SS, i*SS+BS, j*SS, j*SS+BS])
-
- # Now call the parallel mapping function. Returns a list of [mean, rms]
- # for each coordinate.
- if use_extrapolation:
- cm_cr_list = mp.parallel_map(func.eval_func_tuple,
- itertools.izip(itertools.repeat(self.process_mean_rms_maps),
- ind_list, itertools.repeat(mask), itertools.repeat(arr),
- itertools.repeat(kappa)), numcores=ncores)
- else:
- cm_cr_list = mp.parallel_map(func.eval_func_tuple,
- itertools.izip(itertools.repeat(self.process_mean_rms_maps),
- ind_list, itertools.repeat(mask_pad), itertools.repeat(arr_pad),
- itertools.repeat(kappa)), numcores=ncores)
-
- for i, co in enumerate(coord_list):
- cm, cr = cm_cr_list[i]
- mean_map[co] = cm
- rms_map[co] = cr
-
- # Check if all regions have too few unmasked pixels
- if mask is not None and N.size(N.where(mean_map != N.inf)) == 0:
- raise RuntimeError("No unmasked regions from which to determine "\
- "mean and rms maps")
-
- # Step 2: borders of the image
- if bounds[0]:
- coord_list = []
- ind_list = []
- for j in range(boxcount[1]):
- if use_extrapolation:
- coord_list.append((-2, j+1))
- ind_list.append([-BS, arr.shape[0], j*SS,j*SS+BS])
- else:
- coord_list.append((-1, j))
- ind_list.append([-BS, arr_pad.shape[0], j*SS,j*SS+BS])
- if use_extrapolation:
- cm_cr_list = mp.parallel_map(func.eval_func_tuple,
- itertools.izip(itertools.repeat(self.process_mean_rms_maps),
- ind_list, itertools.repeat(mask), itertools.repeat(arr),
- itertools.repeat(kappa)), numcores=ncores)
- else:
- cm_cr_list = mp.parallel_map(func.eval_func_tuple,
- itertools.izip(itertools.repeat(self.process_mean_rms_maps),
- ind_list, itertools.repeat(mask_pad), itertools.repeat(arr_pad),
- itertools.repeat(kappa)), numcores=ncores)
-
- for i, co in enumerate(coord_list):
- cm, cr = cm_cr_list[i]
- mean_map[co] = cm
- rms_map[co] = cr
-
-
- if bounds[1]:
- coord_list = []
- ind_list = []
- for i in range(boxcount[0]):
- if use_extrapolation:
- coord_list.append((i+1, -2))
- ind_list.append([i*SS,i*SS+BS, -BS,arr.shape[1]])
- else:
- coord_list.append((i, -1))
- ind_list.append([i*SS,i*SS+BS, -BS,arr_pad.shape[1]])
- if use_extrapolation:
- cm_cr_list = mp.parallel_map(func.eval_func_tuple,
- itertools.izip(itertools.repeat(self.process_mean_rms_maps),
- ind_list, itertools.repeat(mask), itertools.repeat(arr),
- itertools.repeat(kappa)), numcores=ncores)
- else:
- cm_cr_list = mp.parallel_map(func.eval_func_tuple,
- itertools.izip(itertools.repeat(self.process_mean_rms_maps),
- ind_list, itertools.repeat(mask_pad), itertools.repeat(arr_pad),
- itertools.repeat(kappa)), numcores=ncores)
-
- for i, co in enumerate(coord_list):
- cm, cr = cm_cr_list[i]
- mean_map[co] = cm
- rms_map[co] = cr
-
- if bounds.all():
- if use_extrapolation:
- ind = [-BS,arr.shape[0], -BS,arr.shape[1]]
- self.for_masked(mean_map, rms_map, mask, arr, ind,
- kappa, [-2, -2])
- else:
- ind = [-BS,arr_pad.shape[0], -BS,arr_pad.shape[1]]
- self.for_masked(mean_map, rms_map, mask_pad, arr_pad, ind,
- kappa, [-1, -1])
-
- # Step 3: correct(extrapolate) borders of the image
- def correct_borders(map):
- map[0, :] = map[1, :]
- map[:, 0] = map[:, 1]
- map[-1, :] = map[-2, :]
- map[:, -1] = map[:, -2]
-
- map[0,0] = (map[1,0] + map[0, 1])/2.
- map[-1,0] = (map[-2, 0] + map[-1, 1])/2.
- map[0, -1] = (map[0, -2] + map[1, -1])/2.
- map[-1,-1] = (map[-2, -1] + map[-1, -2])/2.
-
- if use_extrapolation:
- correct_borders(mean_map)
- correct_borders(rms_map)
-
- # Step 4: fill in coordinate axes
- for i in range(2):
- if use_extrapolation:
- axes[i][1:boxcount[i]+1] = (N.arange(boxcount[i])*SS
- + BS/2. - .5)
- if bounds[i]:
- axes[i][-2] = imgshape[i] - BS/2. - .5
- else:
- axes[i][0:boxcount[i]] = N.arange(boxcount[i])*SS - .5
- if bounds[i]:
- axes[i][-2] = imgshape[i] - .5
- axes[i][-1] = imgshape[i] - 1
-
- # Step 5: fill in boxes with < 5 unmasked pixels (set to values of
- # N.inf)
- unmasked_boxes = N.where(mean_map != N.inf)
- if N.size(unmasked_boxes,1) < mapshape[0]*mapshape[1]:
- mean_map = self.fill_masked_regions(mean_map)
- rms_map = self.fill_masked_regions(rms_map)
-
- return axes, mean_map, rms_map
-
-
- def process_mean_rms_maps(self, ind, mask, arr, kappa):
- """Finds mean and rms for one region of an input arr"""
- cm, cr = self.for_masked_mp(mask, arr, ind,
- kappa)
- return cm, cr
-
-
- def fill_masked_regions(self, themap, magic=N.inf):
- """Fill masked regions (defined where values == magic) in themap.
- """
- masked_boxes = N.where(themap == magic) # locations of masked regions
- for i in range(N.size(masked_boxes,1)):
- num_unmasked = 0
- x, y = masked_boxes[0][i], masked_boxes[1][i]
- delx = dely = 1
- while num_unmasked == 0:
- x1 = x - delx
- if x1 < 0: x1 = 0
- x2 = x + 1 + delx
- if x2 > themap.shape[0]: x2 = themap.shape[0]
- y1 = y - dely
- if y1 < 0: y1 = 0
- y2 = y + 1 + dely
- if y2 > themap.shape[1]: y2 = themap.shape[1]
-
- cutout = themap[x1:x2, y1:y2].ravel()
- goodcutout = cutout[cutout != magic]
- num_unmasked = N.alen(goodcutout)
- if num_unmasked > 0:
- themap[x, y] = N.nansum(goodcutout)/float(len(goodcutout))
- delx += 1
- dely += 1
- themap[N.where(N.isnan(themap))] = 0.0
- return themap
-
- def pad_array(self, arr, new_shape):
- """Returns a padded array by mirroring around the edges."""
- # Assume that padding is the same for both axes and is equal
- # around all edges.
- half_size = (new_shape[0] - arr.shape[0]) / 2
- arr_pad = N.zeros( (new_shape), dtype=arr.dtype)
-
- # left band
- band = arr[:half_size, :]
- arr_pad[:half_size, half_size:-half_size] = N.flipud( band )
-
- # right band
- band = arr[-half_size:, :]
- arr_pad[-half_size:, half_size:-half_size] = N.flipud( band )
-
- # bottom band
- band = arr[:, :half_size]
- arr_pad[half_size:-half_size, :half_size] = N.fliplr( band )
-
- # top band
- band = arr[:, -half_size:]
- arr_pad[half_size:-half_size, -half_size:] = N.fliplr( band )
-
- # central band
- arr_pad[half_size:-half_size, half_size:-half_size] = arr
-
- # bottom left corner
- band = arr[:half_size,:half_size]
- arr_pad[:half_size,:half_size] = N.flipud(N.fliplr(band))
-
- # top right corner
- band = arr[-half_size:,-half_size:]
- arr_pad[-half_size:,-half_size:] = N.flipud(N.fliplr(band))
-
- # top left corner
- band = arr[:half_size,-half_size:]
- arr_pad[:half_size,-half_size:] = N.flipud(N.fliplr(band))
-
- # bottom right corner
- band = arr[-half_size:,:half_size]
- arr_pad[-half_size:,:half_size] = N.flipud(N.fliplr(band))
-
- return arr_pad
-
- def for_masked(self, mean_map, rms_map, mask, arr, ind, kappa, co):
-
- bstat = func.bstat#_cbdsm.bstat
- a, b, c, d = ind; i, j = co
- if mask is None:
- m, r, cm, cr, cnt = bstat(arr[a:b, c:d], mask, kappa)
- if cnt > 198: cm = m; cr = r
- mean_map[i, j], rms_map[i, j] = cm, cr
- else:
- pix_unmasked = N.where(mask[a:b, c:d] == False)
- npix_unmasked = N.size(pix_unmasked,1)
- if npix_unmasked > 20: # find clipped mean/rms
- m, r, cm, cr, cnt = bstat(arr[a:b, c:d], mask[a:b, c:d], kappa)
- if cnt > 198: cm = m; cr = r
- mean_map[i, j], rms_map[i, j] = cm, cr
- else:
- if npix_unmasked > 5: # just find simple mean/rms
- cm = N.mean(arr[pix_unmasked])
- cr = N.std(arr[pix_unmasked])
- mean_map[i, j], rms_map[i, j] = cm, cr
- else: # too few unmasked pixels --> set mean/rms to inf
- mean_map[i, j], rms_map[i, j] = N.inf, N.inf
-
-
- def for_masked_mp(self, mask, arr, ind, kappa):
-
- bstat = func.bstat #_cbdsm.bstat
- a, b, c, d = ind
- if mask is None:
- m, r, cm, cr, cnt = bstat(arr[a:b, c:d], mask, kappa)
- if cnt > 198: cm = m; cr = r
- else:
- pix_unmasked = N.where(mask[a:b, c:d] == False)
- npix_unmasked = N.size(pix_unmasked,1)
- if npix_unmasked > 20: # find clipped mean/rms
- m, r, cm, cr, cnt = bstat(arr[a:b, c:d], mask[a:b, c:d], kappa)
- if cnt > 198: cm = m; cr = r
- else:
- if npix_unmasked > 5: # just find simple mean/rms
- cm = N.mean(arr[pix_unmasked])
- cr = N.std(arr[pix_unmasked])
- else: # too few unmasked pixels --> set mean/rms to inf
- cm = N.inf
- cr = N.inf
-
- return cm, cr
-
-
- def remap_axis(self, size, arr):
- """Invert axis mapping done by rms_mean_map
-
- rms_mean_map 'compresses' axes by returning short arrays with
- coordinades of the boxes. This routine 'inverts' this compression
- by calculating coordinates of each pixel of the original array
- within compressed array.
-
- Parameters:
- size: size of the original (and resulting) array
- arr : 'compressed' axis array from rms_mean_map
-
- Example:
- the following 'compressed' axis (see example in rms_mean_map):
-
- ax = array([ 0. , 24.5, 49.5, 74.5, 99. ])
-
- will be remapped as:
-
- print remap_axis(100, ax)
- [ 0. 0.04081633 0.08163265 0.12244898 ....
- ...............................................
- 3.91836735 3.95918367 4. ]
-
- which means that pixel 0 in the original image corresponds to pixels
- 0 in the rms/mean_map array (which is 5x5 array).
- pixel 1 of the original image has coordinate of 0.04081633 in the
- compressed image (e.g. it has no exact counterpart, and it's value
- should be obtained by interpolation)
- """
- from math import floor, ceil
- res = N.zeros(size, dtype=N.float32)
-
- for i in range(len(arr) - 1):
- i1 = arr[i]
- i2 = arr[i+1]
- t = N.arange(ceil(i1), floor(i2)+1, dtype=float)
- res[int(ceil(i1)):int(floor(i2))+1] = i + (t-i1)/(i2-i1)
-
- return res
-
- def make_bright_src_bbox(self, coord, scale, size, shape):
- """Returns bbox given coordinates of center and scale"""
- xindx = int(coord[0]/scale[0])
- yindx = int(coord[1]/scale[1])
- xlow = xindx - int(size/2.0)
- if xlow < 0:
- xlow = 0
- xhigh = xindx + int(size/2.0) + 1
- if xhigh > shape[0]:
- xhigh = shape[0]
- ylow = yindx - int(size/2.0)
- if ylow < 0:
- ylow = 0
- yhigh = yindx + int(size/2.0) + 1
- if yhigh > shape[1]:
- yhigh = shape[1]
-
- src_center = [xindx, yindx]
- return [slice(xlow, xhigh, None), slice(ylow, yhigh, None)], src_center
-
- def output_rmsbox_size(self, img):
- """Prints rms/mean box size"""
- opts = img.opts
- do_adapt = opts.adaptive_rms_box
- mylog = mylogger.logging.getLogger("PyBDSM."+img.log+"RMSimage")
- if (opts.rms_map is not False) or (opts.mean_map not in ['zero', 'const']):
- if do_adapt:
- if opts.rms_box_bright is None:
- mylogger.userinfo(mylog, 'Derived rms_box (box size, step size)',
- '(' + str(img.rms_box_bright[0]) + ', ' +
- str(img.rms_box_bright[1]) + ') pixels (small scale)')
- else:
- mylogger.userinfo(mylog, 'Using user-specified rms_box',
- '(' + str(img.rms_box_bright[0]) + ', ' +
- str(img.rms_box_bright[1]) + ') pixels (small scale)')
- if opts.rms_box is None:
- mylogger.userinfo(mylog, 'Derived rms_box (box size, step size)',
- '(' + str(img.rms_box[0]) + ', ' +
- str(img.rms_box[1]) + ') pixels (large scale)')
- else:
- mylogger.userinfo(mylog, 'Using user-specified rms_box',
- '(' + str(img.rms_box[0]) + ', ' +
- str(img.rms_box[1]) + ') pixels (large scale)')
- else:
- if opts.rms_box is None:
- mylogger.userinfo(mylog, 'Derived rms_box (box size, step size)',
- '(' + str(img.rms_box[0]) + ', ' +
- str(img.rms_box[1]) + ') pixels')
- else:
- mylogger.userinfo(mylog, 'Using user-specified rms_box',
- '(' + str(img.rms_box[0]) + ', ' +
- str(img.rms_box[1]) + ') pixels')
diff --git a/CEP/PyBDSM/src/python/shapefit.py b/CEP/PyBDSM/src/python/shapefit.py
deleted file mode 100755
index 660aeb62c24dee5ffcd3212b8e20439a74d04424..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/python/shapefit.py
+++ /dev/null
@@ -1,166 +0,0 @@
-"""Module shapelets
-
-This will do all the shapelet analysis of islands in an image
-"""
-
-from image import *
-from islands import *
-from shapelets import *
-import mylogger
-import statusbar
-import multi_proc as mp
-import itertools
-import functions as func
-from gausfit import find_bbox
-
-
-Island.shapelet_basis=String(doc="Coordinate system for shapelet decomposition (cartesian/polar)", colname='Basis', units=None)
-Island.shapelet_beta=Float(doc="Value of shapelet scale beta", colname='Beta', units=None)
-Island.shapelet_nmax=Int(doc="Maximum value of shapelet order", colname='NMax', units=None)
-Island.shapelet_centre=Tuple(Float(), Float(),doc="Centre for the shapelet decomposition, starts from zero")
-Island.shapelet_posn_sky = List(Float(), doc="Posn (RA, Dec in deg) of shapelet centre",
- colname=['RA', 'DEC'], units=['deg', 'deg'])
-Island.shapelet_posn_skyE = List(Float(), doc="Error on sky coordinates of shapelet centre",
- colname=['E_RA', 'E_DEC'], units=['deg', 'deg'])
-Island.shapelet_cf=NArray(doc="Coefficient matrix of the shapelet decomposition", colname='Coeff_matrix', units=None)
-
-class Op_shapelets(Op):
- """ Get the image and mask from each island and send it to
- shapelet programs which can then also be called seperately """
-
- def __call__(self, img):
-
- mylog = mylogger.logging.getLogger("PyBDSM."+img.log+"Shapefit")
- bar = statusbar.StatusBar('Decomposing islands into shapelets ...... : ', 0, img.nisl)
- opts = img.opts
- if img.opts.shapelet_do:
- if opts.quiet == False:
- bar.start()
-
- # Set up multiproccessing. First create a simple copy of the Image
- # object that contains the minimal data needed.
- opts_dict = opts.to_dict()
- img_simple = Image(opts_dict)
- img_simple.pixel_beamarea = img.pixel_beamarea
- img_simple.pixel_beam = img.pixel_beam
- img_simple.thresh_pix = img.thresh_pix
- img_simple.minpix_isl = img.minpix_isl
- img_simple.clipped_mean = img.clipped_mean
- img_simple.shape = img.ch0_arr.shape
-
- # Now call the parallel mapping function. Returns a list of
- # [beta, centre, nmax, basis, cf] for each island
- shap_list = mp.parallel_map(func.eval_func_tuple,
- itertools.izip(itertools.repeat(self.process_island),
- img.islands, itertools.repeat(img_simple),
- itertools.repeat(opts)), numcores=opts.ncores,
- bar=bar)
-
- for id, isl in enumerate(img.islands):
- beta, centre, nmax, basis, cf = shap_list[id]
- isl.shapelet_beta=beta
- isl.shapelet_centre=centre
- isl.shapelet_posn_sky=img.pix2sky(centre)
- isl.shapelet_posn_skyE=[0.0, 0.0, 0.0]
- isl.shapelet_nmax=nmax
- isl.shapelet_basis=basis
- isl.shapelet_cf=cf
-
- img.completed_Ops.append('shapelets')
-
-
- def process_island(self, isl, img, opts=None):
- """Processes a single island.
-
- Returns shapelet parameters.
- """
- if opts is None:
- opts = img.opts
- if opts.shapelet_gresid:
- shape = img.shape
- thresh= opts.fittedimage_clip
- model_gaus = N.zeros(shape, dtype=N.float32)
- for g in isl.gaul:
- C1, C2 = g.centre_pix
- b = find_bbox(thresh*isl.rms, g)
- bbox = N.s_[max(0, int(C1-b)):min(shape[0], int(C1+b+1)),
- max(0, int(C2-b)):min(shape[1], int(C2+b+1))]
- x_ax, y_ax = N.mgrid[bbox]
- ffimg = func.gaussian_fcn(g, x_ax, y_ax)
- model_gaus[bbox] = model_gaus[bbox] + ffimg
- arr = isl.image - isl.islmean - model_gaus[isl.bbox]
- if N.std(arr) < thresh * isl.rms:
- return [beta, tuple(N.array(centre) + N.array(isl.origin)), nmax, basis, cf]
- else:
- arr = isl.image - isl.islmean
- mask = isl.mask_active
- basis = opts.shapelet_basis
- beam_pix = img.pixel_beam()
- mode = opts.shapelet_fitmode
- if mode != 'fit':
- mode = ''
- fixed = (0,0,0)
- (beta, centre, nmax) = self.get_shapelet_params(arr, mask, basis, beam_pix, fixed, N.array(isl.origin), mode)
-
- cf = decompose_shapelets(arr, mask, basis, beta, centre, nmax, mode)
-
- return [beta, tuple(N.array(centre) + N.array(isl.origin)), nmax, basis, cf]
-
-
- def get_shapelet_params(self, image, mask, basis, beam_pix, fixed, ori, mode, beta=None, cen=None, nmax=None):
- """ This takes as input an image, its mask (false=valid), basis="cartesian"/"polar",
- fixed=(i,j,k) where i,j,k =0/1 to calculate or take as fixed for (beta, centre, nmax),
- beam_pix has the beam in (pix_fwhm, pix_fwhm, deg),
- beta (the scale), cen (centre of basis expansion), nmax (max order). The output
- is an updated set of values of (beta, centre, nmax). If fixed is 1 and the value is not
- specified as an argument, then fixed is taken as 0."""
- from math import sqrt, log, floor
- import functions as func
- import numpy as N
-
- if fixed[0]==1 and beta==None: fixed[0]=0
- if fixed[1]==1 and cen==None: fixed[1]=0
- if fixed[2]==1 and nmax==None: fixed[2]=0
-
- if fixed[0]*fixed[1]==0:
- (m1, m2, m3)=func.moment(image, mask)
-
- if fixed[0]==0:
- beta=sqrt(m3[0]*m3[1])*2.0
- if beta == 0.0:
- beta = 0.5
- if fixed[1]==0:
- cen=m2
- if fixed[2]==0:
- (n, m)=image.shape
- nmax=int(round(sqrt(1.0*n*n+m*m)/beam_pix[1]))-1
- nmax=min(max(nmax*2+2,10),10) # totally ad hoc
- npix = N.product(image.shape)-N.sum(mask)
- if nmax*nmax >= n*m : nmax = int(floor(sqrt(npix-1))) # -1 is for when n*m is a perfect square
- if mode == 'fit': # make sure npara <= npix
- nmax_max = int(round(0.5*(-3+sqrt(1+8*npix))))
- nmax=min(nmax, nmax_max)
-
- betarange=[0.5,sqrt(beta*max(n,m))] # min, max
-
- if fixed[1]==0:
- cen=shape_findcen(image, mask, basis, beta, nmax, beam_pix) # + check_cen_shapelet
- #print 'First Centre = ',cen,N.array(cen)+ori
-
- from time import time
- t1 = time()
- if fixed[0]==0:
- beta, err=shape_varybeta(image, mask, basis, beta, cen, nmax, betarange, plot=False)
- t2 = time()
- #print 'TIME ',t2-t1, '\n'
- #print 'Final Beta = ',beta, err
-
- if fixed[1]==0 and fixed[0]==0:
- cen=shape_findcen(image, mask, basis, beta, nmax, beam_pix) # + check_cen_shapelet
- #print 'Final Cen = ',N.array(cen)+ori
-
- return beta, cen, nmax
-
-
-
-
diff --git a/CEP/PyBDSM/src/python/shapelets.py b/CEP/PyBDSM/src/python/shapelets.py
deleted file mode 100755
index bba73770d61acebe01a774c3d37f7a552a8ea14b..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/python/shapelets.py
+++ /dev/null
@@ -1,391 +0,0 @@
-"""Module shapelets.
-
-nmax => J = 0..nmax; hence nmax+1 orders calculated.
-ordermax = nmax+1; range(ordermax) has all the values of n
-Order n => J=n, where J=0 is the gaussian.
-
-"""
-
-import numpy as N
-try:
- from astropy.io import fits as pyfits
-except ImportError, err:
- import pyfits
-from scipy.optimize import leastsq
-
-def decompose_shapelets(image, mask, basis, beta, centre, nmax, mode):
- """ Decomposes image (with mask) and beta, centre (2-tuple) , nmax into basis
- shapelets and returns the coefficient matrix cf.
- Mode is 'fit' or 'integrate' for method finding coeffs. If fit then integrated
- values are taken as initial guess.
- Centre is by python convention, for retards who count from zero.
- """
- bad = False
- if (beta < 0 or beta/max(image.shape) > 5 or \
- (max(N.abs(list(centre)))-max(image.shape)/2) > 10*max(image.shape)): bad = True
-
- hc = []
- if not bad:
- hc = shapelet_coeff(nmax, basis)
- else:
- print ' Bad input params'
- ordermax=nmax+1
-
- Bset=N.zeros((ordermax, ordermax, image.shape[0], image.shape[1]), dtype=N.float32)
- cf = N.zeros((ordermax,ordermax)) # coefficient matrix, will fill up only lower triangular part.
- index = [(i,j) for i in range(ordermax) for j in range(ordermax-i)] # i=0->nmax, j=0-nmax-i
- for coord in index:
- B = shapelet_image(basis, beta, centre, hc, coord[0], coord[1], image.shape)
- if mode == 'fit': Bset[coord[0] , coord[1], ::] = B
- m = N.copy(mask)
- for i, v in N.ndenumerate(mask): m[i] = not v
-
- cf[coord] = N.sum(image*B*m)
-
- if mode == 'fit':
- npix = N.product(image.shape)-N.sum(mask)
- npara = (nmax+1)*(nmax+2)*0.5
- cfnew = fit_shapeletbasis(image, mask, cf, Bset)
- recon1 = reconstruct_shapelets(image.shape, mask, basis, beta, centre, nmax, cf)
- recon2 = reconstruct_shapelets(image.shape, mask, basis, beta, centre, nmax, cfnew)
- if N.std(recon2) < 1.2*N.std(recon1): cf = cfnew
-
- return cf
-
-def fit_shapeletbasis(image, mask, cf0, Bset):
- """ Fits the image to the shapelet basis functions to estimate shapelet coefficients
- instead of integrating it out. This should avoid the problems of digitisation and hence
- non-orthonormality. """
- import functions as func
-
- ma = N.where(~mask.flatten())
-
- cfshape = cf0.shape
- res=lambda p, image, Bset, cfshape, mask_flat : (image.flatten()-func.shapeletfit(p, Bset, cfshape))[ma]
-
- if len(ma) <= 5:
- # Not enough degrees of freedom
- cf = cf0
- else:
- (cf, flag)=leastsq(res, cf0.flatten(), args=(image, Bset, cfshape, ma))
- cf = cf.reshape(cfshape)
-
- return cf
-
-def reconstruct_shapelets(size, mask, basis, beta, centre, nmax, cf):
- """ Reconstructs a shapelet image of size, for pixels which are unmasked, for a given
- beta, centre, nmax, basis and the shapelet coefficient matrix cf. """
- rimage = N.zeros(size, dtype=N.float32)
- hc = []
- hc = shapelet_coeff(nmax, basis)
-
- index = [(i,j) for i in range(nmax) for j in range(nmax-i)]
- for coord in index:
- B = shapelet_image(basis, beta, centre, hc, coord[0], coord[1], size)
- rimage += B*cf[coord]
-
- return rimage
-
-def shapelet_image(basis, beta, centre, hc, nx, ny, size):
- """ Takes basis, beta, centre (2-tuple), hc matrix, x, y, size and returns the image of the shapelet of
- order nx,ny on an image of size size. Does what getcartim.f does in fBDSM. nx,ny -> 0-nmax
- Centre is by Python convention, for retards who count from zero. """
- from math import sqrt,pi
- try:
- from scipy import factorial
- except ImportError:
- try:
- from scipy.misc.common import factorial
- except ImportError:
- from scipy.misc import factorial
-
- hcx = hc[nx,:]
- hcy = hc[ny,:]
- ind = N.array([nx,ny])
- fact = factorial(ind)
- dumr1 = N.sqrt((2.0**(ind))*sqrt(pi)*fact)
-
- x = (N.arange(size[0],dtype=float)-centre[0])/beta
- y = (N.arange(size[1],dtype=float)-centre[1])/beta
-
- dumr3 = N.zeros(size[0])
- for i in range(size[0]):
- for j in range(ind[0]+1):
- dumr3[i] += hcx[j]*(x[i]**j)
- B_nx = N.exp(-0.50*x*x)*dumr3/dumr1[0]/sqrt(beta)
-
- dumr3 = N.zeros(size[1])
- for i in range(size[1]):
- for j in range(ind[1]+1):
- dumr3[i] += hcy[j]*(y[i]**j)
- B_ny = N.exp(-0.50*y*y)*dumr3/dumr1[1]/sqrt(beta)
-
- return N.outer(B_nx,B_ny)
-
-
-def shape_findcen(image, mask, basis, beta, nmax, beam_pix): # + check_cen_shapelet
- """ Finds the optimal centre for shapelet decomposition. Minimising various
- combinations of c12 and c21, as in literature doesnt work for all cases.
- Hence, for the c1 image, we find the zero crossing for every vertical line
- and for the c2 image, the zero crossing for every horizontal line, and then
- we find intersection point of these two. This seems to work even for highly
- non-gaussian cases. """
- import functions as func
- import sys
-
- hc = []
- hc = shapelet_coeff(nmax, basis)
-
- msk=N.zeros(mask.shape, dtype=bool)
- for i, v in N.ndenumerate(mask): msk[i] = not v
-
- n,m = image.shape
- cf12 = N.zeros(image.shape, dtype=N.float32)
- cf21 = N.zeros(image.shape, dtype=N.float32)
- index = [(i,j) for i in range(n) for j in range(m)]
- for coord in index:
- if msk[coord]:
- B12 = shapelet_image(basis, beta, coord, hc, 0, 1, image.shape)
- cf12[coord] = N.sum(image*B12*msk)
-
- if coord==(27,51): dumpy = B12
-
- B21 = shapelet_image(basis, beta, coord, hc, 1, 0, image.shape)
- cf21[coord] = N.sum(image*B21*msk)
- else:
- cf12[coord] = None
- cf21[coord] = None
-
- (xmax,ymax) = N.unravel_index(image.argmax(),image.shape) # FIX with mask
- if xmax in [1,n] or ymax in [1,m]:
- (m1, m2, m3) = func.moment(mask)
- xmax,ymax = N.round(m2)
-
- # in high snr area, get zero crossings for each horizontal and vertical line for c1, c2 resp
- tr_mask=mask.transpose()
- tr_cf21=cf21.transpose()
- try:
- (x1,y1) = getzeroes_matrix(mask, cf12, ymax, xmax) # y1 is array of zero crossings
- (y2,x2) = getzeroes_matrix(tr_mask, tr_cf21, xmax, ymax) # x2 is array of zero crossings
-
- # find nominal intersection pt as integers
- xind=N.where(x1==xmax)
- yind=N.where(y2==ymax)
- xind=xind[0][0]
- yind=yind[0][0]
-
- # now take 2 before and 2 after, fit straight lines, get proper intersection
- ninter=5
- if xind<3 or yind<3 or xind>n-2 or yind>m-2:
- ninter = 3
- xft1 = x1[xind-(ninter-1)/2:xind+(ninter-1)/2+1]
- yft1 = y1[xind-(ninter-1)/2:xind+(ninter-1)/2+1]
- xft2 = x2[yind-(ninter-1)/2:yind+(ninter-1)/2+1]
- yft2 = y2[yind-(ninter-1)/2:yind+(ninter-1)/2+1]
- sig = N.ones(ninter, dtype=float)
- smask1=N.array([r == 0 for r in yft1])
- smask2=N.array([r == 0 for r in xft2])
- cen=[0.]*2
- if sum(smask1)<len(yft1) and sum(smask2)<len(xft2):
- [c1, m1], errors = func.fit_mask_1d(xft1, yft1, sig, smask1, func.poly, do_err=False, order=1)
- [c2, m2], errors = func.fit_mask_1d(xft2, yft2, sig, smask2, func.poly, do_err=False, order=1)
- if m2-m1 == 0:
- cen[0] = cen[1] = 0.0
- else:
- cen[0]=(c1-c2)/(m2-m1)
- cen[1]=c1+m1*cen[0]
- else:
- cen[0] = cen[1] = 0.0
-
- # check if estimated centre makes sense
- error=shapelet_check_centre(image, mask, cen, beam_pix)
- except:
- error = 1
- if error > 0:
- #print 'Error '+str(error)+' in finding centre, will take 1st moment instead.'
- (m1, m2, m3) = func.moment(image, mask)
- cen = m2
-
- return cen
-
-def getzeroes_matrix(mask, cf, cen, cenx):
- """ For a matrix cf, and a mask, this returns two vectors; x is the x-coordinate
- and y is the interpolated y-coordinate where the matrix cf croses zero. If there
- is no zero-crossing, y is zero for that column x. """
-
- x = N.arange(cf.shape[0], dtype=N.float32)
- y = N.zeros(cf.shape[0], dtype=N.float32)
-
- # import pylab as pl
- # pl.clf()
- # pl.imshow(cf, interpolation='nearest')
- # ii = N.random.randint(100); pl.title(' zeroes' + str(ii))
- # print 'ZZ ',cen, cenx, ii
-
- for i in range(cf.shape[0]):
- l = [mask[i,j] for j in range(cf.shape[1])]
- npts = len(l)-sum(l)
-
- #print 'npts = ',npts
- if npts > 3 and not N.isnan(cf[i,cen]):
- mrow=mask[i,:]
- if sum(l) == 0:
- low=0
- up=cf.shape[1]-1
- else:
- low = mrow.nonzero()[0][mrow.nonzero()[0].searchsorted(cen)-1]
- #print 'mrow = ',i, mrow, low,
- try:
- up = mrow.nonzero()[0][mrow.nonzero()[0].searchsorted(cen)]
- #print 'up1= ', up
- except IndexError:
- if [mrow.nonzero()[0].searchsorted(cen)][0]==len(mrow.nonzero()):
- up = len(mrow)
- #print 'up2= ', up,
- else:
- raise
- #print
- low += 1; up -= 1
- npoint = up-low+1
- xfn = N.arange(npoint)+low
- yfn = cf[i,xfn]
- root, error = shapelet_getroot(xfn, yfn, x[i], cenx, cen)
- if error != 1:
- y[i] = root
- else:
- y[i] = 0.0
- else:
- y[i] = 0.0
-
- return x,y
-
-def shapelet_getroot(xfn, yfn, xco, xcen, ycen):
- """ This finds the root for finding the shapelet centre. If there are multiple roots, takes
- that which closest to the 'centre', taken as the intensity barycentre. This is the python
- version of getroot.f of anaamika."""
- import functions as func
-
- root=None
- npoint=len(xfn)
- error=0
- if npoint == 0:
- error = 1
- elif yfn.max()*yfn.min() >= 0.:
- error=1
-
- minint=0; minintold=0
- for i in range(1,npoint):
- if yfn[i-1]*yfn[i] < 0.:
- if minintold == 0: # so take nearest to centre
- if abs(yfn[i-1]) < abs(yfn[i]):
- minint=i-1
- else:
- minint=i
- else:
- dnew=func.dist_2pt([xco,xfn[i]], [xcen,ycen])
- dold=func.dist_2pt([xco,xfn[minintold]], [xcen,ycen])
- if dnew <= dold:
- minint=i
- else:
- minint=minintold
- minintold=minint
-
- if minint < 1 or minint > npoint: error=1
- if error != 1:
- low=minint-min(2,minint)#-1)
- up=minint+min(2,npoint-1-minint) # python array indexing rubbish
- nfit=up-low+1
- xfit=xfn[low:low+nfit]
- yfit=yfn[low:low+nfit]
- sig=N.ones(nfit)
- smask=N.zeros(nfit, dtype=bool)
- xx=[i for i in range(low,low+nfit)]
-
- [c, m], errors = func.fit_mask_1d(xfit, yfit, sig, smask, func.poly, do_err=False, order=1)
- root=-c/m
- if root < xfn[low] or root > xfn[up]: error=1
-
- return root, error
-
-def shapelet_check_centre(image, mask, cen, beam_pix):
- "Checks if the calculated centre for shapelet decomposition is sensible. """
- from math import pi
-
- error = 0
- n, m = image.shape
- x, y = round(cen[0]), round(cen[1])
- if x <= 0 or x >= n or y <= 0 or y >= m: error = 1
- if error == 0:
- if not mask[int(round(x)),int(round(y))]: error == 2
-
- if error > 0:
- if (N.product(mask.shape)-sum(sum(mask)))/(pi*0.25*beam_pix[0]*beam_pix[1]) < 2.5:
- error = error*10 # expected to fail since source is too small
-
- return error
-
-def shape_varybeta(image, mask, basis, betainit, cen, nmax, betarange, plot):
- """ Shapelet decomposes and then reconstructs an image with various values of beta
- and looks at the residual rms vs beta to estimate the optimal value of beta. """
- import _cbdsm
-
- nbin = 30
- delta = (2.0*betainit-betainit/2.0)/nbin
- beta_arr = betainit/4.0+N.arange(nbin)*delta
-
- beta_arr = N.arange(0.5, 6.05, 0.05)
- nbin = len(beta_arr)
-
- res_rms=N.zeros(nbin)
- for i in range(len(beta_arr)):
- cf = decompose_shapelets(image, mask, basis, beta_arr[i], cen, nmax, mode='')
- im_r = reconstruct_shapelets(image.shape, mask, basis, beta_arr[i], cen, nmax, cf)
- im_res = image - im_r
- ind = N.where(~mask)
- res_rms[i] = N.std(im_res[ind])
-
- minind = N.argmin(res_rms)
- if minind > 1 and minind < nbin:
- beta = beta_arr[minind]
- error = 0
- else:
- beta = betainit
- error = 1
-
-# if plot:
-# pl.figure()
-# pl.plot(beta_arr,res_rms,'*-')
-# pl.xlabel('Beta')
-# pl.ylabel('Residual rms')
-
- return beta, error
-
-def shapelet_coeff(nmax=20,basis='cartesian'):
- """ Computes shapelet coefficient matrix for cartesian and polar
- hc=shapelet_coeff(nmax=10, basis='cartesian') or
- hc=shapelet_coeff(10) or hc=shapelet_coeff().
- hc(nmax) will be a nmax+1 X nmax+1 matrix."""
- import numpy as N
-
- order=nmax+1
- if basis == 'polar':
- raise NotImplementedError, "Polar shapelets not yet implemented."
-
- hc=N.zeros([order,order])
- hnm1=N.zeros(order); hn=N.zeros(order)
-
- hnm1[0]=1.0; hn[0]=0.0; hn[1]=2.0
- hc[0]=hnm1
- hc[1]=hn
- for ind in range(3,order+1):
- n=ind-2
- hnp1=-2.0*n*hnm1
- hnp1[1:] += 2.0*hn[:order-1]
- hc[ind-1]=hnp1
- hnm1=hn
- hn=hnp1
-
- return hc
-
-
-
diff --git a/CEP/PyBDSM/src/python/sourcecounts.py b/CEP/PyBDSM/src/python/sourcecounts.py
deleted file mode 100644
index 1f33e09df195c337ede349ddef059db3db1160f5..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/python/sourcecounts.py
+++ /dev/null
@@ -1,118 +0,0 @@
-"""Sourcecounts
-
-s is flux in Jy and n is number > s per str
-"""
-
-import numpy as N
-
-s=N.array([ 9.9999997e-05, 0.00010328281, 0.00010667340, 0.00011017529, 0.00011379215, 0.00011752774, 0.00012138595, \
-0.00012537083, 0.00012948645, 0.00013373725, 0.00013812761, 0.00014266209, 0.00014734542, 0.00015218249, 0.00015717837, \
-0.00016233824, 0.00016766752, 0.00017317173, 0.00017885664, 0.00018472817, 0.00019079246, 0.00019705582, 0.00020352470, \
-0.00021020604, 0.00021710672, 0.00022423393, 0.00023159511, 0.00023919797, 0.00024705040, 0.00025516062, 0.00026353705, \
-0.00027218851, 0.00028112394, 0.00029035273, 0.00029988447, 0.00030972913, 0.00031989696, 0.00033039862, 0.00034124497, \
-0.00035244724, 0.00036401744, 0.00037596744, 0.00038830977, 0.00040105727, 0.00041422324, 0.00042782145, 0.00044186602, \
-0.00045637166, 0.00047135353, 0.00048682719, 0.00050280854, 0.00051931484, 0.00053636299, 0.00055397081, 0.00057215663, \
-0.00059093948, 0.00061033899, 0.00063037529, 0.00065106933, 0.00067244272, 0.00069451780, 0.00071731757, 0.00074086577, \
-0.00076518703, 0.00079030672, 0.00081625103, 0.00084304705, 0.00087072275, 0.00089930650, 0.00092882907, 0.00095932081, \
-0.00099081360, 0.0010233402, 0.0010569346, 0.0010916317, 0.0011274681, 0.0011644807, 0.0012027085, 0.0012421905, \
-0.0012829694, 0.0013250869, 0.0013685870, 0.0014135153, 0.0014599183, 0.0015078448, 0.0015573446, 0.0016084694, \
-0.0016612725, 0.0017158090, 0.0017721358, 0.0018303118, 0.0018903976, 0.0019524558, 0.0020165513, 0.0020827511, \
-0.0021511239, 0.0022217415, 0.0022946771, 0.0023700071, 0.0024478103, 0.0025281659, 0.0026111610, 0.0026968806, \
-0.0027854142, 0.0028768543, 0.0029712960, 0.0030688383, 0.0031695808, 0.0032736324, 0.0033810998, 0.0034920950, \
-0.0036067341, 0.0037251366, 0.0038474260, 0.0039737299, 0.0041041803, 0.0042389128, 0.0043780687, 0.0045217923, \
-0.0046702349, 0.0048235501, 0.0049818982, 0.0051454445, 0.0053143604, 0.0054888208, 0.0056690089, 0.0058551119, \
-0.0060473247, 0.0062458473, 0.0064508831, 0.0066626542, 0.0068813767, 0.0071072797, 0.0073405989, 0.0075815772, \
-0.0078304661, 0.0080875214, 0.0083530201, 0.0086272340, 0.0089104511, 0.0092029646, 0.0095050810, 0.0098171150, \
-0.010139393, 0.010472251, 0.010816036, 0.011171106, 0.011537833, 0.011916599, 0.012307799, 0.012711842, 0.013129148, \
-0.013560154, 0.014005309, 0.014465077, 0.014939931, 0.015430382, 0.015936933, 0.016460113, 0.017000468, 0.017558562, \
-0.018134978, 0.018730316, 0.019345198, 0.019980265, 0.020636180, 0.021313628, 0.022013316, 0.022735972, 0.023482339, \
-0.024253221, 0.025049411, 0.025871737, 0.026721058, 0.027598262, 0.028504262, 0.029440004, 0.030406466, 0.031404655, \
-0.032435611, 0.033500414, 0.034600168, 0.035736032, 0.036909178, 0.038120817, 0.039372254, 0.040664773, 0.041999724, \
-0.043378498, 0.044802535, 0.046273317, 0.047792386, 0.049361322, 0.050981764, 0.052655403, 0.054383982, 0.056169309, \
-0.058013245, 0.059917714, 0.061884668, 0.063916229, 0.066014484, 0.068181612, 0.070419893, 0.072731644, 0.075119294, \
-0.077585325, 0.080132306, 0.082762904, 0.085479856, 0.088286005, 0.091184273, 0.094177686, 0.097269312, 0.10046248, \
-0.10376048, 0.10716674, 0.11068483, 0.11431842, 0.11807128, 0.12194734, 0.12595065, 0.13008538, 0.13435584, 0.13876650, \
-0.14332195, 0.14802694, 0.15288639, 0.15790530, 0.16308904, 0.16844295, 0.17397262, 0.17968382, 0.18558250, 0.19167484, \
-0.19796717, 0.20446607, 0.21117832, 0.21811092, 0.22527111, 0.23266634, 0.24030435, 0.24819310, 0.25634068, 0.26475587, \
-0.27344733, 0.28242409, 0.29169556, 0.30127138, 0.31116158, 0.32137644, 0.33192664, 0.34282318, 0.35407743, 0.36570114, \
-0.37770644, 0.39010584, 0.40291208, 0.41613895, 0.42980003, 0.44390959, 0.45848233, 0.47353345, 0.48907870, 0.50513422, \
-0.52171689, 0.53884387, 0.55653316, 0.57480311, 0.59367281, 0.61316204, 0.63329101, 0.65408045, 0.67555267, 0.69772983, \
-0.72063506, 0.74429214, 0.76872587, 0.79396176, 0.82002604, 0.84694600, 0.87474972, 0.90346611, 0.93312526, 0.96375805, \
-0.99539644, 1.0280730, 1.0618227, 1.0966804, 1.1326823, 1.1698662, 1.2082708, 1.2479361, 1.2889036, 1.3312160, 1.3749173, \
-1.4200534, 1.4666711, 1.5148191, 1.5645479, 1.6159091, 1.6689565, 1.7237452, 1.7803327, 1.8387777, 1.8991414, 1.9614867, \
-2.0258787, 2.0923846, 2.1610713, 2.2320154, 2.3052883, 2.3809667, 2.4591296, 2.5398583, 2.6232371, 2.7093532, 2.7982962, \
-2.8901591, 2.9850378, 3.0830312, 3.1842413, 3.2887743, 3.3967385, 3.5082474, 3.6234167, 3.7423668, 3.8652217, 3.9921098, \
-4.1231637, 4.2585196, 4.3983188, 4.5427074, 4.6918364, 4.8458605, 5.0049415, 5.1692443, 5.3389411, 5.5142026, 5.6952238, \
-5.8821878, 6.0752892, 6.2747297, 6.4807177, 6.6934676, 6.9132018, 7.1401496, 7.3745475, 7.6166406, 7.8666806, 8.1249294, \
-8.3916559, 8.6671391, 8.9516649, 9.2455320, 9.5490456, 9.8625231, 10.186292, 10.520689, 10.866064, 11.222776, 11.591200, \
-11.971718, 12.364727, 12.770638, 13.189876, 13.622874, 14.070073, 14.531968, 15.009026, 15.501744, 16.010639, 16.536238, \
-17.079092, 17.639769, 18.218849, 18.816940, 19.434666, 20.072670, 20.731619, 21.412201, 22.115124, 22.841122, 23.590954, \
-24.365402, 25.165274, 25.991404, 26.844654, 27.725914, 28.636105, 29.576176, 30.547108, 31.549913, 32.585640, 33.655365, \
-34.760208, 35.901321, 37.079857, 38.297119, 39.554344, 40.852840, 42.193966, 43.579117, 45.009739, 46.487324, 48.013420, \
-49.589611, 51.217548, 52.898926, 54.635498, 56.429081, 58.281548, 60.194820, 62.170906, 64.211861, 66.319824, 68.496979, \
-70.745613, 73.068062, 75.466751, 77.944183, 80.502945, 83.145714, 85.875237, 88.694359, 91.606033, 94.613190, 97.719162, \
-100.92711, 104.24036, 107.66238, 111.19673, 114.84712, 118.61734, 122.51133, 126.53315, 130.68700, 134.97722, 139.40826, \
-143.98479, 148.71155, 153.59348, 158.63567, 163.84338, 169.22206, 174.77731, 180.51492, 186.44090, 192.56142, 198.88284, \
-205.41180, 212.15511, 219.11977, 226.31306, 233.74251, 241.41557, 249.34081, 257.52621, 265.98032, 274.71198, 283.73026, \
-293.04462, 302.66473, 312.60065, 322.86276, 333.46173, 344.40869, 355.71500, 367.39246, 379.45328, 391.91003, 404.77573, \
-418.06375, 431.78802, 445.96283, 460.60297, 475.72372, 491.34085, 507.47067, 524.13000, 541.33624, 559.10730, 577.46179, \
-596.41876, 615.99811, 636.21954, 657.10541, 678.67700, 700.95673, 723.96783, 747.73438, 772.28113, 797.63373, 823.81854, \
-850.86298, 878.79529, 907.64453, 937.44080, 968.21527, 1000.0000])
-
-n=N.array([ 3.7709775e+10, 3.6065767e+10, 3.4493432e+10, 3.2989649e+10, 3.1551425e+10, 3.0175900e+10, \
-2.8860342e+10, 2.7602137e+10, \
-2.6398808e+10, 2.5247922e+10, 2.4147204e+10, 2.3094475e+10, 2.2087643e+10, 2.1124704e+10, 2.0203747e+10, 1.9322939e+10, \
-1.8480527e+10, 1.7674846e+10, 1.6904289e+10, 1.6167328e+10, 1.5462490e+10, 1.4788384e+10, 1.4143675e+10, 1.3527065e+10, \
-1.2937335e+10, 1.2373316e+10, 1.1833886e+10, 1.1317971e+10, 1.0824550e+10, 1.0352640e+10, 9.9013028e+09, 9.4696428e+09, \
-9.0568028e+09, 8.6619587e+09, 8.2843305e+09, 7.9231647e+09, 7.5777439e+09, 7.2473825e+09, 6.9314243e+09, 6.6292444e+09, \
-6.3402342e+09, 6.0638244e+09, 5.7994639e+09, 5.5466291e+09, 5.3048166e+09, 5.0735457e+09, 4.8523587e+09, 4.6408141e+09, \
-4.4384916e+09, 4.2449897e+09, 4.0599278e+09, 3.8829297e+09, 3.7136481e+09, 3.5517468e+09, 3.3969042e+09, 3.2488120e+09, \
-3.1071754e+09, 2.9717143e+09, 2.8421588e+09, 2.7182515e+09, 2.5997458e+09, 2.4864064e+09, 2.3780086e+09, 2.2743360e+09, \
-2.1751834e+09, 2.0803535e+09, 1.9896579e+09, 1.9029162e+09, 1.8199575e+09, 1.7406141e+09, 1.6647299e+09, 1.5921536e+09, \
-1.5227420e+09, 1.4563558e+09, 1.3928644e+09, 1.3321405e+09, 1.2740643e+09, 1.2185199e+09, 1.1653979e+09, 1.1145907e+09, \
-1.0659987e+09, 1.0195252e+09, 9.7507763e+08, 9.3256806e+08, 8.9191149e+08, 8.5302746e+08, 8.1583853e+08, 7.8027117e+08, \
-7.4625421e+08, 7.1372032e+08, 6.8260474e+08, 6.5284576e+08, 6.2438406e+08, 5.9716326e+08, 5.7112922e+08, 5.4623008e+08, \
-5.2241651e+08, 4.9964106e+08, 4.7785866e+08, 4.5702573e+08, 4.3710147e+08, 4.1804544e+08, 3.9982026e+08, 3.8238954e+08, \
-3.6571878e+08, 3.4977482e+08, 3.3452595e+08, 3.1994208e+08, 3.0599382e+08, 2.9265363e+08, 2.7989501e+08, 2.6769266e+08, \
-2.5602224e+08, 2.4486062e+08, 2.3418562e+08, 2.2397598e+08, 2.1421147e+08, 2.0487264e+08, 1.9594099e+08, 1.8739867e+08, \
-1.7922877e+08, 1.7141509e+08, 1.6394203e+08, 1.5679477e+08, 1.4995909e+08, 1.4342146e+08, 1.3716880e+08, 1.3118874e+08, \
-1.2546940e+08, 1.1999951e+08, 1.1476796e+08, 1.0976452e+08, 1.0497919e+08, 1.0040248e+08, 96025304., 91838968., \
-87835200., 84005912., 80343576., 76840880., 73490912., 70286984., 67222736., 64292076., 61489172., 58808476., \
-56244648., 53792588., 51447432., 49204512., 47059380., 45007768., 43045600., 41168972., 39374160., 37657620., \
-36015888., 34445724., 32944024., 31507790., 30134168., 28820430., 27563966., 26362278., 25212982., 24113790., \
-23062518., 22057078., 21095472., 20175804., 19296216., 18454972., 17650402., 16880912., 16144966., 15441105., \
-14767931., 14124105., 13508346., 12919433., 12356192., 11817510., 11302309., 10809571., 10338324., 9887611.0, \
-9456547.0, 9044277.0, 8649980.0, 8272873.0, 7912207.0, 7567264.5, 7237360.0, 6921837.5, 6620071.0, 6331461.0, \
-6055433.0, 5791438.5, 5538953.0, 5297479.5, 5066528.5, 4845647.0, 4634395.5, 4432353.0, 4239119.0, 4054309.2, \
-3877556.2, 3708509.5, 3546832.0, 3392203.5, 3244316.0, 3102876.0, 2967602.0, 2838228.0, 2729847.5, 2624870.5, \
-2524750.2, 2429229.0, 2338061.0, 2251017.0, 2167880.5, 2088448.4, 2012529.5, 1939942.6, 1870518.1, 1804095.8, \
-1740523.8, 1679660.2, 1621370.6, 1565526.9, 1512157.9, 1460823.1, 1411600.0, 1364385.6, 1319083.4, 1275602.0, \
-1233855.0, 1193760.2, 1155241.0, 1118223.9, 1082639.1, 1048421.7, 1015509.1, 983842.56, 953365.38, 924024.94, \
-895770.81, 868555.00, 842332.44, 817144.38, 792764.06, 769256.56, 746584.44, 724711.62, 703604.50, 683230.62, \
-663559.44, 644562.06, 626210.06, 608477.38, 591338.81, 574770.50, 558749.50, 543254.06, 528263.38, 513757.69, \
-499717.94, 486126.28, 473019.56, 460262.88, 447906.47, 435935.03, 424334.22, 413089.53, 402187.88, 391616.53, \
-381363.44, 371416.84, 361765.66, 352399.28, 343307.47, 334480.50, 325909.12, 317584.28, 309497.50, 301640.47, \
-294005.56, 286584.88, 279402.72, 272383.66, 265559.03, 258922.31, 252467.16, 246187.56, 240077.75, 234132.17, \
-228345.47, 222712.61, 217228.62, 211888.83, 206688.67, 201623.84, 196690.11, 191883.45, 187200.03, 182636.05, \
-178187.92, 173852.23, 169645.80, 165521.64, 161500.73, 157580.05, 153756.70, 150027.80, 146390.59, 142842.50, \
-139380.91, 136003.44, 132707.70, 129491.38, 126352.36, 123288.48, 120297.67, 117378.02, 114527.58, 111744.49, \
-109027.01, 106373.41, 103781.99, 101262.79, 98789.008, 96373.047, 94013.438, 91708.680, 89457.398, 87258.211, \
-85109.805, 83010.930, 80960.391, 78956.891, 76999.320, 75086.586, 73217.594, 71391.312, 69606.703, 67862.789, \
-66158.609, 64493.254, 62865.801, 61275.387, 59728.344, 58208.258, 56722.930, 55271.520, 53853.266, 52467.410, \
-51113.223, 49789.961, 48496.941, 47233.500, 45998.977, 44792.723, 43614.117, 42462.578, 41337.504, 40238.328, \
-39164.488, 38115.469, 37090.699, 36089.668, 35111.887, 34156.848, 33228.004, 32316.406, 31426.256, 30557.111, \
-29708.504, 28880.010, 28071.193, 27281.650, 26510.949, 25758.721, 25024.562, 24308.115, 23608.990, 22926.832, \
-22261.293, 21612.029, 20978.699, 20360.971, 19758.527, 19171.037, 18598.217, 18039.732, 17495.309, 16966.436, \
-16448.930, 15944.685, 15453.382, 14974.762, 14508.550, 14054.481, 13612.296, 13181.744, 12762.577, 12354.543, \
-11957.408, 11570.935, 11194.892, 10829.060, 10473.206, 10127.119, 9790.5850, 9463.3916, 9145.3301, 8836.2021, \
-8535.8027, 8243.9434, 7961.2437, 7685.7393, 7418.2314, 7158.5264, 6906.4458, 6661.8105, 6424.4482, 6194.1807, \
-5970.8477, 5754.2710, 5544.2944, 5340.7573, 5143.5054, 4952.3828, 4767.2373, 4587.9229, 4414.2944, 4246.2085, \
-4083.5212, 3926.0977, 3773.8032, 3626.5049, 3484.0715, 3346.3752, 3213.5771, 3084.9297, 2960.6602, 2840.6472, \
-2724.7744, 2612.9258, 2504.9900, 2400.8569, 2300.4167, 2203.5654, 2110.1995, 2020.2166, 1933.5188, 1850.0120, \
-1769.5944, 1692.1769, 1617.6688, 1545.9810, 1477.0260, 1410.7202, 1346.9801, 1285.7245, 1226.8739, 1170.3518, \
-1116.1688, 1064.0614, 1014.0633, 966.10516, 920.11682, 876.03217, 833.78497, 793.31201, 754.55164, 717.44275, \
-681.92755, 647.94806, 615.44952, 584.37762, 554.67981, 526.30505, 499.20432, 473.32895, 448.63220, 425.07007, \
-402.59656, 381.16980, 360.74893, 341.31854, 322.78470, 305.14084, 288.35059, 272.37881, 257.19098, 242.75432, \
-229.03673, 216.00752, 203.63695, 191.89633])
-
-s=s/1000.0
diff --git a/CEP/PyBDSM/src/python/spectralindex.py b/CEP/PyBDSM/src/python/spectralindex.py
deleted file mode 100644
index a66cbaaa7bc07ed2fc6e99de21f971147cc58946..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/python/spectralindex.py
+++ /dev/null
@@ -1,607 +0,0 @@
-"""Module Spectral index.
-
- This module calculates spectral indices for Gaussians and sources for a multichannel cube.
-
-"""
-
-import numpy as N
-from image import *
-import mylogger
-from gaul2srl import Source
-from copy import deepcopy as cp
-import _cbdsm
-import collapse
-import sys
-import functions as func
-import time
-import statusbar
-from gausfit import Gaussian
-
-
-Gaussian.spec_indx = Float(doc = "Spectral index", colname='Spec_Indx', units=None)
-Gaussian.e_spec_indx = Float(doc = "Error in spectral index", colname='E_Spec_Indx', units=None)
-Gaussian.specin_flux = List(Float(), doc = "Total flux density per channel, Jy", colname=['Total_flux'], units=['Jy'])
-Gaussian.specin_fluxE = List(Float(), doc = "Error in total flux density per channel, Jy", colname=['E_Total_flux'], units=['Jy'])
-Gaussian.specin_freq = List(Float(), doc = "Frequency per channel, Hz", colname=['Freq'], units=['Hz'])
-Source.spec_indx = Float(doc = "Spectral index", colname='Spec_Indx', units=None)
-Source.e_spec_indx = Float(doc = "Error in spectral index", colname='E_Spec_Indx', units=None)
-Source.specin_flux = List(Float(), doc = "Total flux density, Jy", colname=['Total_flux'], units=['Jy'])
-Source.specin_fluxE = List(Float(), doc = "Error in total flux density per channel, Jy", colname=['E_Total_flux'], units=['Jy'])
-Source.specin_freq = List(Float(), doc = "Frequency per channel, Hz", colname=['Freq'], units=['Hz'])
-
-class Op_spectralindex(Op):
- """Computes spectral index of every gaussian and every source.
-
- First do a quick fit to all channels to determine whether averaging over
- frequency is needed to obtain desired SNR (set by img.opts.specind_snr).
- This averaging should be done separately for both Gaussians and
- sources. For S and C sources, averaging only needs to be done once
- (as the sources have only one Gaussian).
-
- For M sources, averaging is needed twice: once to obtain the desired
- SNR for the faintest Gaussian in the source, and once to obtain the
- desired SNR for the source as a whole.
-
- If averaging is needed for a given source, don't let the
- number of resulting channels fall below 2. If it is not possible
- to obtain the desired SNR in 2 or more channels, set spec_indx of
- Gaussian/source to NaN.
-
- """
-
- def __call__(self, img):
- global bar1
-
- mylog = mylogger.logging.getLogger("PyBDSM."+img.log+"SpectIndex")
- img.mylog = mylog
- if img.opts.spectralindex_do:
- mylogger.userinfo(mylog, '\nExtracting spectral indices for all ch0 sources')
- shp = img.image_arr.shape
- if shp[1] > 1:
- # calc freq, beam_spectrum for nchan channels
- self.freq_beamsp_unav(img)
- sbeam = img.beam_spectrum
- freqin = img.freq
-
- # calc initial channel flags if needed
- iniflags = self.iniflag(img)
- img.specind_iniflags = iniflags
- good_chans = N.where(iniflags == False)
- unav_image = img.image_arr[0][good_chans]
- unav_freqs = freqin[good_chans]
- nmax_to_avg = img.opts.specind_maxchan
- nchan = unav_image.shape[0]
- mylog.info('After initial flagging of channels by rms, %i good channels remain' % (nchan,))
- if nmax_to_avg == 0:
- nmax_to_avg = nchan
-
- # calculate the rms map of each unflagged channel
- bar1 = statusbar.StatusBar('Determing rms for channels in image ..... : ', 0, nchan)
- if img.opts.quiet == False:
- bar1.start()
- rms_spec = self.rms_spectrum(img, unav_image) # bar1 updated here
-
- bar2 = statusbar.StatusBar('Calculating spectral indices for sources : ', 0, img.nsrc)
- c_wts = img.opts.collapse_wt
- snr_desired = img.opts.specind_snr
-
- if img.opts.quiet == False and img.opts.verbose_fitting == False:
- bar2.start()
- for src in img.sources:
- isl = img.islands[src.island_id]
- isl_bbox = isl.bbox
-
- # Fit each channel with ch0 Gaussian(s) of the source,
- # allowing only the normalization to vary.
- chan_images = unav_image[:, isl_bbox[0], isl_bbox[1]]
- chan_rms = rms_spec[:, isl_bbox[0], isl_bbox[1]]
- beamlist = img.beam_spectrum
- unavg_total_flux, e_unavg_total_flux = self.fit_channels(img, chan_images, chan_rms, src, beamlist)
-
- # Check for upper limits and mask. gaus_mask is array of (N_channels x N_gaussians)
- # and is True if measured flux is upper limit. n_good_chan_per_gaus is array of N_gaussians
- # that gives number of unmasked channels for each Gaussian.
- gaus_mask, n_good_chan_per_gaus = self.mask_upper_limits(unavg_total_flux, e_unavg_total_flux, snr_desired)
-
- # Average if needed and fit again
- # First find flux of faintest Gaussian of source and use it to estimate rms_desired
- gflux = []
- for g in src.gaussians:
- gflux.append(g.peak_flux)
- rms_desired = min(gflux)/snr_desired
- total_flux = unavg_total_flux
- e_total_flux = e_unavg_total_flux
- freq_av = unav_freqs
- nchan = chan_images.shape[0]
- nchan_prev = nchan
- while min(n_good_chan_per_gaus) < 2 and nchan > 2:
- avimages, beamlist, freq_av, crms_av = self.windowaverage_cube(chan_images, rms_desired, chan_rms,
- c_wts, sbeam, freqin, nmax_to_avg=nmax_to_avg)
- total_flux, e_total_flux = self.fit_channels(img, avimages, crms_av, src, beamlist)
- gaus_mask, n_good_chan_per_gaus = self.mask_upper_limits(total_flux, e_total_flux, snr_desired)
- nchan = avimages.shape[0]
- if nchan == nchan_prev:
- break
- nchan_prev = nchan
- rms_desired *= 0.8
-
- # Now fit Gaussian fluxes to obtain spectral indices.
- # Only fit if there are detections (at specified sigma threshold)
- # in at least two bands. If not, don't fit and set spec_indx
- # and error to NaN.
- for ig, gaussian in enumerate(src.gaussians):
- npos = len(N.where(total_flux[:, ig] > 0.0)[0])
- if img.opts.verbose_fitting:
- if img.opts.flagchan_snr:
- print 'Gaussian #%i : averaged to %i channels, of which %i meet SNR criterion' % (gaussian.gaus_num,
- len(total_flux[:, ig]), n_good_chan_per_gaus[ig])
- else:
- print 'Gaussian #%i : averaged to %i channels, all of which will be used' % (gaussian.gaus_num,
- len(total_flux[:, ig]))
- if (img.opts.flagchan_snr and n_good_chan_per_gaus[ig] < 2) or npos < 2:
- gaussian.spec_indx = N.NaN
- gaussian.e_spec_indx = N.NaN
- gaussian.spec_norm = N.NaN
- gaussian.specin_flux = [N.NaN]
- gaussian.specin_fluxE = [N.NaN]
- gaussian.specin_freq = [N.NaN]
- gaussian.specin_freq0 = N.NaN
- else:
- if img.opts.flagchan_snr:
- good_fluxes_ind = N.where(gaus_mask[:, ig] == False)
- else:
- good_fluxes_ind = range(len(freq_av))
- fluxes_to_fit = total_flux[:, ig][good_fluxes_ind]
- e_fluxes_to_fit = e_total_flux[:, ig][good_fluxes_ind]
- freqs_to_fit = freq_av[good_fluxes_ind]
- fit_res = self.fit_specindex(freqs_to_fit, fluxes_to_fit, e_fluxes_to_fit)
- gaussian.spec_norm, gaussian.spec_indx, gaussian.e_spec_indx = fit_res
- gaussian.specin_flux = fluxes_to_fit.tolist()
- gaussian.specin_fluxE = e_fluxes_to_fit.tolist()
- gaussian.specin_freq = freqs_to_fit.tolist()
- gaussian.specin_freq0 = N.median(freqs_to_fit)
-
- # Next fit total source fluxes for spectral index.
- if len(src.gaussians) > 1:
- # First, check unaveraged SNRs for total source.
- src_total_flux = N.zeros((chan_images.shape[0], 1))
- src_e_total_flux = N.zeros((chan_images.shape[0], 1))
- src_total_flux[:,0] = N.sum(unavg_total_flux, 1) # sum over all Gaussians in source to obtain total fluxes in each channel
- src_e_total_flux[:,0] = N.sqrt(N.sum(N.power(e_unavg_total_flux, 2.0), 1))
- src_mask, n_good_chan = self.mask_upper_limits(src_total_flux, src_e_total_flux, snr_desired)
-
- # Average if needed and fit again
- rms_desired = src.peak_flux_max/snr_desired
- total_flux = unavg_total_flux
- e_total_flux = e_unavg_total_flux
- freq_av = unav_freqs
- nchan = chan_images.shape[0]
- nchan_prev = nchan
- while n_good_chan < 2 and nchan > 2:
- avimages, beamlist, freq_av, crms_av = self.windowaverage_cube(chan_images, rms_desired, chan_rms,
- c_wts, sbeam, freqin, nmax_to_avg=nmax_to_avg)
- total_flux, e_total_flux = self.fit_channels(img, avimages, crms_av, src, beamlist)
- src_total_flux = N.sum(total_flux, 1) # sum over all Gaussians in source to obtain total fluxes in each channel
- src_e_total_flux = N.sqrt(N.sum(N.power(e_total_flux, 2.0), 1))
- src_mask, n_good_chan = self.mask_upper_limits(src_total_flux, src_e_total_flux, snr_desired)
- nchan = avimages.shape[0]
- if nchan == nchan_prev:
- break
- nchan_prev = nchan
- rms_desired *= 0.8
-
- # Now fit source for spectral index.
- src_total_flux = src_total_flux.reshape((src_total_flux.shape[0],))
- src_e_total_flux = src_e_total_flux.reshape((src_e_total_flux.shape[0],))
- src_mask = src_mask.reshape((src_mask.shape[0],))
- if img.opts.verbose_fitting:
- if img.opts.flagchan_snr:
- print 'Source #%i : averaged to %i channels, of which %i meet SNR criterion' % (src.source_id,
- len(src_total_flux), nchan)
- else:
- print 'Source #%i : averaged to %i channels, all of which will be used' % (src.source_id,
- len(src_total_flux))
- npos = len(N.where(src_total_flux > 0.0)[0])
-
- if isinstance(n_good_chan, int):
- n_good_chan = [n_good_chan]
- if (img.opts.flagchan_snr and n_good_chan[0] < 2) or npos < 2:
- src.spec_indx = N.NaN
- src.e_spec_indx = N.NaN
- src.spec_norm = N.NaN
- src.specin_flux = [N.NaN]
- src.specin_fluxE = [N.NaN]
- src.specin_freq = [N.NaN]
- src.specin_freq0 = N.NaN
- else:
- if img.opts.flagchan_snr:
- good_fluxes_ind = N.where(src_mask == False)
- else:
- good_fluxes_ind = range(len(freq_av))
- fluxes_to_fit = src_total_flux[good_fluxes_ind]
- e_fluxes_to_fit = src_e_total_flux[good_fluxes_ind]
- freqs_to_fit = freq_av[good_fluxes_ind]
-
-# if len(freqs_to_fit.shape) == 2:
-# freqs_to_fit = freqs_to_fit.reshape((freqs_to_fit.shape[0],))
-# if len(fluxes_to_fit.shape) == 2:
-# fluxes_to_fit = fluxes_to_fit.reshape((fluxes_to_fit.shape[0],))
-# if len(e_fluxes_to_fit.shape) == 2:
-# e_fluxes_to_fit = e_fluxes_to_fit.reshape((e_fluxes_to_fit.shape[0],))
-
- fit_res = self.fit_specindex(freqs_to_fit, fluxes_to_fit, e_fluxes_to_fit)
- src.spec_norm, src.spec_indx, src.e_spec_indx = fit_res
- src.specin_flux = fluxes_to_fit.tolist()
- src.specin_fluxE = e_fluxes_to_fit.tolist()
- src.specin_freq = freqs_to_fit.tolist()
- src.specin_freq0 = N.median(freqs_to_fit)
- else:
- src.spec_norm = src.gaussians[0].spec_norm
- src.spec_indx = src.gaussians[0].spec_indx
- src.e_spec_indx = src.gaussians[0].e_spec_indx
- src.specin_flux = src.gaussians[0].specin_flux
- src.specin_fluxE = src.gaussians[0].specin_fluxE
- src.specin_freq = src.gaussians[0].specin_freq
- src.specin_freq0 = src.gaussians[0].specin_freq0
-
- if bar2.started:
- bar2.increment()
- img.completed_Ops.append('spectralindex')
- else:
- mylog.warning('Image has only one channel. Spectral index module disabled.')
- img.opts.spectralindex_do = False
-
-####################################################################################
- def flagchans_rmschan(self, crms, zeroflags, iniflags, cutoff):
- """ Calculate clipped rms (r1) of the rms as fn of channel, crms, with zeroflags
- applied and kappa=cutoff. Then exclude crms=0 (for NaN mages etc) and get ch.s
- which are more than cutoff*r1 away from median of rms. If this is less than 10 %
- of all channels, flag them.
-
- """
- # crms_rms and median dont include rms=0 channels
- nchan = len(crms)
- mean, rms, cmean, crms_rms, cnt = _cbdsm.bstat(crms, zeroflags, cutoff)
- zeroind = N.where(crms==0)[0]
- median = N.median(N.delete(crms, zeroind))
- badind = N.where(N.abs(N.delete(crms, zeroind) - median)/crms_rms >=cutoff)[0]
- frac = len(badind)/(nchan - len(zeroind))
-
- if frac <= 0.1:
- badind = N.where(N.abs(crms - median)/crms_rms >=cutoff)[0]
- iniflags[badind] = True
-
- return iniflags
-
-####################################################################################
- def iniflag(self, img):
- """ Calculate clipped rms of every channel, and then median and clipped rms of this rms distribution.
- Exclude channels where rms=0 (all pixels 0 or blanked) and of the remaining, if outliers beyond 5 sigma
- are less then 10 % of number of channels, flag them. This is done only when flagchan_rms = True.
- If False, only rms=0 (meaning, entire channel image is zero or blanked) is flagged."""
-
- image = img.image_arr
- nchan = image.shape[1]
- iniflags = N.zeros(nchan, bool)
- zeroflags = N.zeros(nchan, bool)
- crms = img.channel_clippedrms
-
- for ichan in range(nchan):
- if crms[ichan] == 0: zeroflags[ichan] = True
- iniflags = cp(zeroflags)
-
- if img.opts.flagchan_rms:
- iniflags = self.flagchans_rmschan(crms, zeroflags, iniflags, 4.0)
-
- return iniflags
-
-
-####################################################################################
- def freq_beamsp_unav(self, img):
- """ Defines img.beam_spectrum and img.freq for the unaveraged cube. """
-
- shp = img.image_arr.shape
- sbeam = img.opts.beam_spectrum
- if sbeam is not None and len(sbeam) != shp[1]: sbeam = None # sanity check
- if sbeam is None:
- sbeam = [img.beam]*shp[1]
-
- img.beam_spectrum = sbeam
- img.freq = N.zeros(shp[1])
- crval, cdelt, crpix = img.freq_pars
- if img.wcs_obj.wcs.spec == -1 and \
- img.opts.frequency_sp is None:
- raise RuntimeError("Frequency info not found in header "\
- "and frequencies not specified by user")
- else:
- if img.opts.frequency_sp is None:
- for ichan in range(shp[1]):
- img.freq[ichan] = img.wcs_obj.p2f(ichan)
- else:
- if len(img.opts.frequency_sp) != shp[1]:
- raise RuntimeError("Number of channels does not match number "\
- "of frequencies specified by user")
- for ichan in range(shp[1]):
- img.freq[ichan] = img.opts.frequency_sp[ichan]
-
-####################################################################################
- def rms_spectrum(self, img, image):
- from rmsimage import Op_rmsimage
- global bar1
- mylog = img.mylog
-
- nchan = image.shape[0]
- rms_map = img.use_rms_map
- if img.opts.kappa_clip is None:
- kappa = -img.pixel_beamarea()
- else:
- kappa = img.opts.kappa_clip
- map_opts = (kappa, img.rms_box, img.opts.spline_rank)
-
- if rms_map:
- rms_spec = N.zeros(image.shape, dtype=N.float32)
- mean = N.zeros(image.shape[1:], dtype=N.float32)
- rms = N.zeros(image.shape[1:], dtype=N.float32)
- median_rms = N.zeros(nchan)
- for ichan in range(nchan):
- if bar1.started:
- bar1.increment()
- dumi = Op_rmsimage()
- Op_rmsimage.map_2d(dumi, image[ichan], mean, rms, None, *map_opts)
- rms_spec[ichan,:,:] = rms
- median_rms[ichan] = N.median(rms)
- else:
- rms_spec = N.zeros(image.shape, dtype=N.float32)
- for ichan in range(nchan):
- if bar1.started:
- bar1.increment()
- rms_spec[ichan,:,:] = img.channel_clippedrms[ichan]
- median_rms = rms_spec
-
- str1 = " ".join(["%9.4e" % n for n in img.channel_clippedrms])
- if rms_map:
- mylog.debug('%s %s ' % ('Median rms of channels : ', str1))
- mylog.info('RMS image made for each channel')
- else:
- mylog.debug('%s %s ' % ('RMS of channels : ', str1))
- mylog.info('Clipped rms calculated for each channel')
-
- return rms_spec
-
-
-####################################################################################
- def fit_specindex(self, freqarr, fluxarr, efluxarr, do_log=False):
- """ Fits spectral index to data.
-
- do_log is True/False implies you fit spectral index in logFlux vs logFreq space or not."""
- import functions as func
- import math
- from scipy.optimize import leastsq
-
- x = freqarr
- flux = fluxarr
- eflux = efluxarr
- f0 = N.median(x)
- mask = N.zeros(len(fluxarr), dtype=bool)
-
- if do_log:
- x = N.log10(x/f0); y = N.log10(flux); sig = N.abs(eflux/flux)/2.303
- funct = func.poly
- else:
- x = x/f0; y = flux; sig = eflux
- funct = func.sp_in
-
- spin, espin = func.fit_mask_1d(x, y, sig, mask, funct, do_err=True, order=1)
-
- if do_log:
- spin[0] = math.pow(10.0, spin[0])
- espin[0] = spin[0]*math.log(10.0)*espin[0]
-
- return spin[0], spin[1], espin[1]
-
-
-########################################################################################
-
- def windowaverage_cube(self, imagein, rms_desired, chanrms, c_wts, sbeam,
- freqin, n_min=2, nmax_to_avg=10):
- """Average neighboring channels of cube to obtain desired rms in at least n_min channels
-
- The clipped rms of each channel is compared to the desired rms. If the
- clipped rms is too high, the channel is averaged with as many neighboring
- channels as necessary to obtain at least the desired rms. This is done
- until the number of OK channels is 2. The averaging is done first at
- the frequency extremes, as the frequency range of the resulting averaged
- flux array will be maximized.
-
- For example, if the desired rms is 0.1 and the list of rms's is:
-
- [0.2, 0.2, 0.3, 0.2, 0.2]
-
- the resulting channels that will be averaged are:
-
- [[0, 1], [2], [3, 4]]
- """
- from math import sqrt
- from collapse import avspc_direct, avspc_blanks
-
- nchan = imagein.shape[0]
-
- # chan_list is a list of lists of channels to average. E.g., if we have
- # 5 channels and we want to average only the first 2:
- # chan_list = [[0,1], [2], [3], [4]]
- if len(chanrms.shape) ==3:
- crms = N.mean(N.mean(chanrms, axis=1), axis=1)
- else:
- crms = chanrms
- chan_list = self.get_avg_chan_list(rms_desired, crms, nmax_to_avg)
-
- n_new = len(chan_list)
- beamlist = []
- crms_av = N.zeros(n_new)
- freq_av = N.zeros(n_new)
- imageout = N.zeros((n_new, imagein.shape[1], imagein.shape[2]), dtype=N.float32)
- blank = N.isnan(imagein[0])
- hasblanks = blank.any()
- for ichan, avg_list in enumerate(chan_list):
- if len(avg_list) > 1:
- if not hasblanks:
- imageout[ichan], dum = avspc_direct(avg_list, imagein, crms, c_wts)
- else:
- imageout[ichan], dum = avspc_blanks(avg_list, imagein, crms, c_wts)
- chan_slice = slice(avg_list[0], avg_list[1]+1)
- beamlist.append(tuple(N.mean(sbeam[chan_slice], axis=0)))
- freq_av[ichan] = N.mean(freqin[chan_slice])
- crms_av[ichan] = 1.0/sqrt(N.sum(1.0/crms[chan_slice]**2))
- else:
- imageout[ichan] = imagein[avg_list[0]]
- beamlist.append(sbeam[avg_list[0]])
- freq_av[ichan] = N.mean(freqin[avg_list[0]])
- crms_av[ichan] = 1.0/sqrt(N.sum(1.0/crms[avg_list[0]]**2))
-
- return imageout, beamlist, freq_av, crms_av
-
-
- def get_avg_chan_list(self, rms_desired, chanrms, nmax_to_avg):
- """Returns a list of channels to average to obtain given rms_desired
- in at least 2 channels"""
- end = 0
- chan_list = []
- nchan = len(chanrms)
- good_ind = N.where(N.array(chanrms)/rms_desired < 1.0)[0]
- num_good = len(good_ind)
- if num_good < 2:
- # Average channels at start of list
- rms_avg = chanrms[0]
- while rms_avg > rms_desired:
- end += 1
- chan_slice = slice(0, end)
- rms_avg = 1.0/N.sqrt(N.sum(1.0/N.array(chanrms)[chan_slice]**2))
- if end == nchan or end == nmax_to_avg:
- break
- if end == 0:
- end = 1
- chan_list.append(range(end))
- if end == nchan:
- # This means all channels are averaged into one. If this happens,
- # instead average first half and second half to get two channels
- # and return.
- chan_list = [range(0, int(float(nchan)/2.0)), range(int(float(nchan)/2.0), nchan)]
- return chan_list
-
- # Average channels at end of list
- rms_avg = chanrms[-1]
- end = nchan
- start = nchan
- while rms_avg > rms_desired:
- start -= 1
- chan_slice = slice(start, end)
- rms_avg = 1.0/N.sqrt(N.sum(1.0/chanrms[chan_slice]/chanrms[chan_slice]))
- if end-start == nmax_to_avg:
- break
-
- if start <= max(chan_list[0]):
- # This means we cannot get two averaged channels with desired rms,
- # so just average remaining channels
- chan_list.append(range(max(chan_list[0]), nchan))
- else:
- # First append any channels between those averaged at the start
- # and those at the end
- for i in range(max(chan_list[0])+1, start):
- chan_list.append([i])
- if start < end:
- chan_list.append(range(start, end))
- else:
- # No averaging needed
- for i in range(nchan):
- chan_list.append([i])
- return chan_list
-
-
- def fit_channels(self, img, chan_images, clip_rms, src, beamlist):
- """Fits normalizations of Gaussians in source to multiple channels
-
- If unresolved, the size of the Gaussians are adjusted to match the
- channel's beam size (given by beamlist) before fitting.
-
- Returns array of total fluxes (N_channels x N_Gaussians) and array
- of errors (N_channels x N_Gaussians).
- """
- import functions as func
- from const import fwsig
-
- isl = img.islands[src.island_id]
- isl_bbox = isl.bbox
- nchan = chan_images.shape[0]
- x, y = N.mgrid[isl_bbox]
- gg = src.gaussians
- fitfix = N.ones(len(gg)) # fit only normalization
- srcmask = isl.mask_active
-
- total_flux = N.zeros((nchan, len(fitfix))) # array of fluxes: N_channels x N_Gaussians
- errors = N.zeros((nchan, len(fitfix))) # array of fluxes: N_channels x N_Gaussians
- for cind in range(nchan):
- image = chan_images[cind]
- gg_adj = self.adjust_size_by_freq(img.beam, beamlist[cind], gg)
- p, ep = func.fit_mulgaus2d(image, gg_adj, x, y, srcmask, fitfix, adj=True)
- pbeam = img.beam2pix(beamlist[cind])
- bm_pix = (pbeam[0]/fwsig, pbeam[1]/fwsig, pbeam[2]) # IN SIGMA UNITS
- for ig in range(len(fitfix)):
- total_flux[cind, ig] = p[ig*6]*p[ig*6+3]*p[ig*6+4]/(bm_pix[0]*bm_pix[1])
- p = N.insert(p, N.arange(len(fitfix))*6+6, total_flux[cind])
- rms_isl = N.mean(clip_rms[cind])
- errors[cind] = func.get_errors(img, p, rms_isl, bm_pix=(bm_pix[0]*fwsig, bm_pix[1]*fwsig, bm_pix[2]))[6]
- self.reset_size(gg)
-
- return total_flux, errors
-
- def adjust_size_by_freq(self, beam_ch0, beam, gg):
- """Adjust size of unresolved Gaussians to match the channel's beam size"""
- gg_adj = []
- for g in gg:
- g.size_pix_adj = g.size_pix[:]
- if g.deconv_size_sky[0] == 0.0:
- g.size_pix_adj[0] *= beam[0] / beam_ch0[0]
- if g.deconv_size_sky[1] == 0.0:
- g.size_pix_adj[1] *= beam[1] / beam_ch0[1]
- gg_adj.append(g)
- return gg_adj
-
- def reset_size(self, gg):
- """Reset size of unresolved Gaussians to match the ch0 beam size"""
- for g in gg:
- if hasattr(g, 'size_pix_adj'): del g.size_pix_adj
-
- def mask_upper_limits(self, total_flux, e_total_flux, threshold):
- """Returns mask of upper limits"""
- mask = N.zeros(total_flux.shape, dtype=bool)
- if len(total_flux.shape) == 1:
- is_src = True
- ndet = 0
- ncomp = 1
- else:
- is_src = False
- ndet = N.zeros((total_flux.shape[1]), dtype=int)
- ncomp = len(ndet)
- for ig in range(ncomp):
- for ichan in range(total_flux.shape[0]):
- if is_src:
- meas_flux = total_flux[ichan]
- e_meas_flux = e_total_flux[ichan]
- else:
- meas_flux = total_flux[ichan, ig]
- e_meas_flux = e_total_flux[ichan, ig]
- if meas_flux < threshold * e_meas_flux:
- # Upper limit
- if is_src:
- mask[ichan] = True
- else:
- mask[ichan, ig] = True
- else:
- # Detection
- if is_src:
- ndet += 1
- mask[ichan] = False
- else:
- ndet[ig] += 1
- mask[ichan, ig] = False
- return mask, ndet
diff --git a/CEP/PyBDSM/src/python/statusbar.py b/CEP/PyBDSM/src/python/statusbar.py
deleted file mode 100644
index 6e438fc620a77c343f19e83f841c650a5236074d..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/python/statusbar.py
+++ /dev/null
@@ -1,98 +0,0 @@
-"""Display an animated statusbar"""
-import sys
-import os
-import functions as func
-
-class StatusBar():
- # class variables:
- # max: number of total items to be completed
- # pos: number of completed items
- # spin_pos: current position in array of busy_chars
- # inc: amount of items to increment completed 'pos' by
- # (shared resource)
- # comp: amount of '=' to display in the progress bar
- # started: whether or not the statusbar has been started
- # color: color of text
- def __init__(self, text, pos=0, max=100, color='\033[0m'):
- self.text = text
- self.pos = pos
- self.max = max
- self.busy_char = '|'
- self.spin_pos = 0
- self.inc = 0
- self.started = 0
- self.color = color
- self.__getsize()
- if max > 0:
- self.comp = int(float(self.pos) / self.max * self.columns)
- else:
- self.comp = 0
-
- # find number of columns in terminal
- def __getsize(self):
- try:
- rows, columns = func.getTerminalSize()
- except ValueError:
- rows = columns = 0
- if int(columns) > self.max + 2 + 44 + (len(str(self.max))*2 + 2):
- self.columns = self.max
- else:
- # note: -2 is for brackets, -44 for 'Fitting islands...' text, rest is for pos/max text
- self.columns = int(columns) - 2 - 44 - (len(str(self.max))*2 + 2)
- return
-
- # redraw progress bar
- def __print(self):
- self.__getsize()
-
- sys.stdout.write('\x1b[1G')
- if self.max == 0:
- sys.stdout.write(self.color + self.text + '[] 0/0\033[0m\n')
- else:
- sys.stdout.write(self.color + self.text + '[' + '=' * self.comp + self.busy_char + '-'*(self.columns - self.comp - 1) + '] ' + str(self.pos) + '/' + str(self.max) + '\033[0m')
- sys.stdout.write('\x1b[' + str(self.comp + 2 + 44) + 'G')
- sys.stdout.flush()
- return
-
- # spin the spinner by one increment
- def spin(self):
- busy_chars = ['|','/','-','\\']
- self.spin_pos += 1
- if self.spin_pos >= len(busy_chars):
- self.spin_pos = 0
- # display the busy spinning icon
- self.busy_char = busy_chars[self.spin_pos]
- sys.stdout.write(self.color + busy_chars[self.spin_pos] + '\x1b[1D' + '\033[0m')
- sys.stdout.flush()
-
- # increment number of completed items
- def increment(self):
- self.inc = 1
- if (self.pos + self.inc) >= self.max:
- self.pos = self.max
- self.comp = self.columns
- self.busy_char = ''
- self.__print()
- return 0
- else:
- self.pos += self.inc
- self.inc = 0
- self.spin()
- self.comp = int(float(self.pos) / self.max \
- * self.columns)
- self.__print()
- return 1
-
- def start(self):
- self.started = 1
- self.__print()
-
- def stop(self):
- if self.started:
- self.pos = self.max
- self.comp = self.columns
- self.busy_char = ''
- self.__print()
- sys.stdout.write('\n')
- self.started = 0
- return 0
diff --git a/CEP/PyBDSM/src/python/tc.py b/CEP/PyBDSM/src/python/tc.py
deleted file mode 100644
index d4afe0c32a4c4cfd243b83c9c3804f231fb91bcb..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/python/tc.py
+++ /dev/null
@@ -1,717 +0,0 @@
-"""Defines some basic facilities for handling typed values.
-
-
-It's quite basic and limited implementation tailored specifically for
-use in the PyBDSM user-options and derived properties. For a user
-option, one can define a group that is used when listing the options to
-the screen. For a property (e.g., flux density), one can define the
-column name to be used on output and the associated units.
-
-For a much more generic and capable implementation I can recommend
-to look at Enthought Traits package:
- http://code.enthought.com/projects/traits
-
-
-Defined are:
- - a number tc-handlers which allow to type-check and/or cast
- values to the specific type (tcCType, tcEnum, tcTuple,
- tcOption, tcInstance, tcList, tcAny). These aren't really
- inteded for use by end-user.
-
- - class TC, which implements a concept of type-checked property
- with default value.
-
- - a number of wrappers around TC to simplify it's usage (Int,
- Float, Bool, String, Tuple, Enum, Option, NArray, Instance,
- tInstance, List, Any)
-
-Usage:
-For the most needs it's enough to use wrapper-interface.
-One important remark -- class containing tc-variables should be
-new-style class, thus you should explicitly inherit from 'object'
-for Python < 2.6.
-
-Example:
-from tc import Int, Float, Bool, String, Tuple, Enum, \\
- Option, NArray, Instance, Any, TCInit
-
-class tst(object):
- intval = Int(doc="Integer value")
- boolval = Bool(True, "Some boolean flag")
- op_type = Enum("op1", "op2", doc="Some enumerated value")
-
- def __init__(self):
- TCInit(self) ### this is optional
-
-v = tst()
-v.intval = 1 # OK
-v.intval = "33" # OK, casted to 33
-v.intval = "failure" # FAILS
-v.op_type= "op2" # OK
-v.op_type= "op3" # FAILS
-"""
-import exceptions
-import types
-
-_sequence_types = (types.ListType, types.TupleType)
-_class_types = (types.ClassType, types.TypeType)
-_basic_types = (types.BooleanType, types.IntType, types.LongType,
- types.FloatType, types.ComplexType,
- types.StringType, types.UnicodeType)
-
-
-############################################################
-## Wrappers around TC to simplify it's usage for end-users
-############################################################
-def Int(value=0, doc=None, group=None, colname=None, units=None):
- """Create tc-value of type int"""
- return TC(value, tcCType(int), doc, group, colname, units)
-
-def Float(value=0., doc=None, group=None, colname=None, units=None):
- """Create tc-value of type float"""
- return TC(value, tcCType(float), doc, group, colname, units)
-
-def Bool(value=False, doc=None, group=None):
- """Create tc-value of type bool"""
- return TC(value, tcCType(bool), doc, group)
-
-def String(value='', doc=None, group=None, colname=None, units=None):
- """Create tc-value of type string"""
- return TC(value, tcCType(str), doc, group, colname, units)
-
-def Tuple(*values, **kws):
- """Create tc-value of type tuple.
-
- Parameters:
- values: zero or more arguments
- kws: keyword arguments. Currently only 'doc' and 'group'
- are recognized
-
- If the first item of values is a tuple, it's used as the
- default value. The remaining arguments are used to build
- type constraints and should be TC values.
-
- Examples:
- Tuple((1,2,3)) # tuple of 3 integers, default = (1,2,3)
- Tuple(Int(3), Float(2)) # tuple of int&float, default = (3, 2.0)
- Tuple((1,2), Int(3), Float(2)) # tuple of int+float, default = (1, 2.0)
- """
- doc = kws.pop('doc', None)
- group = kws.pop('group', None)
- if len(values) == 0:
- return TC((), tcTuple(), doc, group)
-
- default = None
- if isinstance(values[0], tuple):
- default, values = values[0], values[1:]
-
- if default is None:
- default = tuple([x._default for x in values])
-
- if len(values) == 0:
- values = [tc_from(x) for x in default]
-
- return TC(default, tcTuple(*values), doc, group)
-
-def Enum(*values, **kws):
- """Create tc-value of type enum.
-
- Parameters:
- values: list or tuple of valid values
- kws: keyword arguments. Currently only 'doc' and 'group'
- are recognized
-
- Default value is taken to be values[0].
-
- Examples:
- Enum(3, [1,2,3]) # enum of 1,2,3 with default of 3
- Enum(1,2,3) # enum of 1,2,3 with default of 1
- """
- default = values[0]
- if (len(values) == 2) and (type(values[1]) in _sequence_types):
- values = values[1]
-
- doc = kws.pop('doc', None)
- group = kws.pop('group', None)
-
- return TC(default, tcEnum(*values), doc, group)
-
-def Option(value, type=None, doc=None, group=None):
- """Creates optional tc-value.
-
- Parameters:
- value, type: default value and type
- doc: doc-string for the value
- group: group designation for the value
- """
- if type is None:
- type = tc_from(value)
-
- if isinstance(value, TC):
- value = value._default
-
- return TC(value, tcOption(type), doc, group)
-
-def NArray(value=None, or_none=True, doc=None, group=None, colname=None,
- units=None):
- """Creates tc-value which holds Numpy arrays
-
- Parameters:
- value: default value
- or_none: if 'None' is valid value
- group: group designation for the value
- colname: name of column if quantity is to be output
- units: units if quantity is to be output
- """
- try:
- import numpy as N
- except:
- raise tcError, "Can't create tc-value of type NArray " \
- "without access to numpy module"
-
- return Instance(value, N.ndarray, or_none, doc, group, colname, units)
-
-def Instance(value, type=None, or_none=True, doc=None, group=None,
- colname=None, units=None):
- """Creates tc-value which holds instances of specific class.
-
- Parameters:
- value, type: default value and type
- or_none: flag if 'None' is valid value for this variable
- group: group designation for the value
- colname: name of column if quantity is to be output
- units: units if quantity is to be output
-
- Examples:
- Instance(instance, class)
- Instance(instance)
- Instance(class)
- """
- if type is None:
- if isinstance(value, _class_types):
- value, type = None, value
- else:
- type = value.__class__
-
- return TC(value, tcInstance(type, or_none), doc, group, colname, units)
-
-def tInstance(type, or_none=False):
- """Create tc-handler for values which are instances of
- the specific class.
-
- This function is useless on it's own, and should be
- used to create Instane-constrain for compound tc-values.
- It's especially usefull for classes which have non-trivial
- constructors.
-
- Parameters:
- type: target type/class
- or_none: flag if 'None' is valid value for this variable
-
- Example: we want to define tc-variable holding a list of objects
- List(Instance(slice, or_none=False) ## FAILS, no default value
- List(Instance(slice)) ## works, but list MAY contain None's
- List(tInstance(slice)) ## GOOD
- """
- if not isinstance(type, _class_types):
- type = type.__class__
-
- return tcInstance(type, or_none)
-
-def List(value, type=None, doc=None, group=None, colname=None, units=None):
- """Creates tc-value which represents a list, where each element
- obeys specific type-constrains.
-
- Parameters:
- doc: docstring for the object
- value, type: default value and type
- group: parameter group to which the option belongs
- colname: name of column if quantity is to be output
- units: units if quantity is to be output
-
-
- Examples:
- List(Int()) # list of integers, default value is []
- List([1,2], Int()) # list of integers, default value is [1,2]
-
-
- Just one more warning -- List always has default value
- ([] in the simples case), and this default value is shared
- between the instances, so be carefull to not modify it.
-
- Counter-example for it:
- class tst(object):
- l = List(Int())
-
- x1 = tst()
- x2 = tst() # both instances share default value
-
- x1.l.append(1)
- print x2.l # this will print [1]
-
- x1.l = [2]
- print x2.l # still [1], as x1 has it's own local value now
- """
- if type is None:
- value, type = [], tc_from(value)
-
- return TC(value, tcList(type), doc, group, colname, units)
-
-def Any(value=None, doc=None, group=None):
- """Creates tc-value of arbitrary type
- (e.g. no type-checking is done)
- """
- return TC(value, tcAny(), doc, group)
-
-def TCInit(obj):
- """Initialize tc-variables in the new instance"""
- TC.set_property_names(obj.__class__)
- obj._tc_values = {}
-
-
-############################################################
-## Exception type
-############################################################
-class tcError(exceptions.Exception):
- """Custom exception type to simplify exception handling"""
- pass
-
-
-############################################################
-## TC -- type-checked variable
-############################################################
-class TC(object):
- """TC is an implementation of the typed-checked value.
-
- The primary usage pattern is via class attributes:
-
- class Test(object): ### MUST be new-style object
- value1 = Int(3)
- value2 = Tuple(Int(5), Option(Any()))
-
- test = Test()
- print test.value1
- test.value2 = (3, None)
-
- An important restriction -- it might only be used with
- new-style objects (e.g. objects derived from 'object'
- or 'type'. And the attribute should be defined in the
- class of the object.
- """
- def __init__(self, value, _type=None, doc=None, group=None, colname=None,
- units=None):
- """Create typed-checked object.
-
- Parameters:
- value: default value
- _type: type specification (instance of tcHandler) or None
- doc: docstring for the object
- group: parameter group to which the option belongs
- colname: name of column if quantity is to be output
- units: units if quantity is to be output
- """
- if _type is not None:
- self._type = _type
- else:
- self._type = tc_from(value)
-
- self._default = self._type.cast(value)
- self._name = None # name is unknown atm
- self._group = group
- self._doc = doc
- self._colname = colname
- self._units = units
-
- self.__doc__ = "default value is %s (%s)" % \
- (str(self._default), self._type.info())
-
- if doc is not None:
- self.__doc__ += "\n" + doc
-
- def __get__(self, instance, cls):
- """Get a value from instance (or return default value)"""
- if instance is None:
- return self
-
- try:
- return instance._tc_values[self]
- except:
- return self._default
-
- def __set__(self, instance, value):
- """Set a value"""
- try:
- values = instance._tc_values
- except:
- values = instance._tc_values = {}
-
- if not self._name:
- self.set_property_names(instance.__class__)
-
- values[self] = self._type.cast(value, self._name,
- instance.__class__.__name__)
-
- def __delete__(self, instance):
- """Revert value to default"""
- try:
- del instance._tc_values[self]
- except:
- pass
-
- def cast(self, value, *args):
- """See tcHandler.cast"""
- return self._type.cast(value, *args)
-
- def info(self):
- """Return description of tc-value"""
- return self.__doc__
-
- def doc(self):
- """Return short description of tc-value"""
- return self._doc
-
- def group(self):
- """Return group designation of tc-value"""
- return self._group
-
- def colname(self):
- """Return column name designation of tc-value"""
- return self._colname
-
- def units(self):
- """Return units designation of tc-value"""
- return self._units
-
- @staticmethod
- def set_property_names(klass):
- """Scan class definition and update _name for all
- TC objects defined there"""
- for k,v in klass.__dict__.iteritems():
- if isinstance(v, TC):
- v._name = k
-
-
-############################################################
-## tcHandler and derived handlers for the specific
-## types/values
-############################################################
-class tcHandler(object):
- """Base class for all tc-handlers"""
- def cast(self, value, *args):
- """Check that provided value meets type requirements
- or cast it to the specific type.
- """
- self.error(strx(value), *args)
-
- def is_valid(self, value):
- """Check if provided value can be safely casted to the
- proper type"""
- try:
- self.cast(value)
- return True
- except:
- return False
-
- def info(self):
- """A description of a valid values"""
- return "value of unknown type"
-
- def error(self, value, *args):
- if len(args) == 2 and args[0]:
- error = "Failed to set property %s of class %s " \
- "to a value of %s; expected %s." % \
- (args[0], args[1], value, self.info())
- else:
- error = "A value of %s can't be casted to %s" % \
- (value, self.info())
- raise tcError(error, value, self.info(), *args)
-
-
-############################################################
-class tcAny(tcHandler):
- """Allows any values of any type"""
- def cast(self, value, *args):
- return value
-
- def info(self):
- return "any value"
-
-
-############################################################
-class tcCType(tcHandler):
- """Ensures that value has a specific python type
-
- This handler implements so-called casting-approach, where
- it will accept all values which can be converted to the
- required type by the means of casting operation. For
- example:
-
- v = tcCType(int)
- print v.cast(3) # casted to 3
- print v.cast(3.3) # casted to 3
- print v.cast("3") # casted to 3
- """
- def __init__(self, _type):
- """Creates tcType handler.
-
- Parameters:
- _type: Python type object or a value of a reqired type
- """
- if not isinstance(_type, types.TypeType):
- _type = type(_type)
-
- self.type = _type
-
- def cast(self, value, *args):
- if type(value) is self.type:
- return value
-
- try:
- return self.type(value)
- except:
- self.error("%s (%s)" % (str_type(value), reprx(value)),
- *args)
-
- def info(self):
- return "a value of %s" % str_type(self.type)
-
-
-############################################################
-class tcEnum(tcHandler):
- """Ensures that a value is a member of a specified list of values"""
- def __init__(self, *values):
- """Creates a tcEnum handler.
-
- Parameters:
- values: list or tuple of all legal values
-
- Description:
- The list of values can be provided as a list/tuple of values
- or just specified in-line. So that ''tcEnum([1,2,3])'' and
- ''tcEnum(1,2,3)'' are equivalent.
- """
- if len(values) == 1 and type(values[0]) in _sequence_types:
- values = values[0]
-
- self.values = values
-
- def cast(self, value, *args):
- if value in self.values:
- return value
-
- self.error(repr(value), *args)
-
- def info(self):
- res = "a value of %s" % \
- " or ".join([repr(x) for x in self.values])
- return res
-
-
-############################################################
-class tcTuple(tcHandler):
- """Ensures that a value is a tuple of specified length,
- with elements that are of specified type
- """
- def __init__(self, *args):
- """Creates a tcTuple handler.
-
- Parameters:
- args: list of tuple components
-
- Description:
- Each tuple component should be either a specific
- tc-handler or a value which can be converted to it
- (by the means of tc_from function)
- """
- self.tcs = tuple([tc_from(x) for x in args])
-
- def cast(self, value, *args):
- try:
- if type(value) in _sequence_types:
- if len(value) == len(self.tcs):
- res = []
- for i, h in enumerate(self.tcs):
- res.append(h.cast(value[i]))
- return tuple(res)
- except:
- pass
-
- self.error(reprx(value), *args)
-
- def info(self):
- res = "a tuple of the form: (%s)" % \
- ", ".join([x.info() for x in self.tcs])
- return res
-
-
-############################################################
-class tcOption(tcHandler):
- """Implements an optional value: None or a value
- restricted by another tcHandler"""
- def __init__(self, _type):
- """Creates tcOption handler.
-
- Parameters:
- _type: tc-handle, Python type object or a value of
- a reqired type
- """
- self.type = tc_from(_type)
-
- def cast(self, value, *args):
- try:
- if value is None:
- return value
- return self.type.cast(value)
- except:
- self.error("%s (%s)" % (str_type(value), reprx(value)),
- *args)
-
- def info(self):
- return self.type.info() + " or None"
-
-
-############################################################
-class tcInstance(tcHandler):
- """Ensures that a value belongs to a specified python
- class or type (or one of it's subclasses).
- """
- def __init__(self, klass, or_none=True):
- """Creates tcInstance handler.
-
- Parameters:
- klass: Python class, type or an instance of python class
- or_none: whether we should accept None as a valid value
- (defaults to True)
- """
- if not isinstance(klass, _class_types):
- klass = klass.__class__
- self.klass = klass
- self.or_none = or_none
-
- def cast(self, value, *args):
- if (value is None) and self.or_none:
- return value
- if isinstance(value, self.klass):
- return value
-
- self.error(reprx(value), *args)
-
- def info(self):
- res = "an instance of " + str_type(self.klass)
- if self.or_none:
- res += " or None"
-
- return res
-
-
-############################################################
-class tcList(tcHandler):
- """Ensures that a value is a list containing elements of
- a specified kind. It also ensures that any change made
- to the list does't violate the list type constrains.
- """
- def __init__(self, kind):
- """Creates tcList handler.
-
- Parameters:
- kind: tc-handler constraining elements of the list
- """
- self.type = tc_from(kind)
-
- def cast(self, value, *args):
- if isinstance(value, _sequence_types):
- return tcListObject(self, value, args)
-
- self.error(reprx(value), *args)
-
- def info(self):
- return "a list where each element is " + self.type.info()
-
-
-############################################################
-class tcListObject(list):
- """Helper class for tcList.
-
- It's basically a customized implementation of list type,
- which imposes specific type constrains on it's elements.
- """
- def __init__(self, tc, values, extras):
- self.list_handler = tc
- self.type = tc.type
- self.extras = extras
-
- ## type-check initial values
- self.__setslice__(0, 0, values)
-
- def __setitem__(self, key, value):
- v = self.type.cast(value, *self.extras)
- list.__setitem__(self, key, v)
-
- def __setslice__(self, i, j, values):
- cast = self.type.cast
- v = [cast(x, *self.extras) for x in values]
- list.__setslice__(self, i, j, v)
-
- def append(self, value):
- v = self.type.cast(value, *self.extras)
- list.append(self, v)
-
- def extend(self, values):
- cast = self.type.cast
- v = [cast(x, *self.extras) for x in values]
- list.extend(self, v)
-
- def insert(self, idx, value):
- v = self.type.cast(value, *self.extras)
- list.insert(self, idx, v)
-
-
-############################################################
-def tc_from(v):
- """tc_from tries to guess an appropriate tc-handler for the
- provided object.
-
- The basic logic is a following:
- - TC object results in it's internal type constrain
- - for a instances and type-objects of the basic numerica
- types we use tcCType handler
- - a list of values results in tcEnum handler
- - a tuple of values results in tcTuple handler
- - a value of None results in tcAny handler
- """
- if isinstance(v, TC):
- return v._type
- if isinstance(v, tcHandler):
- return v
- if v in _basic_types:
- return tcCType(v)
- if type(v) in _basic_types:
- return tcCType(v)
- if type(v) is types.ListType:
- return tcEnum(v)
- if type(v) is types.TupleType:
- return tcTuple(*v)
- if v is None:
- return tcAny()
-
- error = "Can't create tc-handler for a value of %s (%s)" %\
- (str_type(v), reprx(v))
- raise tcError(error)
-
-
-############################################################
-def str_type(v):
- """Pretty-print type of v"""
- if isinstance(v, _class_types):
- return repr(v)[1:-1]
- else:
- return repr(type(v))[1:-1]
-
-
-############################################################
-def reprx(v):
- """Pretty-print value of v"""
- if type(v) is types.InstanceType:
- return v.__class__.__name__
- else:
- return repr(v)
diff --git a/CEP/PyBDSM/src/python/threshold.py b/CEP/PyBDSM/src/python/threshold.py
deleted file mode 100644
index aec020dde432306f6f048bf96cef955702a4c947..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/python/threshold.py
+++ /dev/null
@@ -1,114 +0,0 @@
-"""Module threshold.
-
-Defines operation Op_threshold. If the option 'thresh' is defined
-as 'fdr' then the value of thresh_pix is estimated using the
-False Detection Rate algorithm (using the user defined value
-of fdr_alpha). If thresh is None, then the false detection
-probability is first calculated, and if the number of false source
-pixels is more than fdr_ratio times the estimated number of true source
-pixels, then FDR is chosen, else the hard threshold option is chosen.
-
-Masked images aren't handled properly yet.
-"""
-
-import numpy as N
-from image import Op, Image, NArray
-from math import sqrt,pi,log
-from scipy.special import erfc
-import const
-import mylogger
-
-
-class Op_threshold(Op):
- """Calculates FDR threshold if necessary.
-
- Prerequisites: Module preprocess and rmsimage should be run first.
- """
- def __call__(self, img):
- mylog = mylogger.logging.getLogger("PyBDSM."+img.log+"Threshold ")
- data = img.ch0_arr
- mask = img.mask_arr
- opts = img.opts
- size = N.product(img.ch0_arr.shape)
- sq2 = sqrt(2)
-
- if img.opts.thresh is None:
- source_p = self.get_srcp(img)
- cutoff = 5.0
- false_p = 0.5*erfc(cutoff/sq2)*size
- if false_p < opts.fdr_ratio*source_p:
- img.thresh = 'hard'
- mylogger.userinfo(mylog, "Expected 5-sigma-clipped false detection rate < fdr_ratio")
- mylogger.userinfo(mylog, "Using sigma-clipping ('hard') thresholding")
- else:
- img.thresh = 'fdr'
- mylogger.userinfo(mylog, "Expected 5-sigma-clipped false detection rate > fdr_ratio")
- mylogger.userinfo(mylog, "Using FDR (False Detection Rate) thresholding")
- mylog.debug('%s %g' % ("Estimated number of source pixels (using sourcecounts.py) is ",source_p))
- mylog.debug('%s %g' % ("Number of false positive pixels expected for 5-sigma is ",false_p))
- mylog.debug("Threshold for pixels set to : "+str.swapcase(img.thresh))
- else:
- img.thresh = img.opts.thresh
-
- if img.thresh=='fdr':
- cdelt = img.wcs_obj.acdelt[:2]
- bm = (img.beam[0], img.beam[1])
- area_pix = int(round(N.product(bm)/(abs(N.product(cdelt))* \
- pi/(4.0*log(2.0)))))
- s0 = 0
- for i in range(area_pix):
- s0 += 1.0/(i+1)
- slope = opts.fdr_alpha/s0
- # sort erf of normalised image as vector
- v = N.sort(0.5*erfc(N.ravel((data-img.mean_arr)/img.rms_arr)/sq2))[::-1]
- pcrit = None
- for i,x in enumerate(v):
- if x < slope*i/size:
- pcrit = x
- break
- if pcrit is None:
- raise RuntimeError("FDR thresholding failed. Please check the input image for problems.")
- dumr1 = 1.0-2.0*pcrit
- dumr = 8.0/3.0/pi*(pi-3.0)/(4.0-pi)
- # approx for inv(erfc)
- sigcrit = sqrt(-2.0/pi/dumr-log(1.0-dumr1*dumr1)/2.0+ \
- sqrt((2.0/pi/dumr+log(1.0-dumr1*dumr1)/2.0)* \
- (2.0/pi/dumr+log(1.0-dumr1*dumr1)/2.0)- \
- log(1.0-dumr1*dumr1)/dumr))*sq2
- if pcrit == 0.0:
- img.thresh = 'hard'
- else:
- img.thresh_pix = sigcrit
- mylogger.userinfo(mylog, "FDR threshold (replaces thresh_pix)", str(round(sigcrit, 4)))
- else:
- img.thresh_pix = opts.thresh_pix
-
- img.completed_Ops.append('threshold')
- return img
-
- def get_srcp(self, img):
- import sourcecounts as sc
- fwsig = const.fwsig
- cutoff = 5.0
- spin = -0.80
- freq = img.frequency
- bm = (img.beam[0], img.beam[1])
- cdelt = img.wcs_obj.acdelt[:2]
- x = 2.0*pi*N.product(bm)/abs(N.product(cdelt))/(fwsig*fwsig)*img.omega
-
- smin_L = img.clipped_rms*cutoff*((1.4e9/freq)**spin)
- scflux = sc.s
- scnum = sc.n
- index = 0
- for i,s in enumerate(scflux):
- if s < smin_L:
- index = i
- break
- n1 = scnum[index]; n2 = scnum[-1]
- s1 = scflux[index]; s2 = scflux[-1]
- alpha = 1.0-log(n1/n2)/log(s1/s2)
- A = (alpha-1.0)*n1/(s1**(1.0-alpha))
- source_p = x*A*((cutoff*img.clipped_rms)**(1.0-alpha)) \
- /((1.0-alpha)*(1.0-alpha))
-
- return source_p
diff --git a/CEP/PyBDSM/src/python/wavelet_atrous.py b/CEP/PyBDSM/src/python/wavelet_atrous.py
deleted file mode 100644
index 89253a22c94e472b49766215ece800250d7cd979..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/src/python/wavelet_atrous.py
+++ /dev/null
@@ -1,693 +0,0 @@
-"""Compute a-trous wavelet transform of the gaussian residual image.
-
-Do source extraction on this if asked.
-"""
-import numpy as N
-from image import *
-import mylogger
-import os
-from . import has_pl
-if has_pl:
- import matplotlib.pyplot as pl
-import _cbdsm
-from math import log, floor, sqrt
-from const import fwsig
-from copy import deepcopy as cp
-import functions as func
-import gc
-from numpy import array, product
-import scipy.signal
-from scipy.signal.signaltools import _centered
-from readimage import Op_readimage
-from preprocess import Op_preprocess
-from rmsimage import Op_rmsimage
-from threshold import Op_threshold
-from islands import Op_islands
-from gausfit import Op_gausfit, Gaussian
-from gaul2srl import Op_gaul2srl
-from make_residimage import Op_make_residimage
-from output import Op_outlist
-from interface import raw_input_no_history
-import multi_proc as mp
-import itertools
-import statusbar
-try:
- import pyfftw.interfaces
- pyfftw.interfaces.cache.enable()
- N.fft.fftn = pyfftw.interfaces.numpy_fft.fftn
- N.fft.ifftn = pyfftw.interfaces.numpy_fft.ifftn
- scipy.signal.signaltools.fftn = pyfftw.interfaces.scipy_fftpack.fftn
- scipy.signal.signaltools.ifftn = pyfftw.interfaces.scipy_fftpack.ifftn
-except ImportError:
- pass
-
-jmax = Int(doc = "Maximum order of a-trous wavelet decomposition")
-lpf = String(doc = "Low pass filter used for a-trous wavelet decomposition")
-atrous_islands = List(Any(), doc = "")
-atrous_gaussians = List(Any(), doc = "")
-atrous_sources = List(Any(), doc = "")
-n_pyrsrc = Int(0, doc = "Number of pyramidal sources")
-Image.resid_wavelets = NArray(doc = "Residual image calculated from " \
- "gaussians fitted to wavelet sources")
-
-class Op_wavelet_atrous(Op):
- """Compute a-trous wavelet transform of the gaussian residual image."""
-
- def __call__(self, img):
-
- mylog = mylogger.logging.getLogger("PyBDSM." + img.log + "Wavelet")
-
- if img.opts.atrous_do:
- if img.nisl == 0:
- mylog.warning("No islands found. Skipping wavelet decomposition.")
- img.completed_Ops.append('wavelet_atrous')
- return
-
- mylog.info("Decomposing gaussian residual image into a-trous wavelets")
- bdir = img.basedir + '/wavelet/'
- if img.opts.output_all:
- if not os.path.isdir(bdir): os.makedirs(bdir)
- if not os.path.isdir(bdir + '/residual/'): os.makedirs(bdir + '/residual/')
- if not os.path.isdir(bdir + '/model/'): os.makedirs(bdir + '/model/')
- dobdsm = img.opts.atrous_bdsm_do
- filter = {'tr':{'size':3, 'vec':[1. / 4, 1. / 2, 1. / 4], 'name':'Triangle'},
- 'b3':{'size':5, 'vec':[1. / 16, 1. / 4, 3. / 8, 1. / 4, 1. / 16], 'name':'B3 spline'}}
-
- if dobdsm: wchain, wopts = self.setpara_bdsm(img)
-
- n, m = img.ch0_arr.shape
-
- # Calculate residual image that results from normal (non-wavelet) Gaussian fitting
- Op_make_residimage()(img)
- resid = img.resid_gaus_arr
-
- lpf = img.opts.atrous_lpf
- if lpf not in ['b3', 'tr']: lpf = 'b3'
- jmax = img.opts.atrous_jmax
- l = len(filter[lpf]['vec']) # 1st 3 is arbit and 2nd 3 is whats expected for a-trous
- if jmax < 1 or jmax > 15: # determine jmax
- # Check if largest island size is
- # smaller than 1/3 of image size. If so, use it to determine jmax.
- min_size = min(resid.shape)
- max_isl_shape = (0, 0)
- for isl in img.islands:
- if isl.image.shape[0] * isl.image.shape[1] > max_isl_shape[0] * max_isl_shape[1]:
- max_isl_shape = isl.image.shape
- if max_isl_shape != (0, 0) and min(max_isl_shape) < min(resid.shape) / 3.0:
- min_size = min(max_isl_shape) * 4.0
- else:
- min_size = min(resid.shape)
- jmax = int(floor(log((min_size / 3.0 * 3.0 - l) / (l - 1) + 1) / log(2.0) + 1.0)) + 1
- if min_size * 0.55 <= (l + (l - 1) * (2 ** (jmax) - 1)): jmax = jmax - 1
- img.wavelet_lpf = lpf
- img.wavelet_jmax = jmax
- mylog.info("Using " + filter[lpf]['name'] + ' filter with J_max = ' + str(jmax))
-
- img.atrous_islands = []
- img.atrous_gaussians = []
- img.atrous_sources = []
- img.atrous_opts = []
- img.resid_wavelets_arr = cp(img.resid_gaus_arr)
-
- im_old = img.resid_wavelets_arr
- total_flux = 0.0
- ntot_wvgaus = 0
- stop_wav = False
- pix_masked = N.where(N.isnan(resid) == True)
- jmin = 1
- if img.opts.ncores is None:
- numcores = 1
- else:
- numcores = img.opts.ncores
- for j in range(jmin, jmax + 1): # extra +1 is so we can do bdsm on cJ as well
- mylogger.userinfo(mylog, "\nWavelet scale #" + str(j))
- im_new = self.atrous(im_old, filter[lpf]['vec'], lpf, j, numcores=numcores, use_scipy_fft=img.opts.use_scipy_fft)
- im_new[pix_masked] = N.nan # since fftconvolve wont work with blanked pixels
- if img.opts.atrous_sum:
- w = im_new
- else:
- w = im_old - im_new
- im_old = im_new
- suffix = 'w' + `j`
- filename = img.imagename + '.atrous.' + suffix + '.fits'
- if img.opts.output_all:
- func.write_image_to_file('fits', filename, w, img, bdir)
- mylog.info('%s %s' % ('Wrote ', img.imagename + '.atrous.' + suffix + '.fits'))
-
- # now do bdsm on each wavelet image.
- if dobdsm:
- wopts['filename'] = filename
- wopts['basedir'] = bdir
- box = img.rms_box[0]
- y1 = (l + (l - 1) * (2 ** (j - 1) - 1))
- bs = max(5 * y1, box) # changed from 10 to 5
- if bs > min(n, m) / 2:
- wopts['rms_map'] = False
- wopts['mean_map'] = 'const'
- wopts['rms_box'] = None
- else:
- wopts['rms_box'] = (bs, bs/3)
- if hasattr(img, '_adapt_rms_isl_pos'):
- bs_bright = max(5 * y1, img.rms_box_bright[0])
- if bs_bright < bs/1.5:
- wopts['adaptive_rms_box'] = True
- wopts['rms_box_bright'] = (bs_bright, bs_bright/3)
- else:
- wopts['adaptive_rms_box'] = False
- if j <= 3:
- wopts['ini_gausfit'] = 'default'
- else:
- wopts['ini_gausfit'] = 'nobeam'
- wid = (l + (l - 1) * (2 ** (j - 1) - 1))# / 3.0
- b1, b2 = img.pixel_beam()[0:2]
- b1 = b1 * fwsig
- b2 = b2 * fwsig
- cdelt = img.wcs_obj.acdelt[:2]
-
- wimg = Image(wopts)
- wimg.beam = (sqrt(wid * wid + b1 * b1) * cdelt[0] * 2.0, sqrt(wid * wid + b2 * b2) * cdelt[1] * 2.0, 0.0)
- wimg.orig_beam = img.beam
- wimg.pixel_beam = img.pixel_beam
- wimg.pixel_beamarea = img.pixel_beamarea
- wimg.log = 'Wavelet.'
- wimg.basedir = img.basedir
- wimg.extraparams['bbsprefix'] = suffix
- wimg.extraparams['bbsname'] = img.imagename + '.wavelet'
- wimg.extraparams['bbsappend'] = True
- wimg.bbspatchnum = img.bbspatchnum
- wimg.waveletimage = True
- wimg.j = j
- if hasattr(img, '_adapt_rms_isl_pos'):
- wimg._adapt_rms_isl_pos = img._adapt_rms_isl_pos
-
-
- self.init_image_simple(wimg, img, w, '.atrous.' + suffix)
- for op in wchain:
- op(wimg)
- gc.collect()
- if isinstance(op, Op_islands) and img.opts.atrous_orig_isl:
- if wimg.nisl > 0:
-
- # Find islands that do not share any pixels with
- # islands in original ch0 image.
- good_isl = []
-
- # Make original rank image boolean; rank counts from 0, with -1 being
- # outside any island
- orig_rankim_bool = N.array(img.pyrank + 1, dtype = bool)
-
- # Multiply rank images
- old_islands = orig_rankim_bool * (wimg.pyrank + 1) - 1
-
- # Exclude islands that don't overlap with a ch0 island.
- valid_ids = set(old_islands.flatten())
- for idx, wvisl in enumerate(wimg.islands):
- if idx in valid_ids:
- wvisl.valid = True
- good_isl.append(wvisl)
- else:
- wvisl.valid = False
-
- wimg.islands = good_isl
- wimg.nisl = len(good_isl)
- mylogger.userinfo(mylog, "Number of islands found", '%i' %
- wimg.nisl)
-
- # Renumber islands:
- for wvindx, wvisl in enumerate(wimg.islands):
- wvisl.island_id = wvindx
-
- if isinstance(op, Op_gausfit):
- # If opts.atrous_orig_isl then exclude Gaussians outside of
- # the original ch0 islands
- nwvgaus = 0
- if img.opts.atrous_orig_isl:
- gaul = wimg.gaussians
- tot_flux = 0.0
-
- if img.ngaus == 0:
- gaus_id = -1
- else:
- gaus_id = img.gaussians[-1].gaus_num
- wvgaul = []
- for g in gaul:
- if not hasattr(g, 'valid'):
- g.valid = False
- if not g.valid:
- try:
- isl_id = img.pyrank[int(g.centre_pix[0] + 1), int(g.centre_pix[1] + 1)]
- except IndexError:
- isl_id = -1
- if isl_id >= 0:
- isl = img.islands[isl_id]
- gcenter = (g.centre_pix[0] - isl.origin[0],
- g.centre_pix[1] - isl.origin[1])
- if not isl.mask_active[gcenter]:
- gaus_id += 1
- gcp = Gaussian(img, g.parameters[:], isl.island_id, gaus_id)
- gcp.gaus_num = gaus_id
- gcp.wisland_id = g.island_id
- gcp.jlevel = j
- g.valid = True
- isl.gaul.append(gcp)
- isl.ngaus += 1
- img.gaussians.append(gcp)
- nwvgaus += 1
- tot_flux += gcp.total_flux
- else:
- g.valid = False
- g.jlevel = 0
- else:
- g.valid = False
- g.jlevel = 0
- vg = []
- for g in wimg.gaussians:
- if g.valid:
- vg.append(g)
- wimg.gaussians = vg
- mylogger.userinfo(mylog, "Number of valid wavelet Gaussians", str(nwvgaus))
- else:
- # Keep all Gaussians and merge islands that overlap
- tot_flux = check_islands_for_overlap(img, wimg)
-
- # Now renumber the islands and adjust the rank image before going to next wavelet image
- renumber_islands(img)
-
- total_flux += tot_flux
- if img.opts.interactive and has_pl:
- dc = '\033[34;1m'
- nc = '\033[0m'
- print dc + '--> Displaying islands and rms image...' + nc
- if max(wimg.ch0_arr.shape) > 4096:
- print dc + '--> Image is large. Showing islands only.' + nc
- wimg.show_fit(rms_image=False, mean_image=False, ch0_image=False,
- ch0_islands=True, gresid_image=False, sresid_image=False,
- gmodel_image=False, smodel_image=False, pyramid_srcs=False)
- else:
- wimg.show_fit()
- prompt = dc + "Press enter to continue or 'q' stop fitting wavelet images : " + nc
- answ = raw_input_no_history(prompt)
- while answ != '':
- if answ == 'q':
- img.wavelet_jmax = j
- stop_wav = True
- break
- answ = raw_input_no_history(prompt)
- if len(wimg.gaussians) > 0:
- img.resid_wavelets_arr = self.subtract_wvgaus(img.opts, img.resid_wavelets_arr, wimg.gaussians, wimg.islands)
- if img.opts.atrous_sum:
- im_old = self.subtract_wvgaus(img.opts, im_old, wimg.gaussians, wimg.islands)
- if stop_wav == True:
- break
-
- pyrank = N.zeros(img.pyrank.shape, dtype=N.int32)
- for i, isl in enumerate(img.islands):
- isl.island_id = i
- for g in isl.gaul:
- g.island_id = i
- for dg in isl.dgaul:
- dg.island_id = i
- pyrank[isl.bbox] += N.invert(isl.mask_active) * (i + 1)
- pyrank -= 1 # align pyrank values with island ids and set regions outside of islands to -1
- img.pyrank = pyrank
-
- pdir = img.basedir + '/misc/'
- img.ngaus += ntot_wvgaus
- img.total_flux_gaus += total_flux
- mylogger.userinfo(mylog, "Total flux density in model on all scales" , '%.3f Jy' % img.total_flux_gaus)
- if img.opts.output_all:
- func.write_image_to_file('fits', img.imagename + '.atrous.cJ.fits',
- im_new, img, bdir)
- mylog.info('%s %s' % ('Wrote ', img.imagename + '.atrous.cJ.fits'))
- func.write_image_to_file('fits', img.imagename + '.resid_wavelets.fits',
- (img.ch0_arr - img.resid_gaus_arr + img.resid_wavelets_arr), img, bdir + '/residual/')
- mylog.info('%s %s' % ('Wrote ', img.imagename + '.resid_wavelets.fits'))
- func.write_image_to_file('fits', img.imagename + '.model_wavelets.fits',
- (img.resid_gaus_arr - img.resid_wavelets_arr), img, bdir + '/model/')
- mylog.info('%s %s' % ('Wrote ', img.imagename + '.model_wavelets.fits'))
- img.completed_Ops.append('wavelet_atrous')
-
-
-#######################################################################################################
- def atrous(self, image, filtvec, lpf, j, numcores=1, use_scipy_fft=True):
-
- ff = filtvec[:]
- for i in range(1, len(filtvec)):
- ii = 1 + (2 ** (j - 1)) * (i - 1)
- ff[ii:ii] = [0] * (2 ** (j - 1) - 1)
- kern = N.outer(ff, ff)
- unmasked = N.nan_to_num(image)
- if use_scipy_fft:
- im_new = scipy.signal.fftconvolve(unmasked, kern, mode = 'same')
- else:
- im_new = fftconvolve(unmasked, kern, mode = 'same', pad_to_power_of_two=False, numcores=numcores)
- if im_new.shape != image.shape:
- im_new = im_new[0:image.shape[0], 0:image.shape[1]]
-
- return im_new
-
-#######################################################################################################
- def setpara_bdsm(self, img):
- from types import ClassType, TypeType
-
- chain = [Op_preprocess, Op_rmsimage(), Op_threshold(), Op_islands(),
- Op_gausfit(), Op_gaul2srl(), Op_make_residimage()]
-
- opts = {'thresh':'hard'}
- opts['thresh_pix'] = img.thresh_pix
- opts['kappa_clip'] = 3.0
- opts['rms_map'] = img.opts.rms_map
- opts['mean_map'] = img.opts.mean_map
- opts['thresh_isl'] = img.opts.thresh_isl
- opts['minpix_isl'] = 6
- opts['savefits_rmsim'] = False
- opts['savefits_meanim'] = False
- opts['savefits_rankim'] = False
- opts['savefits_normim'] = False
- opts['polarisation_do'] = False
- opts['aperture'] = None
- opts['group_by_isl'] = img.opts.group_by_isl
- opts['quiet'] = img.opts.quiet
- opts['ncores'] = img.opts.ncores
-
- opts['flag_smallsrc'] = False
- opts['flag_minsnr'] = 0.2
- opts['flag_maxsnr'] = 1.2
- opts['flag_maxsize_isl'] = 2.5
- opts['flag_bordersize'] = 0
- opts['flag_maxsize_bm'] = 50.0
- opts['flag_minsize_bm'] = 0.2
- opts['flag_maxsize_fwhm'] = 0.5
- opts['bbs_patches'] = img.opts.bbs_patches
- opts['filename'] = ''
- opts['output_all'] = img.opts.output_all
- opts['verbose_fitting'] = img.opts.verbose_fitting
- opts['split_isl'] = False
- opts['peak_fit'] = True
- opts['peak_maxsize'] = 30.0
- opts['detection_image'] = ''
- opts['verbose_fitting'] = img.opts.verbose_fitting
-
- ops = []
- for op in chain:
- if isinstance(op, (ClassType, TypeType)):
- ops.append(op())
- else:
- ops.append(op)
-
- return ops, opts
-
-#######################################################################################################
- def init_image_simple(self, wimg, img, w, name):
- wimg.ch0_arr = w
- wimg.ch0_Q_arr = None
- wimg.ch0_U_arr = None
- wimg.ch0_V_arr = None
- wimg.wcs_obj = img.wcs_obj
- wimg.parentname = img.filename
- wimg.filename = img.filename + name
- wimg.imagename = img.imagename + name + '.pybdsm'
- wimg.pix2sky = img.pix2sky
- wimg.sky2pix = img.sky2pix
- wimg.pix2beam = img.pix2beam
- wimg.beam2pix = img.beam2pix
- wimg.pix2gaus = img.pix2gaus
- wimg.gaus2pix = img.gaus2pix
- wimg.pix2coord = img.pix2coord
- wimg.masked = img.masked
- wimg.mask_arr = img.mask_arr
- wimg.use_io = img.use_io
- wimg.do_cache = img.do_cache
- wimg.tempdir = img.tempdir
- wimg.shape = img.shape
- wimg.use_io = 'fits'
-
-
-######################################################################################################
- def subtract_wvgaus(self, opts, residim, gaussians, islands):
- import functions as func
- from make_residimage import Op_make_residimage as opp
-
- dummy = opp()
- shape = residim.shape
- thresh = opts.fittedimage_clip
-
- for g in gaussians:
- if g.valid:
- C1, C2 = g.centre_pix
- if hasattr(g, 'wisland_id'):
- isl = islands[g.wisland_id]
- else:
- isl = islands[g.island_id]
- b = opp.find_bbox(dummy, thresh * isl.rms, g)
- bbox = N.s_[max(0, int(C1 - b)):min(shape[0], int(C1 + b + 1)),
- max(0, int(C2 - b)):min(shape[1], int(C2 + b + 1))]
- x_ax, y_ax = N.mgrid[bbox]
- ffimg = func.gaussian_fcn(g, x_ax, y_ax)
- residim[bbox] = residim[bbox] - ffimg
-
- return residim
-
-#######################################################################################################
- def morphfilter_pyramid(self, img, bdir):
- from math import ceil, floor
-
- jmax = img.wavelet_jmax
- ind = [i for i, isl in enumerate(img.atrous_islands) if len(isl) > 0]
- ind.reverse()
- lpyr = []
- img.npyrsrc = -1
- if len(ind) > 0 :
- for i in ind:
- isls = img.atrous_islands[i]
- for isl in isls:
- if i != ind[0]:
- status = False; dumr = []
- for pyrsrc in lpyr:
- belongs = pyrsrc.belongs(img, isl)
- if belongs: dumr.append(pyrsrc.pyr_id)
- #if len(dumr) > 1:
- # raise RuntimeError("Source in lower wavelet level belongs to more than one higher level.")
- if len(dumr) == 1:
- dumr = dumr[0]
- pyrsrc = lpyr[dumr]
- pyrsrc.add_level(img, i, isl)
- else:
- pyrsrc = Pyramid_source(img, isl, i)
- lpyr.append(pyrsrc)
- else:
- pyrsrc = Pyramid_source(img, isl, i)
- lpyr.append(pyrsrc)
- img.pyrsrcs = lpyr
-
- if img.opts.plot_pyramid and has_pl:
- pl.figure()
- a = ceil(sqrt(jmax)); b = floor(jmax / a)
- if a * b < jmax: b += 1
- colours = ['r', 'g', 'b', 'c', 'm', 'y', 'k']
- sh = img.ch0_arr.shape
- for pyr in img.pyrsrcs:
- for iisl, isl in enumerate(pyr.islands):
- jj = pyr.jlevels[iisl]
- col = colours[pyr.pyr_id % 7]
- pl.subplot(a, b, jj)
- ind = N.where(~isl.mask_active)
- pl.plot(ind[0] + isl.origin[0], ind[1] + isl.origin[1], '.', color = col)
- pl.axis([0.0, sh[0], 0.0, sh[1]])
- pl.title('J = ' + str(jj))
- pl.savefig(bdir + img.imagename + '.pybdsm.atrous.pyramidsrc.png')
-
-#######################################################################################################
-
-class Pyramid_source(object):
- """ Pyramid_source is a source constructed out of multiple wavelet transform images. """
-
- def __init__(self, img, island, level0):
- img.npyrsrc = img.npyrsrc + 1
- self.pyr_id = img.npyrsrc
- self.islands = [island]
- self.jlevels = [level0]
-
- def belongs(self, img, isl):
- import functions as func
- # get centroid of island (as integer)
- mom = func.momanalmask_gaus(isl.image, isl.mask_active, 0, 1.0, False)
- cen = N.array(mom[1:3]) + isl.origin
- icen = (int(round(cen[0])), int(round(cen[1])))
- belong = False
- # check if lies within any island of self
- for i, pyrisl in enumerate(self.islands):
- if N.sum([pyrisl.bbox[j].start <= cen[j] < pyrisl.bbox[j].stop for j in range(2)]) == 2:
- pix = tuple([cen[j] - pyrisl.origin[j] for j in range(2)])
- if not pyrisl.mask_active[pix]:
- belong = True
-
- return belong
-
- def add_level(self, img, level, isl):
- self.islands.append(isl)
- self.jlevels.append(level + 1)
-
-
-Image.pyrsrcs = List(tInstance(Pyramid_source), doc = "List of Pyramidal sources")
-
-def fftconvolve(in1, in2, mode="full", pad_to_power_of_two=True, numcores=1):
- """Convolve two N-dimensional arrays using FFT. See convolve.
-
- """
- s1 = array(in1.shape)
- s2 = array(in2.shape)
- complex_result = (N.issubdtype(in1.dtype, N.complex) or
- N.issubdtype(in2.dtype, N.complex))
- size = s1 + s2 - 1
-
- if pad_to_power_of_two:
- # Use 2**n-sized FFT; it might improve performance
- fsize = 2 ** N.ceil(N.log2(size))
- else:
- # Padding to a power of two might degrade performance, too
- fsize = size
- if has_pyfftw:
- IN1 = N.fft.fftn(in1, fsize, threads=numcores)
- IN1 *= N.fft.fftn(in2, fsize, threads=numcores)
- fslice = tuple([slice(0, int(sz)) for sz in size])
- ret = N.fft.ifftn(IN1, threads=numcores)[fslice].copy()
- else:
- IN1 = N.fft.fftn(in1, fsize)
- IN1 *= N.fft.fftn(in2, fsize)
- fslice = tuple([slice(0, int(sz)) for sz in size])
- ret = N.fft.ifftn(IN1)[fslice].copy()
- del IN1
- if not complex_result:
- ret = ret.real
- if mode == "full":
- return ret
- elif mode == "same":
- if product(s1, axis=0) > product(s2, axis=0):
- osize = s1
- else:
- osize = s2
- return _centered(ret, osize)
- elif mode == "valid":
- return _centered(ret, abs(s2 - s1) + 1)
-
-def merge_islands(img, isl1, isl2):
- """Merge two islands into one
-
- Final island has island_id of isl1. The Gaussians from isl2 are appended
- those in the isl1 list, with numbering starting from the last number in
- img.gaussians (which is also updated with the isl2 Gaussians).
-
- The merged island replaces isl1 in img.
- """
- from islands import Island
- import scipy.ndimage as nd
-
- mask1 = N.zeros(img.ch0_arr.shape, dtype=bool)
- mask1[isl1.bbox] = ~isl1.mask_active
- mask2 = N.zeros(img.ch0_arr.shape, dtype=bool)
- mask2[isl2.bbox] = ~isl2.mask_active
- full_mask = N.logical_or(mask1, mask2)
- overlap_mask = N.logical_and(mask1, mask2)
- if N.any(overlap_mask):
- image = img.ch0_arr
- mask = img.mask_arr
- rms = img.rms_arr
- mean = img.mean_arr
- rank = len(image.shape)
- connectivity = nd.generate_binary_structure(rank, rank)
- labels, count = nd.label(full_mask, connectivity)
- slices = nd.find_objects(labels)
- bbox = slices[0]
- idx = isl1.island_id
- beamarea = img.pixel_beamarea()
- merged_isl = Island(image, mask, mean, rms, labels-1+idx, bbox, idx, beamarea)
-
- # Add all the Gaussians to the merged island
- merged_isl.gaul = isl1.gaul
- merged_isl.dgaul = isl1.dgaul
- copy_gaussians(img, merged_isl, isl2)
- img.islands[idx] = merged_isl
-
-def copy_gaussians(img, isl1, isl2):
- """Copies Gaussians from isl2 to isl1
-
- img.gaussians is also updated
- """
- if img.ngaus == 0:
- gaus_id = -1
- else:
- gaus_id = img.gaussians[-1].gaus_num
- for g in isl2.gaul:
- gaus_id += 1
- gcp = Gaussian(img, g.parameters[:], isl1.island_id, gaus_id)
- gcp.gaus_num = gaus_id
- gcp.jlevel = g.jlevel
- isl1.gaul.append(gcp)
- img.ngaus += 1
- img.gaussians.append(gcp)
-
-def renumber_islands(img):
- """Renumbers island_ids (after, e.g., removing one)
-
- Also renumbers the pyrank image.
- """
- pyrank = N.zeros(img.pyrank.shape, dtype=N.int32)
- for i, isl in enumerate(img.islands):
- isl.island_id = i
- for g in isl.gaul:
- g.island_id = i
- for dg in isl.dgaul:
- dg.island_id = i
- pyrank[isl.bbox] += N.invert(isl.mask_active) * (i + 1)
- pyrank -= 1 # align pyrank values with island ids and set regions outside of islands to -1
- img.pyrank = pyrank
- gaussian_list = [g for isl in img.islands for g in isl.gaul]
- img.gaussians = gaussian_list
-
-
-def check_islands_for_overlap(img, wimg):
- """Checks for overlaps between img and wimg islands"""
- tot_flux = 0.0
-
- # Make masks for regions that have islands
- wav_rankim_bool = N.array(wimg.pyrank + 1, dtype = bool)
- orig_rankim_bool = N.array(img.pyrank + 1, dtype = bool)
-
- # Make "images" of island ids for overlaping regions
- orig_islands = wav_rankim_bool * (img.pyrank + 1) - 1
- wav_islands = orig_rankim_bool * (wimg.pyrank + 1) - 1
- for idx, wvisl in enumerate(wimg.islands):
- wav_ids = N.array(tuple(set(wav_islands.flatten())))
- if len(wvisl.gaul) > 0:
-
- # Get unique island IDs. If an island overlaps with one
- # in the original ch0 image, merge them together. If not,
- # add the island as a new one.
- for wvg in wvisl.gaul:
- tot_flux += wvg.total_flux
- wvg.valid = True
- if idx in wav_ids:
- orig_idx = list(set(orig_islands[N.where(wav_islands == idx)]))
- if len(orig_idx) == 1:
- merge_islands(img, img.islands[orig_idx[0]], wvisl)
- else:
- merge_islands(img, img.islands[orig_idx[0]], wvisl)
- for oidx in orig_idx[1:]:
- merge_islands(img, img.islands[orig_idx[0]], img.islands[oidx])
- img.islands = [x for x in img.islands if x.island_id not in orig_idx[1:]]
- renumber_islands(img)
-
- # Now recalculate the overlap images, since the islands have changed
- orig_rankim_bool = N.array(img.pyrank + 1, dtype = bool)
- orig_islands = wav_rankim_bool * (img.pyrank + 1) - 1
- wav_islands = orig_rankim_bool * (wimg.pyrank + 1) - 1
- else:
- isl_id = img.islands[-1].island_id + 1
- new_isl = wvisl.copy(img.pixel_beamarea(), image=img.ch0_arr[wvisl.bbox], mean=img.mean_arr[wvisl.bbox], rms=img.rms_arr[wvisl.bbox])
- new_isl.gaul = []
- new_isl.dgaul = []
- new_isl.island_id = isl_id
- img.islands.append(new_isl)
- copy_gaussians(img, new_isl, wvisl)
- return tot_flux
diff --git a/CEP/PyBDSM/test/Ateammodels.py b/CEP/PyBDSM/test/Ateammodels.py
deleted file mode 100644
index f9cf268b138608630c1025f112caadf3446152d9..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/test/Ateammodels.py
+++ /dev/null
@@ -1,55 +0,0 @@
-
-import pylab as pl
-import bdsm, pyfits
-import numpy as N
-import os, subprocess
-
-from bdsm.FITS import Op_loadFITS
-from bdsm.collapse import Op_collapse
-from bdsm.preprocess import Op_preprocess
-from bdsm.rmsimage import Op_rmsimage
-from bdsm.threshold import Op_threshold
-from bdsm.islands import Op_islands
-import bdsm.functions as func
-from bdsm.analysis import plotresults
-
-""" Try blindly running bdsm to see if boxsize is ok, so fitting doesnt hang. Then try various segmenting algorithms which dont
-depend on rms ? """
-
-dir = "A-team/"
-ls = subprocess.Popen(["ls",dir], stdout=subprocess.PIPE).communicate()[0]
-ls = ls.split('\n')
-
-files = []; rmsbox = []
-chain = [Op_loadFITS(), Op_collapse(), Op_preprocess(), Op_rmsimage(), Op_threshold(), Op_islands()]
-
-#ls = ['subim.fits']
-bms = [(0.0015, 0.0015, 0.0)]
-dir=''
-for ifile, file in enumerate(ls):
- op = subprocess.Popen(["file",dir+file], stdout=subprocess.PIPE).communicate()[0]
- if "FITS image data" in op:
- print 'Processing ', file
- img = bdsm.execute(chain, {'fits_name': file, 'thresh':"hard", 'solnname' : 'new', 'beam' : bms[ifile]}), 'indir' : dir})
- files.append(file)
- rmsbox.append(img.opts.rms_box)
-
- thr = img.clipped_rms
- op1, markers1 = func.watershed(img.image, thr=thr*3.)
-
-
- pl.figure()
- pl.suptitle(img.filename)
- pl.subplot(2,2,1); pl.imshow(N.transpose(img.image), origin='lower', interpolation='nearest', vmin=-7*thr, vmax=15*thr); pl.title('Image')
- pl.subplot(2,2,2); pl.imshow(N.transpose(op1), origin='lower', interpolation='nearest'), pl.title('watershed1')
- pl.subplot(2,2,3); pl.imshow(N.transpose(markers1), origin='lower', interpolation='nearest'), pl.title('markers1')
- pl.subplot(2,2,4); plotresults(img, newfig=False, cbar=False)
- pl.savefig(dir+file+'_watershed.png')
-
- else:
- print dir+file+' is not a FITS file !!'
-
-
-
-
-
diff --git a/CEP/PyBDSM/test/CMakeLists.txt b/CEP/PyBDSM/test/CMakeLists.txt
index fef71c8f11ed2ae06b826ad8912e6d543969c0d5..e11c36f89e0ea07f84e39042106e1818f67fa000 100644
--- a/CEP/PyBDSM/test/CMakeLists.txt
+++ b/CEP/PyBDSM/test/CMakeLists.txt
@@ -2,23 +2,6 @@
include(LofarCTest)
-# Create symlinks to some Python modules so that they can be found during
-# build/test time.
-execute_process(COMMAND ${CMAKE_COMMAND} -E create_symlink
- ${PACKAGE_BINARY_DIR}/src/c++/_cbdsm.so
- ${PYTHON_BUILD_DIR}/lofar/bdsm/_cbdsm.so)
-
-execute_process(COMMAND ${CMAKE_COMMAND} -E create_symlink
- ${PACKAGE_BINARY_DIR}/src/fortran/_pytesselate.so
- ${PYTHON_BUILD_DIR}/lofar/bdsm/_pytesselate.so)
-
-execute_process(COMMAND ${CMAKE_COMMAND} -E create_symlink
- ${PACKAGE_BINARY_DIR}/src/natgrid/natgridmodule.so
- ${PYTHON_BUILD_DIR}/lofar/bdsm/natgridmodule.so)
-
-execute_process(COMMAND ${CMAKE_COMMAND} -E create_symlink
- ${PACKAGE_SOURCE_DIR}/src/natgrid/Lib/nat.py
- ${PYTHON_BUILD_DIR}/lofar/bdsm/nat.py)
-
-lofar_add_test(tbdsm_import DEPENDS _cbdsm _pytesselate natgridmodule)
-lofar_add_test(tbdsm_process_image DEPENDS _cbdsm _pytesselate natgridmodule)
+configure_file(setpythonpath.run_tmpl setpythonpath.run_script)
+lofar_add_test(tbdsm_import)
+lofar_add_test(tbdsm_process_image)
diff --git a/CEP/PyBDSM/test/colourcorrection.py b/CEP/PyBDSM/test/colourcorrection.py
deleted file mode 100644
index e2566775b3840efa8d57007b99a62020041915f8..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/test/colourcorrection.py
+++ /dev/null
@@ -1,88 +0,0 @@
-"""
-This is for pybdsm for calculating spectral index. We assume a linear spectral index
-in log(freq) and then each channel has a flux which is bit wrong because of the colour
-correction problem within that band.
-
-Now we average n such channels. There will be another error made, partly because of the
-colour correction now for channels (including discretisation) and the colour correction
-of the earlier 2nd order colour correction.
-
-This is to see how much they differ. Refer notebook for forumlae.
-
-"""
-
-import numpy as N
-import pylab as pl
-import math
-
-nchan = N.array([9, 17])
-alpha_arr = N.arange(-1.3, -0.3, 0.1)
-deltanu = N.array([0.05e6, 0.1e6, 0.2e6])
-
-freq = N.arange(40.0e6, 200.0e6, 10.0e6)
-
-pl1 = pl.figure()
-pl2 = pl.figure()
-pl3 = pl.figure()
-k = 0
-for inchan, n in enumerate(nchan):
- for ibw, bw in enumerate(deltanu):
- k += 1
- for ia, alpha in enumerate(alpha_arr):
- f_diff1 = N.zeros(len(freq))
- f_diff2 = N.zeros(len(freq))
- for ifreq, f in enumerate(freq):
- f_arr = N.arange(f-(n-1)/2*bw, f+(n+1)/2*bw, bw)
- f_naive = N.mean(f_arr)
- f1 = N.power(f_arr, alpha)
- f2 = N.power(f_arr, alpha-2.0)
-
- f1 = 1.0/n*N.sum(f1)
- f2 = 1.0/n*N.sum(f2)*bw*bw*alpha*(alpha-1.0)/24.0
-
- f_eff1 = N.power(f1, 1.0/alpha)
- f_eff2 = N.power(f1+f2, 1.0/alpha)
-
- f_diff1[ifreq] = f_naive - f_eff2
- f_diff2[ifreq] = f_eff1 - f_eff2
-
- fig = pl.figure(pl1.number)
- adjustprops = dict(wspace=0.5, hspace=0.5)
- fig.subplots_adjust(**adjustprops)
- ax = pl.subplot(2,3,k)
- pl.plot(freq/1e6, f_diff1/1e3)
- pl.title('n='+str(n)+'; bw='+str(bw/1e6)+' MHz')
- pl.xlabel('Freq(MHz)')
- pl.ylabel('Diff in freq (kHz)')
- pl.setp(ax.get_xticklabels(), rotation='vertical', fontsize=12)
-
- fig = pl.figure(pl2.number)
- adjustprops = dict(wspace=0.5, hspace=0.5)
- fig.subplots_adjust(**adjustprops)
- ax = pl.subplot(2,3,k)
- pl.plot(freq/1e6, f_diff2)
- pl.title('n='+str(n)+'; bw='+str(bw/1e6)+' MHz')
- pl.xlabel('Freq(MHz)')
- pl.ylabel('Diff due to 2nd order (Hz)')
- pl.setp(ax.get_xticklabels(), rotation='vertical', fontsize=12)
-
- fig = pl.figure(pl3.number)
- adjustprops = dict(wspace=0.9, hspace=0.5)
- fig.subplots_adjust(**adjustprops)
- ax = pl.subplot(2,3,k)
- f2 = f_naive+5e6
- y = f_diff1*alpha/f_naive/math.log(f_naive/(f2))
- pl.plot(freq/1e6, y)
- pl.title('n='+str(n)+'; bw='+str(bw/1e6)+' MHz')
- pl.xlabel('Freq(MHz)')
- pl.ylabel('Error in sp.in. for f2=f1+10MHz')
- pl.setp(ax.get_xticklabels(), rotation='vertical', fontsize=12)
-
-pl.figure(pl1.number)
-pl.savefig('colourcorr_full.png')
-pl.figure(pl2.number)
-pl.savefig('colourcorr_order1-2.png')
-pl.figure(pl3.number)
-pl.savefig('colourcorr_delta_spin.png')
-
-
diff --git a/CEP/PyBDSM/test/do_stuff.py b/CEP/PyBDSM/test/do_stuff.py
deleted file mode 100644
index 2d8ee063458ec337327ce25f68c18147d67a8337..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/test/do_stuff.py
+++ /dev/null
@@ -1,53 +0,0 @@
-
-
-
-"""make watershed images for each island in isls """
-
-def do_ws(isls, crms):
- import bdsm.functions as func
- import os, subprocess
- import pylab as pl
- import numpy as N
-
- thr = crms
- for isl in isls:
-
- image = isl.image*~isl.mask_active
- op1, markers1 = func.watershed(image, thr=thr*3.)
-
- pl.figure()
- pl.suptitle('Island '+str(isl.island_id))
- pl.subplot(2,2,1); pl.imshow(N.transpose(image), origin='lower', interpolation='nearest', vmin=-7*thr, vmax=15*thr); pl.title('Image')
- pl.subplot(2,2,2); pl.imshow(N.transpose(op1*~isl.mask_active), origin='lower', interpolation='nearest'); pl.title('watershed1')
- pl.subplot(2,2,3); pl.imshow(N.transpose(markers1*~isl.mask_active), origin='lower', interpolation='nearest'); pl.title('markers1')
-
-def open_isl(isls, crms):
- import pylab as pl
- import scipy.ndimage as nd
- import numpy as N
-
- thr = crms
- ft1 = N.array(((1,0,1), (0,1,0), (1,0,1)), int)
- ft2 = N.array(((0,1,0), (1,1,1), (0,1,0)), int)
- ft3 = N.ones((3,3), int)
- ft5 = N.ones((5,5), int)
- for isl in isls:
- ma = ~isl.mask_active
- open1 = nd.binary_opening(ma, ft1)
- open2 = nd.binary_opening(ma, ft2)
- open3 = nd.binary_opening(ma, ft3)
- open5 = nd.binary_opening(ma, ft5)
-
- pl.figure()
- pl.suptitle('Island '+str(isl.island_id))
- pl.subplot(2,2,1); pl.imshow(N.transpose(isl.image), origin='lower', interpolation='nearest'); pl.title('Image')
- pl.subplot(2,2,2); pl.imshow(N.transpose(ma), origin='lower', interpolation='nearest'); pl.title('mask')
- pl.subplot(2,2,3); pl.imshow(N.transpose(open3), origin='lower', interpolation='nearest'); pl.title('open 3x3')
- pl.subplot(2,2,4); pl.imshow(N.transpose(open5), origin='lower', interpolation='nearest'); pl.title('open 5x5')
- #pl.subplot(2,2,3); pl.imshow(N.transpose(open1), origin='lower', interpolation='nearest'); pl.title('open diag')
- #pl.subplot(2,2,4); pl.imshow(N.transpose(open2), origin='lower', interpolation='nearest'); pl.title('open str')
- pl.savefig('cyga_p_w12_bigisl_'+str(isl.island_id)+'_open.png')
-
-
-
-
diff --git a/CEP/PyBDSM/test/setpythonpath.run_tmpl b/CEP/PyBDSM/test/setpythonpath.run_tmpl
new file mode 100644
index 0000000000000000000000000000000000000000..266d3b10abcf865ae9b87564eacfc7a93047c8db
--- /dev/null
+++ b/CEP/PyBDSM/test/setpythonpath.run_tmpl
@@ -0,0 +1,4 @@
+#!/bin/sh
+
+# Set the python path to the path set at configure time
+PYTHONPATH=@BDSF_ROOT_DIR@:$PYTHONPATH
diff --git a/CEP/PyBDSM/test/tbdsm_import.run b/CEP/PyBDSM/test/tbdsm_import.run
index cbd046707c7dd08200cfec7b8f1160699102e266..ef90d38c36cb78f9e3e5164c7b66192995d450b8 100755
--- a/CEP/PyBDSM/test/tbdsm_import.run
+++ b/CEP/PyBDSM/test/tbdsm_import.run
@@ -1,2 +1,6 @@
#!/bin/sh
-python -c "import lofar.bdsm"
+
+# Set the python path
+source setpythonpath.run_script
+
+python -c "import sys; print '\n'.join(sys.path); import lofar.bdsm"
diff --git a/CEP/PyBDSM/test/tbdsm_process_image.run b/CEP/PyBDSM/test/tbdsm_process_image.run
index 6ffdf07c444e3898ac08232a80ecdeaab81da0d4..72f264472eec213a9e9866bdef82c3aed3ba7259 100755
--- a/CEP/PyBDSM/test/tbdsm_process_image.run
+++ b/CEP/PyBDSM/test/tbdsm_process_image.run
@@ -1,4 +1,8 @@
#!/bin/sh
+
+# Set the python path
+source setpythonpath.run_script
+
test "$?BASH_VERSION" = "0" || eval 'setenv() { export "$1=$2"; }'
# Disable openblas threading affinity, needed on CEP3.
diff --git a/CEP/PyBDSM/test/test.py b/CEP/PyBDSM/test/test.py
deleted file mode 100644
index dcbda27286c4341860894125ee8cc8101bc846df..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/test/test.py
+++ /dev/null
@@ -1,96 +0,0 @@
-
-import sys
-import numpy as N
-
-sys.path.append('')
-
-def plotim():
- """ Plots the image and overlays the island borders with the island number. Also draws the detected gaussians
- at their fwhm radius, with each source being a colour (and line style). """
- bdsm.analysis.plotresults(img)
-
-def getisl(c):
- """ Plots the image and overlays the island borders with the island number. Also draws the detected gaussians
- at their fwhm radius, with each source being a colour (and line style). """
- islid = bdsm.analysis.getisland(img, c)
- return img.islands[islid]
-
-def plot_morph_isl(img, isls=None, thr=None):
- bdsm.analysis.plot_morph_isl(img, isls, thr)
-
-def call_pybdsm(version, parameters):
-
- if version not in ['stable', 'david', 'test']: raise RuntimeError(version+" Version unknown")
- if version == 'stable': import bdsm_stable as bdsm
- if version == 'david': import bdsm_david as bdsm
- if version == 'test': import bdsm_test as bdsm
- img = bdsm.execute(bdsm.fits_chain, parameters)
-
- return img, bdsm
-
-
-#img, bdsm = call_pybdsm('test', {'fits_name': "subim.fits", 'beam' : (0.0015, 0.0015, 0.0), 'thresh':"hard", 'atrous_do' : False})
-
-#img, bdsm = call_pybdsm('test', {'fits_name': "concatenated-003-002.restored.fits", 'thresh':"hard", 'atrous_do' : False, 'stop_at' : 'isl'})
-
-#img = bdsm.execute(bdsm.fits_chain,{'fits_name': "HydraA_74MHz_image.fits", 'thresh':"hard", 'atrous_do' : True, 'atrous_bdsm_do' : False, 'atrous_jmax' : 6, 'solnname' : 'del-norms_nobeam_deeper', 'ini_gausfit' : 'nobeam', 'opdir_overwrite' : 'append', 'mean_map' : False, 'rms_map' : False, 'thresh_pix' : 60, 'thresh_isl' : 45})
-
-#img = bdsm.execute(bdsm.fits_chain,{'fits_name': "HydraA_74MHz_image.pybdsm.atrous.w6_norms_deep.fits", 'thresh':"hard", 'atrous_do' : False, 'solnname' : 'nobeam', 'opdir_overwrite' : 'append', 'mean_map' : False, 'rms_map' : False, 'mean_map' : False, 'ini_gausfit' : 'nobeam', 'flag_smallsrc' : False, 'flag_minsnr' : 0.2, 'flag_maxsnr' : 3.0, 'flag_maxsize_isl' : 5.0, 'flag_maxsize_bm' : 45.0, 'flag_minsize_bm' : 0.2})
-
-#img, bdsm = call_pybdsm('test', {'fits_name': "A2255_85CM_BEAM_cut.fits", 'beam' : (0.0167, 0.0167, 0.0), 'thresh':"hard", 'atrous_do' : True, 'atrous_bdsm_do' : True, 'solnname' : 'del', 'ini_gausfit' : 'fbdsm', 'opdir_overwrite' : 'append'})
-
-#img = bdsm.execute(bdsm.fits_chain,{'fits_name': "matteo_mfs.im.fits", 'beam' : (0.002, 0.002, 0.0), 'thresh':"hard"})
-
-#img = bdsm.execute(bdsm.fits_chain,{'fits_name': "WN65341H.fits", 'beam': (.0165515, .01500, 0.0), 'thresh':"hard", 'atrous_do' : False})
-
-#img, bdsm = call_pybdsm('test', {'fits_name': "WN35078H.fits", 'beam': (.0261, .01500, 0.0), 'thresh':"hard", 'atrous_do' : True, 'shapelet_do' : False, 'ini_gausfit' : 'default' })
-
-#img, bdsm = call_pybdsm('test', {'fits_name': "3C274-P.FITS", 'beam': (.00654, .00654, -45.0), 'thresh':"hard", 'atrous_do' : True, 'atrous_jmax' : 5, 'bbs_patches' : 'single', 'solnname' : 'new', 'ini_gausfit' : 'default', 'opdir_overwrite' : 'append', 'atrous_bdsm_do' : True, 'rms_map' : False, 'mean_map' : False, 'thresh_pix' : 100, 'thresh_isl' : 60})
-
-#img = bdsm.execute(bdsm.fits_chain,{'fits_name': "Cas_A-P.models.FITS", 'thresh':"hard", 'atrous_do' : False, 'rms_map' : False, 'mean_map' : False })
-
-#img = bdsm.execute(bdsm.fits_chain,{'fits_name': "VIRA-4.MOD.FITS", 'thresh':"hard", 'atrous_do' : True })
-
-#img = bdsm.execute(bdsm.fits_chain,{'fits_name': "VIRA-4.MOD.pybdsm.atrous.w6.fits", 'thresh':"hard", 'rms_box' : (63, 21)})
-
-#img = bdsm.execute(bdsm.fits_chain,{'fits_name': "Cyg_A-P_mod.FITS", 'thresh':"hard", 'atrous_do' : False , 'rms_map' : False })
-
-#img = bdsm.execute(bdsm.fits_chain,{'fits_name': "Cyg_A-4.model.FITS", 'thresh':"hard", 'atrous_do' : False, 'rms_map' : False , 'thresh_pix' : 6})
-
-#img = bdsm.execute(bdsm.fits_chain,{'fits_name': "Cyg_A-P-cut.fits", 'thresh':"hard", 'atrous_do' : True , 'rms_map' : False, 'mean_map' : 'const', 'thresh_pix' : 1000, 'thresh_isl' : 800, 'ini_gausfit' : 'default', 'solnname' : 'del', 'atrous_bdsm_do' : False})
-
-img, bdsm = call_pybdsm('test' ,{'fits_name': "Cyg_A-P-cut.pybdsm.atrous.w12.fits", 'thresh':"hard", 'atrous_do' : False , 'rms_map' : False, 'mean_map' : 'const', 'ini_gausfit' : 'fbdsm', 'solnname' : 'del', 'opdir_overwrite' : 'append', 'stop_at' : 'isl'})
-
-#img, bdsm = call_pybdsm('test' ,{'fits_name': "Cyg_A-P-cut.pybdsm.atrous.w12.fits", 'thresh':"hard", 'atrous_do' : False , 'rms_map' : False, 'mean_map' : 'const', 'thresh_pix' : 30, 'thresh_isl' : 20, 'ini_gausfit' : 'fbdsm'})
-
-#img = bdsm.execute(bdsm.fits_chain,{'fits_name': "SB128_138-002-002.fits", 'thresh':"hard", 'solnname' : 'try' })
-
-#img = bdsm.execute(bdsm.fits_chain,{'fits_name': "concatenated-000-004.restored.fits", 'rms_box' : (130, 40), 'thresh':"hard", 'atrous_do' : False, 'shapelet_do' : False })
-
-#img = bdsm.execute(bdsm.fits_chain,{'fits_name': "mi_spam.fits", 'beam': (.0222, .0222, 0.0), 'thresh':"hard", 'atrous_do' : False })
-
-#img = bdsm.execute(bdsm.fits_chain,{'fits_name': "marijke.fits", 'beam': (.004, .004, 0.0), 'thresh':"hard", 'atrous_do' : True, 'thresh_isl' : 20, 'thresh_pix' : 100})
-
-#img = bdsm.execute(bdsm.fits_chain,{'fits_name': "SST1cont.image.restored.fits", 'beam': (.008333, .008333, 0.0), 'thresh':"hard", 'atrous_do' : False})
-
-#img = bdsm.execute(bdsm.fits_chain,{'fits_name': "bootbig.FITS", 'beam': (.00154, .00154, 0.0), 'thresh':"hard", \
-# 'atrous_do' : True, 'atrous_bdsm_do' : False})
-
-#img = bdsm.execute(bdsm.fits_chain,{'fits_name': "WN35060H", 'beam': (.0165515, .01500, 0.0), 'thresh':"hard"})
-
-#img = bdsm.execute(bdsm.fits_chain,{'fits_name': "lock_cube1.fits", 'beam': (.0054, .0044, 0.0), \
-# 'collapse_mode' : 'average', 'collapse_wt' : 'unity', 'beam_sp_derive' : \
-# True, 'atrous_do' : True, 'debug_figs' : True})
-
-#img = bdsm.execute(bdsm.fits_chain,{'fits_name': "newcube1.fits", 'beam': (.00389, .003056, 0.0), \
-# 'collapse_mode' : 'average', 'collapse_wt' : 'rms', 'thresh' : 'hard', 'atrous_do' : True})
-
-#img = bdsm.execute(bdsm.fits_chain,{'fits_name': "sim1.1.FITS", 'beam': (.00143, .00143, 0.0),\
-# 'collapse_mode' : 'average', 'collapse_wt' : 'rms', 'thresh' : 'hard', 'thresh_pix' : '30'})
-
-#img = bdsm.execute(bdsm.fits_chain,{'fits_name': "A2255_I.fits", 'beam': (.018, .014, 5.0), 'collapse_mode'
-# : 'average', 'collapse_wt' : 'rms', 'thresh' : 'hard', 'thresh_isl' : 20.0, 'thresh_pix' : 50.0,
-# 'polarisation_do': True, 'atrous_do' : True})
-
-#img = bdsm.execute(bdsm.fits_chain,{'fits_name': "try.fits", 'beam': (.056, .028, 160.0), 'thresh':"hard", 'thresh_pix':20.})
-
diff --git a/CEP/PyBDSM/test/test_watershed.py b/CEP/PyBDSM/test/test_watershed.py
deleted file mode 100644
index 7187408d2562afb5e61f40d36b3081230af6cb4a..0000000000000000000000000000000000000000
--- a/CEP/PyBDSM/test/test_watershed.py
+++ /dev/null
@@ -1,106 +0,0 @@
-
-import matplotlib.cm as cm
-import scipy.ndimage as nd
-from bdsm.const import fwsig
-from bdsm.gausfit import Op_gausfit as gg
-import bdsm.functions as func
-from _cbdsm import MGFunction
-from _cbdsm import lmder_fit, dn2g_fit, dnsg_fit
-import numpy as N
-from copy import deepcopy as cp
-
-for isl in img.islands:
- #isl = img.islands[153]
- if isl.ngaus > 1:
- thr = isl.mean + img.opts.thresh_pix*isl.rms
- im = isl.image; mask = isl.mask_active; av = img.clipped_mean; im1 = cp(im)
- ind = N.array(N.where(~mask)).transpose()
- ind = [tuple(coord) for coord in ind if im[tuple(coord)] > thr]
- n, m = isl.shape; iniposn = []; inipeak = []
- for c in ind:
- goodlist = [im[i,j] for i in range(c[0]-1,c[0]+2) for j in range(c[1]-1,c[1]+2) \
- if i>=0 and i<n and j>=0 and j<m and (i,j) != c]
- peak = N.sum(im[c] > goodlist) == len(goodlist)
- if peak:
- iniposn.append(c); inipeak.append(im[c])
- nmulsrc = len(iniposn)
- if nmulsrc > 1:
- markers = N.zeros(im.shape, int)
- markers[0,0] = 1
- for ipk in range(nmulsrc):
- pk = inipeak[ipk]; x, y = iniposn[ipk]
- markers[int(round(x)), int(round(y))] = ipk+2
- im2 = N.zeros(im.shape, int)
- im1 = im1 - im1.min()
- im1 = im1/im1.max()*255
- im1 = 255-im1
- nd.watershed_ift(N.array(im1, N.uint8), markers, output = im2)
- fcn = MGFunction(im, isl.mask_active, 1)
- fit = lmder_fit
- gg1 = gg()
- for ipk in range(nmulsrc):
- ind = ipk+2
- mom = func.momanalmask_gaus(im, im2, ind, 1.0, True)
- indd = N.where(im2==ind)
- mom[3] = 3.0; mom[4]=3.0
- g = [float(N.max(im[indd])), int(round(mom[1])), int(round(mom[2])), mom[3]/fwsig, mom[4]/fwsig, mom[5]]
- gg1.add_gaussian(fcn, g, dof = isl.size_active)
- print g
- fit(fcn, final=0, verbose=True)
- print fcn.parameters
- import pylab as pl
- pl.figure()
- pl.subplot(2,2,1);pl.imshow(N.transpose(im), interpolation='nearest', origin='lower'); pl.title(str(isl.island_id))
- pl.subplot(2,2,2);pl.imshow(N.transpose(im1), interpolation='nearest', origin='lower'); pl.title(str(isl.island_id))
- pl.subplot(2,2,3);pl.imshow(N.transpose(im2), interpolation='nearest', origin='lower'); pl.title(str(isl.island_id))
- for g in fcn.parameters:
- A, x1, x2, s1, s2, th = g
- s1, s2 = map(abs, [s1, s2])
- if s1 < s2: # s1 etc are sigma
- ss1=s2; ss2=s1; th1 = divmod(th+90.0, 180)[1]
- else:
- ss1=s1; ss2=s2; th1 = divmod(th, 180)[1]
- c = [A, x1, x2, ss1, ss2, th1]
- x, y = N.indices(isl.shape)
- x2, y2 = func.drawellipse(c)
- #x2 = x2 + isl.origin[0]; y2 = y2 + isl.origin[1]
- pl.subplot(2,2,4); pl.plot(x2, y2, '-r')
- pl.imshow(N.transpose(im), origin='lower', interpolation='nearest')
-
-
-
-import matplotlib.cm as cm
-import scipy.ndimage as nd
-import numpy as N
-from bdsm.const import fwsig
-from bdsm.gausfit import Op_gausfit as gg
-import bdsm.functions as func
-from _cbdsm import MGFunction
-from _cbdsm import lmder_fit, dn2g_fit, dnsg_fit
-image = N.zeros((100,100))
-markers = N.zeros(image.shape, int)
-op1 = N.zeros(image.shape, int)
-op2 = N.zeros(image.shape, int)
-x, y = N.indices(image.shape)
-peaks = [2.0, 8.0, 8.0, 2.0]
-posns = [(30, 20), (50, 20), (30, 70), (50, 70)]
-bmaj = [2.0, 12.0, 2.0, 12.0]
-brat = [2.0, 2.0, 2.0, 2.0]
-markers[10,10] = 1
-for ig in range(len(peaks)):
- g = peaks[ig]*N.exp(-0.5*((x-posns[ig][0])*(x-posns[ig][0])+(y-posns[ig][1])*(y-posns[ig][1])) \
- /(bmaj[ig]*bmaj[ig]/brat[ig]))
- image = image + g
- markers[int(round(posns[ig][0])), int(round(posns[ig][1]))] = ig+2
-
-image1 = image - image.min()
-image1 = image1/image1.max()*255
-image1 = 255-image1
-nd.watershed_ift(N.array(image1, N.uint8), markers, output = op1)
-pl.figure();pl.imshow(N.transpose(image), interpolation='nearest', origin='lower'); pl.title('orig'); pl.colorbar()
-pl.figure();pl.imshow(N.transpose(image1), interpolation='nearest', origin='lower'); pl.title('input1'); pl.colorbar()
-pl.figure();pl.imshow(N.transpose(op1), interpolation='nearest', origin='lower'); pl.title('output1'); pl.colorbar()
-pl.figure();pl.imshow(N.transpose(markers), interpolation='nearest', origin='lower'); pl.title('markers'); pl.colorbar()
-
-
-
diff --git a/CMake/FindPythonModule.cmake b/CMake/FindPythonModule.cmake
index bc54e795eeb1a2296d46c814be483cf0e9733560..9f8ec7caafe1ffb532e120fe9e0e63f6f46fdf54 100644
--- a/CMake/FindPythonModule.cmake
+++ b/CMake/FindPythonModule.cmake
@@ -37,27 +37,30 @@ find_package(PythonInterp)
# set it to FALSE.
# The REQUIRED option stops processing with an error message if the module
# <module> cannot be found.
+# The HINTS option can be used to give a path (or colon-separated list of
+# paths) that are prepended to the search path.
# -----------------------------------------------------------------------------
-macro(find_python_module _module)
+include(CMakeParseArguments)
+macro(find_python_module _module)
# Name of module in uppercase.
string(TOUPPER "${_module}" _MODULE)
+ cmake_parse_arguments(PYTHON_${_MODULE}_FIND
+ "REQUIRED"
+ "HINTS"
+ ""
+ ${ARGN}
+ )
+
+ if(NOT "${PYTHON_${_MODULE}_FIND_UNPARSED_ARGUMENTS}" STREQUAL "")
+ MESSAGE(FATAL_ERROR "Unknown arguments: ${PYTHON_${_MODULE}_FIND_UNPARSED_ARGUMENTS}")
+ endif()
# Try to find the python module, if we have not found it yet.
if(NOT PYTHON_${_MODULE})
-
- # Check if option REQUIRED was given.
- if(NOT "${ARGN}" STREQUAL "")
- if("${ARGN}" STREQUAL "REQUIRED")
- set(PYTHON_${_MODULE}_FIND_REQUIRED TRUE)
- else()
- message(FATAL_ERROR
- "find_python_module called with invalid argument \"${ARGN}\"")
- endif()
- endif()
-
# Try to import the python module we need to find, and get its file path.
if(PYTHON_EXECUTABLE)
+ set(ENV{PYTHONPATH} ${PYTHON_${_MODULE}_FIND_HINTS}:$ENV{PYTHONPATH})
set(_cmd "import ${_module}; print ${_module}.__file__")
execute_process(
COMMAND "${PYTHON_EXECUTABLE}" "-c" "${_cmd}"
diff --git a/CMake/variants/variants.lhd002 b/CMake/variants/variants.lhd002
index 917c84ee22338dc7e22ea8ce514457e0b06a0184..249fcc768bfe2811e42533dd902f1064310da1ef 100644
--- a/CMake/variants/variants.lhd002
+++ b/CMake/variants/variants.lhd002
@@ -5,6 +5,7 @@ set(CASAREST_ROOT_DIR /opt/cep/casarest/current)
set(PYRAP_ROOT_DIR /opt/cep/pyrap/current)
set(WCSLIB_ROOT_DIR /opt/cep/lofar/external/wcslib)
set(AOFLAGGER_ROOT_DIR /opt/cep/aoflagger/current)
+set(BDSF_ROOT_DIR /opt/cep/pybdsf/current)
set(DAL_ROOT_DIR /opt/cep/dal/current)
set(QPID_ROOT_DIR /opt/qpid)
set(LOG4CXX_ROOT_DIR /opt/cep/lofar/external/log4cxx)
diff --git a/Docker/lofar-pipeline/Dockerfile.tmpl b/Docker/lofar-pipeline/Dockerfile.tmpl
index 4f1a939d631490e2ed559d43b208a90dba96b226..59b8c2ab21b74d7ad14b15c36cdc98c74c374677 100644
--- a/Docker/lofar-pipeline/Dockerfile.tmpl
+++ b/Docker/lofar-pipeline/Dockerfile.tmpl
@@ -12,6 +12,22 @@ RUN apt-get update && apt-get install -y python-xmlrunner python-scipy liblog4cp
apt-get -y purge python-pip python-dev && \
apt-get -y autoremove --purge
+#
+# *******************
+# PyBDSF
+# *******************
+#
+
+ENV PYBDSF_VERSION=1.8.8
+
+RUN apt-get update && apt-get install -y git g++ gfortran libboost-python-dev python-setuptools && \
+ mkdir ${INSTALLDIR}/pybdsf && \
+ cd ${INSTALLDIR}/pybdsf && git clone https://github.com/lofar-astron/pybdsf && \
+ cd ${INSTALLDIR}/pybdsf/pybdsf && git checkout tags/v${PYBDSF_VERSION} && \
+ mkdir -p ${INSTALLDIR}/pybdsf/lib/python${PYTHON_VERSION}/site-packages/ && \
+ export PYTHONPATH=${INSTALLDIR}/pybdsf/lib/python${PYTHON_VERSION}/site-packages:${INSTALLDIR}/pybdsf/lib64/python${PYTHON_VERSION}/site-packages:$PYTHONPATH && cd ${INSTALLDIR}/pybdsf/pybdsf && python setup.py install --prefix=${INSTALLDIR}/pybdsf/ && \
+ apt-get -y purge git g++ gfortran libboost-python-dev python-setuptools
+
#
# *******************
# AOFlagger
@@ -49,7 +65,7 @@ RUN apt-get update && apt-get install -y subversion cmake g++ gfortran bison fle
cd ${INSTALLDIR}/lofar && \
svn --non-interactive -q co -r ${LOFAR_REVISION} -N ${LOFAR_BRANCH_URL} src; \
svn --non-interactive -q up src/CMake && \
- cd ${INSTALLDIR}/lofar/build/${LOFAR_BUILDVARIANT} && cmake -DBUILD_PACKAGES=Offline -DBUILD_TESTING=OFF -DCMAKE_INSTALL_PREFIX=${INSTALLDIR}/lofar/ -DCASAREST_ROOT_DIR=${INSTALLDIR}/casarest/ -DCASACORE_ROOT_DIR=${INSTALLDIR}/casacore/ -DAOFLAGGER_ROOT_DIR=${INSTALLDIR}/aoflagger/ -DQPID_ROOT_DIR=/opt/qpid/ -DUSE_OPENMP=True ${INSTALLDIR}/lofar/src/ && \
+ cd ${INSTALLDIR}/lofar/build/${LOFAR_BUILDVARIANT} && cmake -DBUILD_PACKAGES=Offline -DBUILD_TESTING=OFF -DCMAKE_INSTALL_PREFIX=${INSTALLDIR}/lofar/ -DCASAREST_ROOT_DIR=${INSTALLDIR}/casarest/ -DCASACORE_ROOT_DIR=${INSTALLDIR}/casacore/ -DAOFLAGGER_ROOT_DIR=${INSTALLDIR}/aoflagger/ -DBDSF_ROOT_DIR=/opt/pybdsf/lib/python${PYTHON_VERSION}/site-packages/ -DQPID_ROOT_DIR=/opt/qpid/ -DUSE_OPENMP=True ${INSTALLDIR}/lofar/src/ && \
cd ${INSTALLDIR}/lofar/build/${LOFAR_BUILDVARIANT} && sed -i '29,31d' include/ApplCommon/PosixTime.h && \
cd ${INSTALLDIR}/lofar/build/${LOFAR_BUILDVARIANT} && make -j ${J} && \
cd ${INSTALLDIR}/lofar/build/${LOFAR_BUILDVARIANT} && make install && \
diff --git a/Docker/lofar-pipeline/bashrc.d/11-pybdsf b/Docker/lofar-pipeline/bashrc.d/11-pybdsf
new file mode 100644
index 0000000000000000000000000000000000000000..fb52fa0f2bafda59fbf693cc8c03e967fae1644d
--- /dev/null
+++ b/Docker/lofar-pipeline/bashrc.d/11-pybdsf
@@ -0,0 +1,2 @@
+#!/bin/bash
+export PYTHONPATH=${PYTHONPATH}:${INSTALLDIR}/pybdsf/lib/python2.7/site-packages