diff --git a/pywafo/src/wafo/MSO.py b/wafo/MSO.py similarity index 100% rename from pywafo/src/wafo/MSO.py rename to wafo/MSO.py diff --git a/pywafo/src/wafo/MSPPT.py b/wafo/MSPPT.py similarity index 100% rename from pywafo/src/wafo/MSPPT.py rename to wafo/MSPPT.py diff --git a/pywafo/src/wafo/SpecData1D.mm b/wafo/SpecData1D.mm similarity index 100% rename from pywafo/src/wafo/SpecData1D.mm rename to wafo/SpecData1D.mm diff --git a/pywafo/src/wafo/__init__.py b/wafo/__init__.py similarity index 100% rename from pywafo/src/wafo/__init__.py rename to wafo/__init__.py diff --git a/pywafo/src/wafo/autumn.gif b/wafo/autumn.gif similarity index 100% rename from pywafo/src/wafo/autumn.gif rename to wafo/autumn.gif diff --git a/pywafo/src/wafo/bitwise.py b/wafo/bitwise.py similarity index 100% rename from pywafo/src/wafo/bitwise.py rename to wafo/bitwise.py diff --git a/pywafo/src/wafo/containers.py b/wafo/containers.py similarity index 100% rename from pywafo/src/wafo/containers.py rename to wafo/containers.py diff --git a/pywafo/src/wafo/covariance/__init__.py b/wafo/covariance/__init__.py similarity index 100% rename from pywafo/src/wafo/covariance/__init__.py rename to wafo/covariance/__init__.py diff --git a/pywafo/src/wafo/covariance/core.py b/wafo/covariance/core.py similarity index 100% rename from pywafo/src/wafo/covariance/core.py rename to wafo/covariance/core.py diff --git a/pywafo/src/wafo/covariance/estimation.py b/wafo/covariance/estimation.py similarity index 100% rename from pywafo/src/wafo/covariance/estimation.py rename to wafo/covariance/estimation.py diff --git a/pywafo/src/wafo/covariance/test/test_covariance.py b/wafo/covariance/test/test_covariance.py similarity index 100% rename from pywafo/src/wafo/covariance/test/test_covariance.py rename to wafo/covariance/test/test_covariance.py diff --git a/pywafo/src/wafo/data/__init__.py b/wafo/data/__init__.py similarity index 100% rename from pywafo/src/wafo/data/__init__.py rename to wafo/data/__init__.py diff --git a/pywafo/src/wafo/data/atlantic.dat b/wafo/data/atlantic.dat similarity index 100% rename from pywafo/src/wafo/data/atlantic.dat rename to wafo/data/atlantic.dat diff --git a/pywafo/src/wafo/data/gfaks89.dat b/wafo/data/gfaks89.dat similarity index 100% rename from pywafo/src/wafo/data/gfaks89.dat rename to wafo/data/gfaks89.dat diff --git a/pywafo/src/wafo/data/gfaksr89.dat b/wafo/data/gfaksr89.dat similarity index 100% rename from pywafo/src/wafo/data/gfaksr89.dat rename to wafo/data/gfaksr89.dat diff --git a/pywafo/src/wafo/data/info.py b/wafo/data/info.py similarity index 100% rename from pywafo/src/wafo/data/info.py rename to wafo/data/info.py diff --git a/pywafo/src/wafo/data/japansea.dat b/wafo/data/japansea.dat similarity index 100% rename from pywafo/src/wafo/data/japansea.dat rename to wafo/data/japansea.dat diff --git a/pywafo/src/wafo/data/northsea.dat b/wafo/data/northsea.dat similarity index 100% rename from pywafo/src/wafo/data/northsea.dat rename to wafo/data/northsea.dat diff --git a/pywafo/src/wafo/data/sea.dat b/wafo/data/sea.dat similarity index 100% rename from pywafo/src/wafo/data/sea.dat rename to wafo/data/sea.dat diff --git a/pywafo/src/wafo/data/sea.m b/wafo/data/sea.m similarity index 100% rename from pywafo/src/wafo/data/sea.m rename to wafo/data/sea.m diff --git a/pywafo/src/wafo/data/sfa89.dat b/wafo/data/sfa89.dat similarity index 100% rename from pywafo/src/wafo/data/sfa89.dat rename to wafo/data/sfa89.dat diff --git a/pywafo/src/wafo/data/sn.dat b/wafo/data/sn.dat similarity index 100% rename from pywafo/src/wafo/data/sn.dat rename to wafo/data/sn.dat diff --git a/pywafo/src/wafo/data/wafoLogoNewWithBorder.png b/wafo/data/wafoLogoNewWithBorder.png similarity index 100% rename from pywafo/src/wafo/data/wafoLogoNewWithBorder.png rename to wafo/data/wafoLogoNewWithBorder.png diff --git a/pywafo/src/wafo/data/wafoLogoNewWithBorder.svg b/wafo/data/wafoLogoNewWithBorder.svg similarity index 100% rename from pywafo/src/wafo/data/wafoLogoNewWithBorder.svg rename to wafo/data/wafoLogoNewWithBorder.svg diff --git a/pywafo/src/wafo/data/wafoLogoNewWithoutBorder.png b/wafo/data/wafoLogoNewWithoutBorder.png similarity index 100% rename from pywafo/src/wafo/data/wafoLogoNewWithoutBorder.png rename to wafo/data/wafoLogoNewWithoutBorder.png diff --git a/pywafo/src/wafo/data/wafoLogoNewWithoutBorder.svg b/wafo/data/wafoLogoNewWithoutBorder.svg similarity index 100% rename from pywafo/src/wafo/data/wafoLogoNewWithoutBorder.svg rename to wafo/data/wafoLogoNewWithoutBorder.svg diff --git a/pywafo/src/wafo/data/wafologoWithBorder.png b/wafo/data/wafologoWithBorder.png similarity index 100% rename from pywafo/src/wafo/data/wafologoWithBorder.png rename to wafo/data/wafologoWithBorder.png diff --git a/pywafo/src/wafo/data/yura87.dat b/wafo/data/yura87.dat similarity index 100% rename from pywafo/src/wafo/data/yura87.dat rename to wafo/data/yura87.dat diff --git a/pywafo/src/wafo/dctpack.py b/wafo/dctpack.py similarity index 100% rename from pywafo/src/wafo/dctpack.py rename to wafo/dctpack.py diff --git a/pywafo/src/wafo/definitions.py b/wafo/definitions.py similarity index 100% rename from pywafo/src/wafo/definitions.py rename to wafo/definitions.py diff --git a/pywafo/src/wafo/demo_sg.py b/wafo/demo_sg.py similarity index 100% rename from pywafo/src/wafo/demo_sg.py rename to wafo/demo_sg.py diff --git a/pywafo/src/wafo/demos.py b/wafo/demos.py similarity index 100% rename from pywafo/src/wafo/demos.py rename to wafo/demos.py diff --git a/pywafo/src/wafo/doc/__init__.py b/wafo/doc/__init__.py similarity index 100% rename from pywafo/src/wafo/doc/__init__.py rename to wafo/doc/__init__.py diff --git a/pywafo/src/wafo/doc/tutorial_scripts/WAFO Chapter 1.ipynb b/wafo/doc/tutorial_scripts/WAFO Chapter 1.ipynb similarity index 100% rename from pywafo/src/wafo/doc/tutorial_scripts/WAFO Chapter 1.ipynb rename to wafo/doc/tutorial_scripts/WAFO Chapter 1.ipynb diff --git a/pywafo/src/wafo/doc/tutorial_scripts/WAFO Chapter 2.ipynb b/wafo/doc/tutorial_scripts/WAFO Chapter 2.ipynb similarity index 100% rename from pywafo/src/wafo/doc/tutorial_scripts/WAFO Chapter 2.ipynb rename to wafo/doc/tutorial_scripts/WAFO Chapter 2.ipynb diff --git a/pywafo/src/wafo/doc/tutorial_scripts/WAFO Chapter 3.ipynb b/wafo/doc/tutorial_scripts/WAFO Chapter 3.ipynb similarity index 100% rename from pywafo/src/wafo/doc/tutorial_scripts/WAFO Chapter 3.ipynb rename to wafo/doc/tutorial_scripts/WAFO Chapter 3.ipynb diff --git a/pywafo/src/wafo/doc/tutorial_scripts/WAFO Chapter 4.ipynb b/wafo/doc/tutorial_scripts/WAFO Chapter 4.ipynb similarity index 100% rename from pywafo/src/wafo/doc/tutorial_scripts/WAFO Chapter 4.ipynb rename to wafo/doc/tutorial_scripts/WAFO Chapter 4.ipynb diff --git a/pywafo/src/wafo/doc/tutorial_scripts/WAFO Chapter 5.ipynb b/wafo/doc/tutorial_scripts/WAFO Chapter 5.ipynb similarity index 100% rename from pywafo/src/wafo/doc/tutorial_scripts/WAFO Chapter 5.ipynb rename to wafo/doc/tutorial_scripts/WAFO Chapter 5.ipynb diff --git a/pywafo/src/wafo/doc/tutorial_scripts/chapter1.py b/wafo/doc/tutorial_scripts/chapter1.py similarity index 100% rename from pywafo/src/wafo/doc/tutorial_scripts/chapter1.py rename to wafo/doc/tutorial_scripts/chapter1.py diff --git a/pywafo/src/wafo/doc/tutorial_scripts/chapter2.py b/wafo/doc/tutorial_scripts/chapter2.py similarity index 100% rename from pywafo/src/wafo/doc/tutorial_scripts/chapter2.py rename to wafo/doc/tutorial_scripts/chapter2.py diff --git a/pywafo/src/wafo/doc/tutorial_scripts/chapter3.py b/wafo/doc/tutorial_scripts/chapter3.py similarity index 100% rename from pywafo/src/wafo/doc/tutorial_scripts/chapter3.py rename to wafo/doc/tutorial_scripts/chapter3.py diff --git a/pywafo/src/wafo/doc/tutorial_scripts/chapter4.py b/wafo/doc/tutorial_scripts/chapter4.py similarity index 100% rename from pywafo/src/wafo/doc/tutorial_scripts/chapter4.py rename to wafo/doc/tutorial_scripts/chapter4.py diff --git a/pywafo/src/wafo/doc/tutorial_scripts/chapter5.py b/wafo/doc/tutorial_scripts/chapter5.py similarity index 100% rename from pywafo/src/wafo/doc/tutorial_scripts/chapter5.py rename to wafo/doc/tutorial_scripts/chapter5.py diff --git a/pywafo/src/wafo/f2py_tools.py b/wafo/f2py_tools.py similarity index 100% rename from pywafo/src/wafo/f2py_tools.py rename to wafo/f2py_tools.py diff --git a/pywafo/src/wafo/fig.py b/wafo/fig.py similarity index 100% rename from pywafo/src/wafo/fig.py rename to wafo/fig.py diff --git a/pywafo/src/wafo/gaussian.py b/wafo/gaussian.py similarity index 100% rename from pywafo/src/wafo/gaussian.py rename to wafo/gaussian.py diff --git a/pywafo/src/wafo/graphutil.py b/wafo/graphutil.py similarity index 100% rename from pywafo/src/wafo/graphutil.py rename to wafo/graphutil.py diff --git a/pywafo/src/wafo/info.py b/wafo/info.py similarity index 100% rename from pywafo/src/wafo/info.py rename to wafo/info.py diff --git a/pywafo/src/wafo/integrate.py b/wafo/integrate.py similarity index 100% rename from pywafo/src/wafo/integrate.py rename to wafo/integrate.py diff --git a/pywafo/src/wafo/interpolate.py b/wafo/interpolate.py similarity index 100% rename from pywafo/src/wafo/interpolate.py rename to wafo/interpolate.py diff --git a/pywafo/src/wafo/kdetools.py b/wafo/kdetools.py similarity index 100% rename from pywafo/src/wafo/kdetools.py rename to wafo/kdetools.py diff --git a/pywafo/src/wafo/magic.py b/wafo/magic.py similarity index 100% rename from pywafo/src/wafo/magic.py rename to wafo/magic.py diff --git a/pywafo/src/wafo/misc.py b/wafo/misc.py similarity index 100% rename from pywafo/src/wafo/misc.py rename to wafo/misc.py diff --git a/pywafo/src/wafo/namedtuple.py b/wafo/namedtuple.py similarity index 100% rename from pywafo/src/wafo/namedtuple.py rename to wafo/namedtuple.py diff --git a/pywafo/src/wafo/numpy_utils.py b/wafo/numpy_utils.py similarity index 100% rename from pywafo/src/wafo/numpy_utils.py rename to wafo/numpy_utils.py diff --git a/pywafo/src/wafo/objects.py b/wafo/objects.py similarity index 100% rename from pywafo/src/wafo/objects.py rename to wafo/objects.py diff --git a/pywafo/src/wafo/padua.py b/wafo/padua.py similarity index 100% rename from pywafo/src/wafo/padua.py rename to wafo/padua.py diff --git a/pywafo/src/wafo/plotbackend.py b/wafo/plotbackend.py similarity index 100% rename from pywafo/src/wafo/plotbackend.py rename to wafo/plotbackend.py diff --git a/pywafo/src/wafo/polynomial.py b/wafo/polynomial.py similarity index 100% rename from pywafo/src/wafo/polynomial.py rename to wafo/polynomial.py diff --git a/pywafo/src/wafo/polynomial_old.py b/wafo/polynomial_old.py similarity index 100% rename from pywafo/src/wafo/polynomial_old.py rename to wafo/polynomial_old.py diff --git a/pywafo/src/wafo/powerpoint.py b/wafo/powerpoint.py similarity index 100% rename from pywafo/src/wafo/powerpoint.py rename to wafo/powerpoint.py diff --git a/pywafo/src/wafo/sg_filter.py b/wafo/sg_filter.py similarity index 100% rename from pywafo/src/wafo/sg_filter.py rename to wafo/sg_filter.py diff --git a/pywafo/src/wafo/source/c_library/build_all.py b/wafo/source/c_library/build_all.py similarity index 100% rename from pywafo/src/wafo/source/c_library/build_all.py rename to wafo/source/c_library/build_all.py diff --git a/pywafo/src/wafo/source/c_library/c_functions.c b/wafo/source/c_library/c_functions.c similarity index 100% rename from pywafo/src/wafo/source/c_library/c_functions.c rename to wafo/source/c_library/c_functions.c diff --git a/pywafo/src/wafo/source/c_library/c_library rf3 rf5 license.txt b/wafo/source/c_library/c_library rf3 rf5 license.txt similarity index 100% rename from pywafo/src/wafo/source/c_library/c_library rf3 rf5 license.txt rename to wafo/source/c_library/c_library rf3 rf5 license.txt diff --git a/pywafo/src/wafo/source/c_library/c_library.pyf b/wafo/source/c_library/c_library.pyf similarity index 100% rename from pywafo/src/wafo/source/c_library/c_library.pyf rename to wafo/source/c_library/c_library.pyf diff --git a/pywafo/src/wafo/source/c_library/c_librarymodule.c b/wafo/source/c_library/c_librarymodule.c similarity index 100% rename from pywafo/src/wafo/source/c_library/c_librarymodule.c rename to wafo/source/c_library/c_librarymodule.c diff --git a/pywafo/src/wafo/source/c_library/setup.py b/wafo/source/c_library/setup.py similarity index 100% rename from pywafo/src/wafo/source/c_library/setup.py rename to wafo/source/c_library/setup.py diff --git a/pywafo/src/wafo/source/cov2XXXpdf/bounds/cov2acdfb.f b/wafo/source/cov2XXXpdf/bounds/cov2acdfb.f similarity index 100% rename from pywafo/src/wafo/source/cov2XXXpdf/bounds/cov2acdfb.f rename to wafo/source/cov2XXXpdf/bounds/cov2acdfb.f diff --git a/pywafo/src/wafo/source/cov2XXXpdf/bounds/cov2mmpdfb.f b/wafo/source/cov2XXXpdf/bounds/cov2mmpdfb.f similarity index 100% rename from pywafo/src/wafo/source/cov2XXXpdf/bounds/cov2mmpdfb.f rename to wafo/source/cov2XXXpdf/bounds/cov2mmpdfb.f diff --git a/pywafo/src/wafo/source/cov2XXXpdf/bounds/cov2tccpdfb.f b/wafo/source/cov2XXXpdf/bounds/cov2tccpdfb.f similarity index 100% rename from pywafo/src/wafo/source/cov2XXXpdf/bounds/cov2tccpdfb.f rename to wafo/source/cov2XXXpdf/bounds/cov2tccpdfb.f diff --git a/pywafo/src/wafo/source/cov2XXXpdf/bounds/cov2tthpdfb.f b/wafo/source/cov2XXXpdf/bounds/cov2tthpdfb.f similarity index 100% rename from pywafo/src/wafo/source/cov2XXXpdf/bounds/cov2tthpdfb.f rename to wafo/source/cov2XXXpdf/bounds/cov2tthpdfb.f diff --git a/pywafo/src/wafo/source/cov2XXXpdf/cov2acdf.f b/wafo/source/cov2XXXpdf/cov2acdf.f similarity index 100% rename from pywafo/src/wafo/source/cov2XXXpdf/cov2acdf.f rename to wafo/source/cov2XXXpdf/cov2acdf.f diff --git a/pywafo/src/wafo/source/cov2XXXpdf/cov2mmpdf.f b/wafo/source/cov2XXXpdf/cov2mmpdf.f similarity index 100% rename from pywafo/src/wafo/source/cov2XXXpdf/cov2mmpdf.f rename to wafo/source/cov2XXXpdf/cov2mmpdf.f diff --git a/pywafo/src/wafo/source/cov2XXXpdf/cov2mmtpdf.f b/wafo/source/cov2XXXpdf/cov2mmtpdf.f similarity index 100% rename from pywafo/src/wafo/source/cov2XXXpdf/cov2mmtpdf.f rename to wafo/source/cov2XXXpdf/cov2mmtpdf.f diff --git a/pywafo/src/wafo/source/cov2XXXpdf/cov2tccpdf.f b/wafo/source/cov2XXXpdf/cov2tccpdf.f similarity index 100% rename from pywafo/src/wafo/source/cov2XXXpdf/cov2tccpdf.f rename to wafo/source/cov2XXXpdf/cov2tccpdf.f diff --git a/pywafo/src/wafo/source/cov2XXXpdf/cov2tcpdf.f b/wafo/source/cov2XXXpdf/cov2tcpdf.f similarity index 100% rename from pywafo/src/wafo/source/cov2XXXpdf/cov2tcpdf.f rename to wafo/source/cov2XXXpdf/cov2tcpdf.f diff --git a/pywafo/src/wafo/source/cov2XXXpdf/cov2thpdf.f b/wafo/source/cov2XXXpdf/cov2thpdf.f similarity index 100% rename from pywafo/src/wafo/source/cov2XXXpdf/cov2thpdf.f rename to wafo/source/cov2XXXpdf/cov2thpdf.f diff --git a/pywafo/src/wafo/source/cov2XXXpdf/cov2thpdfalan.f b/wafo/source/cov2XXXpdf/cov2thpdfalan.f similarity index 100% rename from pywafo/src/wafo/source/cov2XXXpdf/cov2thpdfalan.f rename to wafo/source/cov2XXXpdf/cov2thpdfalan.f diff --git a/pywafo/src/wafo/source/cov2XXXpdf/cov2tthpdf.f b/wafo/source/cov2XXXpdf/cov2tthpdf.f similarity index 100% rename from pywafo/src/wafo/source/cov2XXXpdf/cov2tthpdf.f rename to wafo/source/cov2XXXpdf/cov2tthpdf.f diff --git a/pywafo/src/wafo/source/mreg/build_all.py b/wafo/source/mreg/build_all.py similarity index 100% rename from pywafo/src/wafo/source/mreg/build_all.py rename to wafo/source/mreg/build_all.py diff --git a/pywafo/src/wafo/source/mreg/cov2mmpdfreg.f b/wafo/source/mreg/cov2mmpdfreg.f similarity index 100% rename from pywafo/src/wafo/source/mreg/cov2mmpdfreg.f rename to wafo/source/mreg/cov2mmpdfreg.f diff --git a/pywafo/src/wafo/source/mreg/cov2mmpdfreg_intfc.f b/wafo/source/mreg/cov2mmpdfreg_intfc.f similarity index 100% rename from pywafo/src/wafo/source/mreg/cov2mmpdfreg_intfc.f rename to wafo/source/mreg/cov2mmpdfreg_intfc.f diff --git a/pywafo/src/wafo/source/mreg/dsvdc.f b/wafo/source/mreg/dsvdc.f similarity index 100% rename from pywafo/src/wafo/source/mreg/dsvdc.f rename to wafo/source/mreg/dsvdc.f diff --git a/pywafo/src/wafo/source/mreg/intfcmod.f b/wafo/source/mreg/intfcmod.f similarity index 100% rename from pywafo/src/wafo/source/mreg/intfcmod.f rename to wafo/source/mreg/intfcmod.f diff --git a/pywafo/src/wafo/source/mreg/mregmodule.f b/wafo/source/mreg/mregmodule.f similarity index 100% rename from pywafo/src/wafo/source/mreg/mregmodule.f rename to wafo/source/mreg/mregmodule.f diff --git a/pywafo/src/wafo/source/mvn/build_all.py b/wafo/source/mvn/build_all.py similarity index 100% rename from pywafo/src/wafo/source/mvn/build_all.py rename to wafo/source/mvn/build_all.py diff --git a/pywafo/src/wafo/source/mvn/mvndst.f b/wafo/source/mvn/mvndst.f similarity index 100% rename from pywafo/src/wafo/source/mvn/mvndst.f rename to wafo/source/mvn/mvndst.f diff --git a/pywafo/src/wafo/source/mvnprd/build_all.py b/wafo/source/mvnprd/build_all.py similarity index 99% rename from pywafo/src/wafo/source/mvnprd/build_all.py rename to wafo/source/mvnprd/build_all.py index 5092b9d..e89b68c 100644 --- a/pywafo/src/wafo/source/mvnprd/build_all.py +++ b/wafo/source/mvnprd/build_all.py @@ -2,7 +2,7 @@ import os import sys from wafo.f2py_tools import f2py_call_str - + def compile_all(): f2py_call = f2py_call_str() diff --git a/pywafo/src/wafo/source/mvnprd/mvnprd.dsp b/wafo/source/mvnprd/mvnprd.dsp similarity index 100% rename from pywafo/src/wafo/source/mvnprd/mvnprd.dsp rename to wafo/source/mvnprd/mvnprd.dsp diff --git a/pywafo/src/wafo/source/mvnprd/mvnprd.dsw b/wafo/source/mvnprd/mvnprd.dsw similarity index 100% rename from pywafo/src/wafo/source/mvnprd/mvnprd.dsw rename to wafo/source/mvnprd/mvnprd.dsw diff --git a/pywafo/src/wafo/source/mvnprd/mvnprd.f b/wafo/source/mvnprd/mvnprd.f similarity index 100% rename from pywafo/src/wafo/source/mvnprd/mvnprd.f rename to wafo/source/mvnprd/mvnprd.f diff --git a/pywafo/src/wafo/source/mvnprd/mvnprd.pyf b/wafo/source/mvnprd/mvnprd.pyf similarity index 100% rename from pywafo/src/wafo/source/mvnprd/mvnprd.pyf rename to wafo/source/mvnprd/mvnprd.pyf diff --git a/pywafo/src/wafo/source/mvnprd/mvnprd_interface.f b/wafo/source/mvnprd/mvnprd_interface.f similarity index 100% rename from pywafo/src/wafo/source/mvnprd/mvnprd_interface.f rename to wafo/source/mvnprd/mvnprd_interface.f diff --git a/pywafo/src/wafo/source/mvnprd/old/mvnprodcorrprb/mvnprodcorrprb.f b/wafo/source/mvnprd/mvnprodcorrprb.f similarity index 96% rename from pywafo/src/wafo/source/mvnprd/old/mvnprodcorrprb/mvnprodcorrprb.f rename to wafo/source/mvnprd/mvnprodcorrprb.f index 8850562..ae000cc 100644 --- a/pywafo/src/wafo/source/mvnprd/old/mvnprodcorrprb/mvnprodcorrprb.f +++ b/wafo/source/mvnprd/mvnprodcorrprb.f @@ -1,16 +1,16 @@ C Does not work: f2py -m mvnprdmod -h mvnprdmod.pyf mvnprodcorrprb.f only: mvnprodcorrprb - - -C gfortran -fPIC -c mvnprodcorrprb.f + + +C gfortran -fPIC -c mvnprodcorrprb.f C f2py -m mvnprdmod -c mvnprodcorrprb.o mvnprodcorrprb_interface.f --fcompiler=gnu95 --compiler=mingw32 -lmsvcr71 C f2py -m mvnprdmod -c mvnprodcorrprb.o mvnprodcorrprb_interface.f --build-dir tmp1 --fcompiler=gnu95 --compiler=mingw32 -lmsvcr71 - + * This is a MEX-file for MATLAB. * and contains a mex-interface to, mvnprodcorrprb a subroutine * for computing multivariate normal probabilities with product * correlation structure. -* The file should compile without errors on (Fortran90) +* The file should compile without errors on (Fortran90) * standard Fortran compilers. * * The mex-interface and mvnprodcorrprb was written by @@ -22,7 +22,7 @@ C f2py -m mvnprdmod -c mvnprodcorrprb.o mvnprodcorrprb_interface.f --build-dir * Email: Per.Brodtkorb@ffi.no * * -* MVNPRODCORRPRBMEX Computes multivariate normal probability +* MVNPRODCORRPRBMEX Computes multivariate normal probability * with product correlation structure. * * CALL [value,error,inform]=mvnprodcorrprbmex(rho,A,B,abseps,releps,useBreakPoints); @@ -30,7 +30,7 @@ C f2py -m mvnprdmod -c mvnprodcorrprb.o mvnprodcorrprb_interface.f --build-dir * RHO REAL, array of coefficients defining the correlation * coefficient by: * correlation(I,J) = RHO(I)*RHO(J) for J/=I -* where +* where * 1 <= RHO(I) <= 1 * A REAL, array of lower integration limits. * B REAL, array of upper integration limits. @@ -41,13 +41,13 @@ C f2py -m mvnprdmod -c mvnprodcorrprb.o mvnprodcorrprb_interface.f --build-dir * USEBREAKPOINTS = 1 If extra integration points should be used * around possible singularities * 0 If no extra -* +* * ERROR REAL estimated absolute error, with 99% confidence level. * VALUE REAL estimated value for the integral * INFORM INTEGER, termination status parameter: * if INFORM = 0, normal completion with ERROR < EPS; -* if INFORM = 1, completion with ERROR > EPS and MAXPTS -* function vaules used; increase MAXPTS to +* if INFORM = 1, completion with ERROR > EPS and MAXPTS +* function vaules used; increase MAXPTS to * decrease ERROR; * * MVNPRODCORRPRB calculates multivariate normal probability @@ -82,19 +82,19 @@ C f2py -m mvnprdmod -c mvnprodcorrprb.o mvnprodcorrprb_interface.f --build-dir INTERFACE CALERF MODULE PROCEDURE CALERF - END INTERFACE + END INTERFACE INTERFACE DERF MODULE PROCEDURE DERF - END INTERFACE + END INTERFACE INTERFACE DERFC MODULE PROCEDURE DERFC - END INTERFACE + END INTERFACE INTERFACE DERFCX MODULE PROCEDURE DERFCX - END INTERFACE + END INTERFACE CONTAINS C-------------------------------------------------------------------- C @@ -261,9 +261,9 @@ C Argonne National Laboratory C Argonne, IL 60439 C C Latest modification: March 19, 1990 -C Updated to F90 by pab 23.03.2003 -C Revised pab Dec 2008 -C updated parameter statements in CALERF so that it works when +C Updated to F90 by pab 23.03.2003 +C Revised pab Dec 2008 +C updated parameter statements in CALERF so that it works when C compiling with gfortran. C C------------------------------------------------------------------ @@ -292,54 +292,54 @@ C------------------------------------------------------------------ DOUBLE PRECISION, PARAMETER :: XBIG = 26.543D0 DOUBLE PRECISION, PARAMETER :: XHUGE = 6.71D7 DOUBLE PRECISION, PARAMETER :: XMAX = 2.53D307 - DOUBLE PRECISION, PARAMETER :: XINF = 1.79D308 + DOUBLE PRECISION, PARAMETER :: XINF = 1.79D308 !--------------------------------------------------------------- ! Coefficents to the rational polynomials !-------------------------------------------------------------- C DOUBLE PRECISION, DIMENSION(5) :: A, Q C DOUBLE PRECISION, DIMENSION(4) :: B C DOUBLE PRECISION, DIMENSION(9) :: C -C DOUBLE PRECISION, DIMENSION(8) :: D +C DOUBLE PRECISION, DIMENSION(8) :: D C DOUBLE PRECISION, DIMENSION(6) :: P C------------------------------------------------------------------ C Coefficients for approximation to erf in first interval -C------------------------------------------------------------------ +C------------------------------------------------------------------ DOUBLE PRECISION, PARAMETER, DIMENSION(5) :: & A = (/ 3.16112374387056560D00, & 1.13864154151050156D02,3.77485237685302021D02, - & 3.20937758913846947D03, 1.85777706184603153D-1/) + & 3.20937758913846947D03, 1.85777706184603153D-1/) DOUBLE PRECISION, PARAMETER, DIMENSION(4) :: & B = (/2.36012909523441209D01,2.44024637934444173D02, & 1.28261652607737228D03,2.84423683343917062D03/) C------------------------------------------------------------------ C Coefficients for approximation to erfc in second interval C------------------------------------------------------------------ - DOUBLE PRECISION, DIMENSION(9) :: + DOUBLE PRECISION, DIMENSION(9) :: & C=(/5.64188496988670089D-1,8.88314979438837594D0, 1 6.61191906371416295D01,2.98635138197400131D02, 2 8.81952221241769090D02,1.71204761263407058D03, 3 2.05107837782607147D03,1.23033935479799725D03, - 4 2.15311535474403846D-8/) - DOUBLE PRECISION, DIMENSION(8) :: - & D =(/1.57449261107098347D01,1.17693950891312499D02, + 4 2.15311535474403846D-8/) + DOUBLE PRECISION, DIMENSION(8) :: + & D =(/1.57449261107098347D01,1.17693950891312499D02, 1 5.37181101862009858D02,1.62138957456669019D03, 2 3.29079923573345963D03,4.36261909014324716D03, 3 3.43936767414372164D03,1.23033935480374942D03/) C------------------------------------------------------------------ C Coefficients for approximation to erfc in third interval -C------------------------------------------------------------------ - DOUBLE PRECISION, parameter, - & DIMENSION(6) :: P =(/3.05326634961232344D-1, +C------------------------------------------------------------------ + DOUBLE PRECISION, parameter, + & DIMENSION(6) :: P =(/3.05326634961232344D-1, & 3.60344899949804439D-1, 1 1.25781726111229246D-1,1.60837851487422766D-2, - 2 6.58749161529837803D-4,1.63153871373020978D-2/) - DOUBLE PRECISION, parameter, - & DIMENSION(5) :: Q =(/2.56852019228982242D00, + 2 6.58749161529837803D-4,1.63153871373020978D-2/) + DOUBLE PRECISION, parameter, + & DIMENSION(5) :: Q =(/2.56852019228982242D00, & 1.87295284992346047D00, 1 5.27905102951428412D-1,6.05183413124413191D-2, 2 2.33520497626869185D-3/) -C------------------------------------------------------------------ - +C------------------------------------------------------------------ + X = ARG Y = ABS(X) IF (Y .LE. THRESH) THEN @@ -377,8 +377,8 @@ C------------------------------------------------------------------ YSQ = AINT(Y*SIXTEN)/SIXTEN DEL = (Y-YSQ)*(Y+YSQ) RESULT = EXP(-YSQ*YSQ) * EXP(-DEL) * RESULT - END IF - + END IF + C------------------------------------------------------------------ C Evaluate erfc for |X| > 4.0 C------------------------------------------------------------------ @@ -441,7 +441,7 @@ C------------------------------------------------------------------ implicit none private public :: dqagpe,dqagp - + INTERFACE dqagpe MODULE PROCEDURE dqagpe END INTERFACE @@ -453,11 +453,11 @@ C------------------------------------------------------------------ INTERFACE dqelg MODULE PROCEDURE dqelg END INTERFACE - - INTERFACE dqpsrt + + INTERFACE dqpsrt MODULE PROCEDURE dqpsrt END INTERFACE - + INTERFACE dqk21 MODULE PROCEDURE dqk21 END INTERFACE @@ -473,7 +473,7 @@ C------------------------------------------------------------------ INTERFACE d1mach MODULE PROCEDURE d1mach END INTERFACE - + contains subroutine dea3(E0,E1,E2,abserr,result) !***PURPOSE Given a slowly convergent sequence, this routine attempts @@ -481,7 +481,7 @@ C------------------------------------------------------------------ ! sequence's limiting value, thus improving the rate of ! convergence. Routine is based on the epsilon algorithm ! of P. Wynn. An estimate of the absolute error is also -! given. +! given. double precision, intent(in) :: E0,E1,E2 double precision, intent(out) :: abserr, result !locals @@ -749,9 +749,9 @@ c***end prologue dqagpe * nint,nintp1,npts2,nres,nrmax,numrl2 logical :: extrap,noext external f -! -! - +! +! + ! ! ! the dimension of rlist2 is determined by the value of @@ -807,13 +807,13 @@ c***end prologue dqagpe ! c***first executable statement dqagpe epmach = d1mach(4) - uflow = d1mach(1) + uflow = d1mach(1) oflow = d1mach(2) ! ! test on validity of parameters ! ----------------------------- ! - hSplit = 0.2D0 + hSplit = 0.2D0 ier = 0 neval = 0 last = 0 @@ -827,7 +827,7 @@ c***first executable statement dqagpe level(1) = 0 npts2 = npts+2 if((npts2.lt.2).or.(limit.le.npts).or. - & ((epsabs.le.0.0d+00).and. + & ((epsabs.le.0.0d+00).and. & (epsrel.lt.dmax1(0.5d+02*epmach,0.5d-28)))) then ier = 6 go to 999 @@ -841,7 +841,7 @@ c***first executable statement dqagpe if(any(points(1:npts)<=a).or.any(b<=points(1:npts))) then ier = 6 go to 999 - endif + endif endif ! ! if any break points are provided, sort them into an @@ -851,7 +851,7 @@ c***first executable statement dqagpe pts(npts+2) = b do i = 1,npts pts(i+1) = minval(points(i:npts)) - enddo + enddo ! ! compute first integral and error approximations. ! ------------------------------------------------ @@ -1545,7 +1545,7 @@ c because of symmetry only the positive abscissae and their c corresponding weights are given. c c xgk - abscissae of the 15-point kronrod rule -! xgk(4), xgk(8) abscissae of the 3-point gauss rule +! xgk(4), xgk(8) abscissae of the 3-point gauss rule c xgk(2), xgk(4),xgk(6), xgk(8) ... abscissae of the 7-point c kronrod rule c xgk(1), xgk(3), ... abscissae which are optimally @@ -1647,7 +1647,7 @@ c resk = resk + wgk(jtwm1) * fsum resabs = resabs + wgk(jtwm1) * (dabs(fval1) + dabs(fval2)) 15 continue - + reskh = resk*0.5d+00 resasc = wgk(8)*dabs(fc-reskh) do 20 j=1,7 @@ -1669,7 +1669,7 @@ c if(resabs.gt.uflow/(0.5d+02*epmach)) abserr = dmax1 * ((epmach*0.5d+02)*resabs,abserr) return - + end subroutine dqk9 subroutine dqkl9(f,a,b,result,abserr,resabs,resasc) ! use functionInterface @@ -1738,7 +1738,7 @@ c because of symmetry only the positive abscissae and their c corresponding weights are given. c c xgk - abscissae of the 9-point Gauss-kronrod-lobatto rule -! xgk(1), xgk(5) abscissae of the 3-point gauss-lobatto rule +! xgk(1), xgk(5) abscissae of the 3-point gauss-lobatto rule c xgk(1), xgk(3),xgk(5) abscissae of the 5-point c kronrod rule c xgk(2), xgk(4), ... abscissae which are optimally @@ -1834,7 +1834,7 @@ c resk = resk + wgk(jtwm1) * fsum resabs = resabs + wgk(jtwm1) * (dabs(fval1) + dabs(fval2)) 15 continue - + reskh = resk*0.5d+00 resasc = wgk(5)*dabs(fc-reskh) do 20 j=1,4 @@ -2174,7 +2174,7 @@ c end subroutine dqelg DOUBLE PRECISION FUNCTION D1MACH(I) implicit none -C +C C Double-precision machine constants. C C D1MACH( 1) = B**(EMIN-1), the smallest positive magnitude. @@ -2191,7 +2191,7 @@ C C Reference: Fox P.A., Hall A.D., Schryer N.L.,"Framework for a C Portable Library", ACM Transactions on Mathematical C Software, Vol. 4, no. 2, June 1978, PP. 177-188. -C +C INTEGER , INTENT(IN) :: I DOUBLE PRECISION, SAVE :: DMACH(7) DOUBLE PRECISION :: B, EPS @@ -2203,14 +2203,14 @@ C IF (DMACH(1) .EQ. 0.0D0) THEN T = DIGITS(ONE) B = DBLE(RADIX(ONE)) ! base number - EPS = SPACING(ONE) + EPS = SPACING(ONE) EMIN = MINEXPONENT(ONE) EMAX = MAXEXPONENT(ONE) DMACH(1) = B**(EMIN-1) !TINY(ONE) DMACH(2) = (B**(EMAX-1)) * (B-B*EPS) !HUGE(ONE) - DMACH(3) = EPS/B ! EPS/B + DMACH(3) = EPS/B ! EPS/B DMACH(4) = EPS - DMACH(5) = LOG10(B) + DMACH(5) = LOG10(B) DMACH(6) = B**(EMAX+5) !infinity DMACH(7) = ZERO/ZERO !nan ENDIF @@ -2248,7 +2248,7 @@ C contains DOUBLE PRECISION FUNCTION D1MACH(I) implicit none -C +C C Double-precision machine constants. C C D1MACH( 1) = B**(EMIN-1), the smallest positive magnitude. @@ -2265,7 +2265,7 @@ C C Reference: Fox P.A., Hall A.D., Schryer N.L.,"Framework for a C Portable Library", ACM Transactions on Mathematical C Software, Vol. 4, no. 2, June 1978, PP. 177-188. -C +C INTEGER , INTENT(IN) :: I DOUBLE PRECISION, SAVE :: DMACH(7) DOUBLE PRECISION :: B, EPS @@ -2277,14 +2277,14 @@ C IF (DMACH(1) .EQ. 0.0D0) THEN T = DIGITS(ONE) B = DBLE(RADIX(ONE)) ! base number - EPS = SPACING(ONE) + EPS = SPACING(ONE) EMIN = MINEXPONENT(ONE) EMAX = MAXEXPONENT(ONE) DMACH(1) = B**(EMIN-1) !TINY(ONE) DMACH(2) = (B**(EMAX-1)) * (B-B*EPS) !HUGE(ONE) - DMACH(3) = EPS/B ! EPS/B + DMACH(3) = EPS/B ! EPS/B DMACH(4) = EPS - DMACH(5) = LOG10(B) + DMACH(5) = LOG10(B) DMACH(6) = B**(EMAX+5) !infinity DMACH(7) = ZERO/ZERO !nan ENDIF @@ -2298,7 +2298,7 @@ C ! sequence's limiting value, thus improving the rate of ! convergence. Routine is based on the epsilon algorithm ! of P. Wynn. An estimate of the absolute error is also -! given. +! given. double precision, intent(in) :: E0,E1,E2 double precision, intent(out) :: abserr, result !locals @@ -2707,10 +2707,10 @@ C ! call AdaptiveSimpson3(f,pts(k),pts(k+1),tol,kflg,error,valk) call dqagp(f,pts(k),pts(k+1),0,pts,tol,0.0D0,limit,valk, * error,neval,kflg) - - endif + + endif abserr = abserr + abs(error) - + errorEstimate = abserr + (b - pts(k+1)) * LTol excess = epsi - errorEstimate if (excess < 0.0D0 ) then @@ -2765,7 +2765,7 @@ C LTol = 0.1D0 * LTol endif elseif ( Lepsi < 5D0 * excess ) then - LTol = (Lepsi + excess) / delta + LTol = (Lepsi + excess) / delta endif val = val + valk if (kflg>0) iflg = IOR(iflg, kflg) @@ -2808,7 +2808,7 @@ C hmax = 0.24D0 c -c initialize everything, +c initialize everything, c particularly the first column vector in the stack. c val = zero @@ -2816,14 +2816,14 @@ c iflg = 0 delta = b - a - - h = half * delta + + h = half * delta c = half * ( a + b ) k = 1 abar = f(a) cbar = f(c) bbar = f(b) - + S = (abar + four * cbar + bbar) * h * onethird v(1,1) = a v(2,1) = h @@ -2833,12 +2833,12 @@ c v(6,1) = S c do while ((1<=k) .and. (k <= stackLimit)) -c +c c take the last column off the stack and process it. c h = half * v(2,k) y = v(1,k) + h - z = v(1,k) + three * h + z = v(1,k) + three * h ybar = f(y) zbar = f(z) Star = ( v(3,k) + four * ybar + v(4,k) ) * h * onethird @@ -2846,36 +2846,36 @@ c SSStar = Star + SStar Sdiff = (SSStar - v(6,k)) correction = Sdiff * zpz66666 !=0.066666... = 1/15.0D0 - localError = abs(Sdiff) * two + localError = abs(Sdiff) * two ! acceptError is made conservative in order to avoid premature termination - acceptError = (localError * delta <= two* epsi * h - & .or. localError < small) + acceptError = (localError * delta <= two* epsi * h + & .or. localError < small) lastInStack = ( stackLimit <= k) stepSizeOK = ( h < hMax ) stepSizeTooSmall = ( h < hMin) - if (lastInStack .or. (stepSizeOK.and.acceptError) + if (lastInStack .or. (stepSizeOK.and.acceptError) & .or. stepSizeTooSmall ) then ! Stop subdividing interval when ! 1) accuracy is sufficient, or ! 2) interval too narrow, or ! 3) subdivided too often. (stack limit reached) - + ! Add partial integral and take a new vector from the bottom of the stack. - abserr = abserr + localError + abserr = abserr + localError val = val + SSStar + correction k = k - 1 c if (.not.acceptError) then if (lastInStack) iflg = IOR(iflg,1) ! stack limit reached if (stepSizeTooSmall) iflg = IOR(iflg,2) ! stepSize limit reached - endif - if (k <= 0) then + endif + if (k <= 0) then return endif else -c Subdivide the interval and create two new vectors in the stack, +c Subdivide the interval and create two new vectors in the stack, c one of which overwrites the vector just processed. vbar = v(5,k) v(2,k) = h @@ -2898,8 +2898,8 @@ c ! by Per A. Brodtkorb 4 June 2003 ! based on psudo code in chapter 7, Kincaid and Cheney (1991). ! Added check on stepsize, i.e., hMin and hMax -! Added an alternitive check on termination: this is more robust -! Reference: +! Added an alternitive check on termination: this is more robust +! Reference: ! D.R. Kincaid & E.W. Cheney (1991) ! "Numerical Analysis" ! Brooks/Cole Publ., 1991 @@ -2933,13 +2933,13 @@ c double precision, dimension(4) :: x, fx, Sn double precision, dimension(5) :: d4fx double precision, dimension(55) :: EPSTAB - double precision :: small + double precision :: small double precision :: delta, h, h8, localError, correction double precision :: Sn1, Sn2, Sn4, Sn1e, Sn2e, Sn4e double precision :: Sn12, Sn24, Sn124, Sn12e, Sn24e double precision :: hmax, hmin, dhmin, val0 double precision :: Lepsi,Ltol, excess, deltaK, errorEstimate - integer :: k, kp1, i, j,ix, numExtrap, IERR + integer :: k, kp1, i, j,ix, numExtrap, IERR integer, parameter :: LIMEXP = 5 logical :: acceptError, lastInStack logical :: stepSizeTooSmall, stepSizeOK @@ -2957,17 +2957,17 @@ c hmin = 1.0D-9 dhmin = 1.0D-1 c -c initialize everything, +c initialize everything, c particularly the first column vector in the stack. c val = zero abserr = zero iflg = 0 - + delta = b - a - h = half * delta + h = half * delta Ltol = Lepsi / delta - + x(1) = a x(3) = half * ( a + b ) x(2) = half * ( a + x(3) ) @@ -2986,24 +2986,24 @@ c v(6 ,1) = x(1) v(7 ,1) = h v(8:10,1) = Sn(1:3); - + do while ((1<=k) .and. (k <= stackLimit)) -! +! ! take the last column off the stack and process it. ! - h = half * v(7,k) + h = half * v(7,k) do i = 1,4 x(i) = v(6,k) + dble(2*i-1)*h fx(i) = f(x(i)) - Sn(i) = ( v(i,k) + four * fx(i) + v(i+1,k) ) * h * onethird + Sn(i) = ( v(i,k) + four * fx(i) + v(i+1,k) ) * h * onethird enddo - + stepSizeOK = ( h < hMax ) - lastInStack = ( stackLimit <= k) + lastInStack = ( stackLimit <= k) if (lastInStack .OR. stepSizeOK) then - Sn1 = v(8,k) - Sn2 = ( v(9,k) + v(10,k) ) + Sn1 = v(8,k) + Sn2 = ( v(9,k) + v(10,k) ) Sn4 = Sn(1) + Sn(2) + Sn(3) + Sn(4) if (numExtrap>0) then Sn12 = (Sn1 - Sn2) @@ -3012,7 +3012,7 @@ c Sn1e = Sn2 - Sn12 * zpz66666 Sn2e = Sn4 - Sn24 * zpz66666 Sn12e = ( Sn1e - Sn2e ) - + Sn24e = (Sn2e - Sn4) ! Sn1e = Sn2e - Sn12e * zpz66666 ! Sn12e = (Sn1e - Sn2e) @@ -3023,12 +3023,12 @@ c ! Correction based on the assumption of slowly varying fourth derivative correction = -Sn24 * zpz588 ! else -! Correction based on assumption that the termination error +! Correction based on assumption that the termination error ! is of the form: C*h^q correction = -Sn24 * Sn24 / Sn124 endif Sn4e = Sn4 + correction - + ! NEWFLG = .TRUE. ! CALL DEA(NEWFLG,Sn1,LIMEXP,val0,localError,EPSTAB,IERR) ! CALL DEA(NEWFLG,Sn2,LIMEXP,val0,localError,EPSTAB,IERR) @@ -3036,7 +3036,7 @@ c ! CALL DEA(NEWFLG,Sn4,LIMEXP,val0,localError,EPSTAB,IERR) ! CALL DEA(NEWFLG,Sn4e,LIMEXP,val0,localError,EPSTAB,IERR) ! localError is made conservative in order to avoid premature -! termination +! termination CALL DEA3(Sn1e,Sn2e,Sn4e,localError,val0) !if (h>dhMin) then !localError = max(localError,abs(correction)) @@ -3052,7 +3052,7 @@ c else acceptError = .FALSE. endif - + stepSizeTooSmall = ( h < hMin) if (lastInStack .or. & ( stepSizeOK .and. acceptError ) .or. @@ -3061,17 +3061,17 @@ c ! 1) accuracy is sufficient, or ! 2) interval too narrow, or ! 3) subdivided too often. (stack limit reached) - + ! Add partial integral and take a new vector from the bottom of the stack. - + abserr = abserr + max(localError, ten*small*val0) - val = val + val0 + val = val + val0 k = k - 1 if (.not.acceptError) then if (lastInStack) iflg = IOR(iflg,1) !stack limit reached - if (stepSizeTooSmall) iflg = IOR(iflg,2) !stepSize limit reached - endif - if (k <= 0) then + if (stepSizeTooSmall) iflg = IOR(iflg,2) !stepSize limit reached + endif + if (k <= 0) then exit ! while loop endif deltaK = (v(6,k+1)-a) @@ -3084,16 +3084,16 @@ c LTol = 0.1D0 * LTol endif elseif (.true..or. Lepsi < four * excess ) then - LTol = (Lepsi + 0.9D0 * excess) / delta + LTol = (Lepsi + 0.9D0 * excess) / delta endif else -! Subdivide the interval and create two new vectors in the stack, +! Subdivide the interval and create two new vectors in the stack, ! one of which overwrites the vector just processed. ! ! v(:,k) = [fx1,fx2,fx3,fx4,fx5,x1,h,S,SL,SR] kp1 = k + 1; ! Process right interval - v(1,kp1) = v(3,k); !fx1R + v(1,kp1) = v(3,k); !fx1R v(2,kp1) = fx(3); !fx2R v(3,kp1) = v(4,k); !fx3R v(4,kp1) = fx(4); !fx4R @@ -3102,7 +3102,7 @@ c v(7,kp1) = h; v(8,kp1) = v(10,k); ! S v(9:10,kp1) = Sn(3:4); ! SL, SR -! Process left interval +! Process left interval v(5,k) = v(3,k); ! fx5L v(4,k) = fx(2); ! fx4L v(3,k) = v(2,k); ! fx3L @@ -3115,7 +3115,7 @@ c k = kp1; endif enddo ! while - if (epsi0) then Sn12 = (Sn1 - Sn2) @@ -3255,14 +3255,14 @@ c ! Correction based on the assumption of slowly varying fourth derivative correction = -Sn48*zpz588 ! else -! Correction based on assumption that the termination error +! Correction based on assumption that the termination error ! is of the form: C*h^q correction = -Sn24e * Sn24e / Sn124 !Sn4e = Sn4e + correction endif CALL DEA3(Sn1e,Sn2e,Sn4e,localError,val0) ! localError is made conservative in order to avoid premature -! termination +! termination ! localError = max(localError,abs(correction)*three) ! localError = abs(correction)*three else @@ -3278,7 +3278,7 @@ c else acceptError = .FALSE. endif - + stepSizeTooSmall = ( h < hMin) if (lastInStack .or. & ( stepSizeOK .and. acceptError ) .or. @@ -3287,17 +3287,17 @@ c ! 1) accuracy is sufficient, or ! 2) interval too narrow, or ! 3) subdivided too often. (stack limit reached) - + ! Add partial integral and take a new vector from the bottom of the stack. - + abserr = abserr + max(localError, ten*small*val0) - val = val + val0 + val = val + val0 k = k - 1 if (.not.acceptError) then if (lastInStack) iflg = IOR(iflg,1) !stack limit reached - if (stepSizeTooSmall) iflg = IOR(iflg,2) !stepSize limit reached - endif - if (k <= 0) then + if (stepSizeTooSmall) iflg = IOR(iflg,2) !stepSize limit reached + endif + if (k <= 0) then exit ! while loop endif deltaK = (v(Nrule+1,k+1)-a) @@ -3310,17 +3310,17 @@ c LTol = 0.1D0 * LTol endif elseif (.TRUE..or. Lepsi < four * excess ) then - LTol = (Lepsi + 0.9D0 * excess) / delta + LTol = (Lepsi + 0.9D0 * excess) / delta endif else -! Subdivide the interval and create two new vectors in the stack, +! Subdivide the interval and create two new vectors in the stack, ! one of which overwrites the vector just processed. ! ! v(:,k) = [fx1,fx2,..,fx8,fx9,x1,h,S,SL,SR,SL1,SL2 SR1,SR2] kp1 = k + 1; ! Process right interval - - v(1,kp1) = v(5,k); !fx1R + + v(1,kp1) = v(5,k); !fx1R v(2,kp1) = fx(5); !fx2R v(3,kp1) = v(6,k); !fx3R v(4,kp1) = fx(6); !fx4R @@ -3336,7 +3336,7 @@ c v(Nrule+4,kp1) = v(Nrule+8,k); ! SL v(Nrule+5,kp1) = v(Nrule+9,k); ! SR v(Nrule+6:Nrule+9,kp1) = Sn(5:8); ! SL1,SL2,SR1, SR2 -! Process left interval +! Process left interval v(9,k) = v(5,k); ! fx9L v(8,k) = fx(4); ! fx8L v(7,k) = v(4,k); ! fx7L @@ -3355,7 +3355,7 @@ c k = kp1; endif enddo ! while - if (epsistepSize) then - Nk = floor((xup-xlo)/stepSize) + 1 + Nk = floor((xup-xlo)/stepSize) + 1 dx = (xup-xlo)/dble(Nk) do j=1, Nk -1 Npts = Npts + 1 @@ -3956,12 +3956,12 @@ c ! Sort the candidates call sortre(brkPts,indices) ! Make unique list of breakpoints - + do k = 1,2*n brk = brkPts(k) if (xlo < brk) then if ( xup <= brk ) exit ! terminate do loop - + ! if (Npts>0) then ! xLow = max(xlo, breakPoints(Npts)) ! else @@ -3975,9 +3975,9 @@ c ! breakPoints(Npts) = brk + dx * dble( j ) ! enddo ! endif - + kU = indices(k) - + !if ( xlo + distance < brk .and. brk + distance < xup ) !then if ( den(kU) < 0.2) then @@ -4016,7 +4016,7 @@ c breakPoints(Npts) = z2 brkPtsVal(Npts) = integrand(z2) indices2(Npts) = kU - kL = kU + kL = kU endif else val1 = 0.0d0 @@ -4045,13 +4045,13 @@ c endif if (val1 < z1) then Npts = Npts + 1 - breakPoints(Npts) = z1 + breakPoints(Npts) = z1 brkPtsVal(Npts) = brkPtsVal(Npts+Nprev) indices2(Npts) = kU endif ! Nprev = Nprev + 1 ! breakPoints(Npts + Nprev) = brk - + if ((val1< z2) .and. (z2 + distance < xup)) then Npts = Npts + 1 breakPoints(Npts) = z2 @@ -4075,11 +4075,11 @@ c ! Locals double precision, parameter :: zero = 0.0D0, one = 1.0D0 integer :: k - -! Uses the regression equation to limit the + +! Uses the regression equation to limit the ! integration limits zMin and zMax - - do k = 1,n + + do k = 1,n if (ZERO < rho(k)) then zMax = max(zMin, min(zMax,(b(k)+den(k)*zCutOff)/rho(k))) zMin = min(zMax, max(zMin,(a(k)-den(k)*zCutOff)/rho(k))) @@ -4120,14 +4120,14 @@ c do I = 1, mNdim zRho = z * mRho(I) ! Uncomment / mDen below if mRho, mA, mB is not scaled - xUp = ( mB(I) - zRho ) !/ mDen(I) + xUp = ( mB(I) - zRho ) !/ mDen(I) xLo = ( mA(I) - zRho ) !/ mDen(I) if (zero 37 (or XMAX) -* +* IF ( Z .GT. XMAX .OR. ZABS .GT. 37) THEN P = 0.d0 ELSE -* +* * |Z| <= 37 -* +* Z2 = ZABS * ZABS EXPNTL = EXP( -Z2 * 0.5D0 ) -* +* * |Z| < CUTOFF = 10/SQRT(2) -* +* IF ( ZABS < CUTOFF ) THEN P = EXPNTL*( (((((P6*ZABS + P5)*ZABS + P4)*ZABS + P3)*ZABS * + P2)*ZABS + P1)*ZABS + P0)/(((((((Q7*ZABS + Q6)*ZABS * + Q5)*ZABS + Q4)*ZABS + Q3)*ZABS + Q2)*ZABS + Q1)*ZABS * + Q0 ) -* +* * |Z| >= CUTOFF. -* +* ELSE - P = EXPNTL/( ZABS + 1.d0/( ZABS + 2.d0/( ZABS + 3.d0/( ZABS + P = EXPNTL/( ZABS + 1.d0/( ZABS + 2.d0/( ZABS + 3.d0/( ZABS * + 4.d0/( ZABS + 0.65D0 ) ) ) ) )/ROOTPI END IF END IF @@ -4332,4 +4332,3 @@ c END FUNCTION FI end module mvnProdCorrPrbMod - \ No newline at end of file diff --git a/pywafo/src/wafo/source/mvnprd/old/mvnprodcorrprb/mvnprodcorrprb_interface.f b/wafo/source/mvnprd/mvnprodcorrprb_interface.f similarity index 75% rename from pywafo/src/wafo/source/mvnprd/old/mvnprodcorrprb/mvnprodcorrprb_interface.f rename to wafo/source/mvnprd/mvnprodcorrprb_interface.f index 190f081..94fab04 100644 --- a/pywafo/src/wafo/source/mvnprd/old/mvnprodcorrprb/mvnprodcorrprb_interface.f +++ b/wafo/source/mvnprd/mvnprodcorrprb_interface.f @@ -1,33 +1,33 @@ - -C gfortran -fPIC -c mvnprodcorrprb.f -C f2py -m mvnprdmod -c mvnprodcorrprb.o mvnprodcorrprb_interface.f --fcompiler=gnu95 --compiler=mingw32 -lmsvcr71 + +C gfortran -fPIC -c mvnprodcorrprb.f +C f2py -m mvnprdmod -c mvnprodcorrprb.o mvnprodcorrprb_interface.f --fcompiler=gnu95 --compiler=mingw32 -lmsvcr71 C module mvnprdmod C contains subroutine prbnormndpc(prb,abserr,IFT,rho,a,b,N,abseps,releps, - & useBreakPoints, useSimpson) - use mvnProdCorrPrbMod, ONLY : mvnprodcorrprb + & useBreakPoints, useSimpson) + use mvnProdCorrPrbMod, ONLY : mvnprodcorrprb integer :: N double precision,dimension(N),intent(in) :: rho,a,b - double precision,intent(in) :: abseps - double precision,intent(in) :: releps - logical, intent(in) :: useBreakPoints + double precision,intent(in) :: abseps + double precision,intent(in) :: releps + logical, intent(in) :: useBreakPoints logical, intent(in) :: useSimpson double precision,intent(out) :: abserr,prb - integer, intent(out) :: IFT - -Cf2py integer, intent(hide), depend(rho) :: N = len(rho) -Cf2py depend(N) a -Cf2py depend(N) b -Cf2py double precision, optional :: abseps = 0.001 -Cf2py double precision, optional :: releps = 0.001 -Cf2py logical, optional :: useBreakPoints =1 -Cf2py logical, optional :: useSimpson = 1 - - - + integer, intent(out) :: IFT + +Cf2py integer, intent(hide), depend(rho) :: N = len(rho) +Cf2py depend(N) a +Cf2py depend(N) b +Cf2py double precision, optional :: abseps = 0.001 +Cf2py double precision, optional :: releps = 0.001 +Cf2py logical, optional :: useBreakPoints =1 +Cf2py logical, optional :: useSimpson = 1 + + + CALL mvnprodcorrprb(rho,a,b,abseps,releps,useBreakPoints, - & useSimpson,abserr,IFT,prb) - + & useSimpson,abserr,IFT,prb) + end subroutine prbnormndpc C end module mvnprdmod \ No newline at end of file diff --git a/pywafo/src/wafo/source/mvnprd/old/mvnprodcorrprb/build_all.py b/wafo/source/mvnprd/old/mvnprodcorrprb/build_all.py similarity index 100% rename from pywafo/src/wafo/source/mvnprd/old/mvnprodcorrprb/build_all.py rename to wafo/source/mvnprd/old/mvnprodcorrprb/build_all.py diff --git a/pywafo/src/wafo/source/mvnprd/mvnprodcorrprb.f b/wafo/source/mvnprd/old/mvnprodcorrprb/mvnprodcorrprb.f similarity index 100% rename from pywafo/src/wafo/source/mvnprd/mvnprodcorrprb.f rename to wafo/source/mvnprd/old/mvnprodcorrprb/mvnprodcorrprb.f diff --git a/pywafo/src/wafo/source/mvnprd/mvnprodcorrprb_interface.f b/wafo/source/mvnprd/old/mvnprodcorrprb/mvnprodcorrprb_interface.f similarity index 100% rename from pywafo/src/wafo/source/mvnprd/mvnprodcorrprb_interface.f rename to wafo/source/mvnprd/old/mvnprodcorrprb/mvnprodcorrprb_interface.f diff --git a/pywafo/src/wafo/source/mvnprd/old/mvnprodcorrprb/old/AdaptiveGaussKronrod.f90 b/wafo/source/mvnprd/old/mvnprodcorrprb/old/AdaptiveGaussKronrod.f90 similarity index 100% rename from pywafo/src/wafo/source/mvnprd/old/mvnprodcorrprb/old/AdaptiveGaussKronrod.f90 rename to wafo/source/mvnprd/old/mvnprodcorrprb/old/AdaptiveGaussKronrod.f90 diff --git a/pywafo/src/wafo/source/mvnprd/old/mvnprodcorrprb/old/adaptivegausskronrod.pyf b/wafo/source/mvnprd/old/mvnprodcorrprb/old/adaptivegausskronrod.pyf similarity index 100% rename from pywafo/src/wafo/source/mvnprd/old/mvnprodcorrprb/old/adaptivegausskronrod.pyf rename to wafo/source/mvnprd/old/mvnprodcorrprb/old/adaptivegausskronrod.pyf diff --git a/pywafo/src/wafo/source/mvnprd/old/mvnprodcorrprb/old/dea.f b/wafo/source/mvnprd/old/mvnprodcorrprb/old/dea.f similarity index 100% rename from pywafo/src/wafo/source/mvnprd/old/mvnprodcorrprb/old/dea.f rename to wafo/source/mvnprd/old/mvnprodcorrprb/old/dea.f diff --git a/pywafo/src/wafo/source/mvnprd/old/mvnprodcorrprb/old/deamod.pyf b/wafo/source/mvnprd/old/mvnprodcorrprb/old/deamod.pyf similarity index 100% rename from pywafo/src/wafo/source/mvnprd/old/mvnprodcorrprb/old/deamod.pyf rename to wafo/source/mvnprd/old/mvnprodcorrprb/old/deamod.pyf diff --git a/pywafo/src/wafo/source/mvnprd/old/mvnprodcorrprb/old/erfcore.f90 b/wafo/source/mvnprd/old/mvnprodcorrprb/old/erfcore.f90 similarity index 100% rename from pywafo/src/wafo/source/mvnprd/old/mvnprodcorrprb/old/erfcore.f90 rename to wafo/source/mvnprd/old/mvnprodcorrprb/old/erfcore.f90 diff --git a/pywafo/src/wafo/source/mvnprd/old/mvnprodcorrprb/old/integration1Dmodule.f b/wafo/source/mvnprd/old/mvnprodcorrprb/old/integration1Dmodule.f similarity index 100% rename from pywafo/src/wafo/source/mvnprd/old/mvnprodcorrprb/old/integration1Dmodule.f rename to wafo/source/mvnprd/old/mvnprodcorrprb/old/integration1Dmodule.f diff --git a/pywafo/src/wafo/source/mvnprd/old/mvnprodcorrprb/old/integration1Dmodule.f90 b/wafo/source/mvnprd/old/mvnprodcorrprb/old/integration1Dmodule.f90 similarity index 100% rename from pywafo/src/wafo/source/mvnprd/old/mvnprodcorrprb/old/integration1Dmodule.f90 rename to wafo/source/mvnprd/old/mvnprodcorrprb/old/integration1Dmodule.f90 diff --git a/pywafo/src/wafo/source/mvnprd/old/mvnprodcorrprb/old/mvnprodcorrprb.f90 b/wafo/source/mvnprd/old/mvnprodcorrprb/old/mvnprodcorrprb.f90 similarity index 100% rename from pywafo/src/wafo/source/mvnprd/old/mvnprodcorrprb/old/mvnprodcorrprb.f90 rename to wafo/source/mvnprd/old/mvnprodcorrprb/old/mvnprodcorrprb.f90 diff --git a/pywafo/src/wafo/source/mvnprd/old/mvnprodcorrprb/old/mvnprodcorrprb.pyf b/wafo/source/mvnprd/old/mvnprodcorrprb/old/mvnprodcorrprb.pyf similarity index 100% rename from pywafo/src/wafo/source/mvnprd/old/mvnprodcorrprb/old/mvnprodcorrprb.pyf rename to wafo/source/mvnprd/old/mvnprodcorrprb/old/mvnprodcorrprb.pyf diff --git a/pywafo/src/wafo/source/mvnprd/old/mvnprodcorrprb/old/mvnprodcorrprbmod.f90 b/wafo/source/mvnprd/old/mvnprodcorrprb/old/mvnprodcorrprbmod.f90 similarity index 100% rename from pywafo/src/wafo/source/mvnprd/old/mvnprodcorrprb/old/mvnprodcorrprbmod.f90 rename to wafo/source/mvnprd/old/mvnprodcorrprb/old/mvnprodcorrprbmod.f90 diff --git a/pywafo/src/wafo/source/mvnprd/old/mvnprodcorrprb/old/test_mvnprodcorrprb.dsp b/wafo/source/mvnprd/old/mvnprodcorrprb/old/test_mvnprodcorrprb.dsp similarity index 100% rename from pywafo/src/wafo/source/mvnprd/old/mvnprodcorrprb/old/test_mvnprodcorrprb.dsp rename to wafo/source/mvnprd/old/mvnprodcorrprb/old/test_mvnprodcorrprb.dsp diff --git a/pywafo/src/wafo/source/mvnprd/old/mvnprodcorrprb/old/test_mvnprodcorrprb.dsw b/wafo/source/mvnprd/old/mvnprodcorrprb/old/test_mvnprodcorrprb.dsw similarity index 100% rename from pywafo/src/wafo/source/mvnprd/old/mvnprodcorrprb/old/test_mvnprodcorrprb.dsw rename to wafo/source/mvnprd/old/mvnprodcorrprb/old/test_mvnprodcorrprb.dsw diff --git a/pywafo/src/wafo/source/mvnprd/old/mvnprodcorrprb/old/test_mvnprodcorrprb.f b/wafo/source/mvnprd/old/mvnprodcorrprb/old/test_mvnprodcorrprb.f similarity index 100% rename from pywafo/src/wafo/source/mvnprd/old/mvnprodcorrprb/old/test_mvnprodcorrprb.f rename to wafo/source/mvnprd/old/mvnprodcorrprb/old/test_mvnprodcorrprb.f diff --git a/pywafo/src/wafo/source/mvnprd/setup.py b/wafo/source/mvnprd/setup.py similarity index 100% rename from pywafo/src/wafo/source/mvnprd/setup.py rename to wafo/source/mvnprd/setup.py diff --git a/pywafo/src/wafo/source/old/dunnettprb.f b/wafo/source/old/dunnettprb.f similarity index 100% rename from pywafo/src/wafo/source/old/dunnettprb.f rename to wafo/source/old/dunnettprb.f diff --git a/pywafo/src/wafo/source/old/erfcore.f b/wafo/source/old/erfcore.f similarity index 100% rename from pywafo/src/wafo/source/old/erfcore.f rename to wafo/source/old/erfcore.f diff --git a/pywafo/src/wafo/source/old/erfcore.pyf b/wafo/source/old/erfcore.pyf similarity index 100% rename from pywafo/src/wafo/source/old/erfcore.pyf rename to wafo/source/old/erfcore.pyf diff --git a/pywafo/src/wafo/source/old/erfcoremod.f b/wafo/source/old/erfcoremod.f similarity index 100% rename from pywafo/src/wafo/source/old/erfcoremod.f rename to wafo/source/old/erfcoremod.f diff --git a/pywafo/src/wafo/source/old/erfcoremod.f90 b/wafo/source/old/erfcoremod.f90 similarity index 100% rename from pywafo/src/wafo/source/old/erfcoremod.f90 rename to wafo/source/old/erfcoremod.f90 diff --git a/pywafo/src/wafo/source/old/erfcoremod.pyf b/wafo/source/old/erfcoremod.pyf similarity index 100% rename from pywafo/src/wafo/source/old/erfcoremod.pyf rename to wafo/source/old/erfcoremod.pyf diff --git a/pywafo/src/wafo/source/old/erfcoremod0.f90 b/wafo/source/old/erfcoremod0.f90 similarity index 100% rename from pywafo/src/wafo/source/old/erfcoremod0.f90 rename to wafo/source/old/erfcoremod0.f90 diff --git a/pywafo/src/wafo/source/old/erfcoremod1.pyf b/wafo/source/old/erfcoremod1.pyf similarity index 100% rename from pywafo/src/wafo/source/old/erfcoremod1.pyf rename to wafo/source/old/erfcoremod1.pyf diff --git a/pywafo/src/wafo/source/old/erfcoremod_interface.f90 b/wafo/source/old/erfcoremod_interface.f90 similarity index 100% rename from pywafo/src/wafo/source/old/erfcoremod_interface.f90 rename to wafo/source/old/erfcoremod_interface.f90 diff --git a/pywafo/src/wafo/source/rind2007/.cproject b/wafo/source/rind2007/.cproject similarity index 100% rename from pywafo/src/wafo/source/rind2007/.cproject rename to wafo/source/rind2007/.cproject diff --git a/pywafo/src/wafo/source/rind2007/.project b/wafo/source/rind2007/.project similarity index 100% rename from pywafo/src/wafo/source/rind2007/.project rename to wafo/source/rind2007/.project diff --git a/pywafo/src/wafo/source/rind2007/Debug/makefile b/wafo/source/rind2007/Debug/makefile similarity index 100% rename from pywafo/src/wafo/source/rind2007/Debug/makefile rename to wafo/source/rind2007/Debug/makefile diff --git a/pywafo/src/wafo/source/rind2007/Debug/objects.mk b/wafo/source/rind2007/Debug/objects.mk similarity index 100% rename from pywafo/src/wafo/source/rind2007/Debug/objects.mk rename to wafo/source/rind2007/Debug/objects.mk diff --git a/pywafo/src/wafo/source/rind2007/Debug/sources.mk b/wafo/source/rind2007/Debug/sources.mk similarity index 100% rename from pywafo/src/wafo/source/rind2007/Debug/sources.mk rename to wafo/source/rind2007/Debug/sources.mk diff --git a/pywafo/src/wafo/source/rind2007/Debug/subdir.mk b/wafo/source/rind2007/Debug/subdir.mk similarity index 100% rename from pywafo/src/wafo/source/rind2007/Debug/subdir.mk rename to wafo/source/rind2007/Debug/subdir.mk diff --git a/pywafo/src/wafo/source/rind2007/build_all.py b/wafo/source/rind2007/build_all.py similarity index 100% rename from pywafo/src/wafo/source/rind2007/build_all.py rename to wafo/source/rind2007/build_all.py diff --git a/pywafo/src/wafo/source/rind2007/erfcoremod.f b/wafo/source/rind2007/erfcoremod.f similarity index 100% rename from pywafo/src/wafo/source/rind2007/erfcoremod.f rename to wafo/source/rind2007/erfcoremod.f diff --git a/pywafo/src/wafo/source/rind2007/fimod.f b/wafo/source/rind2007/fimod.f similarity index 99% rename from pywafo/src/wafo/source/rind2007/fimod.f rename to wafo/source/rind2007/fimod.f index ab7bd7d..83f2ebb 100644 --- a/pywafo/src/wafo/source/rind2007/fimod.f +++ b/wafo/source/rind2007/fimod.f @@ -7,7 +7,7 @@ ! ! FIMOD contains functions for calculating 1D, 2D and 3D Normal and student T probabilites ! and 1D expectations - MODULE FIMOD + MODULE FIMOD ! USE ERFCOREMOD IMPLICIT NONE PRIVATE @@ -1127,7 +1127,7 @@ CALL SINCS( AR + RUC*X, R, RR ) TVTMFN = TVTMFN - RUC*PNTGND( NU, H2, H3, H1, ZRO, ZRO, R, RR ) END IF - END FUNCTION TVTMFN + END FUNCTION TVTMFN ! SUBROUTINE SINCS( X, SX, CS ) ! @@ -1234,8 +1234,8 @@ ! ! Kronrod Rule ! - DOUBLE PRECISION, intent(in) :: A, B - DOUBLE PRECISION, intent(out) :: ERR + DOUBLE PRECISION, intent(in) :: A, B + DOUBLE PRECISION, intent(out) :: ERR DOUBLE PRECISION T, CEN, FC, WID, RESG, RESK ! ! The abscissae and weights are given for the interval (-1,1); @@ -1315,7 +1315,7 @@ KRNRDT = WID * RESK ERR = ABS( WID * ( RESK - RESG ) ) END FUNCTION KRNRDT -! END FUNCTION TVTL +! END FUNCTION TVTL FUNCTION GAUSINT (X1, X2, A, B, C, D) RESULT (value) ! USE GLOBALDATA,ONLY: xCutOff diff --git a/pywafo/src/wafo/source/rind2007/intmodule.f b/wafo/source/rind2007/intmodule.f similarity index 100% rename from pywafo/src/wafo/source/rind2007/intmodule.f rename to wafo/source/rind2007/intmodule.f diff --git a/pywafo/src/wafo/source/rind2007/jacobmod.f b/wafo/source/rind2007/jacobmod.f similarity index 100% rename from pywafo/src/wafo/source/rind2007/jacobmod.f rename to wafo/source/rind2007/jacobmod.f diff --git a/pywafo/src/wafo/source/rind2007/rind71mod.f b/wafo/source/rind2007/rind71mod.f similarity index 83% rename from pywafo/src/wafo/source/rind2007/rind71mod.f rename to wafo/source/rind2007/rind71mod.f index 8f9b9bd..16ec81f 100644 --- a/pywafo/src/wafo/source/rind2007/rind71mod.f +++ b/wafo/source/rind2007/rind71mod.f @@ -1,49 +1,49 @@ !**************************************************************************** ! if compilation complains about too many continuation lines extend it. -! ! -! modules: GLOBALDATA, QUAD, RIND71MOD Version 1.0 ! -! Programs available in module RIND71MOD : -! (NB! the GLOBALDATA and QUAD module is also used to transport the inputs) +! modules: GLOBALDATA, QUAD, RIND71MOD Version 1.0 +! +! Programs available in module RIND71MOD : +! (NB! the GLOBALDATA and QUAD module is also used to transport the inputs) ! ! ! SETDATA initializes global constants explicitly: -! -! CALL SETDATA(EPSS,REPS,EPS2,NIT,xCutOff,NINT,XSPLT) +! +! CALL SETDATA(EPSS,REPS,EPS2,NIT,xCutOff,NINT,XSPLT) ! ! GLOBALDATA module : ! EPSS,CEPSS = 1.d0 - EPSS , controlling the accuracy of indicator function ! EPS2 = if conditional variance is less it is considered as zero -! i.e., the variable is considered deterministic +! i.e., the variable is considered deterministic ! xCutOff = 5 (standard deviations by default) ! -! QUAD module: +! QUAD module: ! Nint1(i) = quadrature formulae used in integration of Xd(i) -! implicitly determining # nodes +! implicitly determining # nodes ! ! INITDATA initializes global constants implicitly: ! -! CALL INITDATA (speed) +! CALL INITDATA (speed) ! -! speed = 1,2,...,9 (1=slowest and most accurate,9=fastest, +! speed = 1,2,...,9 (1=slowest and most accurate,9=fastest, ! but less accurate) ! -! see the GLOBALDATA and QUAD module for other constants and default values +! see the GLOBALDATA and QUAD module for other constants and default values ! ! -!RIND71 computes E[Jacobian*Indicator|Condition]*f_{Xc}(xc(:,ix)) +!RIND71 computes E[Jacobian*Indicator|Condition]*f_{Xc}(xc(:,ix)) ! ! where ! "Indicator" = I{ H_lo(i) < X(i) < H_up(i), i=1:Nt+Nd } -! "Jacobian" = J(X(Nt+1),...,X(Nt+Nd+Nc)), special case is +! "Jacobian" = J(X(Nt+1),...,X(Nt+Nd+Nc)), special case is ! "Jacobian" = |X(Nt+1)*...*X(Nt+Nd)|=|Xd(1)*Xd(2)..Xd(Nd)| ! "condition" = Xc=xc(:,ix), ix=1,...,Nx. -! X = [Xt; Xd ;Xc], a stochastic vector of Multivariate Gaussian +! X = [Xt; Xd ;Xc], a stochastic vector of Multivariate Gaussian ! variables where Xt,Xd and Xc have the length Nt, Nd and Nc, -! respectively. -! (Recommended limitations Nx, Nt<101, Nd<7 and NIT,Nc<11) -! (RIND = Random Integration N Dimensions) +! respectively. +! (Recommended limitations Nx, Nt<101, Nd<7 and NIT,Nc<11) +! (RIND = Random Integration N Dimensions) ! !CALL RIND71(E,S,m,xc,indI,Blo,Bup,xcScale); ! @@ -52,43 +52,43 @@ ! NB!: out=conditional sorted Covariance matrix ! m = the expectation of X=[Xt;Xd;Xc] size N x 1 (in) ! xc = values to condition on size Nc x Nx (in) -! indI = vector of indices to the different barriers in the (in) -! indicator function, length NI, where NI = Nb+1 +! indI = vector of indices to the different barriers in the (in) +! indicator function, length NI, where NI = Nb+1 ! (NB! restriction indI(1)=0, indI(NI)=Nt+Nd ) !Blo,Bup = Lower and upper barrier coefficients used to compute the (in) -! integration limits Hlo and Hup, respectively. +! integration limits Hlo and Hup, respectively. ! size Mb x Nb. If Mb 0 then you must initialize the random generator before you +! if SCIS > 0 then you must initialize the random generator before you ! call rindd by the following lines: ! -! call random_seed(SIZE=seed_size) -! allocate(seed(seed_size)) +! call random_seed(SIZE=seed_size) +! allocate(seed(seed_size)) ! call random_seed(GET=seed(1:seed_size)) ! get current seed ! seed(1)=seed1 ! change seed -! call random_seed(PUT=seed(1:seed_size)) +! call random_seed(PUT=seed(1:seed_size)) ! deallocate(seed) ! -! For further description see the modules +! For further description see the modules ! ! ! References @@ -125,15 +125,15 @@ ! ! R. Ambartzumian, A. Der Kiureghian, V. Ohanian and H. ! Sukiasian (1998) -! "Multinormal probabilities by sequential conditioned +! "Multinormal probabilities by sequential conditioned ! importance sampling: theory and application" (RINDSCIS, MNORMPRB,MVNFUN,MVNFUN2) -! Probabilistic Engineering Mechanics, Vol. 13, No 4. pp 299-308 +! Probabilistic Engineering Mechanics, Vol. 13, No 4. pp 299-308 ! ! Alan Genz (1992) ! 'Numerical Computation of Multivariate Normal Probabilites' ! J. computational Graphical Statistics, Vol.1, pp 141--149 ! -! William H. Press, Saul Teukolsky, +! William H. Press, Saul Teukolsky, ! William T. Wetterling and Brian P. Flannery (1997) ! "Numerical recipes in Fortran 77", Vol. 1, pp 55-63, 299--305 (SVDCMP,SOBSEQ) ! @@ -152,12 +152,12 @@ ! Tested on: DIGITAL UNIX Fortran90 compiler ! PC pentium II with Lahey Fortran90 compiler -! Solaris with SunSoft F90 compiler Version 1.0.1.0 (21229283) -! History: -! revised pab aug 2009 -! -moved c1c2 to c1c2mod -! -removed rateLHD, useMIDP, FxCutOff, CFxCutOff from globaldata module -! revised pab July 2007 +! Solaris with SunSoft F90 compiler Version 1.0.1.0 (21229283) +! History: +! revised pab aug 2009 +! -moved c1c2 to c1c2mod +! -removed rateLHD, useMIDP, FxCutOff, CFxCutOff from globaldata module +! revised pab July 2007 ! -reordered integration methods (SCIS) ! revised pab 9 may 2004 ! removed xcutoff2 @@ -172,23 +172,23 @@ ! revised pab 19.01.2001 ! - added a NEW BVU function ! revised pab 06.11.2000 -! - added checks in condsort2, condsort3, condsort4 telling if the matrix is +! - added checks in condsort2, condsort3, condsort4 telling if the matrix is ! negative definit ! - changed the order of SCIS integration again. ! revised pab 07.09.2000 ! - To many continuation lines in QUAD module => ! broke them up and changed PARAMETER statements into DATA -! statements instead. +! statements instead. ! revised pab 22.05.2000 -! - changed order of SCIS integration: moved the less important SCIS +! - changed order of SCIS integration: moved the less important SCIS ! revised pab 19.04.2000 ! - found a bug in THL when L<-1, now fixed ! revised pab 18.04.2000 ! new name rind60 -! New assumption of BIG for the conditional sorted variables: +! New assumption of BIG for the conditional sorted variables: ! BIG(I,I)=sqrt(Var(X(I)|X(I+1)...X(N))=SQI ! BIG(1:I-1,I)=COV(X(1:I-1),X(I)|X(I+1)...X(N))/SQI -! Otherwise +! Otherwise ! BIG(I,I) = Var(X(I)|X(I+1)...X(N) ! BIG(1:I-1,I)=COV(X(1:I-1),X(I)|X(I+1)...X(N)) ! This also affects C1C2: SQ0=sqrt(Var(X(I)|X(I+1)...X(N)) is removed from input @@ -201,14 +201,14 @@ ! - new name rind57 ! - added condsort0 and condsort4 which sort the covariance matrix using the shortest ! expected integration interval => integration time is much shorter for all methods. -! condsort and condsort3 sort by decreasing conditional variance +! condsort and condsort3 sort by decreasing conditional variance ! revised pab 17.03.2000 ! - changed argp0 so that I0 and I1 really are the indices to the minimum and the second minimum ! - changed rindnit so that norm2dprb is called whenever NITL<1 and Nsnew>=2 ! - changed default parameters for initdata for speed=7,8 and 9 to increase accuracy. ! - Changed so that xCutOff varies with speed => program is much faster without loosing any accuracy it seems ! revised pab 15.03.2000 -! - changed rindscis and mnormprb: moved the actual multidimensional integration +! - changed rindscis and mnormprb: moved the actual multidimensional integration ! into separate module, rcrudemod.f (as a consequence SVDCMP,PYTHAG and SORTRE ! are also moved into this module) => made the structure of the program simpler ! - added the possibility to use adapt, krbvrc, krobov and ranmc to integrate @@ -224,35 +224,35 @@ ! Probably there is an error somehere making variable "value" to behave badly. !Revised by IR. 03.01.2000 Bug in C1C2 fixed and deallocation of ind in RINDNIT. !revised by I.R. 27.12.1999, New name RIND51.f -! I have changed assumption about deterministic variables. Those have now +! I have changed assumption about deterministic variables. Those have now ! variances equal EPS2 not zero and have consequences for C1C2 and on some ! places in RINDND. The effect is that barriers becomes fuzzy (not sharp) ! and prevents for discountinuities due to numerical errors of order 1E-16. -! The program RIND0 is removed making the structure of program simpler. +! The program RIND0 is removed making the structure of program simpler. ! We have still a problem when variables in indicator become -! deterministic before conditioning on derivatives in Xd - it needs to be solved. +! deterministic before conditioning on derivatives in Xd - it needs to be solved. !revised by Igor Rychlik 01.12.1999 New name RIND49.f ! - changed RINDNIT and ARGP0 in order to exclude -! irrelevant variables (such that probability of beeing +! irrelevant variables (such that probability of beeing ! between barriers is 1.) All computations related to NIT -! are moved to RINDNIT (removing RIND2,RIND3). This caused some changes -! in RIND0,RINDDND. Furthermore RINDD1 is removed and moved -! some parts of it to RINDDND. This made program few seconds slower. The lower +! are moved to RINDNIT (removing RIND2,RIND3). This caused some changes +! in RIND0,RINDDND. Furthermore RINDD1 is removed and moved +! some parts of it to RINDDND. This made program few seconds slower. The lower ! bound in older ARGP0 programs contained logical error - corrected. !revised by Per A. Brodtkorb 08.11.1999 -! - fixed a bug in rinddnd +! - fixed a bug in rinddnd ! new line: CmNew(Nst+1:Nsd-1)= Cm(Nst+1:Nsd-1) !revised by Per A. Brodtkorb 28.10.1999 ! - fixed a bug in rinddnd -! - changed rindscis, mnormprb +! - changed rindscis, mnormprb ! - added MVNFUN, MVNFUN2 -! - replaced CVaccept with RelEps +! - replaced CVaccept with RelEps !revised by Per A. Brodtkorb 27.10.1999 ! - changed NINT to NINT1 due to naming conflict with an intrinsic of the same name !revised by Per A. Brodtkorb 25.10.1999 -! - added an alternative FIINV for use in rindscis and mnormprb +! - added an alternative FIINV for use in rindscis and mnormprb !revised by Per A. Brodtkorb 13.10.1999 -! - added useMIDP for use in rindscis and mnormprb +! - added useMIDP for use in rindscis and mnormprb ! !revised by Per A. Brodtkorb 22.09.1999 ! - removed all underscore letters due to @@ -272,7 +272,7 @@ ! - increased the default NUGGET from 1.d-12 to 1.d-8 ! - also set NUGGET depending on speed in INITDATA ! revised by Per A. Brodtkorb 27.08.1999 -! - changed rindnit,rind2: +! - changed rindnit,rind2: ! enabled option to do the integration faster/(smarter?). ! See GLOBALDATA for XSPLT ! revised by Per A. Brodtkorb 17.08.1999 @@ -289,12 +289,12 @@ ! - fixed some bugs ! - added some additonal checks ! - added Hermite, Laguerre quadratures for alternative integration -! - rewritten CONDSORT, conditional covariance matrix in upper -! triangular. +! - rewritten CONDSORT, conditional covariance matrix in upper +! triangular. ! - RINDXXX routines only work on the upper triangular ! of the covariance matrix -! - Added a Nugget effect to the covariance matrix in order -! to ensure the conditioning is not corrupted by numerical errors +! - Added a Nugget effect to the covariance matrix in order +! to ensure the conditioning is not corrupted by numerical errors ! - added the option to condsort Nj variables of Xt, i.e., ! enabling direct integration like the integration of Xd ! by Igor Rychlik 29.10.1998 (PROGRAM RIND11 --- Version 1.0) @@ -304,33 +304,33 @@ !********************************************************************* MODULE GLOBALDATA - IMPLICIT NONE + IMPLICIT NONE ! Constants determining accuracy of integration !----------------------------------------------- - !if the conditional variance are less than: - DOUBLE PRECISION :: EPS2=1.d-4 !- EPS2, the variable is - ! considered deterministic + !if the conditional variance are less than: + DOUBLE PRECISION :: EPS2=1.d-4 !- EPS2, the variable is + ! considered deterministic DOUBLE PRECISION :: EPS = 1.d-2 ! SQRT(EPS2) DOUBLE PRECISION :: XCEPS2=1.d-16 ! if Var(Xc) is less return NaN - DOUBLE PRECISION :: EPSS = 5.d-5 ! accuracy of Indicator - DOUBLE PRECISION :: CEPSS=0.99995 ! accuracy of Indicator - DOUBLE PRECISION :: EPS0 = 5.d-5 ! used in GAUSSLE1 to implicitly - ! determ. # nodes - DOUBLE PRECISION :: xcScale=0.d0 + DOUBLE PRECISION :: EPSS = 5.d-5 ! accuracy of Indicator + DOUBLE PRECISION :: CEPSS=0.99995 ! accuracy of Indicator + DOUBLE PRECISION :: EPS0 = 5.d-5 ! used in GAUSSLE1 to implicitly + ! determ. # nodes + DOUBLE PRECISION :: xcScale=0.d0 DOUBLE PRECISION :: fxcEpss=1.d-20 ! if less do not compute E(...|Xc) - DOUBLE PRECISION :: xCutOff=5.d0 ! upper/lower truncation limit of the - ! normal CDF - ! Nugget>0: Adds a small value to diagonal + DOUBLE PRECISION :: xCutOff=5.d0 ! upper/lower truncation limit of the + ! normal CDF + ! Nugget>0: Adds a small value to diagonal ! elements of the covariance matrix to ensure - ! that the inversion is not corrupted by - ! round off errors. - ! Good choice might be 1e-8 + ! that the inversion is not corrupted by + ! round off errors. + ! Good choice might be 1e-8 DOUBLE PRECISION :: NUGGET=1.d-8 ! Obs NUGGET must be smaller then EPS2 - + !parameters controlling the performance of RINDSCIS and MNORMPRB: - INTEGER :: SCIS=0 !=0 integr. all by quadrature - !=1 Integrate all by SADAPT for Ndim<9 and by KRBVRC otherwise - !=2 Integrate all by SADAPT for Ndim<9 and by KROBOV otherwise + INTEGER :: SCIS=0 !=0 integr. all by quadrature + !=1 Integrate all by SADAPT for Ndim<9 and by KRBVRC otherwise + !=2 Integrate all by SADAPT for Ndim<9 and by KROBOV otherwise !=3 Integrate all by KRBVRC (Fast and reliable) !=4 Integrate all by KROBOV (Fast and reliable) !=5 Integrate all by RCRUDE (Reliable) @@ -338,16 +338,16 @@ !=7 Integrate all by DKBVRC (Ndim<1001) INTEGER :: NSIMmax = 1000 ! maximum number of simulations per stochastic dimension INTEGER :: NSIMmin = 10 ! minimum number of simulations per stochastic dimension - INTEGER :: Ntscis = 0 ! Ntscis=Nt-Nj-Njj when SCIS>0 otherwise Ntscis=0 - DOUBLE PRECISION :: RelEps = 0.001 ! Relative error, i.e. if + INTEGER :: Ntscis = 0 ! Ntscis=Nt-Nj-Njj when SCIS>0 otherwise Ntscis=0 + DOUBLE PRECISION :: RelEps = 0.001 ! Relative error, i.e. if ! 3.0*STD(XIND)/XIND is less we accept the estimate ! The following may be allocated outside RINDD ! if one wants the coefficient of variation, i.e. - ! STDEV(XIND)/XIND when SCIS=2. (NB: size Nx) + ! STDEV(XIND)/XIND when SCIS=2. (NB: size Nx) DOUBLE PRECISION, DIMENSION(:), ALLOCATABLE :: COV integer :: COVix ! counting variable for COV - LOGICAL,PARAMETER :: useC1C2=.true. ! use C1C2 in rindscis,mnormprb - LOGICAL,PARAMETER :: C1C2det=.true. ! use C1C2 only on the variables that becomes + LOGICAL,PARAMETER :: useC1C2=.true. ! use C1C2 in rindscis,mnormprb + LOGICAL,PARAMETER :: C1C2det=.true. ! use C1C2 only on the variables that becomes ! deterministic after conditioning on X(N) ! used in rinddnd rindd1 and rindscis mnormprb @@ -355,20 +355,20 @@ ! if Hup>=xCutOff AND Hlo<-XSPLT OR ! Hup>=XSPLT AND Hl0<=-xCutOff then ! do a different integration to increase speed - ! in rind2 and rindnit. This give slightly different + ! in rind2 and rindnit. This give slightly different ! results ! DEFAULT 5 =xCutOff => do the same integration allways - ! However, a resonable value is XSPLT=1.5 - DOUBLE PRECISION :: XSPLT = 5.d0 ! DEFAULT XSPLT= 5 =xCutOff - ! weight between upper&lower limit returned by ARGP0 - DOUBLE PRECISION, PARAMETER :: Plowgth=0.d0 ! 0 => no weight to + ! However, a resonable value is XSPLT=1.5 + DOUBLE PRECISION :: XSPLT = 5.d0 ! DEFAULT XSPLT= 5 =xCutOff + ! weight between upper&lower limit returned by ARGP0 + DOUBLE PRECISION, PARAMETER :: Plowgth=0.d0 ! 0 => no weight to ! lower limit INTEGER :: NIT=2 ! NIT=maximum # of iterations/integrations by - ! quadrature used to calculate the indicator function + ! quadrature used to calculate the indicator function ! size information of the covariance matrix BIG - ! Nt,Nd,....Ntd,Nx must be set before calling - ! RINDD. NsXtmj, NsXdj is set in RINDD + ! Nt,Nd,....Ntd,Nx must be set before calling + ! RINDD. NsXtmj, NsXdj is set in RINDD INTEGER :: Nt,Nd,Nc,Ntdc,Ntd,Nx ! Constants determines how integration is done INTEGER :: Nj=0,Njj=0 ! Njj is not implemented yet @@ -376,10 +376,10 @@ ! Blo/Bup size Mb x NI-1 ! indI vector of length NI INTEGER :: NI,Mb ! must be set before calling RINDD - + ! The following is allocated in RINDD - DOUBLE PRECISION, DIMENSION(:,:), ALLOCATABLE :: SQ - DOUBLE PRECISION, DIMENSION(:), ALLOCATABLE :: Hlo,Hup + DOUBLE PRECISION, DIMENSION(:,:), ALLOCATABLE :: SQ + DOUBLE PRECISION, DIMENSION(:), ALLOCATABLE :: Hlo,Hup INTEGER, DIMENSION(:), ALLOCATABLE :: index1,xedni,indXtd INTEGER, DIMENSION(:), ALLOCATABLE :: NsXtmj, NsXdj @@ -393,87 +393,87 @@ DOUBLE PRECISION, PARAMETER :: PI= 3.14159265358979D0 !=pi DOUBLE PRECISION, PARAMETER :: TWOPI=6.28318530717958D0 !=2*pi END MODULE GLOBALDATA - - MODULE C1C2MOD - IMPLICIT NONE - INTERFACE C1C2 - MODULE PROCEDURE C1C2 - END INTERFACE + + MODULE C1C2MOD + IMPLICIT NONE + INTERFACE C1C2 + MODULE PROCEDURE C1C2 + END INTERFACE CONTAINS - SUBROUTINE C1C2(C1, C2, Cm, B1, SQ, ind) + SUBROUTINE C1C2(C1, C2, Cm, B1, SQ, ind) ! The regression equation for the conditional distr. of Y given X=x ! is equal to the conditional expectation of Y given X=x, i.e., -! +! ! E(Y|X=x)=E(Y)+Cov(Y,X)/Var(X)[x-E(X)] ! -! Let x1=(x-E(X))/SQRT(Var(X)) be zero mean, C1Hup(I) or ! -! Since we are truncating all Gaussian variables to -! the interval [-C,C], then if for any I -! -! a) Cm(I)+x1*B1(I)-C*SQ(I)>Hup(I) or -! -! b) Cm(I)+x1*B1(I)+C*SQ(I)0 @@ -482,9 +482,9 @@ ENDIF IF (C1.LT.CC1) THEN C1 = CC1 !changedLimits=1 - IF (C2.GT.CC2) C2 = CC2 + IF (C2.GT.CC2) C2 = CC2 IF (C1.GE.C2) GO TO 112 - ELSEIF (C2.GT.CC2) THEN + ELSEIF (C2.GT.CC2) THEN C2 = CC2 !changedLimits=1 IF (C1.GE.C2) GO TO 112 END IF @@ -492,42 +492,42 @@ END DO !IF (changedLimits.EQ.1) THEN ! PRINT *,'C1C2=',C1,C2 -!END IF +!END IF RETURN 112 continue C1 = -2D0*xCutOff - C2 = -2D0*xCutOff - + C2 = -2D0*xCutOff + RETURN END SUBROUTINE C1C2 END MODULE C1C2MOD !************************************** - MODULE FUNCMOD + MODULE FUNCMOD ! FUNCTION module containing constants transfeered to mvnfun and mvnfun2 - IMPLICIT NONE + IMPLICIT NONE DOUBLE PRECISION, DIMENSION(:,:), ALLOCATABLE :: BIG DOUBLE PRECISION, DIMENSION(: ), ALLOCATABLE :: Cm,CmN,xd,xc DOUBLE PRECISION :: Pl1,Pu1 - + INTERFACE MVNFUN MODULE PROCEDURE MVNFUN END INTERFACE - + INTERFACE MVNFUN2 MODULE PROCEDURE MVNFUN2 END INTERFACE CONTAINS function MVNFUN(Ndim,W) RESULT (XIND) - USE FIMOD + USE FIMOD USE C1C2MOD USE JACOBMOD USE GLOBALDATA, ONLY : Hlo,Hup,xCutOff,Nt,Nd,Nj,Ntd,SQ, & NsXtmj, NsXdj,indXtd,index1,useC1C2,C1C2det,EPS2 IMPLICIT NONE - DOUBLE PRECISION, DIMENSION(: ), INTENT(in) :: W + DOUBLE PRECISION, DIMENSION(: ), INTENT(in) :: W INTEGER, INTENT(in) :: Ndim DOUBLE PRECISION :: XIND !local variables @@ -537,10 +537,10 @@ INTEGER :: Ndleft,Ndjleft,Ntmj !MVNFUN Multivariate Normal integrand function -! where the integrand is transformed from an integral +! where the integrand is transformed from an integral ! having integration limits Hl0 and Hup to an ! integral having constant integration limits i.e. -! Hup 1 +! Hup 1 ! int jacob(xd,xc)*f(xd,xt)dxt dxd = int F2(W) dW !Hlo 0 ! @@ -548,12 +548,12 @@ ! The vector must have the length Ndim=Nst0+Ntd-Nsd0 ! BIG - conditional sorted covariance matrix (IN) ! Cm = conditional mean of Xd and Xt given Xc, E(Xd,Xt|Xc) -! CmN - local conditional mean +! CmN - local conditional mean ! xd - variables to the jacobian variable, need no initialization -! xc - conditional variables (IN) +! xc - conditional variables (IN) ! Pl1 = FI(XMI) for the first integration variable (IN) ! Pu1 = FI(XMA) ------||------------------------------- -! print *,'MVNFUN, ndim', ndim, shape(W) +! print *,'MVNFUN, ndim', ndim, shape(W) CmN(1:Ntd) = Cm(1:Ntd) ! initialize conditional mean Nst = NsXtmj(Ntd+1) ! index to last stoch variable of Xt before conditioning on X(Ntd) Ntmj=Nt-Nj @@ -565,7 +565,7 @@ endif Pl=Pl1 Pu=Pu1 -! IF (NDIM.LT.Nst0+Ntd-Nsd0+1) PRINT *, 'MVNFUN NDIM,',NDIM +! IF (NDIM.LT.Nst0+Ntd-Nsd0+1) PRINT *, 'MVNFUN NDIM,',NDIM Y=Pu-Pl if (Nd+Nj.EQ.0) then SQ0=SQ(1,1) @@ -575,13 +575,13 @@ Nsd = NsXdj(Ndjleft+1) ! index to last stoch variable of Xd and Nj of Xt before conditioning on X(Ntd) Ndleft=Nd SQ0=SQ(Ntd,Ntd) - !print *,'mvnfun,nst,nsd,nd,nj',nst,nsd,Nd,Nj + !print *,'mvnfun,nst,nsd,nd,nj',nst,nsd,Nd,Nj !print *,'mvn start K loop' DO K=Ntd-1,Nsd0,-1 X=FIINV(Pl+W(Ntd-K)*(Pu-Pl)) IF (index1(K+1).GT.Nt) THEN ! isXd xd (Ndleft) = CmN(K+1)+X*SQ0 - Ndleft=Ndleft-1 + Ndleft=Ndleft-1 END IF Nst = NsXtmj(K+1) ! # stoch. var. of Xt before conditioning on X(K) if (Nst.GT.0) CmN(1:Nst) =CmN(1:Nst)+X*BIG(1:Nst,K+1) !/SQ0 @@ -590,15 +590,15 @@ Ndjleft = Ndjleft-1 Nsd = NsXdj(Ndjleft+1) SQ0 = SQ(K,K) - + XMA = (Hup (K)-CmN(K))/SQ0 XMI = (Hlo (K)-CmN(K))/SQ0 - - if (useC1C2) then ! see if we can narrow down sampling range + + if (useC1C2) then ! see if we can narrow down sampling range XMI=max(XMI,-xCutOff) XMA=min(XMA,xCutOff) if (C1C2det) then - NsdN = NsXdj(Ndjleft) + NsdN = NsXdj(Ndjleft) NstN = NsXtmj(K) CALL C1C2(XMI,XMA,CmN(Nsd:NsdN-1), & BIG(Nsd:NsdN-1,K),SQ(Nsd:NsdN-1,K), @@ -611,12 +611,12 @@ & SQ(Nsd:K-1,Ntmj+Ndjleft),indXtd(Nsd:K-1)) CALL C1C2(XMI,XMA,CmN(1:Nst),BIG(1:Nst,K) & ,SQ(1:Nst,Ntmj+Ndjleft),indXtd(1:Nst)) - endif + endif IF (XMA.LE.XMI) goto 260 endif Pl = FI(XMI) Pu = FI(XMA) - Y=Y*(Pu-Pl) + Y=Y*(Pu-Pl) ENDDO ! K LOOP X = FIINV(Pl+W(Ntd-Nsd0+1)*(Pu-Pl)) Nst = NsXtmj(Nsd0) ! # stoch. var. of Xt after conditioning on X(Nsd0) @@ -625,15 +625,15 @@ if (Nd.gt.0) then CmN(Nsd:Nsd0-1) = CmN(Nsd:Nsd0-1)+X*BIG(Nsd:Nsd0-1,Nsd0) !/SQ0 if (Ndleft.gt.0) then - if (index1(Nsd0).GT.Nt) then + if (index1(Nsd0).GT.Nt) then xd (Ndleft) = CmN(Nsd0)+X*SQ0 Ndleft=Ndleft-1 endif - K=Nsd0-1 + K=Nsd0-1 do while (Ndleft.gt.0) if ((index1(K).GT.Nt)) THEN ! isXd xd (Ndleft) = CmN(K) - Ndleft=Ndleft-1 + Ndleft=Ndleft-1 END IF K=K-1 ENDDO @@ -645,32 +645,32 @@ SQ0 = SQ(1,1) XMA = MIN((Hup (1)-CmN(1))/SQ0,xCutOff) XMI = MAX((Hlo (1)-CmN(1))/SQ0,-xCutOff) - + if (C1C2det) then - NstN = NsXtmj(1) ! # stoch. var. after conditioning + NstN = NsXtmj(1) ! # stoch. var. after conditioning CALL C1C2(XMI,XMA,CmN(NstN+1:Nst), & BIG(1,NstN+1:Nst),SQ(NstN+1:Nst,1), & indXtd(NstN+1:Nst)) else CALL C1C2(XMI,XMA,CmN(2:Nst),BIG(1,2:Nst), & SQ(2:Nst,1),indXtd(2:Nst)) - endif + endif IF (XMA.LE.XMI) GO TO 260 Pl = FI(XMI) Pu = FI(XMA) Y = Y*(Pu-Pl) endif - !if (COVix.gt.2) then + !if (COVix.gt.2) then !print *,' mvnfun start K2 loop' !endif 200 do K = 2,Nst0 - X = FIINV(Pl+W(Ntd-Nsd0+K)*(Pu-Pl)) + X = FIINV(Pl+W(Ntd-Nsd0+K)*(Pu-Pl)) Nst = NsXtmj(K-1) ! index to last stoch. var. before conditioning on X(K) CmN(K:Nst)=CmN(K:Nst)+X*BIG(K-1,K:Nst) !/SQ0 SQ0 = SQ(K,K) XMA = MIN((Hup (K)-CmN(K))/SQ0,xCutOff) XMI = MAX((Hlo (K)-CmN(K))/SQ0,-xCutOff) - + if (C1C2det) then NstN = NsXtmj(K) ! index to last stoch. var. after conditioning X(K) CALL C1C2(XMI,XMA,CmN(NstN+1:Nst), @@ -682,7 +682,7 @@ endif IF (XMA.LE.XMI) GO TO 260 Pl = FI(XMI) - Pu = FI(XMA) + Pu = FI(XMA) Y=Y*(Pu-Pl) enddo ! K loop XIND = Y @@ -694,7 +694,7 @@ END FUNCTION MVNFUN function MVNFUN2(Ndim,W) RESULT (XIND) - USE FIMOD + USE FIMOD USE C1C2MOD USE GLOBALDATA, ONLY : Hlo,Hup,xCutOff,Njj,Nj,Ntscis,Ntd,SQ, & NsXtmj, NsXdj,indXtd,index1,useC1C2,C1C2det,Nt,EPS2 @@ -708,22 +708,22 @@ INTEGER :: Nst,NstN,Nst0,K !MVNFUN2 Multivariate Normal integrand function -! where the integrand is transformed from an integral +! where the integrand is transformed from an integral ! having integration limits Hl0 and Hup to an ! integral having constant integration limits i.e. -! Hup 1 +! Hup 1 ! int f(xt)dxt = int F2(W) dW !Hlo 0 ! ! W - new transformed integration variables, valid range 0..1 ! The vector must have the size Nst0 ! BIG - conditional sorted covariance matrix (IN) -! CmN - Local conditional mean +! CmN - Local conditional mean ! Cm = Conditional mean E(Xt,Xd|Xc) ! Pl1 = FI(XMI) for the first integration variable ! Pu1 = FI(XMA) ------||------------------------- - - !print *,'MVNFUN2, ndim', ndim, shape(W) + + !print *,'MVNFUN2, ndim', ndim, shape(W) Nst0 = NsXtmj(Njj+Ntscis) if (Njj.GT.0) then @@ -731,24 +731,24 @@ else Nst = NsXtmj(Ntscis+1) endif -! IF (NDIM.LT.Nst0+Njj) PRINT *, 'MVNFUN2 NDIM,',NDIM +! IF (NDIM.LT.Nst0+Njj) PRINT *, 'MVNFUN2 NDIM,',NDIM ! initialize conditional mean CmN(1:Nst)=Cm(1:Nst) - + Pl = Pl1 Pu = Pu1 - + Y = Pu-Pl SQ0 = SQ(1,1) - + do K = 2,Nst0 - X = FIINV(Pl+W(K-1)*(Pu-Pl)) + X = FIINV(Pl+W(K-1)*(Pu-Pl)) Nst = NsXtmj(K-1) ! index to last stoch. var. before conditioning on X(K) CmN(K:Nst)=CmN(K:Nst)+X*BIG(K-1,K:Nst) !/SQ0 SQ0 = SQ(K,K) XMA = MIN((Hup (K)-CmN(K))/SQ0,xCutOff) XMI = MAX((Hlo (K)-CmN(K))/SQ0,-xCutOff) - + if (C1C2det) then NstN=NsXtmj(K) ! index to last stoch. var. after conditioning on X(K) CALL C1C2(XMI,XMA,CmN(NstN+1:Nst), @@ -760,7 +760,7 @@ endif IF (XMA.LE.XMI) GO TO 260 Pl = FI(XMI) - Pu = FI(XMA) + Pu = FI(XMA) Y = Y*(Pu-Pl) enddo ! K loop XIND = Y @@ -778,91 +778,91 @@ INTEGER :: minQNr=1 ! minimum quadrature number ! used in GaussLe1, Gaussle2 INTEGER :: Le2QNr=8 ! quadr. number used in rind2,rindnit - INTEGER, DIMENSION(sizNint) :: Nint1 ! use quadr. No. Nint1(i) in + INTEGER, DIMENSION(sizNint) :: Nint1 ! use quadr. No. Nint1(i) in ! integration of Xd(i) ! # different quadratures stored for : - !------------------------------------- - INTEGER,PARAMETER :: NLeW=13 ! Legendre - INTEGER,PARAMETER :: NHeW=13 ! Hermite - INTEGER,PARAMETER :: NLaW=13 ! Laguerre + !------------------------------------- + INTEGER,PARAMETER :: NLeW=13 ! Legendre + INTEGER,PARAMETER :: NHeW=13 ! Hermite + INTEGER,PARAMETER :: NLaW=13 ! Laguerre ! Quadrature Number stored for : - !------------------------------------- - INTEGER, DIMENSION(NLeW) :: LeQNr ! Legendre - INTEGER, DIMENSION(NHeW) :: HeQNr ! Hermite - INTEGER, DIMENSION(NLaW) :: LaQNr ! Laguerre + !------------------------------------- + INTEGER, DIMENSION(NLeW) :: LeQNr ! Legendre + INTEGER, DIMENSION(NHeW) :: HeQNr ! Hermite + INTEGER, DIMENSION(NLaW) :: LaQNr ! Laguerre PARAMETER (LeQNr=(/ 2,3,4,5,6,7, 8, 9, 10, 12, 16, 20, 24 /)) PARAMETER (HeQNr=(/ 2,3,4,5,6,7, 8, 9, 10, 12, 16, 20, 24 /)) PARAMETER (LaQNr=(/ 2,3,4,5,6,7, 8, 9, 10, 12, 16, 20, 24 /)) - ! The indices to the weights & nodes stored for: + ! The indices to the weights & nodes stored for: !------------------------------------------------ INTEGER, DIMENSION(NLeW+1) :: LeIND !Legendre INTEGER, DIMENSION(NHeW+1) :: HeIND !Hermite INTEGER, DIMENSION(NLaW+1) :: LaIND !Laguerre - + PARAMETER (LeIND=(/0,2,5,9,14,20,27,35,44,54,66,82,102,126/)) !Legendre PARAMETER (HeIND=(/0,2,5,9,14,20,27,35,44,54,66,82,102,126/)) !Hermite - PARAMETER (LaIND=(/0,2,5,9,14,20,27,35,44,54,66,82,102,126/)) !Laguerre + PARAMETER (LaIND=(/0,2,5,9,14,20,27,35,44,54,66,82,102,126/)) !Laguerre !------------------------------------------------ - DOUBLE PRECISION, DIMENSION(126) :: LeBP,LeWF,HeBP,HeWF + DOUBLE PRECISION, DIMENSION(126) :: LeBP,LeWF,HeBP,HeWF DOUBLE PRECISION, DIMENSION(126) :: LaBP0,LaWF0,LaBP5,LaWF5 !The Hermite Quadrature integrates an integral of the form ! inf n ! Int (exp(-x^2) F(x)) dx = Sum wf(j)*F( bp(j) ) -! -Inf j=1 +! -Inf j=1 !The Laguerre Quadrature integrates an integral of the form ! inf n ! Int (x^alpha exp(-x) F(x)) dx = Sum wf(j)*F( bp(j) ) -! 0 j=1 +! 0 j=1 ! weights stored here are for alpha=0 and alpha=-0.5 ! initialize Legendre weights, wf, and nodes, bp !PARAMETER ( LeWF = ( - DATA ( LeWF(I), I = 1, 78 ) - * / 1.d0, 1.d0, 0.555555555555556d0, - * 0.888888888888889d0, 0.555555555555556d0, + DATA ( LeWF(I), I = 1, 78 ) + * / 1.d0, 1.d0, 0.555555555555556d0, + * 0.888888888888889d0, 0.555555555555556d0, * 0.347854845137454d0, 0.652145154862546d0, - * 0.652145154862546d0, 0.347854845137454d0, - * 0.236926885056189d0, 0.478628670499366d0, + * 0.652145154862546d0, 0.347854845137454d0, + * 0.236926885056189d0, 0.478628670499366d0, * 0.568888888888889d0, 0.478628670499366d0, - * 0.236926885056189d0, 0.171324492379170d0, + * 0.236926885056189d0, 0.171324492379170d0, * 0.360761573048139d0, 0.467913934572691d0, * 0.467913934572691d0, 0.360761573048139d0, - * 0.171324492379170d0, 0.129484966168870d0, + * 0.171324492379170d0, 0.129484966168870d0, * 0.279705391489277d0, 0.381830050505119d0, * 0.417959183673469d0, 0.381830050505119d0, - * 0.279705391489277d0, 0.129484966168870d0, - * 0.101228536290376d0, 0.222381034453374d0, + * 0.279705391489277d0, 0.129484966168870d0, + * 0.101228536290376d0, 0.222381034453374d0, * 0.313706645877887d0, 0.362683783378362d0, - * 0.362683783378362d0, 0.313706645877887d0, + * 0.362683783378362d0, 0.313706645877887d0, * 0.222381034453374d0, 0.101228536290376d0, * 0.081274388361574d0, 0.180648160694857d0, - * 0.260610696402935d0, 0.312347077040003d0, + * 0.260610696402935d0, 0.312347077040003d0, * 0.330239355001260d0, 0.312347077040003d0, * 0.260610696402935d0, 0.180648160694857d0, - * 0.081274388361574d0, 0.066671344308688d0, + * 0.081274388361574d0, 0.066671344308688d0, * 0.149451349150581d0, 0.219086362515982d0, * 0.269266719309996d0, 0.295524224714753d0, - * 0.295524224714753d0, 0.269266719309996d0, + * 0.295524224714753d0, 0.269266719309996d0, * 0.219086362515982d0, 0.149451349150581d0, - * 0.066671344308688d0, 0.047175336386512d0, - * 0.106939325995318d0, 0.160078328543346d0, - * 0.203167426723066d0, 0.233492536538355d0, + * 0.066671344308688d0, 0.047175336386512d0, + * 0.106939325995318d0, 0.160078328543346d0, + * 0.203167426723066d0, 0.233492536538355d0, * 0.249147048513403d0, 0.249147048513403d0, - * 0.233492536538355d0, - * 0.203167426723066d0, 0.160078328543346d0, - * 0.106939325995318d0, 0.047175336386512d0, + * 0.233492536538355d0, + * 0.203167426723066d0, 0.160078328543346d0, + * 0.106939325995318d0, 0.047175336386512d0, * 0.027152459411754094852d0, 0.062253523938647892863d0, * 0.095158511682492784810d0, 0.124628971255533872052d0, * 0.149595988816576732081d0, 0.169156519395002538189d0, * 0.182603415044923588867d0, 0.189450610455068496285d0, * 0.189450610455068496285d0, 0.182603415044923588867d0, * 0.169156519395002538189d0, 0.149595988816576732081d0/ - DATA ( LeWF(I), I = 79, 126 ) + DATA ( LeWF(I), I = 79, 126 ) * / 0.124628971255533872052d0, 0.095158511682492784810d0, * 0.062253523938647892863d0, 0.027152459411754094852d0, * 0.017614007139152118312d0, 0.040601429800386941331d0, @@ -874,7 +874,7 @@ * 0.142096109318382051329d0, 0.131688638449176626898d0, * 0.118194531961518417312d0, 0.101930119817240435037d0, * 0.083276741576704748725d0, 0.062672048334109063570d0, - * 0.040601429800386941331d0, 0.017614007139152118312d0, + * 0.040601429800386941331d0, 0.017614007139152118312d0, * 0.012341229799987199547d0, 0.028531388628933663181d0, * 0.044277438817419806169d0, 0.059298584915436780746d0, * 0.073346481411080305734d0, 0.086190161531953275917d0, @@ -891,35 +891,35 @@ DATA ( LeBP(I), I=1,77) * / -0.577350269189626d0,0.577350269189626d0, * -0.774596669241483d0, 0.d0, - * 0.774596669241483d0, -0.861136311594053d0, + * 0.774596669241483d0, -0.861136311594053d0, * -0.339981043584856d0, 0.339981043584856d0, * 0.861136311594053d0, -0.906179845938664d0, * -0.538469310105683d0, 0.d0, - * 0.538469310105683d0, 0.906179845938664d0, + * 0.538469310105683d0, 0.906179845938664d0, * -0.932469514203152d0, -0.661209386466265d0, * -0.238619186083197d0, 0.238619186083197d0, - * 0.661209386466265d0, 0.932469514203152d0, + * 0.661209386466265d0, 0.932469514203152d0, * -0.949107912342759d0, -0.741531185599394d0, * -0.405845151377397d0, 0.d0, - * 0.405845151377397d0, 0.741531185599394d0, - * 0.949107912342759d0, -0.960289856497536d0, + * 0.405845151377397d0, 0.741531185599394d0, + * 0.949107912342759d0, -0.960289856497536d0, * -0.796666477413627d0, -0.525532409916329d0, - * -0.183434642495650d0, 0.183434642495650d0, + * -0.183434642495650d0, 0.183434642495650d0, * 0.525532409916329d0, 0.796666477413627d0, * 0.960289856497536d0, -0.968160239507626d0, * -0.836031107326636d0, -0.613371432700590d0, * -0.324253423403809d0, 0.d0, * 0.324253423403809d0, 0.613371432700590d0, - * 0.836031107326636d0, 0.968160239507626d0, + * 0.836031107326636d0, 0.968160239507626d0, * -0.973906528517172d0, -0.865063366688985d0, - * -0.679409568299024d0, -0.433395394129247d0, - * -0.148874338981631d0, 0.148874338981631d0, + * -0.679409568299024d0, -0.433395394129247d0, + * -0.148874338981631d0, 0.148874338981631d0, * 0.433395394129247d0, 0.679409568299024d0, * 0.865063366688985d0, 0.973906528517172d0, - * -0.981560634246719d0, -0.904117256370475d0, + * -0.981560634246719d0, -0.904117256370475d0, * -0.769902674194305d0, -0.587317954286617d0, * -0.367831498198180d0, -0.125233408511469d0, - * 0.125233408511469d0, 0.367831498198180d0, + * 0.125233408511469d0, 0.367831498198180d0, * 0.587317954286617d0, 0.769902674194305d0, * 0.904117256370475d0, 0.981560634246719d0, * -0.989400934991649932596d0, @@ -953,12 +953,12 @@ * 0.545421471388839535658d0, 0.648093651936975569252d0, * 0.740124191578554364244d0, 0.820001985973902921954d0, * 0.886415527004401034213d0, 0.938274552002732758524d0, - * 0.974728555971309498198d0, 0.995187219997021360180d0 / + * 0.974728555971309498198d0, 0.995187219997021360180d0 / - ! initialize Hermite weights in HeWF and + ! initialize Hermite weights in HeWF and ! nodes in HeBP - ! NB! the relative error of these numbers - ! are less than 10^-15 + ! NB! the relative error of these numbers + ! are less than 10^-15 ! PARAMETER DATA (HeWF(I),I=1,78) / 8.8622692545275816d-1, * 8.8622692545275816d-1, @@ -1000,7 +1000,7 @@ * 2.8064745852853318d-1, 5.0792947901661278d-1, * 5.0792947901661356d-1, 2.8064745852853334d-1, * 8.3810041398985735d-2, 1.2880311535510015d-2/ - DATA (HeWF(I),I=79,126) / + DATA (HeWF(I),I=79,126) / * 9.3228400862418407d-4, 2.7118600925378956d-5, * 2.3209808448651966d-7, 2.6548074740111787d-10, * 2.2293936455342015d-13, 4.3993409922730765d-10, @@ -1025,7 +1025,7 @@ * 5.6886916364044037d-5, 2.1582457049023460d-6, * 4.0189711749414963d-8, 3.0462542699876118d-10, * 6.5846202430782225d-13, 1.6643684964889408d-16 / - + !hermite nodes ! PARAMETER (HeBP = ( DATA (HeBP(I),I=1,79) / -7.07106781186547572d-1, @@ -1068,10 +1068,10 @@ * -2.7348104613815177d-1, 2.7348104613815244d-1, * 8.2295144914465579d-1, 1.3802585391988802d0, * 1.9517879909162534d0, 2.5462021578474801d0/ - DATA (HeBP(I),I=80,126) / + DATA (HeBP(I),I=80,126) / * 3.1769991619799565d0, 3.8694479048601265d0, - * 4.6887389393058196d0, -5.3874808900112274d0, - * -4.6036824495507513d0, -3.9447640401156296d0, + * 4.6887389393058196d0, -5.3874808900112274d0, + * -4.6036824495507513d0, -3.9447640401156296d0, * -3.3478545673832154d0, -2.7888060584281300d0, * -2.2549740020892721d0, -1.7385377121165839d0, * -1.2340762153953209d0, -7.3747372854539361d-1, @@ -1094,38 +1094,38 @@ * 4.6256627564237816d0, 5.2593829276680353d0, * 6.0159255614257550d0 / !initialize Laguerre weights and nodes (basepoints) - ! for alpha=0 - ! NB! the relative error of these numbers - ! are less than 10^-15 + ! for alpha=0 + ! NB! the relative error of these numbers + ! are less than 10^-15 ! PARAMETER DATA (LaWF0(I),I=1,75) / 8.5355339059327351d-1, - * 1.4644660940672624d-1, 7.1109300992917313d-1, - * 2.7851773356924092d-1, 1.0389256501586137d-2, - * 6.0315410434163386d-1, - * 3.5741869243779956d-1, 3.8887908515005364d-2, - * 5.3929470556132730d-4, 5.2175561058280850d-1, - * 3.9866681108317570d-1, 7.5942449681707588d-2, - * 3.6117586799220489d-3, 2.3369972385776180d-5, - * 4.5896467394996360d-1, 4.1700083077212080d-1, - * 1.1337338207404497d-1, 1.0399197453149061d-2, - * 2.6101720281493249d-4, 8.9854790642961944d-7, - * 4.0931895170127397d-1, 4.2183127786171964d-1, - * 1.4712634865750537d-1, - * 2.0633514468716974d-2, 1.0740101432807480d-3, - * 1.5865464348564158d-5, 3.1703154789955724d-8, - * 3.6918858934163773d-1, 4.1878678081434328d-1, - * 1.7579498663717152d-1, 3.3343492261215649d-2, - * 2.7945362352256712d-3, 9.0765087733581999d-5, - * 8.4857467162725493d-7, 1.0480011748715038d-9, - * 3.3612642179796304d-1, 4.1121398042398466d-1, - * 1.9928752537088576d0, 4.7460562765651609d-2, - * 5.5996266107945772d-3, 3.0524976709321133d-4, - * 6.5921230260753743d-6, 4.1107693303495271d-8, - * 3.2908740303506941d-11, - * 3.0844111576502009d-1, 4.0111992915527328d-1, - * 2.1806828761180935d-1, 6.2087456098677683d-2, - * 9.5015169751810902d-3, 7.5300838858753855d-4, - * 2.8259233495995652d-5, 4.2493139849626742d-7, + * 1.4644660940672624d-1, 7.1109300992917313d-1, + * 2.7851773356924092d-1, 1.0389256501586137d-2, + * 6.0315410434163386d-1, + * 3.5741869243779956d-1, 3.8887908515005364d-2, + * 5.3929470556132730d-4, 5.2175561058280850d-1, + * 3.9866681108317570d-1, 7.5942449681707588d-2, + * 3.6117586799220489d-3, 2.3369972385776180d-5, + * 4.5896467394996360d-1, 4.1700083077212080d-1, + * 1.1337338207404497d-1, 1.0399197453149061d-2, + * 2.6101720281493249d-4, 8.9854790642961944d-7, + * 4.0931895170127397d-1, 4.2183127786171964d-1, + * 1.4712634865750537d-1, + * 2.0633514468716974d-2, 1.0740101432807480d-3, + * 1.5865464348564158d-5, 3.1703154789955724d-8, + * 3.6918858934163773d-1, 4.1878678081434328d-1, + * 1.7579498663717152d-1, 3.3343492261215649d-2, + * 2.7945362352256712d-3, 9.0765087733581999d-5, + * 8.4857467162725493d-7, 1.0480011748715038d-9, + * 3.3612642179796304d-1, 4.1121398042398466d-1, + * 1.9928752537088576d0, 4.7460562765651609d-2, + * 5.5996266107945772d-3, 3.0524976709321133d-4, + * 6.5921230260753743d-6, 4.1107693303495271d-8, + * 3.2908740303506941d-11, + * 3.0844111576502009d-1, 4.0111992915527328d-1, + * 2.1806828761180935d-1, 6.2087456098677683d-2, + * 9.5015169751810902d-3, 7.5300838858753855d-4, + * 2.8259233495995652d-5, 4.2493139849626742d-7, * 1.8395648239796174d-9, 9.9118272196090085d-13, & 2.6473137105544342d-01, & 3.7775927587313773d-01, 2.4408201131987739d-01, @@ -1166,33 +1166,33 @@ & 2.4518188458785009d-26, 4.0883015936805334d-30, & 5.5753457883284229d-35 / ! PARAMETER (LaBP0=(/ - DATA (LaBP0(I),I=1,78) /5.8578643762690485d-1, - * 3.4142135623730949d+00, 4.1577455678347897d-1, - * 2.2942803602790409d0, 6.2899450829374803d0, - * 3.2254768961939217d-1, 1.7457611011583465d0, - * 4.5366202969211287d0, 9.3950709123011364d0, - * 2.6356031971814076d-1, 1.4134030591065161d0, - * 3.5964257710407206d0, 7.0858100058588356d0, - * 1.2640800844275784d+01, 2.2284660417926061d-1, - * 1.1889321016726229d0, 2.9927363260593141d+00, - * 5.7751435691045128d0, 9.8374674183825839d0, - * 1.5982873980601699d+01, 1.9304367656036231d-1, - * 1.0266648953391919d0, 2.5678767449507460d0, - * 4.9003530845264844d0, 8.1821534445628572d0, - * 1.2734180291797809d+01, 1.9395727862262543d+01, - * 1.7027963230510107d-1, 9.0370177679938035d-1, - * 2.2510866298661316d0, 4.2667001702876597d0, - * 7.0459054023934673d0, 1.0758516010180994d+01, - * 1.5740678641278004d+01, 2.2863131736889272d+01, - * 1.5232222773180798d-1, 8.0722002274225590d-1, - * 2.0051351556193473d0, 3.7834739733312328d0, - * 6.2049567778766175d0, 9.3729852516875773d0, - * 1.3466236911092089d+01, 1.8833597788991703d+01, - * 2.6374071890927389d+01, 1.3779347054049221d-1, - * 7.2945454950317090d-1, 1.8083429017403163d0, - * 3.4014336978548996d0, - * 5.5524961400638029d0, 8.3301527467644991d0, - * 1.1843785837900066d+01, 1.6279257831378107d+01, + DATA (LaBP0(I),I=1,78) /5.8578643762690485d-1, + * 3.4142135623730949d+00, 4.1577455678347897d-1, + * 2.2942803602790409d0, 6.2899450829374803d0, + * 3.2254768961939217d-1, 1.7457611011583465d0, + * 4.5366202969211287d0, 9.3950709123011364d0, + * 2.6356031971814076d-1, 1.4134030591065161d0, + * 3.5964257710407206d0, 7.0858100058588356d0, + * 1.2640800844275784d+01, 2.2284660417926061d-1, + * 1.1889321016726229d0, 2.9927363260593141d+00, + * 5.7751435691045128d0, 9.8374674183825839d0, + * 1.5982873980601699d+01, 1.9304367656036231d-1, + * 1.0266648953391919d0, 2.5678767449507460d0, + * 4.9003530845264844d0, 8.1821534445628572d0, + * 1.2734180291797809d+01, 1.9395727862262543d+01, + * 1.7027963230510107d-1, 9.0370177679938035d-1, + * 2.2510866298661316d0, 4.2667001702876597d0, + * 7.0459054023934673d0, 1.0758516010180994d+01, + * 1.5740678641278004d+01, 2.2863131736889272d+01, + * 1.5232222773180798d-1, 8.0722002274225590d-1, + * 2.0051351556193473d0, 3.7834739733312328d0, + * 6.2049567778766175d0, 9.3729852516875773d0, + * 1.3466236911092089d+01, 1.8833597788991703d+01, + * 2.6374071890927389d+01, 1.3779347054049221d-1, + * 7.2945454950317090d-1, 1.8083429017403163d0, + * 3.4014336978548996d0, + * 5.5524961400638029d0, 8.3301527467644991d0, + * 1.1843785837900066d+01, 1.6279257831378107d+01, * 2.1996585811980765d+01, 2.9920697012273894d+01 , & 1.1572211735802050d-01, 6.1175748451513112d-01, & 1.5126102697764183d+00, 2.8337513377435077d+00, @@ -1275,7 +1275,7 @@ & 8.9550013377233881e+00, 1.1677033673975952e+01, & 1.4851431341801243e+01, 1.8537743178606682e+01, & 2.2821300693525199e+01, 2.7831438211328681e+01/ - DATA (LaBP5(I),I=80,126) / + DATA (LaBP5(I),I=80,126) / & 3.3781970488226136e+01, 4.1081666525491165e+01, & 5.0777223877537075e+01, 3.0463239279482423e-02, & 2.7444471579285024e-01, 7.6388755844391365e-01, @@ -1300,7 +1300,7 @@ & 4.6376979557540103e+01, 5.2795432527283602e+01, & 6.0206666963057259e+01, 6.9068601975304347e+01, & 8.0556280819950416e+01/ - + ! PARAMETER (LaWF5 = (/ DATA (LaWF5(I),I=1,79) / 1.6098281800110255e+00, & 1.6262567089449037e-01, 1.4492591904487846e+00, @@ -1379,18 +1379,18 @@ INTERFACE GAUSSHE0 MODULE PROCEDURE GAUSSHE0 END INTERFACE - + INTERFACE GAUSSLE1 - MODULE PROCEDURE GAUSSLE1 + MODULE PROCEDURE GAUSSLE1 END INTERFACE INTERFACE GAUSSLE2 - MODULE PROCEDURE GAUSSLE2 + MODULE PROCEDURE GAUSSLE2 END INTERFACE INTERFACE GAUSSQ - MODULE PROCEDURE GAUSSQ + MODULE PROCEDURE GAUSSQ END INTERFACE CONTAINS @@ -1409,38 +1409,38 @@ ! The subroutine picks the lowest Gauss-Legendre ! quadrature needed to integrate the test function - ! gaussint to the specified accuracy, EPS0. + ! gaussint to the specified accuracy, EPS0. ! The nodes and weights between the integration - ! limits XMI and XMA (all normalized) are returned. + ! limits XMI and XMA (all normalized) are returned. ! Note that the weights are multiplied with - ! 1/sqrt(2*pi)*exp(.5*bpout^2) + ! 1/sqrt(2*pi)*exp(.5*bpout^2) IF (XMA.LE.XMI) THEN ! PRINT * , 'Warning XMIN>=XMAX in GAUSSLE1 !',XMI,XMA RETURN ENDIF - - DO I = minQnr, NLeW + + DO I = minQnr, NLeW NN = N !initialize DO J = LeIND(I)+1, LeIND(I+1) BPOUT (NN+1) = 0.5d0*(LeBP(J)*(XMA-XMI)+XMA+XMI) Z1 = BPOUT (NN+1) * BPOUT (NN+1) !IF (Z1.LE.xCutOff2) THEN NN=NN+1 - WFout (NN) = 0.5d0 * SQTWOPI1 * (XMA - XMI) * - & LeWF(J) *EXP ( - 0.5d0* Z1 ) + WFout (NN) = 0.5d0 * SQTWOPI1 * (XMA - XMI) * + & LeWF(J) *EXP ( - 0.5d0* Z1 ) !ENDIF ENDDO - + SDOT = GAUSINT (XMI, XMA, - 2.5d0, 2.d0, 2.5d0, 2.d0) SDOT1 = 0.d0 - + DO k = N+1, NN - SDOT1 = SDOT1+WFout(k)*(-2.5d0+2.d0*BPOUT(k) )* - & (2.5d0 + 2.d0 * BPOUT (k) ) + SDOT1 = SDOT1+WFout(k)*(-2.5d0+2.d0*BPOUT(k) )* + & (2.5d0 + 2.d0 * BPOUT (k) ) ENDDO DIFF1 = ABS (SDOT - SDOT1) - + IF (EPS0.GT.DIFF1) THEN N=NN ! PRINT * ,'gaussle1, XMI,XMA,NN',XMI,XMA,NN @@ -1450,76 +1450,76 @@ RETURN END SUBROUTINE GAUSSLE1 - SUBROUTINE GAUSSLE0 (N, wfout, bpout, XMI, XMA, N0) + SUBROUTINE GAUSSLE0 (N, wfout, bpout, XMI, XMA, N0) USE GLOBALDATA, ONLY : EPSS ! USE QUAD, ONLY : LeBP,LeWF,NLeW,LeIND IMPLICIT NONE - INTEGER, INTENT(in) :: N0 + INTEGER, INTENT(in) :: N0 INTEGER, INTENT(inout) :: N - DOUBLE PRECISION, DIMENSION(:), INTENT(out) :: wfout,bpout - DOUBLE PRECISION, INTENT(in) :: XMI,XMA + DOUBLE PRECISION, DIMENSION(:), INTENT(out) :: wfout,bpout + DOUBLE PRECISION, INTENT(in) :: XMI,XMA ! Local variables DOUBLE PRECISION,PARAMETER :: SQTWOPI1 = 0.39894228040143D0 !=1/sqrt(2*pi) - DOUBLE PRECISION :: Z1 + DOUBLE PRECISION :: Z1 INTEGER :: J ! The subroutine computes Gauss-Legendre ! nodes and weights between - ! the (normalized) integration limits XMI and XMA + ! the (normalized) integration limits XMI and XMA ! Note that the weights are multiplied with ! 1/sqrt(2*pi)*exp(.5*bpout^2) so that ! b ! int f(x)*exp(-x^2/2)/sqrt(2*pi)dx=sum f(bp(j))*wf(j) ! a j - IF (XMA.LE.XMI) THEN + IF (XMA.LE.XMI) THEN !PRINT * , 'Warning XMIN>=XMAX in GAUSSLE0 !',XMI,XMA RETURN ! no more nodes added ENDIF IF ((XMA-XMI).LT.EPSS) THEN N=N+1 BPout (N) = 0.5d0 * (XMA + XMI) - Z1 = BPOUT (N) * BPOUT (N) - WFout (N) = SQTWOPI1 * (XMA - XMI) *EXP ( - 0.5d0* Z1 ) + Z1 = BPOUT (N) * BPOUT (N) + WFout (N) = SQTWOPI1 * (XMA - XMI) *EXP ( - 0.5d0* Z1 ) RETURN ENDIF - IF (N0.GT.NLeW) THEN - !PRINT * , 'error in GAUSSLE0, quadrature not available' - STOP - ENDIF - !print *, 'GAUSSLE0',N0 - - !print *, N - DO J = LeIND(N0)+1, LeIND(N0+1) - + IF (N0.GT.NLeW) THEN + !PRINT * , 'error in GAUSSLE0, quadrature not available' + STOP + ENDIF + !print *, 'GAUSSLE0',N0 + + !print *, N + DO J = LeIND(N0)+1, LeIND(N0+1) + BPout (N+1) = 0.5d0 * (LeBP(J) * (XMA - XMI) + XMA + XMI) Z1 = BPOUT (N+1) * BPOUT (N+1) ! IF (Z1.LE.xCutOff2) THEN N=N+1 ! add a new node and weight - WFout (N) = 0.5d0 * SQTWOPI1 * (XMA - XMI) * - & LeWF(J) *EXP ( - 0.5d0* Z1 ) - ! ENDIF + WFout (N) = 0.5d0 * SQTWOPI1 * (XMA - XMI) * + & LeWF(J) *EXP ( - 0.5d0* Z1 ) + ! ENDIF ENDDO !print *,BPout - RETURN + RETURN END SUBROUTINE GAUSSLE0 - SUBROUTINE GAUSSLE2 (N, wfout, bpout, XMI, XMA, N0) + SUBROUTINE GAUSSLE2 (N, wfout, bpout, XMI, XMA, N0) USE GLOBALDATA, ONLY : xCutOff,EPSS ! USE QUAD, ONLY : LeBP,LeWF,NLeW,LeIND,minQNr IMPLICIT NONE - INTEGER, INTENT(in) :: N0 + INTEGER, INTENT(in) :: N0 INTEGER, INTENT(inout) :: N - DOUBLE PRECISION, DIMENSION(:), INTENT(out) :: wfout,bpout - DOUBLE PRECISION, INTENT(in) :: XMI,XMA + DOUBLE PRECISION, DIMENSION(:), INTENT(out) :: wfout,bpout + DOUBLE PRECISION, INTENT(in) :: XMI,XMA ! Local variables - DOUBLE PRECISION :: Z1 + DOUBLE PRECISION :: Z1 INTEGER :: J,N1 DOUBLE PRECISION,PARAMETER :: SQTWOPI1 = 0.39894228040143D0 !=1/sqrt(2*pi) ! The subroutine computes Gauss-Legendre ! nodes and weights between ! the (normalized) integration limits XMI and XMA ! This procedure select number of nodes - ! depending on the length of the integration interval. + ! depending on the length of the integration interval. ! Note that the weights are multiplied with ! 1/sqrt(2*pi)*exp(.5*bpout^2) so that ! b @@ -1533,28 +1533,28 @@ ! IF (XMA.LT.XMI+EPSS) THEN ! N=N+1 ! BPout (N) = 0.65d0 * (XMA + XMI) -! Z1 = BPOUT (N) * BPOUT (N) -! WFout (N) = SQTWOPI1 * (XMA - XMI) *EXP ( - 0.5d0* Z1 ) +! Z1 = BPOUT (N) * BPOUT (N) +! WFout (N) = SQTWOPI1 * (XMA - XMI) *EXP ( - 0.5d0* Z1 ) ! RETURN ! ENDIF IF (N0.GT.NLeW) THEN - !PRINT * , 'Warning in GAUSSLE2, quadrature not available' - ENDIF - !print *, 'GAUSSLE2',N0 - - !print *, N + !PRINT * , 'Warning in GAUSSLE2, quadrature not available' + ENDIF + !print *, 'GAUSSLE2',N0 + + !print *, N N1=CEILING(0.5d0*(XMA-XMI)*DBLE(N0)/xCutOff) !0.65d0 N1=MAX(MIN(N1,NLew),minQNr) - - DO J = LeIND(N1)+1, LeIND(N1+1) - + + DO J = LeIND(N1)+1, LeIND(N1+1) + BPout (N+1) = 0.5d0 * (LeBP(J) * (XMA - XMI) + XMA + XMI) Z1 = BPOUT (N+1) * BPOUT (N+1) ! IF (Z1.LE.xCutOff2) THEN N=N+1 ! add a new node and weight - WFout (N) = 0.5d0 * SQTWOPI1 * (XMA - XMI) * - & LeWF(J) *EXP ( - 0.5d0* Z1 ) - ! ENDIF + WFout (N) = 0.5d0 * SQTWOPI1 * (XMA - XMI) * + & LeWF(J) *EXP ( - 0.5d0* Z1 ) + ! ENDIF ENDDO !PRINT * ,'gaussle2, XMI,XMA,N',XMI,XMA,N !print *,BPout @@ -1564,17 +1564,17 @@ SUBROUTINE GAUSSHE0 (N, WFout, BPout, XMI, XMA, N0) ! USE QUAD, ONLY : HeBP,HeWF,HeIND,NHeW IMPLICIT NONE - INTEGER, INTENT(in) :: N0 + INTEGER, INTENT(in) :: N0 INTEGER, INTENT(inout) :: N - DOUBLE PRECISION, DIMENSION(:), INTENT(out) :: wfout,bpout - DOUBLE PRECISION, INTENT(in) :: XMI,XMA + DOUBLE PRECISION, DIMENSION(:), INTENT(out) :: wfout,bpout + DOUBLE PRECISION, INTENT(in) :: XMI,XMA ! Local variables DOUBLE PRECISION, PARAMETER :: SQPI1= 5.6418958354776D-1 !=1/sqrt(pi) DOUBLE PRECISION, PARAMETER :: SQTWO= 1.41421356237310D0 !=sqrt(2) INTEGER :: J ! The subroutine returns modified Gauss-Hermite ! nodes and weights between - ! the integration limits XMI and XMA + ! the integration limits XMI and XMA ! for the chosen number of nodes ! implicitly assuming that the integrand ! goes smoothly towards zero as its approach XMI or XMA @@ -1583,41 +1583,41 @@ ! Inf ! int f(x)*exp(-x^2/2)/sqrt(2*pi)dx=sum f(bp(j))*wf(j) ! -Inf j - - IF (XMA.LE.XMI) THEN - !PRINT * , 'Warning XMIN>=XMAX in GAUSSHE0 !',XMI,XMA + + IF (XMA.LE.XMI) THEN + !PRINT * , 'Warning XMIN>=XMAX in GAUSSHE0 !',XMI,XMA RETURN ! no more nodes added ENDIF - IF (N0.GT.NHeW) THEN + IF (N0.GT.NHeW) THEN !PRINT * , 'error in GAUSSHE0, quadrature not available' - STOP - ENDIF - + STOP + ENDIF + DO J = HeIND(N0)+1, HeIND(N0+1) - BPout (N+1) = HeBP (J) * SQTWO + BPout (N+1) = HeBP (J) * SQTWO IF (BPout (N+1).GT.XMA) THEN RETURN - END IF + END IF IF (BPout (N+1).GE.XMI) THEN N=N+1 ! add the node - WFout (N) = HeWF (J) * SQPI1 + WFout (N) = HeWF (J) * SQPI1 END IF ENDDO - RETURN - END SUBROUTINE GAUSSHE0 + RETURN + END SUBROUTINE GAUSSHE0 SUBROUTINE GAUSSLA0 (N, WFout, BPout, XMI, XMA, N0) USE GLOBALDATA, ONLY : SQPI1 ! USE QUAD, ONLY : LaBP5,LaWF5,LaIND,NLaW IMPLICIT NONE - INTEGER, INTENT(in) :: N0 + INTEGER, INTENT(in) :: N0 INTEGER, INTENT(inout) :: N - DOUBLE PRECISION, DIMENSION(:), INTENT(out) :: wfout,bpout + DOUBLE PRECISION, DIMENSION(:), INTENT(out) :: wfout,bpout DOUBLE PRECISION, INTENT(in) :: XMI, XMA INTEGER :: J ! The subroutine returns modified Gauss-Laguerre ! nodes and weights for alpha=-0.5 between - ! the integration limits XMI and XMA + ! the integration limits XMI and XMA ! for the chosen number of nodes ! implicitly assuming the integrand ! goes smoothly towards zero as its approach XMI or XMA @@ -1626,69 +1626,69 @@ ! Inf ! int f(x)*exp(-x^2/2)/sqrt(2*pi)dx=sum f(bp(j))*wf(j) ! 0 j - - IF (XMA.LE.XMI) THEN - !PRINT * , 'Warning XMIN>=XMAX in GAUSSLA0 !',XMI,XMA + + IF (XMA.LE.XMI) THEN + !PRINT * , 'Warning XMIN>=XMAX in GAUSSLA0 !',XMI,XMA RETURN !no more nodes added ENDIF - IF (N0.GT.NLaW) THEN + IF (N0.GT.NLaW) THEN !PRINT * , 'error in GAUSSLA0, quadrature not available' - STOP - ENDIF - + STOP + ENDIF + DO J = LaIND(N0)+1, LaIND(N0+1) IF (XMA.LE.0.d0) THEN BPout (N+1) = -SQRT(2.d0*LaBP5(J)) ELSE - BPout (N+1) = SQRT(2.d0*LaBP5(J)) + BPout (N+1) = SQRT(2.d0*LaBP5(J)) END IF IF (BPout (N+1).GT.XMA) THEN RETURN - END IF + END IF IF (BPout (N+1).GE.XMI) THEN - N=N+1 ! add the node + N=N+1 ! add the node WFout (N) = LaWF5 (J)*0.5d0*SQPI1 END IF ENDDO !PRINT *,'gaussla0, bp',LaBP5(LaIND(N0)+1:LaIND(N0+1)) !PRINT *,'gaussla0, wf',LaWF5(LaIND(N0)+1:LaIND(N0+1)) - RETURN - END SUBROUTINE GAUSSLA0 + RETURN + END SUBROUTINE GAUSSLA0 - SUBROUTINE GAUSSQ(N, WF, BP, XMI, XMA, N0) + SUBROUTINE GAUSSQ(N, WF, BP, XMI, XMA, N0) USE GLOBALDATA, ONLY : xCutOff ! USE QUAD , ONLY : minQNr IMPLICIT NONE - INTEGER, INTENT(in) :: N0 + INTEGER, INTENT(in) :: N0 INTEGER, INTENT(inout) :: N - DOUBLE PRECISION, DIMENSION(:), INTENT(out) :: wf,bp + DOUBLE PRECISION, DIMENSION(:), INTENT(out) :: wf,bp DOUBLE PRECISION, INTENT(in) :: XMI,XMA INTEGER :: N1 - ! The subroutine returns + ! The subroutine returns ! nodes and weights between - ! the integration limits XMI and XMA + ! the integration limits XMI and XMA ! for the chosen number of nodes ! Note that the nodes and weights are modified ! according to ! Inf ! int f(x)*exp(-x^2/2)/sqrt(2*pi)dx=sum f(bp(j))*wf(j) ! 0 j - - !IF (XMA.LE.XMI) THEN - ! PRINT * , 'Warning XMIN>=XMAX in GAUSSQ !',XMI,XMA + + !IF (XMA.LE.XMI) THEN + ! PRINT * , 'Warning XMIN>=XMAX in GAUSSQ !',XMI,XMA ! RETURN !no more nodes added - !ENDIF - CALL GAUSSLE0(N,WF,BP,XMI,XMA,N0) - RETURN + !ENDIF + CALL GAUSSLE0(N,WF,BP,XMI,XMA,N0) + RETURN IF ((XMA.GE.xCutOff).AND.(XMI.LE.-xCutOff)) THEN - CALL GAUSSHE0(N,WF,BP,XMI,XMA,N0) + CALL GAUSSHE0(N,WF,BP,XMI,XMA,N0) ELSE - CALL GAUSSLE2(N,WF,BP,XMI,XMA,N0) + CALL GAUSSLE2(N,WF,BP,XMI,XMA,N0) RETURN IF (((XMA.LT.xCutOff).AND.(XMI.GT.-xCutOff)).OR.(.TRUE.) - & .OR.(XMI.GT.0.d0).OR.(XMA.LT.0.d0)) THEN + & .OR.(XMI.GT.0.d0).OR.(XMA.LT.0.d0)) THEN ! Grid by Gauss-LegENDre quadrature - CALL GAUSSLE2(N,WF,BP,XMI,XMA,N0) + CALL GAUSSLE2(N,WF,BP,XMI,XMA,N0) ELSE ! this does not work well !PRINT *,'N0',N0,N @@ -1702,7 +1702,7 @@ IF (XMA.GT.0.d0) THEN CALL GAUSSLE2 (N, WF,BP,0.d0,XMA,N0) ENDIF - CALL GAUSSLA0 (N, WF,BP,XMI,0.d0, N1) + CALL GAUSSLA0 (N, WF,BP,XMI,0.d0, N1) END IF END IF ENDIF @@ -1711,12 +1711,12 @@ RETURN END SUBROUTINE GAUSSQ END MODULE QUAD - + MODULE RIND71MOD IMPLICIT NONE PRIVATE PUBLIC :: RIND71, INITDATA, SETDATA,ECHO - + INTERFACE FUNCTION MVNFUN(N,Z) result (VAL) DOUBLE PRECISION,DIMENSION(:), INTENT(IN) :: Z @@ -1731,7 +1731,7 @@ INTEGER, INTENT(IN) :: N DOUBLE PRECISION :: VAL END FUNCTION MVNFUN2 - END INTERFACE + END INTERFACE INTERFACE FUNCTION FI( Z ) RESULT (VALUE) @@ -1746,7 +1746,7 @@ DOUBLE PRECISION :: VALUE END FUNCTION FIINV END INTERFACE - + INTERFACE FUNCTION JACOB(XD,XC) RESULT (VALUE) DOUBLE PRECISION, DIMENSION(:), INTENT(in) :: XD,XC @@ -1769,7 +1769,7 @@ INTERFACE ARGP0 MODULE PROCEDURE ARGP0 END INTERFACE - + INTERFACE RINDDND MODULE PROCEDURE RINDDND END INTERFACE @@ -1781,12 +1781,12 @@ INTERFACE RINDNIT MODULE PROCEDURE RINDNIT END INTERFACE - - INTERFACE BARRIER + + INTERFACE BARRIER MODULE PROCEDURE BARRIER END INTERFACE - INTERFACE echo + INTERFACE echo MODULE PROCEDURE echo END INTERFACE @@ -1805,12 +1805,12 @@ INTERFACE CONDSORT0 MODULE PROCEDURE CONDSORT0 END INTERFACE - + INTERFACE CONDSORT MODULE PROCEDURE CONDSORT END INTERFACE - + INTERFACE CONDSORT2 MODULE PROCEDURE CONDSORT2 END INTERFACE @@ -1824,18 +1824,18 @@ END INTERFACE CONTAINS - SUBROUTINE SETDATA(method,scale, dEPSS,dREPS,dEPS2, - & dNIT,dXc, dNINT,dXSPLT) + SUBROUTINE SETDATA(method,scale, dEPSS,dREPS,dEPS2, + & dNIT,dXc, dNINT,dXSPLT) USE GLOBALDATA USE FIMOD USE QUAD, ONLY: sizNint,Nint1,minQnr,Le2Qnr IMPLICIT NONE - DOUBLE PRECISION , INTENT(in) :: scale, dEPSS,dREPS + DOUBLE PRECISION , INTENT(in) :: scale, dEPSS,dREPS DOUBLE PRECISION , INTENT(in) :: dEPS2,dXc, dXSPLT !INTEGER, DIMENSION(:), INTENT(in) :: dNINT INTEGER, INTENT(in) :: method,dNINT,dNIT INTEGER :: N=1 - + !N=SIZE(dNINT) IF (sizNint.LT.N) THEN !PRINT *,'Error in setdata, Nint too large' @@ -1843,24 +1843,24 @@ ENDIF NINT1(1:N)=dNINT !(1:N) ! quadrature formulae for the Xd variables IF (N.LT.sizNint) THEN - NINT1(N:sizNint)=NINT1(N) - END IF + NINT1(N:sizNint)=NINT1(N) + END IF minQnr = 1 Le2Qnr = NINT1(1) - - SCIS = method + + SCIS = method XcScale = scale RelEps = dREPS - EPSS = dEPSS ! accuracy of integration - CEPSS = 1.d0 - EPSS - EPS2 = dEPS2 ! Constants controlling + EPSS = dEPSS ! accuracy of integration + CEPSS = 1.d0 - EPSS + EPS2 = dEPS2 ! Constants controlling EPS = SQRT(EPS2) - xCutOff = dXc - XSPLT = dXSPLT + xCutOff = dXc + XSPLT = dXSPLT NIT = dNIT - + IF (Nc.LT.1) NUGGET=0.d0 ! Nugget is not needed when Nc=0 - + IF (EPSS.LE.1e-4) NsimMax=2000 IF (EPSS.LE.1e-5) NsimMax=4000 IF (EPSS.LE.1e-6) NsimMax=8000 @@ -1874,30 +1874,30 @@ PRINT *,'SCIS = 1 SADAPT if NDIM<9 otherwise by KRBVRC' CASE (2) PRINT *,'SCIS = 2 SADAPT if NDIM<20 otherwise by KRBVRC' - CASE (3) + CASE (3) PRINT *,'SCIS = 3 KRBVRC (Ndim<101)' CASE (4) PRINT *,'SCIS = 4 KROBOV (Ndim<101)' CASE (5) PRINT *,'SCIS = 5 RCRUDE (Ndim<1001)' - CASE (6) - PRINT *,'SCIS = 6 SOBNIED (Ndim<1041)' - CASE (7:) - PRINT *,'SCIS = 7 DKBVRC (Ndim<1001)' + CASE (6) + PRINT *,'SCIS = 6 SOBNIED (Ndim<1041)' + CASE (7:) + PRINT *,'SCIS = 7 DKBVRC (Ndim<1001)' END SELECT PRINT *,'EPSS = ', EPSS, ' RELEPS = ' ,RELEPS PRINT *,'EPS2 = ',EPS2, ' xCutOff = ',xCutOff PRINT *,'NsimMax = ',NsimMax !,FIINV(EPSS) ENDIF - RETURN + RETURN END SUBROUTINE SETDATA - - SUBROUTINE INITDATA (speed) + + SUBROUTINE INITDATA (speed) USE GLOBALDATA USE FIMOD USE QUAD, ONLY: sizNint,Nint1,minQnr,Le2Qnr IMPLICIT NONE - INTEGER , INTENT(in) :: speed + INTEGER , INTENT(in) :: speed SELECT CASE (speed) CASE (9:) NINT1 (1) = 2 @@ -1906,7 +1906,7 @@ CASE (8) NINT1 (1) = 3 NINT1 (2) = 4 - NINT1 (3) = 5 + NINT1 (3) = 5 CASE (7) NINT1 (1) = 4 NINT1 (2) = 5 @@ -1924,11 +1924,11 @@ NINT1 (2) = 8 ! use quadr. form. No. 7 in integration of Xd(2) NINT1 (3) = 9 ! use quadr. form. No. 8 in integration of Xd(3) CASE (3) - NINT1 (1) = 8 - NINT1 (2) = 9 + NINT1 (1) = 8 + NINT1 (2) = 9 NINT1 (3) = 10 CASE (2) - NINT1 (1) = 9 + NINT1 (1) = 9 NINT1 (2) = 10 NINT1 (3) = 11 CASE (:1) @@ -1936,75 +1936,75 @@ NINT1 (2) = 12 NINT1 (3) = 13 END SELECT - NsimMax=1000*abs(10-min(speed,9)) + NsimMax=1000*abs(10-min(speed,9)) NsimMin=0 SELECT case (speed) CASE (11:) - EPSS = 1d-1 + EPSS = 1d-1 CASE (10) - EPSS = 1d-2 - CASE (7:9) - EPSS = 1d-3 + EPSS = 1d-2 + CASE (7:9) + EPSS = 1d-3 CASE (4:6) EPSS = 1d-4 CASE (:3) - EPSS = 1d-5 - END SELECT - - - EPSS=EPSS*1d-1 - RELEPS = MIN(EPSS ,1.d-2) + EPSS = 1d-5 + END SELECT + + + EPSS=EPSS*1d-1 + RELEPS = MIN(EPSS ,1.d-2) EPS2=EPSS*1.d1 !EPS2*1.d+1 !EPS2=1.d-10 !xCutOff=MIN(MAX(ABS(FIINV(EPSS)),3.5d0),5.d0) !xCutOff=ABS(FIINV(EPSS*1.d-1)) ! this is good xCutOff=ABS(FIINV(EPSS)) - !xCutOff=ABS(FIINV(EPSS*5.d-1)) - if (SCIS.gt.0) then - xCutOff= MIN(MAX(xCutOff+0.5d0,4.d0),5.d0) + !xCutOff=ABS(FIINV(EPSS*5.d-1)) + if (SCIS.gt.0) then + xCutOff= MIN(MAX(xCutOff+0.5d0,4.d0),5.d0) ! This gives approximately the same accuracy as when using RINDDND and RINDNIT - EPSS=EPSS*1.d+2 + EPSS=EPSS*1.d+2 !EPS2=1.d-10 endif NINT1(1:sizNint)=NINT1(3) - Le2Qnr=NINT1(1) + Le2Qnr=NINT1(1) minQnr=1 ! minimum quadrature No. used in GaussLe1,Gaussle2 NUGGET = EPS2*1.d-1 IF (Nc.LT.1) NUGGET=0.d0 ! Nugget is not needed when Nc=0 EPS = SQRT(EPS2) - CEPSS = 1.d0 - EPSS - + CEPSS = 1.d0 - EPSS + ! If SCIS=0 then the absolute error is usually less than EPSS*100 ! otherwise absolute error is less than EPSS return IF (.FALSE.) THEN - print *,'Requested parameters :' - SELECT CASE (SCIS) - CASE (:0) - PRINT *,'NIT = ',NIT,' integration by quadrature' - CASE (1) - PRINT *,'SCIS = 1 SADAPT if NDIM<9 otherwise by KRBVRC' - CASE (2) - PRINT *,'SCIS = 2 SADAPT if NDIM<19 otherwise by KRBVRC' - CASE (3) - PRINT *,'SCIS = 3 KRBVRC (Ndim<101)' - CASE (4) - PRINT *,'SCIS = 4 KROBOV (Ndim<101)' - CASE (5) - PRINT *,'SCIS = 5 RCRUDE (Ndim<1001)' - CASE (6) - PRINT *,'SCIS = 6 SOBNIED (Ndim<1041)' - CASE (7:) - PRINT *,'SCIS = 7 DKBVRC (Ndim<1001)' + print *,'Requested parameters :' + SELECT CASE (SCIS) + CASE (:0) + PRINT *,'NIT = ',NIT,' integration by quadrature' + CASE (1) + PRINT *,'SCIS = 1 SADAPT if NDIM<9 otherwise by KRBVRC' + CASE (2) + PRINT *,'SCIS = 2 SADAPT if NDIM<19 otherwise by KRBVRC' + CASE (3) + PRINT *,'SCIS = 3 KRBVRC (Ndim<101)' + CASE (4) + PRINT *,'SCIS = 4 KROBOV (Ndim<101)' + CASE (5) + PRINT *,'SCIS = 5 RCRUDE (Ndim<1001)' + CASE (6) + PRINT *,'SCIS = 6 SOBNIED (Ndim<1041)' + CASE (7:) + PRINT *,'SCIS = 7 DKBVRC (Ndim<1001)' END SELECT PRINT *,'EPSS = ', EPSS, ' RELEPS = ' ,RELEPS PRINT *,'EPS2 = ',EPS2, ' xCutOff = ',xCutOff PRINT *,'NsimMax = ',NsimMax !,FIINV(EPSS) ENDIF - RETURN + RETURN END SUBROUTINE INITDATA SUBROUTINE ECHO(array) @@ -2025,20 +2025,20 @@ USE GLOBALDATA, ONLY :Nt,Nj,Njj,Nd,Nc,Nx,Ntd,Ntdc,NsXtmj,NsXdj, & indXtd,index1,xedni,SQ,Hlo,Hup,fxcepss,EPS2,XCEPS2,NIT, & SQTWOPI1,xCutOff,SCIS,Ntscis,COVix,EPS, xcScale - IMPLICIT NONE + IMPLICIT NONE DOUBLE PRECISION, DIMENSION(:,:), INTENT(in) :: BIG1 - DOUBLE PRECISION, DIMENSION(:,:), INTENT(in) :: xc1 - DOUBLE PRECISION, DIMENSION(:), INTENT(in) :: Ex - DOUBLE PRECISION, DIMENSION(:), INTENT(out):: fxind - DOUBLE PRECISION, DIMENSION(:,:), INTENT(in) :: Blo, Bup - INTEGER, DIMENSION(:), INTENT(in) :: indI + DOUBLE PRECISION, DIMENSION(:,:), INTENT(in) :: xc1 + DOUBLE PRECISION, DIMENSION(:), INTENT(in) :: Ex + DOUBLE PRECISION, DIMENSION(:), INTENT(out):: fxind + DOUBLE PRECISION, DIMENSION(:,:), INTENT(in) :: Blo, Bup + INTEGER, DIMENSION(:), INTENT(in) :: indI INTEGER, INTENT(IN) :: Nt1 ! local variables INTEGER :: J,ix,Ntdcmj,Nst,Nsd,INFORM - DOUBLE PRECISION :: xind,SQ0,xx,fxc,quant -! IF (.NOT.PRESENT(xcScale)) THEN -! xcScale = 0.0d0 -! ENDIF + DOUBLE PRECISION :: xind,SQ0,xx,fxc,quant +! IF (.NOT.PRESENT(xcScale)) THEN +! xcScale = 0.0d0 +! ENDIF Nt =Nt1 !print *,'rindd SCIS',SCIS Nc = size(xc1,dim=1) @@ -2047,7 +2047,7 @@ IF (Nt+Nc.GT.Ntdc) Nt=Ntdc-Nc ! make sure it does not exceed Ntdc-Nc Nd = Ntdc - Nt - Nc Ntd = Nt + Nd - + !Initialization !Call Initdata(speed) Nj = MIN(Nj,MAX(Nt,0)) ! make sure Nj<=Nt @@ -2055,26 +2055,26 @@ ALLOCATE(xc(1:Nc)) IF (Nd.GT.0) THEN ALLOCATE(xd(1:Nd)) - xd = 0.d0 + xd = 0.d0 END IF If (SCIS.GT.0) then Ntscis=Nt-Nj-Njj - ALLOCATE(SQ(1:Ntd,1:Ntd)) ! Cond. stdev's + ALLOCATE(SQ(1:Ntd,1:Ntd)) ! Cond. stdev's ALLOCATE(NsXtmj(1:Ntd+1)) ! indices to stoch. var. See condsort else Ntscis=0 - ALLOCATE(SQ(1:Ntd,1:max(Njj+Nj+Nd,1)) ) ! Cond. stdev's + ALLOCATE(SQ(1:Ntd,1:max(Njj+Nj+Nd,1)) ) ! Cond. stdev's ALLOCATE(NsXtmj(1:Nd+Nj+Njj+1)) ! indices to stoch. var. See condsort endif ALLOCATE(BIG(Ntdc,Ntdc)) ALLOCATE(Cm(Ntdc),CmN(Ntd)) !Cond. mean which has the same order as local Cm = 0.d0 !covariance matrices (after sorting) or excluding !irrelevant variables. - - ALLOCATE(index1(Ntdc)) ! indices to the var. original place in BIG + + ALLOCATE(index1(Ntdc)) ! indices to the var. original place in BIG index1=(/(J,J=1,Ntdc)/) ! (before sort.) - ALLOCATE(xedni(Ntdc)) ! indices to var. new place (after sorting), + ALLOCATE(xedni(Ntdc)) ! indices to var. new place (after sorting), xedni=index1 ! eg. the point xedni(1) is the original position ! of variable with conditional mean CM(1). ALLOCATE(Hlo(Ntd)) ! lower and upper integration limits are computed @@ -2083,16 +2083,16 @@ Hlo = 0.d0 ! However later on some variables will be exluded ! since those are irrelevant and hence CMnew(1) ! does not to be conditional mean of the same variable - ! as CM(1) is from the beginning. Consequently - ALLOCATE(Hup(Ntd)) ! the order of Hup, Hlo will be unchanged. So we need + ! as CM(1) is from the beginning. Consequently + ALLOCATE(Hup(Ntd)) ! the order of Hup, Hlo will be unchanged. So we need Hup=0.d0 ! to know where the relevant variables bounds are ! This will be given in the subroutines by a vector indS. ALLOCATE(NsXdj(Nd+Nj+1)) ! indices to stoch. var. See condsort NsXdj=0 - ALLOCATE(indXtd(Ntd)) ! indices to Xt and Xd as they are + ALLOCATE(indXtd(Ntd)) ! indices to Xt and Xd as they are indXtd=(/(J,J=1,Ntd)/) ! sorted in Hlo and Hup - + BIG = BIG1(1:Ntdc,1:Ntdc) !conditional covariance matrix BIG @@ -2101,14 +2101,14 @@ !xc = SUM(xc1(1:Nc,1:Nx),DIM=2)/DBLE(Nx) ! average of all xc's xc = xc1(1:Nc,max(Nx/2,1)) ! Or select the one in the middle CALL BARRIER(xc,indI,Blo,Bup) ! compute average integrationlimits - + ! print *,'rindd,xcmean:',xc ! print *,'rindd,Hup:',Hup ! print *,'rindd,Hlo:',Hlo - - CALL CONDSORT0(BIG,Cm,xc,SQ,index1,xedni,NsXtmj,NsXdj,INFORM) - ELSE ! sort by decreasing cond. variance - CALL CONDSORT (BIG,SQ,index1,xedni,NsXtmj,NsXdj,INFORM) + + CALL CONDSORT0(BIG,Cm,xc,SQ,index1,xedni,NsXtmj,NsXdj,INFORM) + ELSE ! sort by decreasing cond. variance + CALL CONDSORT (BIG,SQ,index1,xedni,NsXtmj,NsXdj,INFORM) ENDIF IF (INFORM.GT.0) GOTO 110 !Degenerated case the density can not computed @@ -2123,36 +2123,36 @@ fxind = 0.d0 ! initialize ! Now the loop over all different values of ! variables Xc (the one one is conditioning on) - DO ix = 1, Nx ! is started. The density f_{Xc}(xc(:,ix)) + DO ix = 1, Nx ! is started. The density f_{Xc}(xc(:,ix)) COVix = ix ! will be computed and denoted by fxc. - xind = 0.d0 + xind = 0.d0 fxc = 1.d0 ! Cm = Ex (1:Ntdc) -! index1=(/(J,J=1,Ntdc)/) +! index1=(/(J,J=1,Ntdc)/) ! xedni=index1 -! BIG = BIG1(1:Ntdc,1:Ntdc) -! CALL BARRIER(xc1(1:Nc,ix),indI,Blo,Bup) ! integrationlimits +! BIG = BIG1(1:Ntdc,1:Ntdc) +! CALL BARRIER(xc1(1:Nc,ix),indI,Blo,Bup) ! integrationlimits ! CALL CONDSORT0 (BIG,Cm,xc1(:,ix),SQ, index1, ! & xedni, NsXtmj,NsXdj) - + ! Set the original means of the variables Cm =Ex (index1(1:Ntdc)) ! Cm(1:Ntdc) =Ex (index1(1:Ntdc)) quant = 0.0d0 - DO J = 1, Nc !Recursive conditioning on the last Nc variables + DO J = 1, Nc !Recursive conditioning on the last Nc variables Ntdcmj=Ntdc-J SQ0 = BIG(Ntdcmj+1,Ntdcmj+1) ! SQRT(var(X(i)|X(i+1),X(i+2),...,X(Ntdc))) ! i=Ntdc-J+1 (J=1 var(X(Ntdc)) - + xx = (xc1(index1(Ntdcmj+1)-Ntd,ix)-Cm(Ntdcmj+1))/SQ0 !Trick to calculate - !fxc = fxc*SQTWPI1*EXP(-0.5*(XX**2))/SQ0 + !fxc = fxc*SQTWPI1*EXP(-0.5*(XX**2))/SQ0 quant = quant - 0.5d0 * xx * xx + LOG(SQTWOPI1) - LOG(SQ0) - - ! conditional mean (expectation) - ! E(X(1:i-1)|X(i),X(i+1),...,X(Ntdc)) - Cm(1:Ntdcmj) = Cm(1:Ntdcmj)+xx*BIG (1:Ntdcmj,Ntdcmj+1) - ENDDO -! fxc probability density for i=Ntdc-J+1, + + ! conditional mean (expectation) + ! E(X(1:i-1)|X(i),X(i+1),...,X(Ntdc)) + Cm(1:Ntdcmj) = Cm(1:Ntdcmj)+xx*BIG (1:Ntdcmj,Ntdcmj+1) + ENDDO +! fxc probability density for i=Ntdc-J+1, ! fXc=f(X(i)|X(i+1),X(i+2)...X(Ntdc))* ! f(X(i+1)|X(i+2)...X(Ntdc))*..*f(X(Ntdc)) @@ -2161,21 +2161,21 @@ !PRINT *, 'Rindd, Cm=',Cm(xedni(max(1,Nt-5):Ntdc)) !PRINT *, 'Rindd, Cm=',Cm(xedni(1:Ntdc)) - !IF (fxc .LT.fxcEpss) print *,'small, fxc=',fxc + !IF (fxc .LT.fxcEpss) print *,'small, fxc=',fxc IF (fxc .LT.fxcEpss) GOTO 100 ! Small probability don't bother calculating it - !set the global integration limits Hlo,Hup + !set the global integration limits Hlo,Hup CALL BARRIER(xc1(1:Nc,ix),indI,Blo,Bup) - + Nst = NsXtmj(Ntscis+Njj+Nd+Nj+1) - Nsd = NsXdj(Nd+Nj+1) - IF (any((Cm(Nst+1:Nsd-1) .GT.Hup(Nst+1:Nsd-1)+EPS ).OR. - * (Cm (Nst+1:Nsd-1)+EPS .LT.Hlo (Nst+1:Nsd-1)))) GO TO 100 !degenerate case - !mean of deterministic variable(s) is - ! outside the barriers - + Nsd = NsXdj(Nd+Nj+1) + IF (any((Cm(Nst+1:Nsd-1) .GT.Hup(Nst+1:Nsd-1)+EPS ).OR. + * (Cm (Nst+1:Nsd-1)+EPS .LT.Hlo (Nst+1:Nsd-1)))) GO TO 100 !degenerate case + !mean of deterministic variable(s) is + ! outside the barriers + !PRINT *,'RINDD SCIS',SCIS IF (SCIS.GE.1.AND.SCIS.LE.9) then ! integrate all by SCIS XIND=RINDSCIS(xc1(:,ix)) @@ -2186,33 +2186,33 @@ CASE (:0) IF (SCIS.NE.0) then ! integrate all by SCIS XIND=MNORMPRB(Cm(1:Nst)) - ELSE + ELSE XIND=RINDNIT(BIG,SQ(1:Nst,1),Cm,indXtd(1:Nst),NIT) - END IF + END IF CASE (1:) - xind=RINDDND(BIG,Cm,xd,xc1(:,ix),Nd,Nj) + xind=RINDDND(BIG,Cm,xd,xc1(:,ix),Nd,Nj) END SELECT - 100 fxind(ix)=xind*fxc + 100 fxind(ix)=xind*fxc !IF (fxc .LT.fxcEpss) print *,'small, fxc, xind',fxc,xind !PRINT *, 'Rindd, Cm=',Cm(xedni(1:Ntdc)) ENDDO !ix ! PRINT *, 'Rindd, Cm=',Cm(xedni(1:Ntdc)) 110 CONTINUE - IF (ALLOCATED(xc)) DEALLOCATE(xc) - IF (ALLOCATED(xd)) DEALLOCATE(xd) + IF (ALLOCATED(xc)) DEALLOCATE(xc) + IF (ALLOCATED(xd)) DEALLOCATE(xd) IF (ALLOCATED(SQ)) DEALLOCATE(SQ) IF (ALLOCATED(NsXtmj)) DEALLOCATE(NsXtmj) - IF (ALLOCATED(Cm)) DEALLOCATE(Cm) - IF (ALLOCATED(CmN)) DEALLOCATE(CmN) - IF (ALLOCATED(BIG)) DEALLOCATE(BIG) + IF (ALLOCATED(Cm)) DEALLOCATE(Cm) + IF (ALLOCATED(CmN)) DEALLOCATE(CmN) + IF (ALLOCATED(BIG)) DEALLOCATE(BIG) IF (ALLOCATED(index1)) DEALLOCATE(index1) IF (ALLOCATED(xedni)) DEALLOCATE(xedni) ! print *,'before dealocation',Ntd,size(Hup),size(Hlo) IF (ALLOCATED(Hlo)) DEALLOCATE(Hlo) - IF (ALLOCATED(Hup)) DEALLOCATE(Hup) + IF (ALLOCATED(Hup)) DEALLOCATE(Hup) IF (ALLOCATED(NsXdj)) DEALLOCATE(NsXdj) - IF (ALLOCATED(indXtd)) DEALLOCATE(indXtd) - RETURN + IF (ALLOCATED(indXtd)) DEALLOCATE(indXtd) + RETURN END SUBROUTINE RIND71 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -2248,47 +2248,47 @@ I1 = 1 Plo = 0.d0 Nind = 0 - - DO I = 1,Nstoc,1 + + DO I = 1,Nstoc,1 Xup = xCutOff Xlo =-xCutOff IF (SQ(I).GE.EPS2) THEN Xup = MIN( (Hup (indS(I)) - Cm (I))/ SQ(I),Xup) Xlo = MAX( (Hlo (indS(I)) - Cm (I))/ SQ(I),Xlo) - ELSE + ELSE IF (Hup(indS(I))+EPS.LT.Cm (I)) Xup = Xlo IF (Hlo(indS(I)).GT.Cm (I)+EPS) Xlo = Xup !PRINT *,'argpo',Xlo,Xup - END IF + END IF IF (Xup.LE.Xlo+EPSS) THEN ! +EPSS P0 = 0.d0 Plo = 0.d0 ind(1) = I I0 = 1 Nind = 1 - RETURN + RETURN ENDIF IF ((Xup+EPSS.LT.xCutOff).or.(Xlo+xCutOff.GT.EPSS)) THEN Nind = Nind+1 ind(Nind) = I - ! this procedure calculates + ! this procedure calculates Prb = FI(Xup)-FI(Xlo) Plo = Plo+Prb - IF (Prb.LT.P0) THEN + IF (Prb.LT.P0) THEN I1 = I0 - I0 = Nind - P1 = P0 ! Prob(I0)=Prob(XMA>X(i0)>XMI)= + I0 = Nind + P1 = P0 ! Prob(I0)=Prob(XMA>X(i0)>XMI)= P0 = Prb ! min Prob(Hup(i)> X(i)>Hlo(i)) IF (P0.LT.EPSS) THEN Plo=0.d0 - RETURN + RETURN ENDIF ELSEIF (Prb.LT.P1) THEN I1 = Nind - P1 = Prb + P1 = Prb ENDIF - ENDIF + ENDIF ENDDO Plo = MAX(0.d0,1.d0-DBLE(Nind)+Plo) @@ -2296,13 +2296,13 @@ ! print *,'ARGP0',Nstoc,Nind,P0,Plo,I0,I1,CM(ind(I0)) RETURN END SUBROUTINE ARGP0 - - + + !Ntmj is the number of elements in indicator !since Nj points of process valeus (Nt) have !been moved to the jacobian. -!index1 contains the original +!index1 contains the original !positions of variables in the !covaraince matrix before condsort !and that why if index(Ntmj+1)>Nt @@ -2317,16 +2317,16 @@ ! ******************* RINDDND **************************************** !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - RECURSIVE FUNCTION RINDDND (BIG,Cm,xd,xc,Ndleft,Njleft) - & RESULT (xind) + + RECURSIVE FUNCTION RINDDND (BIG,Cm,xd,xc,Ndleft,Njleft) + & RESULT (xind) USE JACOBMOD USE GLOBALDATA, ONLY :SQPI1, SQTWOPI1,Hup,Hlo,Nt,Nj,Njj,Nd, & NsXtmj,NsXdj,EPS2,NIT,xCutOff,EPSS,CEPSS,index1, & indXtd,SQ,SQTWO,SQTWO1,SCIS,Ntscis,C1C2det,EPS - USE FIMOD + USE FIMOD USE C1C2MOD - USE QUAD + USE QUAD IMPLICIT NONE INTEGER,INTENT(in) :: Ndleft,Njleft ! # DIMENSIONs to integrate DOUBLE PRECISION, DIMENSION(:,:), INTENT(inout) :: BIG @@ -2336,40 +2336,40 @@ !local variables DOUBLE PRECISION :: xind DOUBLE PRECISION :: xind1 - DOUBLE PRECISION, DIMENSION(PMAX) :: WXdi, Xdi !weights/nodes + DOUBLE PRECISION, DIMENSION(PMAX) :: WXdi, Xdi !weights/nodes DOUBLE PRECISION, DIMENSION(: ), ALLOCATABLE :: CmNEW INTEGER :: Nrr, Nr, J, N,Ndleft1,Ndjleft,Ntmj,isXd - INTEGER :: Nst,Nstn,Nsd,NsdN - DOUBLE PRECISION :: SQ0,fxd,XMA,XMI + INTEGER :: Nst,Nstn,Nsd,NsdN + DOUBLE PRECISION :: SQ0,fxd,XMA,XMI Ntmj=Nt-Nj Ndjleft= Ndleft+Njleft N=Ntmj+Ndjleft - + IF (index1(N).GT.Nt) THEN isXd=1 ELSE isXd=0 END IF - XIND = 0.d0 - SQ0 = BIG (N, N) -! index to last stoch. variable of Xt before conditioning on X(N) - Nst = NsXtmj(Ntscis+Njj+Ndjleft+1) + XIND = 0.d0 + SQ0 = BIG (N, N) +! index to last stoch. variable of Xt before conditioning on X(N) + Nst = NsXtmj(Ntscis+Njj+Ndjleft+1) !******************************************************************************** !** Here Starts the degenerated case the remaining variables are deterministic ** !******************************************************************************** - + IF (SQ0.LT.EPS2) THEN !Next is the check for the special situation !that after conditioning on Xc all derivatives are - !singular and not satisfying the limitations - !(so something is generally wrong) + !singular and not satisfying the limitations + !(so something is generally wrong) IF (any((Cm(Nst+1:N).GT.Hup(Nst+1:N)+EPS ).OR. & (Cm(Nst+1:N)+EPS.LT.Hlo(Nst+1:N)))) THEN - RETURN !the mean of Xd or Xt is too extreme - ENDIF + RETURN !the mean of Xd or Xt is too extreme + ENDIF !Here we are putting in all conditional expectations !for the values of the "deterministic" derivatives. IF (Nd.GT.0) THEN @@ -2377,7 +2377,7 @@ DO WHILE (Ndleft1.GT.0) IF (index1(N).GT.Nt) THEN ! isXd xd (Ndleft1) = Cm (N) - Ndleft1=Ndleft1-1 + Ndleft1=Ndleft1-1 END IF N=N-1 ENDDO @@ -2386,7 +2386,7 @@ fxd = 1.d0 ! XIND = FxCutOff??? END IF - XIND=fxd + XIND=fxd IF (Nst.le.0) RETURN IF (SCIS.ne.0) then XIND=fxd*MNORMPRB(Cm(1:Nst)) @@ -2396,30 +2396,30 @@ END IF RETURN ENDIF - + !***** Here Starts the conditioning on the last variable (nondeterministic) * !**************************************************************************** - ! SQ0 = SQ(N,Ntscis+Njj+Ndjleft) !SQRT (SS0) + ! SQ0 = SQ(N,Ntscis+Njj+Ndjleft) !SQRT (SS0) !print *,'RINDD SQO', SQ0,SQ(N,Ntscis+Njj+Ndjleft) !SQ(1:N,Ndjleft) - + XMA=MIN((Hup (indXtd(N))-Cm (N))/SQ0, xCutOff) XMI=MAX((Hlo (indXtd(N))-Cm (N))/SQ0,-xCutOff) ! See if we can narrow down integration range ! index to first stoch. variable of Xd before conditioning on X(N) - Nsd = NsXdj(Ndjleft+1) + Nsd = NsXdj(Ndjleft+1) ! index to last stoch. variable of Xt after cond. on X(N) - NstN = NsXtmj(Ntscis+Njj+Ndjleft) - + NstN = NsXtmj(Ntscis+Njj+Ndjleft) + !PRINT *,xmi,xma ! print *,Ntscis+Njj+Ndjleft ! print *,'CM=',Cm(1:N-1) ! print *,'SQ=', SQ(1:N-1,Ntscis+Njj+Ndjleft) - if (C1C2det) then ! checking only on the variables that becomes deterministic + if (C1C2det) then ! checking only on the variables that becomes deterministic ! index to first stoch. variable of Xd after conditioning on X(N) - NsdN = NsXdj(Ndjleft) + NsdN = NsXdj(Ndjleft) CALL C1C2(XMI,XMA,Cm(Nsd:NsdN-1),BIG(Nsd:NsdN-1,N), & SQ(Nsd:NsdN-1,Ntscis+Njj+Ndjleft),indXtd(Nsd:NsdN-1)) CALL C1C2(XMI,XMA,Cm(NstN+1:Nst),BIG(NstN+1:Nst,N), @@ -2438,62 +2438,62 @@ XIND=0.d0 RETURN ENDIF - Nrr = NINT1 (MIN(Ndjleft,sizNint)) - Nr=0 ! initialize # of nodes + Nrr = NINT1 (MIN(Ndjleft,sizNint)) + Nr=0 ! initialize # of nodes !print *, 'rinddnd Nrr',Nrr !Grid the interval [XMI,XMA] by GAUSS quadr. - CALL GAUSSLE2(Nr, WXdi, Xdi,XMI,XMA, Nrr) + CALL GAUSSLE2(Nr, WXdi, Xdi,XMI,XMA, Nrr) !print *, 'Xdi',Xdi - ALLOCATE(CmNEW(1:N-1)) - ! The following variables are independent of X(N) + ALLOCATE(CmNEW(1:N-1)) + ! The following variables are independent of X(N) ! because BIG(Nst+1:Nsd-1,N) is set to 0 in condsrort. ! Thus the mean is not changed for these variables ! in order to avoid numerical problems ! The following if test is necessary on Solaris F90 compiler. - if (Nst+1.LT.Nsd) CmNEW(Nst+1:Nsd-1)=Cm(Nst+1:Nsd-1) + if (Nst+1.LT.Nsd) CmNEW(Nst+1:Nsd-1)=Cm(Nst+1:Nsd-1) ! print *,Ndjleft,N,NstN+1,Nsd-1 ! print *,BIG(Nst+1:Nsd-1,N) ! print *,'Cm=',Cm(NstN+1:Nsd-1) - DO J = 1, Nr + DO J = 1, Nr ! IF (Wxdi(J).GT.(CFxCutOff)) GO TO 100 !THEN ! EPSS??? IF (isXd.EQ.1) xd (Ndleft) = Xdi (J)*SQ0 + Cm (N) - - ! Here we start with the case when there + + ! Here we start with the case when there ! some derivatives left to integrate. ! The following if test is necessary on Solaris F90 compiler. - if (1.LE.Nst) CmNEW(1:Nst) = Cm(1:Nst)+Xdi(J)*BIG(1:Nst,N) + if (1.LE.Nst) CmNEW(1:Nst) = Cm(1:Nst)+Xdi(J)*BIG(1:Nst,N) if (Nsd.LT.N) CmNEW(Nsd:(N-1)) = Cm(Nsd:(N-1))+ - & Xdi(J)*BIG(Nsd:(N-1),N) + & Xdi(J)*BIG(Nsd:(N-1),N) !print *,'CmNew=',N-1,Ndjleft,CmNew(1:N-1) fxd = Wxdi(J) IF (Ndjleft.GT.1) THEN XIND1=RINDDND(BIG,CmNEW,xd,xc,Ndleft-isXd,Njleft-1+isXd) ELSE ! Here all is conditioned on ! and we wish to compute the - ! conditional probability that + ! conditional probability that ! variables in indicator stays between barriers. XIND1 = 1.d0 - !if there are derivatives we need - !to compute the jacobian, jacob(xd,xc) - IF (Nd.GT.0) fxd = fxd *jacob(xd(1:Nd),xc) - !If there are no derivatives + !if there are derivatives we need + !to compute the jacobian, jacob(xd,xc) + IF (Nd.GT.0) fxd = fxd *jacob(xd(1:Nd),xc) + !If there are no derivatives !then we assume that jacob(xc)=1 - + IF (NstN.LT.1) GOTO 100 !Here there are no points in indicator !left to integrate and hence XIND1=1. - !integrate by Monte Carlo - SCIS + !integrate by Monte Carlo - SCIS IF (SCIS.NE.0) XIND1 = MNORMPRB(CmNEW) - !integrate by quadrature + !integrate by quadrature IF (SCIS.EQ.0) XIND1 = RINDNIT(BIG, & SQ(:,Ntscis+Njj+1),CmNEW,indXtd(1:NstN),NIT) !print *,'jacobian',xind,xind1,xind+fxd*xind1 END IF - 100 CONTINUE + 100 CONTINUE XIND = XIND+XIND1 * fxd !END IF ENDDO - - DEALLOCATE(CmNEW) + + DEALLOCATE(CmNEW) RETURN END FUNCTION RINDDND @@ -2501,18 +2501,18 @@ ! ******************* RINDNIT **************************************** !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! old procedure rind2-6 + ! old procedure rind2-6 RECURSIVE FUNCTION RINDNIT(R,SQ,Cm,indS,NITL) RESULT (xind) USE GLOBALDATA, ONLY : Hlo,Hup,EPS2, EPSS,CEPSS & ,xCutOff,Plowgth,XSPLT - USE FIMOD + USE FIMOD USE C1C2MOD USE QUAD IMPLICIT NONE - DOUBLE PRECISION, DIMENSION(:,:), INTENT(in) :: R + DOUBLE PRECISION, DIMENSION(:,:), INTENT(in) :: R DOUBLE PRECISION, DIMENSION(: ), INTENT(in) :: SQ DOUBLE PRECISION, DIMENSION(: ), INTENT(in) :: Cm - DOUBLE PRECISION :: xind + DOUBLE PRECISION :: xind INTEGER, DIMENSION(: ), INTENT(in) :: indS INTEGER, INTENT(in) :: NITL ! local variables @@ -2527,7 +2527,7 @@ DOUBLE PRECISION, DIMENSION(2) :: XMI, XMA INTEGER, DIMENSION(2) :: INFIN DOUBLE PRECISION :: SGN,P0,Plo,rho - INTEGER :: Ns,Nsnew,row,r1,r2,J,N1 + INTEGER :: Ns,Nsnew,row,r1,r2,J,N1 ! Assumption is that there is at least one variable X in the indicator, ! LNIT nonegative integer. @@ -2545,13 +2545,13 @@ ! the global variables Hlo and Hup ! Ns = size of indS =# of variables in indicator before conditioning ! Nsnew = # of relevant variables in indicator before conditioning -! I0,I1 = indicies to minimum prob. and next minimal, respectively -! ..NEW = the var. above after conditioning on X(I0) or used in recursion +! I0,I1 = indicies to minimum prob. and next minimal, respectively +! ..NEW = the var. above after conditioning on X(I0) or used in recursion ! ind = temp. variable storing indices Ns=SIZE(indS) !=# stochastic variables before conditioning XIND=1.d0 - + if (Ns.lt.1) return ALLOCATE(ind(1:Ns)) @@ -2571,14 +2571,14 @@ ! Now CEPSS>P0>EPSS+Plo and there are more than one relevant variable (NSnew>1) ! Those have indices ind(I0), ind(I1). ! Hence we have nondegenerated case. - + SS0 = R (ind(I0) ,ind(I0)) - SQ0 = SQRT(SS0) + SQ0 = SQRT(SS0) r1=indS(ind(I0)) ! print *,'P0-Plo,SS0,Sq0',P0-Plo,SS0,Sq0 XMA(1) = MIN((Hup (r1)-Cm (ind(I0)))/SQ0,xCutOff) - XMI(1) = MAX((Hlo (r1)-Cm (ind(I0)))/SQ0,-xCutOff) - + XMI(1) = MAX((Hlo (r1)-Cm (ind(I0)))/SQ0,-xCutOff) + !If NSnew = 2 then we can compute the probability exactly and recursion stops. IF ((NSnew.EQ.2).OR.(NITL.LT.1)) THEN !.OR.(NITL.LT.1) ! Not necessary any longer: @@ -2587,21 +2587,21 @@ ! if (I0.eq.I1) print *,'rindnit, I1,I0:',I1,I0 SS1 = R (ind(I1) ,ind(I1)) SQ1 = SQRT(SS1) - + IF (ind(I0).LT.ind(I1)) THEN SS=R(ind(I0),ind(I1)) ELSE SS=R(ind(I1),ind(I0)) ENDIF rho= SS/(SQ0*SQ1) - + r2=indS(ind(I1)) XMA(2) = MIN((Hup (r2)-Cm (ind(I1)))/SQ1,xCutOff) XMI(2) = MAX((Hlo (r2)-Cm (ind(I1)))/SQ1,-xCutOff) IF (ABS(rho).gt.1.d0+EPSS) THEN !print *,'rindnit, Correlation > 1, rho=',rho IF (ABS(rho).gt.1.d0+EPSS) GO TO 300 - rho = sign(1.D0,rho) + rho = sign(1.D0,rho) ! print *,'rindnit, P0,Plo',P0,Plo,XIND ! print *,'rindnit I0,I1:',I0,I1 ! print *,'rindnit XMI,XMA,XMI1,XMA1:',XMI(1),XMA(1), @@ -2617,14 +2617,14 @@ * if INFIN(I) = 0, Ith limits are (-infinity, UPPER(I)]; * if INFIN(I) = 1, Ith limits are [LOWER(I), infinity); * if INFIN(I) = 2, Ith limits are [LOWER(I), UPPER(I)]. -! INFIN = 2 +! INFIN = 2 IF (XMI(1).LE.-xCutOff) INFIN(1)=0 IF (XMI(2).LE.-xCutOff) INFIN(2)=0 IF (XMA(1).GE. xCutOff) INFIN(1)=1 IF (XMA(2).GE. xCutOff) INFIN(2)=1 !print *,'rindnit, xind,xind2=', XIND, BVNMVN(XMI,XMA,INFIN,rho) - XIND = BVNMVN(XMI,XMA,INFIN,rho) + XIND = BVNMVN(XMI,XMA,INFIN,rho) ! print *,xind GOTO 300 END IF @@ -2658,8 +2658,8 @@ ALLOCATE(CMnew(1:NSnew-1)) ALLOCATE(SQnew(1:NSnew-1)) ALLOCATE(B(1:NSnew-1)) - !This DO loop is divided in two parts in order - !to only work on the upper triangular of R + !This DO loop is divided in two parts in order + !to only work on the upper triangular of R DO row=1,I0-1 r1=ind(row) Rnew(row,row:I0-1)=R(r1,ind(row:I0-1)) @@ -2675,19 +2675,19 @@ DO row=I0+1,NSnew ind(row-1)=ind(row) enddo - - + + CMnew=CM(ind(1:NSnew-1)) SQnew=SQ(ind(1:NSnew-1)) indSnew=indS(ind(1:NSnew-1)) - + !USE the XSPLIT variant IF (SGN.LT.0.d0) XIND2 = RINDNIT(Rnew,SQnew,CMnew,indSnew,NITL-1) ! Perform conditioning on X(I0) NSnew=NSnew-1 N1=0 - DO row = 1, NSnew + DO row = 1, NSnew Rnew(row,row:NSnew) = Rnew(row,row:NSnew) - & B(row)*B(row:NSnew) !/SS0) SS = RNEW(row,row) @@ -2698,29 +2698,29 @@ N1=N1+1 ! count number of deterministic variables END IF ENDDO - + !See if we can Narrow down the limits - CALL C1C2(XMI(1),XMA(1),CmNew,B,SQNEW,indSnew) + CALL C1C2(XMI(1),XMA(1),CmNew,B,SQNEW,indSnew) XIND = (FI (XMA(1)) - FI (XMI(1))) - ! if Nsnew<=N1 then PRB = XIND almost always + ! if Nsnew<=N1 then PRB = XIND almost always ! if this check is not performed then ! the numerical integration may currupt the answer due ! to the limited number of nodes used in the integration IF (XIND.LT.EPSS.OR.Nsnew.LT.N1+1) GOTO 200 - - ! print *,'rindnit gaussle2' - N1=0 ! computing nodes for num. integration. - CALL GAUSSLE2 (N1, H1, XX1, XMI(1), XMA(1),LE2Qnr) + + ! print *,'rindnit gaussle2' + N1=0 ! computing nodes for num. integration. + CALL GAUSSLE2 (N1, H1, XX1, XMI(1), XMA(1),LE2Qnr) ! new conditional covariance XIND = 0.d0 -! print *,'rindnit for loop',N1 +! print *,'rindnit for loop',N1 DO J = 1, N1 - !IF (H1(J).GT.CFxCutOff) THEN - CMnew=Cm(ind(1:NSnew)) + XX1(J)*B !/ SQ0) - XIND1=RINDNIT(Rnew,SQnew,CMnew,indSnew,NITL-1) + !IF (H1(J).GT.CFxCutOff) THEN + CMnew=Cm(ind(1:NSnew)) + XX1(J)*B !/ SQ0) + XIND1=RINDNIT(Rnew,SQnew,CMnew,indSnew,NITL-1) XIND = XIND+XIND1 * H1 (J) - !END IF + !END IF ENDDO 200 CONTINUE XIND=XIND2+SGN*XIND @@ -2741,31 +2741,31 @@ if (allocated(SQNEW)) DEALLOCATE(SQNEW) if (allocated(B)) DEALLOCATE(B) if (allocated(ind)) DEALLOCATE(ind) -! print *,'rindnit leaving end' - RETURN +! print *,'rindnit leaving end' + RETURN END FUNCTION RINDNIT - - SUBROUTINE BARRIER(xc,indI,Blo,Bup) + + SUBROUTINE BARRIER(xc,indI,Blo,Bup) USE GLOBALDATA, ONLY : Hup,Hlo,xedni,Ntd,index1 IMPLICIT NONE INTEGER, DIMENSION(: ), INTENT(in) :: indI - DOUBLE PRECISION, DIMENSION(:,:), INTENT(in) :: Blo,Bup + DOUBLE PRECISION, DIMENSION(:,:), INTENT(in) :: Blo,Bup DOUBLE PRECISION, DIMENSION(: ), INTENT(in) :: xc INTEGER :: I, J, K, L INTEGER :: Mb, Nb, NI, Nc -!this procedure set Hlo,Hup according to Blo/Bup +!this procedure set Hlo,Hup according to Blo/Bup Mb=size(Blo,DIM=1) Nb=size(Blo,DIM=2) NI=size(indI,DIM=1) Nc=size(xc,DIM=1) - - DO J = 2, NI - DO I =indI (J - 1) + 1 , indI (J) + + DO J = 2, NI + DO I =indI (J - 1) + 1 , indI (J) L=xedni(I) - Hlo (L) = Blo (1, J - 1) - Hup (L) = Bup (1, J - 1) - DO K = 1, Mb-1 + Hlo (L) = Blo (1, J - 1) + Hup (L) = Bup (1, J - 1) + DO K = 1, Mb-1 Hlo(L) = Hlo(L)+Blo(K+1,J-1)*xc(K) Hup(L) = Hup(L)+Bup(K+1,J-1)*xc(K) ENDDO ! K @@ -2775,18 +2775,18 @@ !print * ,size(Hup),Hup(xedni(1:Ntd)) !print * ,'barrier hlo:' !print * ,size(Hlo),Hlo(xedni(1:Ntd)) - RETURN + RETURN END SUBROUTINE BARRIER function MNORMPRB(Cm1) RESULT (VALUE) USE ADAPTMOD USE KRBVRCMOD USE KROBOVMOD - USE RCRUDEMOD - USE DKBVRCMOD + USE RCRUDEMOD + USE DKBVRCMOD USE SSOBOLMOD USE FUNCMOD - USE FIMOD + USE FIMOD USE C1C2MOD USE GLOBALDATA, ONLY : Hlo,Hup,xCutOff,NUGGET,EPSS,EPS2, & RelEps,NSIMmax,NSIMmin,Nt,Nd,Nj,Ntd,SQ, @@ -2805,10 +2805,10 @@ ! SCIS = Sequential conditioned importance sampling ! LHSCIS = Latin Hypercube Sequential Conditioned Importance Sampling ! -! ! NB!!: R must be conditional sorted by condsort3 +! ! NB!!: R must be conditional sorted by condsort3 ! works on the upper triangular part of R ! -! References +! References ! R. Ambartzumian, A. Der Kiureghian, V. Ohanian and H. ! Sukiasian (1998) ! Probabilistic Engineering Mechanics, Vol. 13, No 4. pp 299-308 @@ -2838,18 +2838,18 @@ if (allocated(COV)) then ! save the coefficient of variation in COV COV(COVix)=0.d0 endif - + VALUE=1.d0 return endif !print *,' mnormprb start calculat' VALUE=0.d0 - Cm(1:Nst-Njj)=Cm1(Njj+1:Nst) ! initialize conditional mean + Cm(1:Nst-Njj)=Cm1(Njj+1:Nst) ! initialize conditional mean SQ0 = SQ(Njj+1,Njj+1) XMA = MIN((Hup (Njj+1)-Cm1(Njj+1))/SQ0,xCutOff) XMI = MAX((Hlo (Njj+1)-Cm1(Njj+1))/SQ0,-xCutOff) - - if (useC1C2) then ! see if we can narrow down sampling range + + if (useC1C2) then ! see if we can narrow down sampling range CALL C1C2(XMI,XMA,Cm1(Njj+2:Nst),BIG(1,2:Nst), & SQ(2:Nst,1),indXtd(2:Nst)) endif @@ -2860,48 +2860,48 @@ MAXPTS = NSIMmax*Ndim MINPTS = NSIMmin*Ndim ABSEPS = EPSS - DEF = 1 ! krbvrc is fastest - SELECT CASE (DEF) - CASE (:1) - !print * ,'RINDSCIS: Ndim',Ndim - IF (NDIM.lt.9) THEN - CALL SADAPT(Ndim,MAXPTS,MVNFUN2,ABSEPS, - & RELEPS,ERROR,VALUE,INFORM) - ELSE - CALL KRBVRC( NDIM, MINPTS, MAXPTS, MVNFUN2, ABSEPS, RELEPS, - & ERROR, VALUE, INFORM ) - ENDIF - CASE (2) - !print * ,'RINDSCIS: Ndim',Ndim - IF (NDIM.lt.19) THEN - ! Call the subregion adaptive integration subroutine - CALL SADAPT(Ndim,MAXPTS,MVNFUN2,ABSEPS, - & RELEPS,ERROR,VALUE,INFORM) - ELSE - CALL KRBVRC( NDIM, MINPTS, MAXPTS, MVNFUN2, ABSEPS, RELEPS, - & ERROR, VALUE, INFORM ) - ENDIF - CASE (3) - CALL KRBVRC( NDIM, MINPTS, MAXPTS, MVNFUN2, ABSEPS, RELEPS, - & ERROR, VALUE, INFORM ) - CASE (4) - CALL KROBOV( NDIM, MINPTS, MAXPTS, MVNFUN2, ABSEPS, RELEPS, - & ERROR, VALUE, INFORM ) - CASE (5) ! Call Crude Monte Carlo integration procedure - CALL RANMC( NDIM, MAXPTS, MVNFUN2, ABSEPS, - & RELEPS, ERROR, VALUE, INFORM ) - CASE (6) ! Call the scrambled Sobol sequence rule integration procedure - CALL SOBNIED( NDIM, MINPTS, MAXPTS, MVNFUN2, ABSEPS, RELEPS, - & ERROR, VALUE, INFORM ) - CASE (7:) - CALL DKBVRC( NDIM, MINPTS, MAXPTS, MVNFUN2, ABSEPS, RELEPS, - & ERROR, VALUE, INFORM ) - END SELECT - + DEF = 1 ! krbvrc is fastest + SELECT CASE (DEF) + CASE (:1) + !print * ,'RINDSCIS: Ndim',Ndim + IF (NDIM.lt.9) THEN + CALL SADAPT(Ndim,MAXPTS,MVNFUN2,ABSEPS, + & RELEPS,ERROR,VALUE,INFORM) + ELSE + CALL KRBVRC( NDIM, MINPTS, MAXPTS, MVNFUN2, ABSEPS, RELEPS, + & ERROR, VALUE, INFORM ) + ENDIF + CASE (2) + !print * ,'RINDSCIS: Ndim',Ndim + IF (NDIM.lt.19) THEN + ! Call the subregion adaptive integration subroutine + CALL SADAPT(Ndim,MAXPTS,MVNFUN2,ABSEPS, + & RELEPS,ERROR,VALUE,INFORM) + ELSE + CALL KRBVRC( NDIM, MINPTS, MAXPTS, MVNFUN2, ABSEPS, RELEPS, + & ERROR, VALUE, INFORM ) + ENDIF + CASE (3) + CALL KRBVRC( NDIM, MINPTS, MAXPTS, MVNFUN2, ABSEPS, RELEPS, + & ERROR, VALUE, INFORM ) + CASE (4) + CALL KROBOV( NDIM, MINPTS, MAXPTS, MVNFUN2, ABSEPS, RELEPS, + & ERROR, VALUE, INFORM ) + CASE (5) ! Call Crude Monte Carlo integration procedure + CALL RANMC( NDIM, MAXPTS, MVNFUN2, ABSEPS, + & RELEPS, ERROR, VALUE, INFORM ) + CASE (6) ! Call the scrambled Sobol sequence rule integration procedure + CALL SOBNIED( NDIM, MINPTS, MAXPTS, MVNFUN2, ABSEPS, RELEPS, + & ERROR, VALUE, INFORM ) + CASE (7:) + CALL DKBVRC( NDIM, MINPTS, MAXPTS, MVNFUN2, ABSEPS, RELEPS, + & ERROR, VALUE, INFORM ) + END SELECT + if (allocated(COV)) then ! save the coefficient of variation in COV if ((VALUE.gt.0.d0)) COV(COVix)=ERROR/VALUE/3.0d0 endif - + !print *,'mnormprb, error, inform,',error,inform !print *,'leaving mnormprb' return @@ -2909,12 +2909,12 @@ FUNCTION RINDSCIS(xc1) result(VALUE) -!RINDSCIS Multivariate Normal integrals by SCIS +!RINDSCIS Multivariate Normal integrals by SCIS ! SCIS = Sequential conditioned importance sampling ! The points can be sampled using Lattice rules, Latin Hypercube samples, -! uniformly distributed, or using an adaptive algorithm -! -! References +! uniformly distributed, or using an adaptive algorithm +! +! References ! R. Ambartzumian, A. Der Kiureghian, V. Ohanian and H. ! Sukiasian (1998) ! Probabilistic Engineering Mechanics, Vol. 13, No 4. pp 299-308 @@ -2925,11 +2925,11 @@ USE ADAPTMOD USE KRBVRCMOD USE KROBOVMOD - USE RCRUDEMOD - USE DKBVRCMOD + USE RCRUDEMOD + USE DKBVRCMOD USE SSOBOLMOD USE FUNCMOD - USE FIMOD + USE FIMOD USE C1C2MOD USE JACOBMOD USE GLOBALDATA, ONLY : Hlo,Hup,xCutOff,NUGGET,EPSS,EPS2, @@ -2943,9 +2943,9 @@ INTEGER :: Ndim,Ndleft,Ntmj,NLHD INTEGER :: MINPTS,MAXPTS, INFORM DOUBLE PRECISION :: ABSEPS, ERROR - + VALUE = 0.d0 - + ! print *,'enter rindscis' Nst = NsXtmj(Ntd+1) Ntmj=Nt-Nj @@ -2956,22 +2956,22 @@ endif Nsd = NsXdj(Nd+Nj+1) Nsd0 = NsXdj(1) - Ndim = Nst0+Ntd-Nsd0+1 ! # dim. we treat stochastically + Ndim = Nst0+Ntd-Nsd0+1 ! # dim. we treat stochastically MAXPTS = NSIMmax*Ndim MINPTS = NSIMmin*Ndim ABSEPS = EPSS - IF (Nc.GT.0) xc=xc1 + IF (Nc.GT.0) xc=xc1 if (Nd+Nj.gt.0) then - IF ( BIG(Ntd,Ntd).LT.EPS2) THEN !degenerate case + IF ( BIG(Ntd,Ntd).LT.EPS2) THEN !degenerate case IF (Nd.GT.0) THEN Ndleft=Nd;K=Ntd DO WHILE (Ndleft.GT.0) IF (index1(K).GT.Nt) THEN ! isXd xd (Ndleft) = Cm (K) - Ndleft=Ndleft-1 + Ndleft=Ndleft-1 END IF K=K-1 ENDDO @@ -2979,12 +2979,12 @@ ELSE VALUE = 1.d0 ! VALUE = FxCutOff??? END IF - !print *,'jacob,xd',VALUE,xd + !print *,'jacob,xd',VALUE,xd IF (Nst.LT.1) then if (allocated(COV)) then ! save the coefficient of variation in COV COV(COVix)=0.d0 endif - RETURN + RETURN endif !print *,'RINDSCIS calling MNORMPRB ' VALUE=VALUE*MNORMPRB(Cm(1:Nst)) @@ -2995,17 +2995,17 @@ if (allocated(COV)) then ! save the coefficient of variation in COV COV(COVix)=0.d0 endif - + VALUE=1.d0 return endif - + if (Nd+Nj.gt.0) then SQ0=SQ(Ntd,Ntd) XMA = MIN((Hup (Ntd)-Cm(Ntd))/SQ0,xCutOff) XMI = MAX((Hlo (Ntd)-Cm(Ntd))/SQ0,-xCutOff) - - if (useC1C2) then ! see if we can narrow down sampling range + + if (useC1C2) then ! see if we can narrow down sampling range CALL C1C2(XMI,XMA,Cm(1:Ntd-1),BIG(1:Ntd-1,Ntd), & SQ(1:Ntd-1,Ntd),indXtd(1:Ntd-1)) endif @@ -3013,13 +3013,13 @@ SQ0=SQ(1,1) XMA = MIN((Hup (1)-Cm(1))/SQ0,xCutOff) XMI = MAX((Hlo (1)-Cm(1))/SQ0,-xCutOff) - - if (useC1C2) then ! see if we can narrow down sampling range + + if (useC1C2) then ! see if we can narrow down sampling range CALL C1C2(XMI,XMA,Cm(2:Nst),BIG(1,2:Nst), & SQ(2:Nst,1),indXtd(2:Nst)) - endif + endif endif - IF (XMA.LE.XMI) return !PQ= Y=0 for all return + IF (XMA.LE.XMI) return !PQ= Y=0 for all return Pl1 = FI(XMI) Pu1 = FI(XMA) IF ( Ndim .GT. 20. AND. SCIS.EQ.3) THEN @@ -3039,30 +3039,30 @@ ENDIF CASE (2) !print * ,'RINDSCIS: Ndim',Ndim - IF (NDIM.lt.19) THEN -! Call the subregion adaptive integration subroutine + IF (NDIM.lt.19) THEN +! Call the subregion adaptive integration subroutine CALL SADAPT(Ndim,MAXPTS,MVNFUN,ABSEPS, & RELEPS,ERROR,VALUE,INFORM) ELSE CALL KRBVRC( NDIM, MINPTS, MAXPTS, MVNFUN, ABSEPS, RELEPS, & ERROR, VALUE, INFORM ) ENDIF - CASE (3) - CALL KRBVRC( NDIM, MINPTS, MAXPTS, MVNFUN, ABSEPS, RELEPS, - & ERROR, VALUE, INFORM ) - CASE (4) - CALL KROBOV( NDIM, MINPTS, MAXPTS, MVNFUN, ABSEPS, RELEPS, + CASE (3) + CALL KRBVRC( NDIM, MINPTS, MAXPTS, MVNFUN, ABSEPS, RELEPS, + & ERROR, VALUE, INFORM ) + CASE (4) + CALL KROBOV( NDIM, MINPTS, MAXPTS, MVNFUN, ABSEPS, RELEPS, & ERROR, VALUE, INFORM ) CASE (5) ! Call Crude Monte Carlo integration procedure - CALL RANMC( NDIM, MAXPTS, MVNFUN, ABSEPS, - & RELEPS, ERROR, VALUE, INFORM ) - CASE (6) ! Call the scrambled Sobol sequence rule integration procedure - CALL SOBNIED( NDIM, MINPTS, MAXPTS, MVNFUN, ABSEPS, RELEPS, - & ERROR, VALUE, INFORM ) - CASE (7:) - CALL DKBVRC( NDIM, MINPTS, MAXPTS, MVNFUN, ABSEPS, RELEPS, - & ERROR, VALUE, INFORM ) - END SELECT + CALL RANMC( NDIM, MAXPTS, MVNFUN, ABSEPS, + & RELEPS, ERROR, VALUE, INFORM ) + CASE (6) ! Call the scrambled Sobol sequence rule integration procedure + CALL SOBNIED( NDIM, MINPTS, MAXPTS, MVNFUN, ABSEPS, RELEPS, + & ERROR, VALUE, INFORM ) + CASE (7:) + CALL DKBVRC( NDIM, MINPTS, MAXPTS, MVNFUN, ABSEPS, RELEPS, + & ERROR, VALUE, INFORM ) + END SELECT if (allocated(COV)) then ! save the coefficient of variation in COV if ((VALUE.gt.0.d0)) COV(COVix)=ERROR/VALUE/3.0d0 endif @@ -3071,7 +3071,7 @@ endif !print *,'rindscis, Ndim,MINPTS, error',Ndim,MINPTS,error END FUNCTION RINDSCIS - + !******************************************************************** SUBROUTINE CONDSORT0 (R,Cm,xcmean,CSTD,index1,xedni,NsXtmj,NsXdj @@ -3082,9 +3082,9 @@ DOUBLE PRECISION, DIMENSION(:,:), INTENT(inout) :: R DOUBLE PRECISION, DIMENSION(: ), INTENT(inout) :: Cm DOUBLE PRECISION, DIMENSION(: ), INTENT(in) :: xcmean - DOUBLE PRECISION, DIMENSION(:,:), INTENT(out) :: CSTD - INTEGER, DIMENSION(: ), INTENT(inout) :: index1 - INTEGER, DIMENSION(: ), INTENT(inout) :: xedni + DOUBLE PRECISION, DIMENSION(:,:), INTENT(out) :: CSTD + INTEGER, DIMENSION(: ), INTENT(inout) :: index1 + INTEGER, DIMENSION(: ), INTENT(inout) :: xedni INTEGER, DIMENSION(: ), INTENT(out) :: NsXtmj INTEGER, DIMENSION(: ), INTENT(out) :: NsXdj INTEGER, INTENT(out) :: INFORM @@ -3097,82 +3097,82 @@ INTEGER :: I0,I1 INTEGER :: Nstoc,Ntmp,NstoXd !,degenerate INTEGER :: changed,m1,r1,c1,r2,c2,ix,iy,Njleft,Ntmj - + ! R = Input: Cov(X) where X=[Xt Xd Xc] is stochastic vector -! Output: sorted Conditional Covar. matrix Shape N X N (N=Nt+Nd+Nc) +! Output: sorted Conditional Covar. matrix Shape N X N (N=Nt+Nd+Nc) ! CSTD = SQRT(Var(X(1:I-1)|X(I:N))) ! conditional standard deviation. Shape Ntd X max(Nd+Nj,1) ! index1 = indices to the variables original place. Size Ntdc ! xedni = indices to the variables new place. Size Ntdc ! NsXtmj(I) = indices to the last stochastic variable -! among Nt-Nj first of Xt after conditioning on +! among Nt-Nj first of Xt after conditioning on ! X(Nt-Nj+I). Size Nd+Nj+Njj+Ntscis+1 ! NsXdj(I) = indices to the first stochastic variable -! among Xd+Nj of Xt after conditioning on +! among Xd+Nj of Xt after conditioning on ! X(Nt-Nj+I). Size Nd+Nj+1 -! +! ! R=Cov([Xt,Xd,Xc]) is a covariance matrix of the stochastic vector X=[Xt Xd Xc] -! where the variables Xt, Xd and Xc have the size Nt, Nd and Nc, respectively. +! where the variables Xt, Xd and Xc have the size Nt, Nd and Nc, respectively. ! Xc is (are) the conditional variable(s). ! Xd and Xt are the variables to integrate. -! Xd + Nj variables of Xt are integrated directly by the RindDXX +! Xd + Nj variables of Xt are integrated directly by the RindDXX ! subroutines in the order of shortest expected integration interval. -! The remaining Nt-Nj variables of Xt are integrated in -! increasing order of the marginal probabilities by the RindXX subroutines. -! CONDSORT prepare and rearrange the covariance matrix +! The remaining Nt-Nj variables of Xt are integrated in +! increasing order of the marginal probabilities by the RindXX subroutines. +! CONDSORT prepare and rearrange the covariance matrix ! in a special way to accomodate this strategy: -! -! After conditioning and sorting, the first Nt-Nj x Nt-Nj block of R +! +! After conditioning and sorting, the first Nt-Nj x Nt-Nj block of R ! will contain the conditional covariance matrix -! of Xt(1:Nt-Nj) given Xt(Nt-Nj+1:Nt) Xd and Xc, i.e., -! Cov(Xt(1:Nt-Nj),Xt(1:Nt-Nj)|Xt(Nt-Nj+1:Nt), Xd,Xc) +! of Xt(1:Nt-Nj) given Xt(Nt-Nj+1:Nt) Xd and Xc, i.e., +! Cov(Xt(1:Nt-Nj),Xt(1:Nt-Nj)|Xt(Nt-Nj+1:Nt), Xd,Xc) ! NB! for Nj>0 the order of Xd and Xt(Nt-Nj+1:Nt) may be mixed. -! The covariances, Cov(X(1:I-1),X(I)|X(I+1:N)), needed for computation of the -! conditional expectation, E(X(1:I-1)|X(I:N), are saved in column I of R +! The covariances, Cov(X(1:I-1),X(I)|X(I+1:N)), needed for computation of the +! conditional expectation, E(X(1:I-1)|X(I:N), are saved in column I of R ! for I=Nt-Nj+1:Ntdc. -! -! IF any of the variables have variance less than EPS2. They will be -! be treated as deterministic and not stochastic variables by the -! RindXXX subroutines. The deterministic variables are moved to -! middle in the order they became deterministic in order to +! +! IF any of the variables have variance less than EPS2. They will be +! be treated as deterministic and not stochastic variables by the +! RindXXX subroutines. The deterministic variables are moved to +! middle in the order they became deterministic in order to ! keep track of them. Their variance and covariance with -! the remaining stochastic variables are set to zero in +! the remaining stochastic variables are set to zero in ! order to avoid numerical difficulties. -! -! NsXtmj(I) is the number of variables among the Nt-Nj -! first we treat stochastically after conditioning on X(Nt-Nj+I). +! +! NsXtmj(I) is the number of variables among the Nt-Nj +! first we treat stochastically after conditioning on X(Nt-Nj+I). ! The covariance matrix is sorted so that all variables with indices ! from 1 to NsXtmj(I) are stochastic after conditioning -! on X(Nt-Nj+I). Thus NsXtmj(I) may also be considered +! on X(Nt-Nj+I). Thus NsXtmj(I) may also be considered ! as the index to the last stochastic variable after conditioning ! on X(Nt-Nj+I). In other words NsXtmj keeps track of the deterministic -! and stochastic variables among the Nt-Nj first variables in each +! and stochastic variables among the Nt-Nj first variables in each ! conditioning step. ! ! Similarly NsXdj(I) keeps track of the deterministic and stochastic ! variables among the Nd+Nj following variables in each conditioning step. ! NsXdj(I) is the index to the first stochastic variable -! among the Nd+Nj following variables after conditioning on X(Nt-Nj+I). +! among the Nd+Nj following variables after conditioning on X(Nt-Nj+I). ! The covariance matrix is sorted so that all variables with indices ! from NsXdj(I+1) to NsXdj(I)-1 are deterministic conditioned on -! X(Nt-Nj+I). +! X(Nt-Nj+I). ! ! Var(Xc(1))>Var(Xc(2)|Xc(1))>...>Var(Xc(Nc)|Xc(1),Xc(2),...,Xc(Nc)). ! If Nj=0 then -! Var(Xd(1)|Xc)>Var(Xd(2)|Xd(1),Xc)>...>Var(Xd(Nd)|Xd(1),Xd(2),...,Xd(Nd),Xc). -! +! Var(Xd(1)|Xc)>Var(Xd(2)|Xd(1),Xc)>...>Var(Xd(Nd)|Xd(1),Xd(2),...,Xd(Nd),Xc). +! ! NB!! Since R is symmetric, only the upper triangular contains the ! sorted conditional covariance. The whole matrix -! is easily obtained by copying elements of the upper triangle to +! is easily obtained by copying elements of the upper triangle to ! the lower or by uncommenting some lines in the end of this subroutine ! ! revised pab 18.04.2000 ! new name rind60 -! New assumption of BIG for the conditional sorted variables: +! New assumption of BIG for the conditional sorted variables: ! BIG(I,I)=sqrt(Var(X(I)|X(I+1)...X(N))=SQI ! BIG(1:I-1,I)=COV(X(1:I-1),X(I)|X(I+1)...X(N))/SQI -! Otherwise +! Otherwise ! BIG(I,I) = Var(X(I)|X(I+1)...X(N) ! BIG(1:I-1,I)=COV(X(1:I-1),X(I)|X(I+1)...X(N)) ! This also affects C1C2: SQ0=sqrt(Var(X(I)|X(I+1)...X(N)) is removed from input @@ -3180,33 +3180,33 @@ ! Using SQ to temporarily store the diagonal of R -! Adding a nugget effect to ensure the the inversion is -! not corrupted by round off errors -! good choice for nugget might be 1e-8 +! Adding a nugget effect to ensure the the inversion is +! not corrupted by round off errors +! good choice for nugget might be 1e-8 !call getdiag(SQ,R) INFORM = 0 ALLOCATE(SQ(1:Ntdc)) ALLOCATE(ind(1:Ntdc)) IF (Nd+Nj+Njj+Ntscis.GT.0) THEN ALLOCATE(CSTD2(1:Ntd,1:Nd+Nj+Njj+Ntscis)) - CSTD2=0.d0 ! initialize CSTD + CSTD2=0.d0 ! initialize CSTD ENDIF !CALL ECHO(R,Ntdc) - DO ix = 1, Ntdc - R(ix,ix) = R(ix,ix)+Nugget + DO ix = 1, Ntdc + R(ix,ix) = R(ix,ix)+Nugget SQ(ix) = R(ix,ix) - index1 (ix) = ix ! initialize index1 + index1 (ix) = ix ! initialize index1 ENDDO - + Ntmj = Nt-Nj Njleft = Nj NstoXd = Ntmj+1 Nstoc = Ntmj - - + + DO ix = 1, Nc ! Condsort Xc r1=Ntdc-ix - m=r1+2-MAXLOC(SQ(r1+1:Ntd+1:-1)) + m=r1+2-MAXLOC(SQ(r1+1:Ntd+1:-1)) IF (SQ(m(1)).LT.XCEPS2) THEN INFORM = 1 !PRINT *,'Condsort0, degenerate Xc' @@ -3219,28 +3219,28 @@ SQ(r1+1) = SQRT(SQ(m(1))) R(index1(1:r1+1),m1) = R(index1(1:r1+1),m1)/SQ(r1+1) R(m1,index1(1:r1)) = R(index1(1:r1),m1) - + ! Calculate the conditional mean Cm(1:r1)=Cm(1:r1)+(xcmean(index1(r1+1)-Ntd)-Cm(r1+1))* & R(index1(1:r1),m1) !/SQ(r1+1) ! sort and calculate conditional covariances CALL CONDSORT2(R,SQ,index1,Nstoc,NstoXd,Njleft,m1,r1) - ENDDO ! ix + ENDDO ! ix ! index to first stochastic variable of Xd and Nj of Xt - NsXdj(Nd+Nj+1) = NstoXd + NsXdj(Nd+Nj+1) = NstoXd ! index to last stochastic variable of Nt-Nj of Xt - NsXtmj(Nd+Nj+Njj+Ntscis+1) = Nstoc + NsXtmj(Nd+Nj+Njj+Ntscis+1) = Nstoc !print *, 'condsort index1', index1 - !print *, 'condsort Xd' + !print *, 'condsort Xd' !call echo(R,Ntdc) - + DO ix = 1, Nd+Nj ! Condsort Xd + Nj of Xt CALL ARGP0(I1,r2,P1,XX,SQRT(SQ(NstoXd:Ntd-ix+1)), & Cm(NstoXd:Ntd-ix+1),index1(NstoXd:Ntd-ix+1),ind,r1) IF (r1.NE.0) I1=ind(I1) m = MIN(NstoXd+I1-1,Ntd-ix+1) IF (Njleft.GT.0) THEN - + CALL ARGP0(I0,r2,P0,XX,SQRT(SQ(1:Nstoc)), & Cm(1:Nstoc),index1(1:Nstoc),ind,r1) IF (r1.NE.0) I0=ind(I0) @@ -3259,7 +3259,7 @@ Njleft=Njleft-1 END IF END IF ! Njleft - IF (SQ(m(1)).LT.EPS2) THEN + IF (SQ(m(1)).LT.EPS2) THEN !PRINT *,'Condsort, degenerate Xd' Ntmp = Nd+Nj+1-ix NsXtmj(Ntscis+Njj+1:Ntmp+Ntscis+Njj+1) = Nstoc @@ -3267,7 +3267,7 @@ IF (ix.EQ.1) THEN DO iy = 1,Ntd !sqrt(VAR(X(I)|X(Ntd-ix+1:Ntdc)) r1 = index1(iy) - CSTD2(r1,Ntscis+Njj+1:Ntmp+Ntscis+Njj)=SQRT(SQ(iy)) + CSTD2(r1,Ntscis+Njj+1:Ntmp+Ntscis+Njj)=SQRT(SQ(iy)) ENDDO ELSE DO iy=ix,Nd+Nj @@ -3285,80 +3285,80 @@ SQ0 = SQRT(SQ(m(1))) SQ(r1+1) = SQ0 CSTD2(m1,Nd+Nj+Ntscis+Njj+1-ix)=SQ0 - + R(index1(1:r1+1),m1) = R(index1(1:r1+1),m1)/SQ0 R(m1,index1(1:r1)) = R(index1(1:r1),m1) - + XMA = MIN( (Hup (index1(r1+1)) - Cm (r1+1))/ SQ0,xCutOff) XMA = MAX(XMA,-xCutOff) - XMI = MAX( (Hlo (index1(r1+1)) - Cm (r1+1))/ SQ0,-xCutOff) + XMI = MAX( (Hlo (index1(r1+1)) - Cm (r1+1))/ SQ0,-xCutOff) XMI = MIN(XMI,xCutOff) ! There is something wrong with XX IF (P1.GT. EPSS ) THEN - ! Calculate the normalized expected mean without the jacobian + ! Calculate the normalized expected mean without the jacobian XX = SQTWOPI1*(EXP(-0.5d0*XMI*XMI)-EXP(-0.5d0*XMA*XMA))/P1 ELSE IF ( XMI .LE. -xCutOff ) XX = XMA IF ( XMA .GE. xCutOff ) XX = XMI IF (XMI.GT.-xCutOff.AND.XMA.LT.xCutOff) XX=(XMI+XMA)*0.5d0 END IF - + ! Calculate the conditional expected mean - Cm(1:r1) = Cm(1:r1)+XX*R(index1(1:r1),m1) + Cm(1:r1) = Cm(1:r1)+XX*R(index1(1:r1),m1) - ! Calculating conditional variances + ! Calculating conditional variances CALL CONDSORT2(R,SQ,index1,Nstoc,NstoXd,Njleft,m1,Ntd-ix) ! saving indices NsXtmj(Nd+Nj+Njj+Ntscis+1-ix)=Nstoc NsXdj(Nd+Nj+1-ix)=NstoXd - + ! Calculating standard deviations non-deterministic variables DO r2=1,Nstoc r1=index1(r2) - CSTD2(r1,Nd+Nj+Njj+Ntscis+1-ix)=SQRT(SQ(r2)) !sqrt(VAR(X(I)|X(Ntd-ix+1:Ntdc)) - ENDDO + CSTD2(r1,Nd+Nj+Njj+Ntscis+1-ix)=SQRT(SQ(r2)) !sqrt(VAR(X(I)|X(Ntd-ix+1:Ntdc)) + ENDDO DO r2=NstoXd,Ntd-ix r1=index1(r2) - CSTD2(r1,Nd+Nj+Ntscis+Njj+1-ix)=SQRT(SQ(r2)) !sqrt(VAR(X(I)|X(Ntd-ix+1:Ntdc)) + CSTD2(r1,Nd+Nj+Ntscis+Njj+1-ix)=SQRT(SQ(r2)) !sqrt(VAR(X(I)|X(Ntd-ix+1:Ntdc)) ENDDO - ENDDO ! ix - - + ENDDO ! ix + + 200 IF ((SCIS.GT.0).OR. (Njj.gt.0)) THEN ! check on Njj instead ! Calculating conditional variances and sort for Nstoc of Xt CALL CONDSORT4(R,Cm,CSTD2,SQ,index1,NsXtmj,Nstoc) !Nst0=Nstoc ENDIF - IF (Nd+Nj+Njj+Ntscis.GT.0) THEN + IF (Nd+Nj+Njj+Ntscis.GT.0) THEN DO r2=1,Ntd ! sorting CSTD according to index1 - r1=index1(r2) + r1=index1(r2) CSTD(r2,:)= CSTD2(r1,:) END DO DEALLOCATE(CSTD2) ELSE - IF (Nc.EQ.0) THEN - ix=1; Nstoc=Ntmj + IF (Nc.EQ.0) THEN + ix=1; Nstoc=Ntmj DO WHILE (ix.LE.Nstoc) IF (SQ(ix).LT.EPS2) THEN DO WHILE ((SQ(Nstoc).LT.EPS2).AND.(ix.LT.Nstoc)) SQ(Nstoc)=0.d0 !MAX(0.d0,SQ(Nstoc)) Nstoc=Nstoc-1 - END DO + END DO CALL swapint(index1(ix),index1(Nstoc)) ! swap indices !CALL swapre(SQ(ix),SQ(Nstoc)) SQ(ix)=SQ(Nstoc);SQ(Nstoc)=0.d0 Nstoc=Nstoc-1 ENDIF ix=ix+1 - END DO + END DO ENDIF CSTD(1:Nt,1)=SQRT(SQ(1:Nt)) NsXtmj(1)=Nstoc - ENDIF + ENDIF - changed=0 - DO r2=Ntdc,1,-1 ! sorting the upper triangular of the + changed=0 + DO r2=Ntdc,1,-1 ! sorting the upper triangular of the r1=index1(r2) ! covariance matrix according to index1 xedni(r1)=r2 !PRINT *,'condsort,xedni',xedni @@ -3374,9 +3374,9 @@ R(r2,c2)=R(r1,c1) END IF END DO - END IF + END IF END DO - ! you may sort the lower triangular according + ! you may sort the lower triangular according ! to index1 also, but it is not needed ! since R is symmetric. Uncomment the ! following if the whole matrix is needed @@ -3398,8 +3398,8 @@ ! PRINT 600, R ! PRINT 600, SQ DEALLOCATE(SQ) - IF (ALLOCATED(ind)) DEALLOCATE(ind) - RETURN + IF (ALLOCATED(ind)) DEALLOCATE(ind) + RETURN END SUBROUTINE CONDSORT0 @@ -3411,7 +3411,7 @@ DOUBLE PRECISION, DIMENSION(:,:), INTENT(inout) :: R,CSTD2 DOUBLE PRECISION, DIMENSION(: ), INTENT(inout) :: Cm DOUBLE PRECISION, DIMENSION(:), INTENT(inout) :: SQ ! diag. of R - INTEGER, DIMENSION(: ), INTENT(inout) :: index1,NsXtmj + INTEGER, DIMENSION(: ), INTENT(inout) :: index1,NsXtmj INTEGER, INTENT(inout) :: Nstoc ! local variables DOUBLE PRECISION :: P0,Plo,XMI,XMA,SQ0,XX @@ -3421,7 +3421,7 @@ INTEGER :: m1 INTEGER :: Nsold INTEGER :: r1,c1,row,col,iy,ix -! This function condsort all the Xt variables for use with RINDSCIS and +! This function condsort all the Xt variables for use with RINDSCIS and ! MNORMPRB !Nsoold=Nstoc @@ -3433,7 +3433,7 @@ IF (r1.NE.0) I0=ind(I0) m = ix-1+max(I0-1,1) ! m=ix-1+MAXLOC(SQ(ix:Nstoc)) - + IF (SQ(m(1)).LT.EPS2) THEN !PRINT *,'Condsort3, error degenerate X' NsXtmj(1:Njj+Ntscis)=0 @@ -3445,38 +3445,38 @@ CALL swapre(SQ(ix),SQ(m(1))) SQ0=SQRT(SQ(ix)) CSTD2(m1,ix)=SQ0 - + R(index1(ix:Nstoc),m1) = R(index1(ix:Nstoc),m1)/SQ0 R(m1,index1(ix+1:Nstoc)) = R(index1(ix+1:Nstoc),m1) CALL swapre(Cm(m(1)),Cm(ix)) - - + + XMA = MIN( (Hup (index1(ix)) - Cm (ix))/ SQ0,xCutOff) - XMI = MAX( (Hlo (index1(ix)) - Cm (ix))/ SQ0,-xCutOff) + XMI = MAX( (Hlo (index1(ix)) - Cm (ix))/ SQ0,-xCutOff) XMA = MAX(XMA,-xCutOff) XMI = MIN(XMI,xCutOff) IF (P0.GT. EPSS ) THEN - ! Calculate the expected mean + ! Calculate the expected mean XX= SQTWOPI1*(EXP(-0.5d0*XMI*XMI)-EXP(-0.5d0*XMA*XMA))/P0 ELSE IF ( XMI .LE. -xCutOff ) XX = XMA IF ( XMA .GE. xCutOff ) XX = XMI IF (XMI.GT.-xCutOff.AND.XMA.LT.xCutOff) XX=(XMI+XMA)*0.5d0 END IF - + ! Calculate the conditional expected mean Cm(ix+1:Nstoc)=Cm(ix+1:Nstoc)+XX* - & R(m1,index1(ix+1:Nstoc)) + & R(m1,index1(ix+1:Nstoc)) - ! Calculating conditional variances for the + ! Calculating conditional variances for the ! first Nstoc variables. - ! variables with variance less than EPS2 - ! will be treated as deterministic and not + ! variables with variance less than EPS2 + ! will be treated as deterministic and not ! stochastic variables and are therefore moved ! to the end among these variables. - ! Nstoc is the # of variables we treat - ! stochastically + ! Nstoc is the # of variables we treat + ! stochastically iy=ix+1;Nsold=Nstoc DO WHILE (iy.LE.Nstoc) r1=index1(iy) @@ -3496,7 +3496,7 @@ Nstoc=Nstoc-1 r1=index1(Nstoc) SQ(Nstoc)=R(r1,r1)-R(r1,m1)*R(m1,r1) !/R(m1,m1) - END DO + END DO CALL swapint(index1(iy),index1(Nstoc)) ! swap indices !CALL swapre(SQ(iy),SQ(Nstoc)) ! swap values SQ(iy)=SQ(Nstoc); @@ -3505,7 +3505,7 @@ Nstoc=Nstoc-1 ENDIF iy=iy+1 - END DO + END DO NsXtmj(ix)=Nstoc ! saving index to last stoch. var. after conditioning ! Calculating Covariances for non-deterministic variables DO row=ix+1,Nstoc @@ -3517,8 +3517,8 @@ R(c1,r1)=R(r1,c1)-R(r1,m1)*R(m1,c1) !/R(m1,m1) R(r1,c1)=R(c1,r1) ENDDO - ENDDO - ! similarly for deterministic values + ENDDO + ! similarly for deterministic values DO row=Nstoc+1,Nsold r1=index1(row) SQ(row) = 0.d0 !MAX(0.d0,SQ(row)) @@ -3540,7 +3540,7 @@ ! PRINT *,'Nstoc,Njj, Ntscis',Nstoc,Njj,Ntscis endif IF (ALLOCATED(ind)) DEALLOCATE(ind) - RETURN + RETURN END SUBROUTINE CONDSORT4 SUBROUTINE CONDSORT (R,CSTD,index1,xedni,NsXtmj,NsXdj,INFORM) @@ -3548,9 +3548,9 @@ & XCEPS2,SCIS,Ntscis IMPLICIT NONE DOUBLE PRECISION, DIMENSION(:,:), INTENT(inout) :: R - DOUBLE PRECISION, DIMENSION(:,:), INTENT(out) :: CSTD - INTEGER, DIMENSION(: ), INTENT(out) :: index1 - INTEGER, DIMENSION(: ), INTENT(out) :: xedni + DOUBLE PRECISION, DIMENSION(:,:), INTENT(out) :: CSTD + INTEGER, DIMENSION(: ), INTENT(out) :: index1 + INTEGER, DIMENSION(: ), INTENT(out) :: xedni INTEGER, DIMENSION(: ), INTENT(out) :: NsXtmj INTEGER, DIMENSION(: ), INTENT(out) :: NsXdj INTEGER, INTENT(out) :: INFORM @@ -3560,83 +3560,83 @@ INTEGER, DIMENSION(1 ) :: m INTEGER :: Nstoc,Ntmp,NstoXd !,degenerate INTEGER :: changed,m1,r1,c1,row,col,ix,iy,Njleft,Ntmj - + ! R = Input: Cov(X) where X=[Xt Xd Xc] is stochastic vector -! Output: sorted Conditional Covar. matrix Shape N X N (N=Nt+Nd+Nc) +! Output: sorted Conditional Covar. matrix Shape N X N (N=Nt+Nd+Nc) ! CSTD = SQRT(Var(X(1:I-1)|X(I:N))) ! conditional standard deviation. Shape Ntd X max(Nd+Nj,1) ! index1 = indices to the variables original place. Size Ntdc ! xedni = indices to the variables new place. Size Ntdc ! NsXtmj(I) = indices to the last stochastic variable -! among Nt-Nj first of Xt after conditioning on +! among Nt-Nj first of Xt after conditioning on ! X(Nt-Nj+I). Size Nd+Nj+Njj+Ntscis+1 ! NsXdj(I) = indices to the first stochastic variable -! among Xd+Nj of Xt after conditioning on +! among Xd+Nj of Xt after conditioning on ! X(Nt-Nj+I). Size Nd+Nj+1 -! +! ! R=Cov([Xt,Xd,Xc]) is a covariance matrix of the stochastic vector X=[Xt Xd Xc] -! where the variables Xt, Xd and Xc have the size Nt, Nd and Nc, respectively. +! where the variables Xt, Xd and Xc have the size Nt, Nd and Nc, respectively. ! Xc is (are) the conditional variable(s). ! Xd and Xt are the variables to integrate. -! Xd + Nj variables of Xt are integrated directly by the RindDXX +! Xd + Nj variables of Xt are integrated directly by the RindDXX ! subroutines in the order of decreasing conditional variance. -! The remaining Nt-Nj variables of Xt are integrated in -! increasing order of the marginal probabilities by the RindXX subroutines. -! CONDSORT prepare and rearrange the covariance matrix +! The remaining Nt-Nj variables of Xt are integrated in +! increasing order of the marginal probabilities by the RindXX subroutines. +! CONDSORT prepare and rearrange the covariance matrix ! by decreasing order of conditional variances in a special way ! to accomodate this strategy: -! -! After conditioning and sorting, the first Nt-Nj x Nt-Nj block of R +! +! After conditioning and sorting, the first Nt-Nj x Nt-Nj block of R ! will contain the conditional covariance matrix -! of Xt(1:Nt-Nj) given Xt(Nt-Nj+1:Nt) Xd and Xc, i.e., -! Cov(Xt(1:Nt-Nj),Xt(1:Nt-Nj)|Xt(Nt-Nj+1:Nt), Xd,Xc) +! of Xt(1:Nt-Nj) given Xt(Nt-Nj+1:Nt) Xd and Xc, i.e., +! Cov(Xt(1:Nt-Nj),Xt(1:Nt-Nj)|Xt(Nt-Nj+1:Nt), Xd,Xc) ! NB! for Nj>0 the order of Xd and Xt(Nt-Nj+1:Nt) may be mixed. -! The covariances, Cov(X(1:I-1),X(I)|X(I+1:N)), needed for computation of the -! conditional expectation, E(X(1:I-1)|X(I:N), are saved in column I of R +! The covariances, Cov(X(1:I-1),X(I)|X(I+1:N)), needed for computation of the +! conditional expectation, E(X(1:I-1)|X(I:N), are saved in column I of R ! for I=Nt-Nj+1:Ntdc. -! -! IF any of the variables have variance less than EPS2. They will be -! be treated as deterministic and not stochastic variables by the -! RindXXX subroutines. The deterministic variables are moved to -! middle in the order they became deterministic in order to +! +! IF any of the variables have variance less than EPS2. They will be +! be treated as deterministic and not stochastic variables by the +! RindXXX subroutines. The deterministic variables are moved to +! middle in the order they became deterministic in order to ! keep track of them. Their variance and covariance with -! the remaining stochastic variables are set to zero in +! the remaining stochastic variables are set to zero in ! order to avoid numerical difficulties. -! -! NsXtmj(I) is the number of variables among the Nt-Nj -! first we treat stochastically after conditioning on X(Nt-Nj+I). +! +! NsXtmj(I) is the number of variables among the Nt-Nj +! first we treat stochastically after conditioning on X(Nt-Nj+I). ! The covariance matrix is sorted so that all variables with indices ! from 1 to NsXtmj(I) are stochastic after conditioning -! on X(Nt-Nj+I). Thus NsXtmj(I) may also be considered +! on X(Nt-Nj+I). Thus NsXtmj(I) may also be considered ! as the index to the last stochastic variable after conditioning ! on X(Nt-Nj+I). In other words NsXtmj keeps track of the deterministic -! and stochastic variables among the Nt-Nj first variables in each +! and stochastic variables among the Nt-Nj first variables in each ! conditioning step. ! ! Similarly NsXdj(I) keeps track of the deterministic and stochastic ! variables among the Nd+Nj following variables in each conditioning step. ! NsXdj(I) is the index to the first stochastic variable -! among the Nd+Nj following variables after conditioning on X(Nt-Nj+I). +! among the Nd+Nj following variables after conditioning on X(Nt-Nj+I). ! The covariance matrix is sorted so that all variables with indices ! from NsXdj(I+1) to NsXdj(I)-1 are deterministic conditioned on -! X(Nt-Nj+I). +! X(Nt-Nj+I). ! ! Var(Xc(1))>Var(Xc(2)|Xc(1))>...>Var(Xc(Nc)|Xc(1),Xc(2),...,Xc(Nc)). ! If Nj=0 then -! Var(Xd(1)|Xc)>Var(Xd(2)|Xd(1),Xc)>...>Var(Xd(Nd)|Xd(1),Xd(2),...,Xd(Nd),Xc). -! +! Var(Xd(1)|Xc)>Var(Xd(2)|Xd(1),Xc)>...>Var(Xd(Nd)|Xd(1),Xd(2),...,Xd(Nd),Xc). +! ! NB!! Since R is symmetric, only the upper triangular contains the ! sorted conditional covariance. The whole matrix -! is easily obtained by copying elements of the upper triangle to +! is easily obtained by copying elements of the upper triangle to ! the lower or by uncommenting some lines in the end of this subroutine ! revised pab 18.04.2000 ! new name rind60 -! New assumption of BIG for the conditional sorted variables: +! New assumption of BIG for the conditional sorted variables: ! BIG(I,I)=sqrt(Var(X(I)|X(I+1)...X(N))=SQI -! BIG(1:I-1,I)=COV(X(1:I-1),X(I)|X(I+1)...X(N))/SQI -! Otherwise +! BIG(1:I-1,I)=COV(X(1:I-1),X(I)|X(I+1)...X(N))/SQI +! Otherwise ! BIG(I,I) = Var(X(I)|X(I+1)...X(N) ! BIG(1:I-1,I)=COV(X(1:I-1),X(I)|X(I+1)...X(N)) ! This also affects C1C2: SQ0=sqrt(Var(X(I)|X(I+1)...X(N)) is removed from input @@ -3645,35 +3645,35 @@ ! Using SQ to temporarily store the diagonal of R -! Adding a nugget effect to ensure the the inversion is -! not corrupted by round off errors -! good choice for nugget might be 1e-8 +! Adding a nugget effect to ensure the the inversion is +! not corrupted by round off errors +! good choice for nugget might be 1e-8 !call getdiag(SQ,R) INFORM = 0 ALLOCATE(SQ(1:Ntdc)) IF (Nd+Nj+Njj+Ntscis.GT.0) THEN ALLOCATE(CSTD2(1:Ntd,1:Nd+Nj+Njj+Ntscis)) - CSTD2=0.d0 ! initialize CSTD + CSTD2=0.d0 ! initialize CSTD ENDIF !CALL ECHO(R,Ntdc) - DO ix = 1, Ntdc - R(ix,ix)=R(ix,ix)+Nugget + DO ix = 1, Ntdc + R(ix,ix)=R(ix,ix)+Nugget SQ(ix)=R(ix,ix) - index1 (ix) = ix ! initialize index1 + index1 (ix) = ix ! initialize index1 ENDDO - + Ntmj=Nt-Nj !NsXtmj(Njj+Nd+Nj+1)=Ntmj ! index to last stochastic variable of Nt-Nj of Xt !NsXdj(Nd+Nj+1)=Ntmj+1 ! index to first stochastic variable of Xd and Nj of Xt !degenerate=0 Njleft=Nj NstoXd=Ntmj+1;Nstoc=Ntmj - - + + DO ix = 1, Nc ! Condsort Xc r1 = Ntdc-ix - m=r1+2-MAXLOC(SQ(r1+1:Ntd+1:-1)) + m=r1+2-MAXLOC(SQ(r1+1:Ntd+1:-1)) IF (SQ(m(1)).LT.XCEPS2) THEN INFORM = 1 !PRINT *,'Condsort, degenerate Xc' @@ -3691,14 +3691,14 @@ R(m1,index1(1:r1)) = R(index1(1:r1),m1) ! sort and calculate conditional covariances CALL CONDSORT2(R,SQ,index1,Nstoc,NstoXd,Njleft,m1,Ntdc-ix) - ENDDO ! ix - + ENDDO ! ix + NsXdj(Nd+Nj+1) = NstoXd ! index to first stochastic variable of Xd and Nj of Xt NsXtmj(Nd+Nj+Njj+Ntscis+1) = Nstoc ! index to last stochastic variable of Nt-Nj of Xt !print *, 'condsort index1', index1 - !print *, 'condsort Xd' + !print *, 'condsort Xd' !call echo(R,Ntdc) - + DO ix = 1, Nd+Nj ! Condsort Xd + Nj of Xt r1 = Ntd-ix IF (Njleft.GT.0) THEN @@ -3714,7 +3714,7 @@ ELSE m=r1+2-MAXLOC(SQ(r1+1:Ntmj+1:-1)) END IF - IF (SQ(m(1)).LT.EPS2) THEN + IF (SQ(m(1)).LT.EPS2) THEN !PRINT *,'Condsort, degenerate Xd' !degenerate=1 Ntmp=Nd+Nj+1-ix @@ -3723,7 +3723,7 @@ IF (ix.EQ.1) THEN DO iy=1,Ntd !sqrt(VAR(X(I)|X(Ntd-ix+1:Ntdc)) r1=index1(iy) - CSTD2(r1,Ntscis+Njj+1:Ntmp+Ntscis+Njj)=SQRT(SQ(iy)) + CSTD2(r1,Ntscis+Njj+1:Ntmp+Ntscis+Njj)=SQRT(SQ(iy)) ENDDO ELSE DO iy=ix,Nd+Nj @@ -3739,28 +3739,28 @@ !CALL swapRe(SQ(Ntd-ix+1),SQ(m(1))) SQ(r1+1) = SQRT(SQ(m(1))) CSTD2(m1,Nd+Nj+Ntscis+Njj+1-ix) = SQ(r1+1) - + R(index1(1:r1+1),m1) = R(index1(1:r1+1),m1)/SQ(r1+1) R(m1,index1(1:r1)) = R(index1(1:r1),m1) - - ! Calculating conditional variances + + ! Calculating conditional variances CALL CONDSORT2(R,SQ,index1,Nstoc,NstoXd,Njleft,m1,Ntd-ix) ! saving indices NsXtmj(Nd+Nj+Njj+Ntscis+1-ix)=Nstoc NsXdj(Nd+Nj+1-ix)=NstoXd - + ! Calculating standard deviations non-deterministic variables DO row=1,NsXtmj(Nd+Nj+Njj+Ntscis+2-ix) !Nstoc r1=index1(row) - CSTD2(r1,Nd+Nj+Njj+Ntscis+1-ix)=SQRT(SQ(row)) !sqrt(VAR(X(I)|X(Ntd-ix+1:Ntdc)) - ENDDO - DO row=NsXdj(Nd+Nj+2-ix),Ntd-ix !NstoXd,Ntd-ix + CSTD2(r1,Nd+Nj+Njj+Ntscis+1-ix)=SQRT(SQ(row)) !sqrt(VAR(X(I)|X(Ntd-ix+1:Ntdc)) + ENDDO + DO row=NsXdj(Nd+Nj+2-ix),Ntd-ix !NstoXd,Ntd-ix r1=index1(row) - CSTD2(r1,Nd+Nj+Ntscis+Njj+1-ix)=SQRT(SQ(row)) !sqrt(VAR(X(I)|X(Ntd-ix+1:Ntdc)) + CSTD2(r1,Nd+Nj+Ntscis+Njj+1-ix)=SQRT(SQ(row)) !sqrt(VAR(X(I)|X(Ntd-ix+1:Ntdc)) ENDDO - ENDDO ! ix - - + ENDDO ! ix + + 200 IF ((SCIS.GT.0).OR. (Njj.gt.0)) THEN ! check on Njj instead ! Calculating conditional variances and sort for Nstoc of Xt CALL CONDSORT3(R,CSTD2,SQ,index1,NsXtmj,Nstoc) @@ -3768,33 +3768,33 @@ ENDIF IF ((Nd+Nj+Njj+Ntscis.GT.0)) THEN DO row=1,Ntd ! sorting CSTD according to index1 - r1=index1(row) + r1=index1(row) CSTD(row,:)= CSTD2(r1,:) END DO DEALLOCATE(CSTD2) - ELSE - IF (Nc.EQ.0) THEN - ix=1; Nstoc=Ntmj + ELSE + IF (Nc.EQ.0) THEN + ix=1; Nstoc=Ntmj DO WHILE (ix.LE.Nstoc) IF (SQ(ix).LT.EPS2) THEN DO WHILE ((SQ(Nstoc).LT.EPS2).AND.(ix.LT.Nstoc)) SQ(Nstoc)=0.d0 !max(0.d0,SQ(Nstoc)) Nstoc=Nstoc-1 - END DO + END DO CALL swapint(index1(ix),index1(Nstoc)) ! swap indices !CALL swapRe(SQ(ix),SQ(Nstoc)) SQ(ix)=SQ(Nstoc);SQ(Nstoc)=0.d0 Nstoc=Nstoc-1 ENDIF ix=ix+1 - END DO + END DO ENDIF CSTD(1:Nt,1)=SQRT(SQ(1:Nt)) NsXtmj(1)=Nstoc - ENDIF + ENDIF - changed=0 - DO row=Ntdc,1,-1 ! sorting the upper triangular of the + changed=0 + DO row=Ntdc,1,-1 ! sorting the upper triangular of the r1=index1(row) ! covariance matrix according to index1 xedni(r1)=row !PRINT *,'condsort,xedni',xedni @@ -3810,9 +3810,9 @@ R(row,col)=R(r1,c1) END IF END DO - END IF + END IF END DO - ! you may sort the lower triangular according + ! you may sort the lower triangular according ! to index1 also, but it is not needed ! since R is symmetric. Uncomment the ! following if the whole matrix is needed @@ -3834,7 +3834,7 @@ ! PRINT 600, R ! PRINT 600, SQ DEALLOCATE(SQ) - + RETURN END SUBROUTINE CONDSORT @@ -3843,8 +3843,8 @@ USE GLOBALDATA, ONLY : Ntd,EPS2,XCEPS2 IMPLICIT NONE DOUBLE PRECISION, DIMENSION(:,:), INTENT(inout) :: R - DOUBLE PRECISION, DIMENSION(:), INTENT(inout) :: SQ - INTEGER, DIMENSION(: ), INTENT(inout) :: index1 + DOUBLE PRECISION, DIMENSION(:), INTENT(inout) :: SQ + INTEGER, DIMENSION(: ), INTENT(inout) :: index1 INTEGER, INTENT(inout) :: Nstoc,NstoXd,Njleft INTEGER, INTENT(in) :: m1,N ! local variables @@ -3854,12 +3854,12 @@ ! save their old values Nsold=Nstoc;Ndold=NstoXd - ! Calculating conditional variances for the - ! Xc variables. + ! Calculating conditional variances for the + ! Xc variables. DO row=Ntd+1,N r1 = index1(row) SQ(row) = R(r1,r1)-R(r1,m1)*R(m1,r1) !/R(m1,m1) - IF (SQ(row).LT.XCEPS2) THEN + IF (SQ(row).LT.XCEPS2) THEN IF (SQ(row).LT.-XCEPS2) THEN !print *, 'Condsort2,Error: Covariance negative definit' ENDIF @@ -3875,14 +3875,14 @@ R(r1,c1) = R(c1,r1) ENDDO ENDIF - ENDDO ! Calculating conditional variances for the + ENDDO ! Calculating conditional variances for the ! first Nstoc variables. - ! variables with variance less than EPS2 - ! will be treated as deterministic and not + ! variables with variance less than EPS2 + ! will be treated as deterministic and not ! stochastic variables and are therefore moved ! to the end among these Nt-Nj first variables. - ! Nstoc is the # of variables we treat - ! stochastically + ! Nstoc is the # of variables we treat + ! stochastically iy=1 DO WHILE (iy.LE.Nstoc) r1=index1(iy) @@ -3893,7 +3893,7 @@ ENDIF r1=index1(Nstoc) SQ(Nstoc)=R(r1,r1)-R(r1,m1)*R(m1,r1) !/R(m1,m1) - + DO WHILE ((SQ(Nstoc).LT.EPS2).AND.(iy.LT.Nstoc)) IF (SQ(Nstoc).LT.-EPS2) THEN !print *, 'Condsort2,Error: Covariance negative definit' @@ -3902,21 +3902,21 @@ Nstoc=Nstoc-1 r1=index1(Nstoc) SQ(Nstoc)=R(r1,r1)-R(r1,m1)*R(m1,r1) !/R(m1,m1) - END DO + END DO CALL swapint(index1(iy),index1(Nstoc)) ! swap indices !CALL swapre(SQ(iy),SQ(Nstoc)) ! swap values SQ(iy)=SQ(Nstoc);SQ(Nstoc)=0.d0 Nstoc=Nstoc-1 ENDIF iy=iy+1 - END DO - - ! Calculating conditional variances for the - ! stochastic variables Xd and Njleft of Xt. + END DO + + ! Calculating conditional variances for the + ! stochastic variables Xd and Njleft of Xt. ! Variables with conditional variance less than ! EPS2 are moved to the beginning among these ! with only One exception: if it is one of the - ! Xt variables and Nstoc>0 then it switch place + ! Xt variables and Nstoc>0 then it switch place ! with Xt(Nstoc) DO iy=Ndold,MIN(Ntd,N) @@ -3924,7 +3924,7 @@ SQ(iy)=R(r1,r1)-R(r1,m1)*R(m1,r1) !/R(m1,m1) IF (SQ(iy).LT.EPS2) THEN IF (Njleft.GT.0) THEN - Ntmp=NstoXd+Njleft + Ntmp=NstoXd+Njleft IF (iy.LT.Ntmp) THEN IF (Nstoc.GT.0) THEN !switch place with Xt(Nstoc) CALL swapint(index1(iy),index1(Nstoc)) @@ -3941,7 +3941,7 @@ ELSE CALL swapint(index1(iy),index1(Ntmp)) CALL swapint(index1(Ntmp),index1(NstoXd)) - !CALL swapre(SQ(iy),SQ(Ntmp)) + !CALL swapre(SQ(iy),SQ(Ntmp)) !CALL swapre(SQ(Ntmp),SQ(NstoXd)) SQ(iy)=SQ(Ntmp);SQ(Ntmp)=SQ(NstoXd) SQ(NstoXd)=0.d0 @@ -3955,8 +3955,8 @@ ENDIF ENDIF ! SQ < EPS2 ENDDO - - + + ! Calculating Covariances for non-deterministic variables DO row=1,Nstoc r1=index1(row) @@ -3971,21 +3971,21 @@ R(c1,r1)=R(r1,c1)-R(r1,m1)*R(m1,c1) !/R(m1,m1) R(r1,c1)=R(c1,r1) ENDDO - ENDDO + ENDDO DO row=NstoXd,MIN(Ntd,N) r1=index1(row) R(r1,r1)=SQ(row) - + DO col=row+1,N c1=index1(col) R(c1,r1)=R(r1,c1)-R(r1,m1)*R(m1,c1) !/R(m1,m1) R(r1,c1)=R(c1,r1) ENDDO ENDDO - + ! Set covariances for Deterministic variables to zero ! in order to avoid numerical problems - + DO row=Ndold,NStoXd-1 r1=index1(row) SQ(row) = 0.d0 !MAX(SQ(row),0.d0) @@ -4001,7 +4001,7 @@ R(r1,c1)=0.d0 ENDDO ENDDO - + DO row=Nstoc+1,Nsold r1=index1(row) SQ(row) = 0.d0 !MAX(SQ(row),0.d0) @@ -4017,7 +4017,7 @@ R(r1,c1)=0.d0 ENDDO ENDDO - RETURN + RETURN END SUBROUTINE CONDSORT2 SUBROUTINE CONDSORT3(R,CSTD2,SQ,index1,NsXtmj,Nstoc) @@ -4025,21 +4025,21 @@ IMPLICIT NONE DOUBLE PRECISION, DIMENSION(:,:), INTENT(inout) :: R,CSTD2 DOUBLE PRECISION, DIMENSION(:), INTENT(inout) :: SQ ! diag. of R - INTEGER, DIMENSION(: ), INTENT(inout) :: index1,NsXtmj + INTEGER, DIMENSION(: ), INTENT(inout) :: index1,NsXtmj INTEGER, DIMENSION(1) :: m INTEGER, INTENT(inout) :: Nstoc ! local variables INTEGER :: m1 INTEGER :: Nsold INTEGER :: r1,c1,row,col,iy,ix -! This function condsort all the Xt variables for use with RINDSCIS and +! This function condsort all the Xt variables for use with RINDSCIS and ! MNORMPRB !Nsoold=Nstoc ix=1 - + DO WHILE ((ix.LE.Nstoc).and.(ix.LE.(Ntscis+Njj))) - m=ix-1+MAXLOC(SQ(ix:Nstoc)) + m=ix-1+MAXLOC(SQ(ix:Nstoc)) IF (SQ(m(1)).LT.EPS2) THEN !PRINT *,'Condsort3, error degenerate X' NsXtmj(1:Njj+Ntscis)=0 @@ -4050,17 +4050,17 @@ CALL swapint(index1(m(1)),index1(ix)) SQ(ix) = SQRT(SQ(m(1))) CSTD2(m1,ix) = SQ(ix) - + R(index1(ix:Nstoc),m1) = R(index1(ix:Nstoc),m1)/SQ(ix) R(m1,index1(ix+1:Nstoc)) = R(index1(ix+1:Nstoc),m1) - ! Calculating conditional variances for the + ! Calculating conditional variances for the ! first Nstoc variables. - ! variables with variance less than EPS2 - ! will be treated as deterministic and not + ! variables with variance less than EPS2 + ! will be treated as deterministic and not ! stochastic variables and are therefore moved ! to the end among these variables. - ! Nstoc is the # of variables we treat - ! stochastically + ! Nstoc is the # of variables we treat + ! stochastically iy=ix+1;Nsold=Nstoc DO WHILE (iy.LE.Nstoc) r1=index1(iy) @@ -4079,14 +4079,14 @@ Nstoc=Nstoc-1 r1=index1(Nstoc) SQ(Nstoc)=R(r1,r1)-R(r1,m1)*R(m1,r1) !/R(m1,m1) - END DO + END DO CALL swapint(index1(iy),index1(Nstoc)) ! swap indices !CALL swapre(SQ(iy),SQ(Nstoc)) ! SQ(iy)=SQ(Nstoc); SQ(Nstoc)=0.d0 ! swap values Nstoc=Nstoc-1 ENDIF iy=iy+1 - END DO + END DO NsXtmj(ix)=Nstoc ! saving index to last stoch. var. after conditioning ! Calculating Covariances for non-deterministic variables DO row=ix+1,Nstoc @@ -4098,8 +4098,8 @@ R(c1,r1)=R(r1,c1)-R(r1,m1)*R(m1,c1) !/R(m1,m1) R(r1,c1)=R(c1,r1) ENDDO - ENDDO - ! similarly for deterministic values + ENDDO + ! similarly for deterministic values DO row=Nstoc+1,Nsold r1=index1(row) SQ(row)=0.d0 !MAX(SQ(row),0.d0) @@ -4113,32 +4113,32 @@ ix=ix+1 ENDDO NsXtmj(Nstoc+1:Njj+Ntscis)=Nstoc - RETURN + RETURN END SUBROUTINE CONDSORT3 SUBROUTINE swapRe(m,n) IMPLICIT NONE DOUBLE PRECISION, INTENT(inout) :: m,n - DOUBLE PRECISION :: tmp + DOUBLE PRECISION :: tmp tmp=m m=n n=tmp END SUBROUTINE swapRe - + SUBROUTINE swapint(m,n) IMPLICIT NONE INTEGER, INTENT(inout) :: m,n - INTEGER :: tmp + INTEGER :: tmp tmp=m m=n n=tmp END SUBROUTINE swapint - + SUBROUTINE getdiag(diag,matrix) IMPLICIT NONE DOUBLE PRECISION, DIMENSION(: ), INTENT(out) :: diag DOUBLE PRECISION, DIMENSION(:,:), INTENT(in) :: matrix - DOUBLE PRECISION, DIMENSION(: ), ALLOCATABLE :: vector + DOUBLE PRECISION, DIMENSION(: ), ALLOCATABLE :: vector ALLOCATE(vector(SIZE(matrix))) vector=PACK(matrix,.TRUE.) @@ -4146,7 +4146,7 @@ DEALLOCATE(vector) END SUBROUTINE getdiag - END MODULE RIND71MOD + END MODULE RIND71MOD diff --git a/pywafo/src/wafo/source/rind2007/rind_interface.f b/wafo/source/rind2007/rind_interface.f similarity index 91% rename from pywafo/src/wafo/source/rind2007/rind_interface.f rename to wafo/source/rind2007/rind_interface.f index a8960c9..6723520 100644 --- a/pywafo/src/wafo/source/rind2007/rind_interface.f +++ b/wafo/source/rind2007/rind_interface.f @@ -1,7 +1,7 @@ ! This is a interface-file for Python ! This file contains a interface to RIND a subroutine ! for computing multivariate normal expectations. -! The file is self contained and should compile without errors on (Fortran90) +! The file is self contained and should compile without errors on (Fortran90) ! standard Fortran compilers. ! ! The interface was written by @@ -12,40 +12,40 @@ ! Norway ! Email: Per.Brodtkorb@ffi.no ! -! +! ! RIND Computes multivariate normal expectations ! -! E[Jacobian*Indicator|Condition ]*f_{Xc}(xc(:,ix)) +! E[Jacobian*Indicator|Condition ]*f_{Xc}(xc(:,ix)) ! where ! "Indicator" = I{ H_lo(i) < X(i) < H_up(i), i=1:N_t+N_d } -! "Jacobian" = J(X(Nt+1),...,X(Nt+Nd+Nc)), special case is +! "Jacobian" = J(X(Nt+1),...,X(Nt+Nd+Nc)), special case is ! "Jacobian" = |X(Nt+1)*...*X(Nt+Nd)|=|Xd(1)*Xd(2)..Xd(Nd)| ! "condition" = Xc=xc(:,ix), ix=1,...,Nx. -! X = [Xt; Xd; Xc], a stochastic vector of Multivariate Gaussian +! X = [Xt; Xd; Xc], a stochastic vector of Multivariate Gaussian ! variables where Xt,Xd and Xc have the length Nt, Nd and Nc, -! respectively. (Recommended limitations Nx,Nt<=100, Nd<=6 and Nc<=10) -! +! respectively. (Recommended limitations Nx,Nt<=100, Nd<=6 and Nc<=10) +! ! CALL: [value,error,terror,inform]=rind(S,m,indI,Blo,Bup,INFIN,xc, ! Nt,SCIS,XcScale,ABSEPS,RELEPS,COVEPS,MAXPTS,MINPTS,seed,NIT,xCutOff,Nc1c2); ! ! ! VALUE = estimated value for the expectation as explained above size 1 x Nx -! ERROR = estimated sampling error, with 99% confidence level. size 1 x Nx +! ERROR = estimated sampling error, with 99% confidence level. size 1 x Nx ! TERROR = estimated truncation error ! INFORM = INTEGER, termination status parameter: (not implemented yet) ! if INFORM = 0, normal completion with ERROR < EPS; -! if INFORM = 1, completion with ERROR > EPS and MAXPTS -! function vaules used; increase MAXPTS to +! if INFORM = 1, completion with ERROR > EPS and MAXPTS +! function vaules used; increase MAXPTS to ! decrease ERROR; ! if INFORM = 2, N > 100 or N < 1. -! +! ! S = Covariance matrix of X=[Xt;Xd;Xc] size Ntdc x Ntdc (Ntdc=Nt+Nd+Nc) ! m = the expectation of X=[Xt;Xd;Xc] size N x 1 -! indI = vector of indices to the different barriers in the -! indicator function, length NI, where NI = Nb+1 +! indI = vector of indices to the different barriers in the +! indicator function, length NI, where NI = Nb+1 ! (NB! restriction indI(1)=0, indI(NI)=Nt+Nd ) -! B_lo,B_up = Lower and upper barriers used to compute the integration -! limits, Hlo and Hup, respectively. size Mb x Nb +! B_lo,B_up = Lower and upper barriers used to compute the integration +! limits, Hlo and Hup, respectively. size Mb x Nb ! INFIN = INTEGER, array of integration limits flags: size 1 x Nb (in) ! if INFIN(I) < 0, Ith limits are (-infinity, infinity); ! if INFIN(I) = 0, Ith limits are (-infinity, Hup(I)]; @@ -54,7 +54,7 @@ ! xc = values to condition on size Nc x Nx ! Nt = size of Xt ! SCIS = Integer defining integration method -! 1 Integrate all by SADAPT for Ndim<9 and by KRBVRC otherwise +! 1 Integrate all by SADAPT for Ndim<9 and by KRBVRC otherwise ! 2 Integrate all by SADAPT by Genz (1992) (Fast) ! 3 Integrate all by KRBVRC by Genz (1993) (Fast) ! 4 Integrate all by KROBOV by Genz (1992) (Fast) @@ -64,23 +64,23 @@ ! ABSEPS = REAL absolute error tolerance. ! RELEPS = REAL relative error tolerance. ! COVEPS = REAL error in cholesky factorization -! MAXPTS = INTEGER, maximum number of function values allowed. This -! parameter can be used to limit the time. A sensible +! MAXPTS = INTEGER, maximum number of function values allowed. This +! parameter can be used to limit the time. A sensible ! strategy is to start with MAXPTS = 1000*N, and then ! increase MAXPTS if ERROR is too large. ! MINPTS = INTEGER, minimum number of function values allowed ! SEED = INTEGER, seed to the random generator used in the integrations ! NIT = INTEGER, maximum number of Xt variables to integrate -! xCutOff = REAL upper/lower truncation limit of the marginal normal CDF -! Nc1c2 = INTEGER number of times to use the regression equation to restrict -! integration area. Nc1c2 = 1,2 is recommended. +! xCutOff = REAL upper/lower truncation limit of the marginal normal CDF +! Nc1c2 = INTEGER number of times to use the regression equation to restrict +! integration area. Nc1c2 = 1,2 is recommended. +! ! -! ! If Mb=0, -! IF INFIN(j)~=0, Hlo(i)=Blo(1,j)+Blo(2:Mb,j).'*xc(1:Mb-1,ix), -! IF INFIN(j)~=1, Hup(i)=Bup(1,j)+Bup(2:Mb,j).'*xc(1:Mb-1,ix), +! IF INFIN(j)~=0, Hlo(i)=Blo(1,j)+Blo(2:Mb,j).'*xc(1:Mb-1,ix), +! IF INFIN(j)~=1, Hup(i)=Bup(1,j)+Bup(2:Mb,j).'*xc(1:Mb-1,ix), ! ! where i=indI(j-1)+1:indI(j), j=2:NI, ix=1:Nx ! @@ -105,118 +105,118 @@ !set LIB=%DFDir%\LIB;%VCDir%\LIB ! ! then you are ready to compile this file at the matlab prompt using the following command: -! -! mex -O -output mexrind2007 intmodule.f jacobmod.f rind2007.f mexrind2007.f -! - - - subroutine set_constants(method,xcscale,abseps,releps,coveps, - & maxpts,minpts,nit,xcutoff,Nc1c2, NINT1, xsplit) - use rindmod, only : setconstants - use rind71mod, only : setdata - double precision :: xcscale,abseps,releps,coveps,xcutoff,xsplit - integer method, maxpts, minpts, nit, Nc1c2, NINT1 -Cf2py double precision, optional :: xcscale = 0.0e0 -Cf2py double precision, optional :: abseps = 0.01e0 -Cf2py double precision, optional :: releps = 0.01e0 -Cf2py double precision, optional :: coveps = 1.0e-10 -Cf2py double precision, optional :: xcutoff = 5.0e0 -Cf2py double precision, optional :: xsplit = 5.0e0 - -Cf2py integer, optional :: method = 3 -Cf2py integer, optional :: minpts = 0 -Cf2py integer, optional :: maxpts = 40000 -Cf2py integer, optional :: nit = 1000 -Cf2py integer, optional :: Nc1c2 = 2 -Cf2py integer, optional :: nint1 = 2 - -! Method>0 - call setconstants(method,xcscale,abseps,releps,coveps, - & maxpts,minpts,nit,xcutoff,Nc1c2) -! method==0 - call SETDATA(method,xcscale,abseps,releps,coveps, - & nit, xCutOff,NINT1,xsplit) - return - end subroutine set_constants - SUBROUTINE show_constants() - use rindmod - print *, 'method=', mMethod - print *, 'xcscale=', mXcScale - print *, 'abseps=', mAbsEps - print *, 'releps=', mRelEps - print *, 'coveps=', mCovEps - print *, 'maxpts=', mMaxPts - print *, 'minpts=', mMinPts - print *, 'nit=', mNit - print *, 'xcutOff=', mXcutOff - print *, 'Nc1c2=', mNc1c2 - end subroutine show_constants +! +! mex -O -output mexrind2007 intmodule.f jacobmod.f rind2007.f mexrind2007.f +! + - SUBROUTINE rind(VALS,ERR,TERR,Big,Ex,Xc,Nt,INDI,Blo,Bup, + subroutine set_constants(method,xcscale,abseps,releps,coveps, + & maxpts,minpts,nit,xcutoff,Nc1c2, NINT1, xsplit) + use rindmod, only : setconstants + use rind71mod, only : setdata + double precision :: xcscale,abseps,releps,coveps,xcutoff,xsplit + integer method, maxpts, minpts, nit, Nc1c2, NINT1 +Cf2py double precision, optional :: xcscale = 0.0e0 +Cf2py double precision, optional :: abseps = 0.01e0 +Cf2py double precision, optional :: releps = 0.01e0 +Cf2py double precision, optional :: coveps = 1.0e-10 +Cf2py double precision, optional :: xcutoff = 5.0e0 +Cf2py double precision, optional :: xsplit = 5.0e0 + +Cf2py integer, optional :: method = 3 +Cf2py integer, optional :: minpts = 0 +Cf2py integer, optional :: maxpts = 40000 +Cf2py integer, optional :: nit = 1000 +Cf2py integer, optional :: Nc1c2 = 2 +Cf2py integer, optional :: nint1 = 2 + +! Method>0 + call setconstants(method,xcscale,abseps,releps,coveps, + & maxpts,minpts,nit,xcutoff,Nc1c2) +! method==0 + call SETDATA(method,xcscale,abseps,releps,coveps, + & nit, xCutOff,NINT1,xsplit) + return + end subroutine set_constants + SUBROUTINE show_constants() + use rindmod + print *, 'method=', mMethod + print *, 'xcscale=', mXcScale + print *, 'abseps=', mAbsEps + print *, 'releps=', mRelEps + print *, 'coveps=', mCovEps + print *, 'maxpts=', mMaxPts + print *, 'minpts=', mMinPts + print *, 'nit=', mNit + print *, 'xcutOff=', mXcutOff + print *, 'Nc1c2=', mNc1c2 + end subroutine show_constants + + SUBROUTINE rind(VALS,ERR,TERR,Big,Ex,Xc,Nt,INDI,Blo,Bup, & INFIN,seed1,Ntdc,Nc,Nx,Ni,Mb,Nb,Nx1) - USE rindmod + USE rindmod USE rind71mod, only : rind71 IMPLICIT NONE INTEGER :: Ntd,Nj,K,I - INTEGER :: seed1 + INTEGER :: seed1 integer :: Nx,Nx1,Nt, Nc,Ntdc,Ni,Nb,Mb - DOUBLE PRECISION, dimension(Ntdc,Ntdc) :: BIG - DOUBLE PRECISION, dimension(Ntdc) :: Ex - DOUBLE PRECISION, dimension(Nc,Nx1) :: Xc + DOUBLE PRECISION, dimension(Ntdc,Ntdc) :: BIG + DOUBLE PRECISION, dimension(Ntdc) :: Ex + DOUBLE PRECISION, dimension(Nc,Nx1) :: Xc DOUBLE PRECISION, dimension(Mb,Nb) :: Blo,Bup DOUBLE PRECISION, dimension(Nx) :: VALS, ERR,TERR - INTEGER, dimension(Ni) :: IndI + INTEGER, dimension(Ni) :: IndI INTEGER, DIMENSION(Nb) :: INFIN INTEGER, ALLOCATABLE :: seed(:) - INTEGER :: seed_size -Cf2py integer, intent(hide), depend(Ex) :: Ntdc = len(Ex) -Cf2py integer, intent(hide), depend(Xc) :: Nc = shape(Xc,0) -Cf2py integer, intent(hide), depend(Xc) :: Nx1 = shape(Xc,1) -Cf2py integer, intent(hide), depend(Xc) :: Nx = max(shape(Xc,1),1) -Cf2py integer, intent(hide), depend(Blo) :: Mb = shape(Blo,0), Nb = shape(Blo,1), -Cf2py integer, intent(hide), depend(Indi) :: Ni = len(Indi) -Cf2py depend(Ntdc) Big -Cf2py depend(Nb) INFIN -Cf2py depend(Mb,Nb) Bup -Cf2py double precision, intent(out), depend(Nx) :: VALS -Cf2py double precision, intent(out), depend(Nx) :: ERR -Cf2py double precision, intent(out), depend(Nx) :: TERR - -C print *, 'Ntdc=', Ntdc,' Nt=',Nt,' Nc=',Nc -C print *, 'Nx=', Nx, 'Mb=', Mb, ' Nb=', Nb, ' Ni=',Ni -C Ni = Nb+1 -C Nx = max(Nx1,1) - if (Ni.EQ.Nb+1) then - else - print *, '(ni==nb+1) failed: rind:ni=', Ni, ', nb=',Nb - return - endif - + INTEGER :: seed_size +Cf2py integer, intent(hide), depend(Ex) :: Ntdc = len(Ex) +Cf2py integer, intent(hide), depend(Xc) :: Nc = shape(Xc,0) +Cf2py integer, intent(hide), depend(Xc) :: Nx1 = shape(Xc,1) +Cf2py integer, intent(hide), depend(Xc) :: Nx = max(shape(Xc,1),1) +Cf2py integer, intent(hide), depend(Blo) :: Mb = shape(Blo,0), Nb = shape(Blo,1), +Cf2py integer, intent(hide), depend(Indi) :: Ni = len(Indi) +Cf2py depend(Ntdc) Big +Cf2py depend(Nb) INFIN +Cf2py depend(Mb,Nb) Bup +Cf2py double precision, intent(out), depend(Nx) :: VALS +Cf2py double precision, intent(out), depend(Nx) :: ERR +Cf2py double precision, intent(out), depend(Nx) :: TERR + +C print *, 'Ntdc=', Ntdc,' Nt=',Nt,' Nc=',Nc +C print *, 'Nx=', Nx, 'Mb=', Mb, ' Nb=', Nb, ' Ni=',Ni +C Ni = Nb+1 +C Nx = max(Nx1,1) + if (Ni.EQ.Nb+1) then + else + print *, '(ni==nb+1) failed: rind:ni=', Ni, ', nb=',Nb + return + endif + Ntd = Ntdc - Nc; ! Nd = Ntd - Nt - + IF (Ntd.EQ.INDI(Ni)) THEN -! Call the computational subroutine. - IF (mMethod.gt.0) THEN - CALL random_seed(SIZE=seed_size) - ALLOCATE(seed(seed_size)) - !print *,'rindinterface seed', seed1 - CALL random_seed(GET=seed(1:seed_size)) ! get current state - seed(1:seed_size)=seed1 ! change seed - CALL random_seed(PUT=seed(1:seed_size)) - CALL random_seed(GET=seed(1:seed_size)) ! get current state - !print *,'rindinterface seed', seed - DEALLOCATE(seed) - CALL RINDD(VALS,ERR,TERR,Big,Ex,Xc,Nt,INDI,Blo,Bup,INFIN) - ELSE - CALL RIND71(VALS,Big,Ex,Xc,Nt,INDI,Blo,Bup) - ERR(:) = -1 - TERR(:) = -1 +! Call the computational subroutine. + IF (mMethod.gt.0) THEN + CALL random_seed(SIZE=seed_size) + ALLOCATE(seed(seed_size)) + !print *,'rindinterface seed', seed1 + CALL random_seed(GET=seed(1:seed_size)) ! get current state + seed(1:seed_size)=seed1 ! change seed + CALL random_seed(PUT=seed(1:seed_size)) + CALL random_seed(GET=seed(1:seed_size)) ! get current state + !print *,'rindinterface seed', seed + DEALLOCATE(seed) + CALL RINDD(VALS,ERR,TERR,Big,Ex,Xc,Nt,INDI,Blo,Bup,INFIN) + ELSE + CALL RIND71(VALS,Big,Ex,Xc,Nt,INDI,Blo,Bup) + ERR(:) = -1 + TERR(:) = -1 ENDIF - ELSE + ELSE print *,'INDI(Ni) must equal Nt+Nd!' ENDIF - + RETURN END SUBROUTINE rind diff --git a/pywafo/src/wafo/source/rind2007/rindmod.f b/wafo/source/rind2007/rindmod.f similarity index 86% rename from pywafo/src/wafo/source/rind2007/rindmod.f rename to wafo/source/rind2007/rindmod.f index ded7d1d..73c5bf9 100644 --- a/pywafo/src/wafo/source/rind2007/rindmod.f +++ b/wafo/source/rind2007/rindmod.f @@ -1,98 +1,98 @@ -! Programs available in module RINDMOD : +! Programs available in module RINDMOD : ! ! 1) setConstants -! 2) RINDD -! -! SETCONSTANTS set member variables controlling the performance of RINDD -! -! CALL setConstants(method,xcscale,abseps,releps,coveps,maxpts,minpts,nit,xcutoff,Nc1c2) -! -! METHOD = INTEGER defining the SCIS integration method -! 1 Integrate by SADAPT for Ndim<9 and by KRBVRC otherwise -! 2 Integrate by SADAPT for Ndim<20 and by KRBVRC otherwise -! 3 Integrate by KRBVRC by Genz (1993) (Fast Ndim<101) (default) -! 4 Integrate by KROBOV by Genz (1992) (Fast Ndim<101) -! 5 Integrate by RCRUDE by Genz (1992) (Slow Ndim<1001) -! 6 Integrate by SOBNIED (Fast Ndim<1041) -! 7 Integrate by DKBVRC by Genz (2003) (Fast Ndim<1001) -! -! XCSCALE = REAL to scale the conditinal probability density, i.e., -! f_{Xc} = exp(-0.5*Xc*inv(Sxc)*Xc + XcScale) (default XcScale =0) -! ABSEPS = REAL absolute error tolerance. (default 0) -! RELEPS = REAL relative error tolerance. (default 1e-3) -! COVEPS = REAL error tolerance in Cholesky factorization (default 1e-13) -! MAXPTS = INTEGER, maximum number of function values allowed. This -! parameter can be used to limit the time. A sensible -! strategy is to start with MAXPTS = 1000*N, and then -! increase MAXPTS if ERROR is too large. -! (Only for METHOD~=0) (default 40000) -! MINPTS = INTEGER, minimum number of function values allowed. -! (Only for METHOD~=0) (default 0) -! NIT = INTEGER, maximum number of Xt variables to integrate -! This parameter can be used to limit the time. -! If NIT is less than the rank of the covariance matrix, -! the returned result is a upper bound for the true value -! of the integral. (default 1000) -! XCUTOFF = REAL cut off value where the marginal normal -! distribution is truncated. (Depends on requested -! accuracy. A value between 4 and 5 is reasonable.) -! NC1C2 = number of times to use the regression equation to restrict -! integration area. Nc1c2 = 1,2 is recommended. (default 2) -! -! -!RIND computes E[Jacobian*Indicator|Condition]*f_{Xc}(xc(:,ix)) +! 2) RINDD +! +! SETCONSTANTS set member variables controlling the performance of RINDD +! +! CALL setConstants(method,xcscale,abseps,releps,coveps,maxpts,minpts,nit,xcutoff,Nc1c2) +! +! METHOD = INTEGER defining the SCIS integration method +! 1 Integrate by SADAPT for Ndim<9 and by KRBVRC otherwise +! 2 Integrate by SADAPT for Ndim<20 and by KRBVRC otherwise +! 3 Integrate by KRBVRC by Genz (1993) (Fast Ndim<101) (default) +! 4 Integrate by KROBOV by Genz (1992) (Fast Ndim<101) +! 5 Integrate by RCRUDE by Genz (1992) (Slow Ndim<1001) +! 6 Integrate by SOBNIED (Fast Ndim<1041) +! 7 Integrate by DKBVRC by Genz (2003) (Fast Ndim<1001) +! +! XCSCALE = REAL to scale the conditinal probability density, i.e., +! f_{Xc} = exp(-0.5*Xc*inv(Sxc)*Xc + XcScale) (default XcScale =0) +! ABSEPS = REAL absolute error tolerance. (default 0) +! RELEPS = REAL relative error tolerance. (default 1e-3) +! COVEPS = REAL error tolerance in Cholesky factorization (default 1e-13) +! MAXPTS = INTEGER, maximum number of function values allowed. This +! parameter can be used to limit the time. A sensible +! strategy is to start with MAXPTS = 1000*N, and then +! increase MAXPTS if ERROR is too large. +! (Only for METHOD~=0) (default 40000) +! MINPTS = INTEGER, minimum number of function values allowed. +! (Only for METHOD~=0) (default 0) +! NIT = INTEGER, maximum number of Xt variables to integrate +! This parameter can be used to limit the time. +! If NIT is less than the rank of the covariance matrix, +! the returned result is a upper bound for the true value +! of the integral. (default 1000) +! XCUTOFF = REAL cut off value where the marginal normal +! distribution is truncated. (Depends on requested +! accuracy. A value between 4 and 5 is reasonable.) +! NC1C2 = number of times to use the regression equation to restrict +! integration area. Nc1c2 = 1,2 is recommended. (default 2) +! +! +!RIND computes E[Jacobian*Indicator|Condition]*f_{Xc}(xc(:,ix)) ! ! where ! "Indicator" = I{ H_lo(i) < X(i) < H_up(i), i=1:Nt+Nd } -! "Jacobian" = J(X(Nt+1),...,X(Nt+Nd+Nc)), special case is +! "Jacobian" = J(X(Nt+1),...,X(Nt+Nd+Nc)), special case is ! "Jacobian" = |X(Nt+1)*...*X(Nt+Nd)|=|Xd(1)*Xd(2)..Xd(Nd)| ! "condition" = Xc=xc(:,ix), ix=1,...,Nx. -! X = [Xt; Xd ;Xc], a stochastic vector of Multivariate Gaussian +! X = [Xt; Xd ;Xc], a stochastic vector of Multivariate Gaussian ! variables where Xt,Xd and Xc have the length Nt, Nd and Nc, -! respectively. -! (Recommended limitations Nx, Nt<101, Nd<7 and NIT,Nc<11) -! (RIND = Random Integration N Dimensions) +! respectively. +! (Recommended limitations Nx, Nt<101, Nd<7 and NIT,Nc<11) +! (RIND = Random Integration N Dimensions) ! !CALL RINDD(E,err,terr,S,m,xc,Nt,indI,Blo,Bup,INFIN); ! ! E = expectation/density as explained above size 1 x Nx (out) -! ERR = estimated sampling error size 1 x Nx (out) +! ERR = estimated sampling error size 1 x Nx (out) ! TERR = estimated truncation error size 1 x Nx (out) ! S = Covariance matrix of X=[Xt;Xd;Xc] size N x N (N=Nt+Nd+Nc) (in) ! m = the expectation of X=[Xt;Xd;Xc] size N x 1 (in) ! xc = values to condition on size Nc x Nx (in) -! indI = vector of indices to the different barriers in the (in) -! indicator function, length NI, where NI = Nb+1 +! indI = vector of indices to the different barriers in the (in) +! indicator function, length NI, where NI = Nb+1 ! (NB! restriction indI(1)=0, indI(NI)=Nt+Nd ) ! Blo,Bup = Lower and upper barrier coefficients used to compute the (in) -! integration limits A and B, respectively. +! integration limits A and B, respectively. ! size Mb x Nb. If Mb=0, -! IF INFIN(j)~=0, A(i)=Blo(1,j)+Blo(2:Mb,j).'*xc(1:Mb-1,ix), -! IF INFIN(j)~=1, B(i)=Bup(1,j)+Bup(2:Mb,j).'*xc(1:Mb-1,ix), +! IF INFIN(j)~=0, A(i)=Blo(1,j)+Blo(2:Mb,j).'*xc(1:Mb-1,ix), +! IF INFIN(j)~=1, B(i)=Bup(1,j)+Bup(2:Mb,j).'*xc(1:Mb-1,ix), ! ! where i=indI(j-1)+1:indI(j), j=1:NI-1, ix=1:Nx ! Thus the integration limits may change with the conditional ! variables. -!Example: -! The indices, indI=[0 3 5 6], and coefficients Blo=[0 0 -1], -! Bup=[0 0 5], INFIN=[0 1 2] -! means that A = [-inf -inf -inf 0 0 -1] B = [0 0 0 inf inf 5] +!Example: +! The indices, indI=[0 3 5 6], and coefficients Blo=[0 0 -1], +! Bup=[0 0 5], INFIN=[0 1 2] +! means that A = [-inf -inf -inf 0 0 -1] B = [0 0 0 inf inf 5] ! ! ! (Recommended limitations Nx,Nt<101, Nd<7 and Nc<11) ! Also note that the size information have to be transferred to RINDD -! through the input arguments E,S,m,Nt,IndI,Blo,Bup and INFIN +! through the input arguments E,S,m,Nt,IndI,Blo,Bup and INFIN ! -! For further description see the modules +! For further description see the modules ! ! References ! Podgorski et al. (2000) @@ -101,9 +101,9 @@ ! ! R. Ambartzumian, A. Der Kiureghian, V. Ohanian and H. ! Sukiasian (1998) -! "Multinormal probabilities by sequential conditioned +! "Multinormal probabilities by sequential conditioned ! importance sampling: theory and application" (MVNFUN) -! Probabilistic Engineering Mechanics, Vol. 13, No 4. pp 299-308 +! Probabilistic Engineering Mechanics, Vol. 13, No 4. pp 299-308 ! ! Alan Genz (1992) ! 'Numerical Computation of Multivariate Normal Probabilites' (MVNFUN) @@ -117,25 +117,25 @@ ! P. A. Brodtkorb (2004), (RINDD, MVNFUN, COVSRT) ! Numerical evaluation of multinormal expectations ! In Lund university report series -! and in the Dr.Ing thesis: +! and in the Dr.Ing thesis: ! The probability of Occurrence of dangerous Wave Situations at Sea. ! Dr.Ing thesis, Norwegian University of Science and Technolgy, NTNU, ! Trondheim, Norway. ! Tested on: DIGITAL UNIX Fortran90 compiler ! PC pentium II with Lahey Fortran90 compiler -! Solaris with SunSoft F90 compiler Version 1.0.1.0 (21229283) -! History: -! Revised pab aug. 2009 -! -renamed from rind2007 to rindmod -! Revised pab July 2007 -! - separated the absolute error into ERR and TERR. +! Solaris with SunSoft F90 compiler Version 1.0.1.0 (21229283) +! History: +! Revised pab aug. 2009 +! -renamed from rind2007 to rindmod +! Revised pab July 2007 +! - separated the absolute error into ERR and TERR. ! - renamed from alanpab24 -> rind2007 ! revised pab 23may2004 ! RIND module totally rewritten according to the last reference. - MODULE GLOBALCONST ! global constants + MODULE GLOBALCONST ! global constants IMPLICIT NONE DOUBLE PRECISION, PARAMETER :: gSQTWPI1= 0.39894228040143D0 !=1/sqrt(2*pi) DOUBLE PRECISION, PARAMETER :: gSQPI1 = 0.56418958354776D0 !=1/sqrt(pi) @@ -161,34 +161,34 @@ ! USE PRINTMOD ! used for debugging only IMPLICIT NONE PRIVATE - PUBLIC :: RINDD, SetConstants - PUBLIC :: mCovEps, mAbsEps,mRelEps, mXcutOff, mXcScale + PUBLIC :: RINDD, SetConstants + PUBLIC :: mCovEps, mAbsEps,mRelEps, mXcutOff, mXcScale PUBLIC :: mNc1c2, mNIT, mMaxPts,mMinPts, mMethod, mSmall private :: preInit private :: initIntegrand private :: initfun,mvnfun,cvsrtxc,covsrt1,covsrt,rcscale,rcswap - private :: cleanUp - - INTERFACE RINDD - MODULE PROCEDURE RINDD + private :: cleanUp + + INTERFACE RINDD + MODULE PROCEDURE RINDD END INTERFACE - - INTERFACE SetConstants - MODULE PROCEDURE SetConstants - END INTERFACE - + + INTERFACE SetConstants + MODULE PROCEDURE SetConstants + END INTERFACE + ! mInfinity = what is considered as infinite value in FI -! mFxcEpss = if fxc is less, do not compute E(...|Xc) +! mFxcEpss = if fxc is less, do not compute E(...|Xc) ! mXcEps2 = if any Var(Xc(j)|Xc(1),...,Xc(j-1)) <= XCEPS2 then return NAN double precision, parameter :: mInfinity = 8.25d0 ! 37.0d0 - double precision, parameter :: mFxcEpss = 1.0D-20 + double precision, parameter :: mFxcEpss = 1.0D-20 double precision, save :: mXcEps2 = 2.3d-16 ! Constants defining accuracy of integration: ! mCovEps = termination criteria for Cholesky decomposition ! mAbsEps = requested absolute tolerance ! mRelEps = requested relative tolerance ! mXcutOff = truncation value to c1c2 -! mXcScale = scale factor in the exponential (in order to avoid overflow) +! mXcScale = scale factor in the exponential (in order to avoid overflow) ! mNc1c2 = number of times to use function c1c2, i.e.,regression ! equation to restrict integration area. ! mNIT = maximum number of Xt variables to integrate @@ -198,7 +198,7 @@ ! 3 Integrate all by KRBVRC by Genz (1998) (Fast and reliable) ! 4 Integrate all by KROBOV by Genz (1992) (Fast and reliable) ! 5 Integrate all by RCRUDE by Genz (1992) (Reliable) -! 6 Integrate all by SOBNIED by Hong and Hickernell +! 6 Integrate all by SOBNIED by Hong and Hickernell ! 7 Integrate all by DKBVRC by Genz (2003) (Fast Ndim<1001) double precision, save :: mCovEps = 1.0d-10 double precision, save :: mAbsEps = 0.01d0 @@ -210,22 +210,22 @@ integer, save :: mMaxPts = 40000 integer, save :: mMinPts = 0 integer, save :: mMethod = 3 - - + + ! Integrand variables: -! mBIG = Cholesky Factor/Covariance matrix: +! mBIG = Cholesky Factor/Covariance matrix: ! Upper triangular part is the cholesky factor -! Lower triangular part contains the conditional -! standarddeviations +! Lower triangular part contains the conditional +! standarddeviations ! (mBIG2 is only used if mNx>1) ! mCDI = Cholesky DIagonal elements ! mA,mB = Integration limits ! mINFI = integrationi limit flags ! mCm = conditional mean -! mINFIXt, +! mINFIXt, ! mINFIXd = # redundant variables of Xt and Xd, -! respectively -! mIndex1, +! respectively +! mIndex1, ! mIndex2 = indices to the variables original place. Size Ntdc ! xedni = indices to the variables new place. Size Ntdc ! mNt = # Xt variables @@ -234,22 +234,22 @@ ! mNtd = mNt + mNd ! mNtdc = mNt + mNd + mNc ! mNx = # different integration limits - + double precision,allocatable, dimension(:,:) :: mBIG,mBIG2 - double precision,allocatable, dimension(:) :: mA,mB,mCDI,mCm + double precision,allocatable, dimension(:) :: mA,mB,mCDI,mCm INTEGER, DIMENSION(:),ALLOCATABLE :: mInfi,mIndex1,mIndex2,mXedni INTEGER,SAVE :: mNt,mNd,mNc,mNtdc, mNtd, mNx ! Size information - INTEGER,SAVE :: mInfiXt,mInfiXd + INTEGER,SAVE :: mInfiXt,mInfiXd logical,save :: mInitIntegrandCalled = .FALSE. DOUBLE PRECISION, DIMENSION(:), ALLOCATABLE :: mCDIXd, mCmXd DOUBLE PRECISION, DIMENSION(:), ALLOCATABLE :: mXd, mXc, mY double precision, save :: mSmall = 2.3d-16 - + ! variables set in initfun and used in mvnfun: INTEGER, PRIVATE :: mI0,mNdleftN0 DOUBLE PRECISION, PRIVATE :: mE1,mD1, mVAL0 - + contains subroutine setConstants(method,xcscale,abseps,releps,coveps, & maxpts,minpts,nit,xcutoff,Nc1c2) @@ -267,16 +267,16 @@ if (present(minpts)) mMinPts = minpts if (present(nit)) mNit = nit if (present(xcutOff)) mXcutOff = xCutOff - if (present(Nc1c2)) mNc1c2 = max(Nc1c2,1) -! print *, 'method=', mMethod -! print *, 'xcscale=', mXcScale -! print *, 'abseps=', mAbsEps -! print *, 'releps=', mRelEps -! print *, 'coveps=', mCovEps -! print *, 'maxpts=', mMaxPts -! print *, 'minpts=', mMinPts -! print *, 'nit=', mNit -! print *, 'xcutOff=', mXcutOff + if (present(Nc1c2)) mNc1c2 = max(Nc1c2,1) +! print *, 'method=', mMethod +! print *, 'xcscale=', mXcScale +! print *, 'abseps=', mAbsEps +! print *, 'releps=', mRelEps +! print *, 'coveps=', mCovEps +! print *, 'maxpts=', mMaxPts +! print *, 'minpts=', mMinPts +! print *, 'nit=', mNit +! print *, 'xcutOff=', mXcutOff ! print *, 'Nc1c2=', mNc1c2 end subroutine setConstants @@ -296,7 +296,7 @@ mNx = MAX( SIZE( Xc, dim = 2), 1 ) mNtdc = SIZE( BIG, dim = 1 ) ! make sure it does not exceed Ntdc-Nc - IF (mNt+mNc.GT.mNtdc) mNt = mNtdc - mNc + IF (mNt+mNc.GT.mNtdc) mNt = mNtdc - mNc mNd = mNtdc-mNt-mNc mNtd = mNt+mNd IF (mNd < 0) THEN @@ -305,9 +305,9 @@ inform = 3 return ENDIF - + ! PRINT *,'Nt Nd Nc Ntd Ntdc,',Nt, Nd, Nc, Ntd, Ntdc - + ! ALLOCATION !~~~~~~~~~~~~ IF (mNd>0) THEN @@ -317,30 +317,30 @@ mxd(:) = gZERO END IF ALLOCATE(mBIG(mNtdc,mNtdc),mCm(mNtdc),mY(mNtd)) - ALLOCATE(mIndex1(mNtdc),mA(mNtd),mB(mNtd),mINFI(mNtd),mXc(mNc)) + ALLOCATE(mIndex1(mNtdc),mA(mNtd),mB(mNtd),mINFI(mNtd),mXc(mNc)) ALLOCATE(mCDI(mNtd),mXedni(mNtdc),mIndex2(mNtdc)) - + ! Initialization !~~~~~~~~~~~~~~~~~~~~~ ! Copy upper triangular of input matrix, only. do i = 1,mNtdc - mBIG(1:i,i) = BIG(1:i,i) + mBIG(1:i,i) = BIG(1:i,i) end do - + mIndex2 = (/(J,J=1,mNtdc)/) - + ! CALL mexprintf('BIG Before CovsrtXc'//CHAR(10)) ! CALL ECHO(BIG) -! sort BIG by decreasing cond. variance for Xc - CALL CVSRTXC(mNt,mNd,mBIG,mIndex2,INFORM) +! sort BIG by decreasing cond. variance for Xc + CALL CVSRTXC(mNt,mNd,mBIG,mIndex2,INFORM) ! CALL mexprintf('BIG after CovsrtXc'//CHAR(10)) ! CALL ECHO(BIG) - - IF (INFORM.GT.0) return ! degenerate case exit VALS=0 for all + + IF (INFORM.GT.0) return ! degenerate case exit VALS=0 for all ! (should perhaps return NaN instead??) - DO I=mNtdc,1,-1 + DO I=mNtdc,1,-1 J = mIndex2(I) ! covariance matrix according to index2 mXedni(J) = I END DO @@ -366,10 +366,10 @@ integer :: I,J inform = 0 NDIM = 0 - VALUE = gZERO + VALUE = gZERO fxc = gONE abserr = mSmall - + IF (mInitIntegrandCalled) then do i = 1,mNtdc mBIG(1:i,i) = mBIG2(1:i,i) !Copy input matrix @@ -377,33 +377,33 @@ else mInitIntegrandCalled = .TRUE. endif - + ! Set the original means of the variables - mCm(:) = Ex(mIndex2(1:mNtdc)) ! Cm(1:Ntdc) =Ex (index1(1:Ntdc)) + mCm(:) = Ex(mIndex2(1:mNtdc)) ! Cm(1:Ntdc) =Ex (index1(1:Ntdc)) IF (mNc>0) THEN mXc(:) = Xc(:,ix) !mXc(1:Nc) = Xc(1:Nc,ix) QUANT = DBLE(mNc)*LOG(gSQTWPI1) - I = mNtdc - DO J = 1, mNc -! Iterative conditioning on the last Nc variables + I = mNtdc + DO J = 1, mNc +! Iterative conditioning on the last Nc variables SQ0 = mBIG(I,I) ! SQRT(Var(X(i)|X(i+1),X(i+2),...,X(Ntdc))) xx = (mXc(mIndex2(I) - mNtd) - mCm(I))/SQ0 !Trick to calculate - !fxc = fxc*SQTWPI1*EXP(-0.5*(XX**2))/SQ0 - QUANT = QUANT - gHALF*xx*xx - LOG(SQ0) - ! conditional mean (expectation) - ! E(X(1:i-1)|X(i),X(i+1),...,X(Ntdc)) + !fxc = fxc*SQTWPI1*EXP(-0.5*(XX**2))/SQ0 + QUANT = QUANT - gHALF*xx*xx - LOG(SQ0) + ! conditional mean (expectation) + ! E(X(1:i-1)|X(i),X(i+1),...,X(Ntdc)) mCm(1:I-1) = mCm(1:I-1) + xx*mBIG(1:I-1,I) I = I-1 ENDDO - ! Calculating the - ! fxc probability density for i=Ntdc-J+1, + ! Calculating the + ! fxc probability density for i=Ntdc-J+1, ! fXc=f(X(i)|X(i+1),X(i+2)...X(Ntdc))* ! f(X(i+1)|X(i+2)...X(Ntdc))*..*f(X(Ntdc)) - fxc = EXP(QUANT+mXcScale) - - ! if fxc small: don't bother + fxc = EXP(QUANT+mXcScale) + + ! if fxc small: don't bother ! calculating it, goto end IF (fxc < mFxcEpss) then abserr = gONE @@ -415,33 +415,33 @@ ! NOTE: mA and mB are integration limits with mCm subtracted CALL setIntLimits(mXc,indI,Blo,Bup,INFIN,inform) if (inform>0) return - mIndex1(:) = mIndex2(:) - CALL COVSRT(.FALSE., mNt,mNd,mBIG,mCm,mA,mB,mINFI, + mIndex1(:) = mIndex2(:) + CALL COVSRT(.FALSE., mNt,mNd,mBIG,mCm,mA,mB,mINFI, & mINDEX1,mINFIXt,mINFIXd,NDIM,mY,mCDI) CALL INITFUN(VALUE,abserr,INFORM) ! IF INFORM>0 : degenerate case: -! Integral can be calculated excactly, ie. +! Integral can be calculated excactly, ie. ! mean of deterministic variables outside the barriers, -! or NDIM = 1 +! or NDIM = 1 return end subroutine initIntegrand subroutine cleanUp -! Deallocate all work arrays and vectors - IF (ALLOCATED(mXc)) DEALLOCATE(mXc) - IF (ALLOCATED(mXd)) DEALLOCATE(mXd) - IF (ALLOCATED(mCm)) DEALLOCATE(mCm) - IF (ALLOCATED(mBIG2)) DEALLOCATE(mBIG2) - IF (ALLOCATED(mBIG)) DEALLOCATE(mBIG) +! Deallocate all work arrays and vectors + IF (ALLOCATED(mXc)) DEALLOCATE(mXc) + IF (ALLOCATED(mXd)) DEALLOCATE(mXd) + IF (ALLOCATED(mCm)) DEALLOCATE(mCm) + IF (ALLOCATED(mBIG2)) DEALLOCATE(mBIG2) + IF (ALLOCATED(mBIG)) DEALLOCATE(mBIG) IF (ALLOCATED(mIndex2)) DEALLOCATE(mIndex2) IF (ALLOCATED(mIndex1)) DEALLOCATE(mIndex1) IF (ALLOCATED(mXedni)) DEALLOCATE(mXedni) IF (ALLOCATED(mA)) DEALLOCATE(mA) - IF (ALLOCATED(mB)) DEALLOCATE(mB) - IF (ALLOCATED(mY)) DEALLOCATE(mY) - IF (ALLOCATED(mCDI)) DEALLOCATE(mCDI) - IF (ALLOCATED(mCDIXd)) DEALLOCATE(mCDIXd) - IF (ALLOCATED(mCmXd)) DEALLOCATE(mCmXd) + IF (ALLOCATED(mB)) DEALLOCATE(mB) + IF (ALLOCATED(mY)) DEALLOCATE(mY) + IF (ALLOCATED(mCDI)) DEALLOCATE(mCDI) + IF (ALLOCATED(mCDIXd)) DEALLOCATE(mCDIXd) + IF (ALLOCATED(mCmXd)) DEALLOCATE(mCmXd) IF (ALLOCATED(mINFI)) DEALLOCATE(mINFI) end subroutine cleanUp function integrandBound(I0,N,Y,FINY) result (bound1) @@ -460,15 +460,15 @@ FINB = 0 IK = 2 DO I = I0, N - ! E(Y(I) | Y(1))/STD(Y(IK)|Y(1)) - TMP = mBIG(IK-1,I)*Y + ! E(Y(I) | Y(1))/STD(Y(IK)|Y(1)) + TMP = mBIG(IK-1,I)*Y IF (mINFI(I) > -1) then ! May have infinite int. Limits if Nd>0 IF ( mINFI(I) .NE. 0 ) THEN IF ( FINA .EQ. 1 ) THEN AI = MAX( AI, mA(I) - tmp ) ELSE - AI = mA(I) - tmp + AI = mA(I) - tmp FINA = 1 END IF END IF @@ -476,12 +476,12 @@ IF ( FINB .EQ. 1 ) THEN BI = MIN( BI, mB(I) - tmp) ELSE - BI = mB(I) - tmp + BI = mB(I) - tmp FINB = 1 END IF END IF endif - + IF (I.EQ.N.OR.mBIG(IK+1,I+1)>gZERO) THEN CALL MVNLMS( AI, BI,2*FINA+FINB-1, D1, E1 ) IF (D10) THEN + + IF (mINFIXd>0) THEN ! Redundant variables of Xd: replace Xd with the mean I = mNt + mNd !-INFIS J = mNdleftN0-mINFIXd - + DO WHILE (mNdleftN0>J) isXd = (mNt < mIndex1(I)) - IF (isXd) THEN + IF (isXd) THEN mXd (mNdleftN0) = mCm (I) - mNdleftN0 = mNdleftN0-1 + mNdleftN0 = mNdleftN0-1 END IF I = I-1 ENDDO ENDIF - IF (N+1 < 1) THEN -! Degenerate case, No relevant variables left to integrate + IF (N+1 < 1) THEN +! Degenerate case, No relevant variables left to integrate ! Print *,'rind ndim1',Ndim1 - IF (mNd>0) THEN + IF (mNd>0) THEN VALUE = jacob (mXd,mXc) ! jacobian of xd,xc ELSE VALUE = gONE @@ -575,7 +575,7 @@ ENDIF IF (mNIT<=100) THEN xCut = mXcutOff - + J = 1 DO I = 2, N+1 IF (mBIG(J+1,I)>gZERO) THEN @@ -588,7 +588,7 @@ ENDIF END DO ELSE - xCut = gZERO + xCut = gZERO ENDIF NdleftO = mNdleftN0 @@ -600,7 +600,7 @@ IF ( FINA .EQ. 1 ) THEN AI = MAX( AI, mA(I) ) ELSE - AI = mA(I) + AI = mA(I) FINA = 1 END IF END IF @@ -608,23 +608,23 @@ IF ( FINB .EQ. 1 ) THEN BI = MIN( BI, mB(I) ) ELSE - BI = mB(I) + BI = mB(I) FINB = 1 END IF END IF endif isXd = (mINDEX1(I)>mNt) IF (isXd) THEN ! Save the mean for Xd - mCmXd(mNdleftN0) = mCm(I) - mCDIXd(mNdleftN0) = mCDI(I) + mCmXd(mNdleftN0) = mCm(I) + mCDIXd(mNdleftN0) = mCDI(I) mNdleftN0 = mNdleftN0-1 END IF - + IF (I.EQ.N+1.OR.mBIG(2,I+1)>gZERO) THEN IF (useC1C2.AND.I=E0) GOTO 200 @@ -635,8 +635,8 @@ upError = abs(E0-mE1) loError = abs(D0-mD1) if (upError>mSmall) then - upError = upError*integrandBound(I+1,N+1,BI,FINB) - endif + upError = upError*integrandBound(I+1,N+1,BI,FINB) + endif if (loError>mSmall) then loError = loError*integrandBound(I+1,N+1,AI,FINA) endif @@ -644,12 +644,12 @@ !CALL printvar(log10(loError+upError+msmall),'lo+up-err') ELSE CALL MVNLMS( AI, BI,2*FINA+FINB-1, mD1, mE1 ) - IF (mD1>=mE1) GOTO 200 + IF (mD1>=mE1) GOTO 200 ENDIF !CALL MVNLMS( AI, BI,2*FINA+FINB-1, mD1, mE1 ) !IF (mD1>=mE1) GOTO 200 IF ( NdleftO<=0) THEN - IF (mNd>0) mVAL0 = JACOB(mXd,mXc) + IF (mNd>0) mVAL0 = JACOB(mXd,mXc) SELECT CASE (I-N) CASE (1) !IF (I.EQ.N+1) THEN VALUE = (mE1-mD1)*mVAL0 @@ -657,7 +657,7 @@ GO TO 200 CASE (0) !ELSEIF (I.EQ.N) THEN !D1=1/sqrt(1-rho^2)=1/STD(X(I+1)|X(1)) - mD1 = SQRT( gONE + mBIG(1,I+1)*mBIG(1,I+1) ) + mD1 = SQRT( gONE + mBIG(1,I+1)*mBIG(1,I+1) ) mINFI(2) = mINFI(I+1) mA(1) = AI mB(1) = BI @@ -666,20 +666,20 @@ IF ( mINFI(2) .NE. 1 ) mB(2) = mB(I+1)/mD1 VALUE = BVNMVN( mA, mB,mINFI,mBIG(1,I+1)/mD1 )*mVAL0 abserr = (abserr+1.0d-14)*mVAL0 - GO TO 200 + GO TO 200 CASE ( -1 ) !ELSEIF (I.EQ.N-1) THEN IF (.FALSE.) THEN -! TODO :this needs further checking! (it should work though) +! TODO :this needs further checking! (it should work though) !1/D1= sqrt(1-r12^2) = STD(X(I+1)|X(1)) !1/E1= STD(X(I+2)|X(1)X(I+1)) !D1 = BIG(I+1,1) !E1 = BIG(I+2,2) - + mD1 = gONE/SQRT( gONE + mBIG(1,I+1)*mBIG(1,I+1) ) R12 = mBIG( 1, I+1 ) * mD1 if (mBIG(3,I+2)>gZERO) then mE1 = gONE/SQRT( gONE + mBIG(1,I+2)*mBIG(1,I+2) + - & mBIG(2,I+2)*mBIG(2,I+2) ) + & mBIG(2,I+2)*mBIG(2,I+2) ) R13 = mBIG( 1, I+2 ) * mE1 R23 = mBIG( 2, I+2 ) * (mE1 * mD1) + R12 * R13 else @@ -729,8 +729,8 @@ RETURN 200 INFORM = 1 RETURN - END SUBROUTINE INITFUN -! + END SUBROUTINE INITFUN +! ! Integrand subroutine ! FUNCTION MVNFUN( Ndim, W ) RESULT (VAL) @@ -744,19 +744,19 @@ INTEGER :: N,I, J, FINA, FINB INTEGER :: NdleftN, NdleftO ,IK DOUBLE PRECISION :: TMP, AI, BI, DI, EI - LOGICAL :: useC1C2, isXd + LOGICAL :: useC1C2, isXd !MVNFUN Multivariate Normal integrand function -! where the integrand is transformed from an integral +! where the integrand is transformed from an integral ! having integration limits A and B to an ! integral having constant integration limits i.e. -! B 1 +! B 1 ! int jacob(xd,xc)*f(xd,xt)dxt dxd = int F2(W) dW ! A 0 ! ! W - new transformed integration variables, valid range 0..1 ! The vector must have the length Ndim returned from Covsrt ! mBIG - conditional sorted ChOlesky Factor of the covariance matrix (IN) -! mCDI - Cholesky DIagonal elements used to calculate the mean +! mCDI - Cholesky DIagonal elements used to calculate the mean ! mCm - conditional mean of Xd and Xt given Xc, E(Xd,Xt|Xc) ! mXd - variables to the jacobian variable, need no initialization size Nd ! mXc - conditional variables (IN) @@ -764,11 +764,11 @@ ! variables otherwise it is one of Xt !PRINT *,'Mvnfun,ndim',Ndim - + ! xCut = gZERO ! xCutOff N = mNt+mNd-mINFIXt-mINFIXd-1 - IK = 1 ! Counter for Ndim + IK = 1 ! Counter for Ndim FINA = 0 FINB = 0 @@ -780,7 +780,7 @@ IF (useC1C2) THEN ! Calculate the conditional mean ! E(Y(I) | Y(1),...Y(I0))/STD(Y(I)|Y(1),,,,Y(I0)) - mY(mI0+1:N+1) = mBIG(IK, mI0+1:N+1)*mY(IK) + mY(mI0+1:N+1) = mBIG(IK, mI0+1:N+1)*mY(IK) ENDIF IF (NdleftO.GT.NdleftN ) THEN mXd(NdleftN+1:NdleftO) = mCmXd(NdleftN+1:NdleftO)+ @@ -788,32 +788,32 @@ ENDIF NdleftO = NdleftN IK = 2 !=IK+1 - - + + DO I = mI0+1, N+1 IF (useC1C2) THEN TMP = mY(I) ELSE TMP = 0.d0 - DO J = 1, IK-1 + DO J = 1, IK-1 ! E(Y(I) | Y(1),...Y(IK-1))/STD(Y(IK)|Y(1),,,,Y(IK-1)) - TMP = TMP + mBIG(J,I)*mY(J) + TMP = TMP + mBIG(J,I)*mY(J) END DO ENDIF IF (mINFI(I) < 0) GO TO 100 ! May have infinite int. Limits if Nd>0 IF ( mINFI(I) .NE. 0 ) THEN IF ( FINA .EQ. 1 ) THEN - AI = MAX( AI, mA(I) - TMP) + AI = MAX( AI, mA(I) - TMP) ELSE - AI = mA(I) - TMP + AI = mA(I) - TMP FINA = 1 END IF IF (FINB.EQ.1.AND.BI<=AI) GOTO 200 END IF IF ( mINFI(I) .NE. 1 ) THEN IF ( FINB .EQ. 1 ) THEN - BI = MIN( BI, mB(I) - TMP) + BI = MIN( BI, mB(I) - TMP) ELSE BI = mB(I) - TMP FINB = 1 @@ -821,23 +821,23 @@ IF (FINA.EQ.1.AND.BI<=AI) GOTO 200 END IF 100 isXd = (mNt gZERO ) THEN + END IF + IF (I == N+1 .OR. mBIG(IK+1,I+1) > gZERO ) THEN IF (useC1C2) THEN -! Note: for J =I+1:N+1: Y(J) = conditional expectation, E(Yj|Y1,...Yk) +! Note: for J =I+1:N+1: Y(J) = conditional expectation, E(Yj|Y1,...Yk) CALL C1C2(I+1,N+1,IK,mA,mB,mINFI,mY,mBIG,AI,BI,FINA,FINB) ENDIF - CALL MVNLMS( AI, BI, 2*FINA+FINB-1, DI, EI ) + CALL MVNLMS( AI, BI, 2*FINA+FINB-1, DI, EI ) IF ( DI >= EI ) GO TO 200 VAL = VAL * ( EI - DI ) - + IF ( I <= N .OR. (NdleftN < NdleftO)) THEN mY(IK) = FIINV( DI + W(IK)*( EI - DI ) ) IF (NdleftN < NdleftO ) THEN @@ -847,17 +847,17 @@ ENDIF useC1C2 = (IK+1<=mNc1c2) IF (useC1C2) THEN - + ! E(Y(J) | Y(1),...Y(I))/STD(Y(J)|Y(1),,,,Y(I)) mY(I+1:N+1) = mY(I+1:N+1) + mBIG(IK, I+1:N+1)*mY(IK) ENDIF - ENDIF + ENDIF IK = IK + 1 FINA = 0 FINB = 0 END IF END DO - IF (mNd>0) VAL = VAL * jacob(mXd,mXc) + IF (mNd>0) VAL = VAL * jacob(mXd,mXc) RETURN 200 VAL = gZERO RETURN @@ -868,53 +868,53 @@ !!******************* RINDD - the main program *********************!! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! SUBROUTINE RINDD(VALS,ERR,TERR,Big,Ex,Xc,Nt, - & indI,Blo,Bup,INFIN) + & indI,Blo,Bup,INFIN) USE RCRUDEMOD USE KRBVRCMOD USE ADAPTMOD - USE KROBOVMOD + USE KROBOVMOD USE DKBVRCMOD USE SSOBOLMOD - IMPLICIT NONE + IMPLICIT NONE DOUBLE PRECISION, DIMENSION(: ), INTENT(out):: VALS, ERR ,TERR DOUBLE PRECISION, DIMENSION(:,:), INTENT(in) :: BIG - DOUBLE PRECISION, DIMENSION(:,:), INTENT(in) :: Xc - DOUBLE PRECISION, DIMENSION(:), INTENT(in) :: Ex - DOUBLE PRECISION, DIMENSION(:,:), INTENT(in) :: Blo, Bup + DOUBLE PRECISION, DIMENSION(:,:), INTENT(in) :: Xc + DOUBLE PRECISION, DIMENSION(:), INTENT(in) :: Ex + DOUBLE PRECISION, DIMENSION(:,:), INTENT(in) :: Blo, Bup INTEGER, DIMENSION(:), INTENT(in) :: indI,INFIN - INTEGER, INTENT(in) :: Nt + INTEGER, INTENT(in) :: Nt ! DOUBLE PRECISION, INTENT(in) :: XcScale ! local variables INTEGER :: ix, INFORM, NDIM, MAXPTS, MINPTS DOUBLE PRECISION :: VALUE,fxc,absERR,absERR2 double precision :: LABSEPS,LRELEPS - - - VALS(:) = gZERO - ERR(:) = gONE - TERR(:) = gONE - - call preInit(BIG,Xc,Nt,inform) - IF (INFORM.GT.0) GOTO 110 ! degenerate case exit VALS=0 for all + + + VALS(:) = gZERO + ERR(:) = gONE + TERR(:) = gONE + + call preInit(BIG,Xc,Nt,inform) + IF (INFORM.GT.0) GOTO 110 ! degenerate case exit VALS=0 for all ! (should perhaps return NaN instead??) ! Now the loop over all different values of -! variables Xc (the one one is conditioning on) +! variables Xc (the one one is conditioning on) ! is started. The density f_{Xc}(xc(:,ix)) ! will be computed and denoted by fxc. - DO ix = 1, mNx + DO ix = 1, mNx call initIntegrand(ix,Xc,Ex,indI,Blo,Bup,infin, & fxc,value,abserr,NDIM,inform) - - IF (INFORM.GT.0) GO TO 100 - + + IF (INFORM.GT.0) GO TO 100 + MAXPTS = mMAXPTS MINPTS = mMINPTS LABSEPS = max(mABSEPS-abserr,0.2D0*mABSEPS) !*fxc LRELEPS = mRELEPS ABSERR2 = mSmall - + SELECT CASE (mMethod) CASE (:1) IF (NDIM < 9) THEN @@ -925,7 +925,7 @@ CALL KRBVRC(NDIM, MINPTS, MAXPTS, MVNFUN,LABSEPS,LRELEPS, & ABSERR2, VALUE, INFORM ) ENDIF - CASE (2) + CASE (2) ! Call the subregion adaptive integration subroutine IF ( NDIM .GT. 19.) THEN ! print *, 'Ndim too large for SADMVN => Calling KRBVRC' @@ -940,39 +940,39 @@ CALL KRBVRC( NDIM, MINPTS, MAXPTS, MVNFUN, LABSEPS, & LRELEPS, ABSERR2, VALUE, INFORM ) CASE (4) ! Call the Lattice rule - ! integration procedure + ! integration procedure CALL KROBOV( NDIM, MINPTS, MAXPTS, MVNFUN, LABSEPS, & LRELEPS,ABSERR2, VALUE, INFORM ) CASE (5) ! Call Crude Monte Carlo integration procedure - CALL RANMC( NDIM, MAXPTS, MVNFUN, LABSEPS, - & LRELEPS, ABSERR2, VALUE, INFORM ) + CALL RANMC( NDIM, MAXPTS, MVNFUN, LABSEPS, + & LRELEPS, ABSERR2, VALUE, INFORM ) CASE (6) ! Call the scrambled Sobol sequence rule integration procedure CALL SOBNIED( NDIM, MINPTS, MAXPTS, MVNFUN, LABSEPS, LRELEPS, - & ABSERR2, VALUE, INFORM ) - CASE (7:) - CALL DKBVRC( NDIM, MINPTS, MAXPTS, MVNFUN, LABSEPS, LRELEPS, & ABSERR2, VALUE, INFORM ) - END SELECT + CASE (7:) + CALL DKBVRC( NDIM, MINPTS, MAXPTS, MVNFUN, LABSEPS, LRELEPS, + & ABSERR2, VALUE, INFORM ) + END SELECT ! IF (INFORM.gt.0) print *,'RIND, INFORM,error =',inform,error - 100 VALS(ix) = VALUE*fxc - IF (SIZE(ERR, DIM = 1).EQ.mNx) ERR(ix) = abserr2*fxc - IF (SIZE(TERR, DIM = 1).EQ.mNx) TERR(ix) = abserr*fxc + 100 VALS(ix) = VALUE*fxc + IF (SIZE(ERR, DIM = 1).EQ.mNx) ERR(ix) = abserr2*fxc + IF (SIZE(TERR, DIM = 1).EQ.mNx) TERR(ix) = abserr*fxc ENDDO !ix 110 CONTINUE call cleanUp - RETURN + RETURN END SUBROUTINE RINDD - - SUBROUTINE setIntLimits(xc,indI,Blo,Bup,INFIN,inform) + + SUBROUTINE setIntLimits(xc,indI,Blo,Bup,INFIN,inform) IMPLICIT NONE DOUBLE PRECISION, DIMENSION(: ), INTENT(in) :: xc - INTEGER, DIMENSION(: ), INTENT(in) :: indI,INFIN - DOUBLE PRECISION, DIMENSION(:,:), INTENT(in) :: Blo,Bup + INTEGER, DIMENSION(: ), INTENT(in) :: indI,INFIN + DOUBLE PRECISION, DIMENSION(:,:), INTENT(in) :: Blo,Bup integer, intent(out) :: inform !Local variables - INTEGER :: I, J, K, L,Mb1,Nb,NI,Nc + INTEGER :: I, J, K, L,Mb1,Nb,NI,Nc DOUBLE PRECISION :: xCut, SQ0 !this procedure set mA,mB and mInfi according to Blo/Bup and INFIN ! @@ -992,44 +992,44 @@ NI = size(indI,DIM=1) Nc = size(xc,DIM=1) if (Mb1>Nc .or. Nb.NE.NI-1) then -! size of variables inconsistent +! size of variables inconsistent inform = 4 return endif - + ! IF (Mb.GT.Nc+1) print *,'barrier: Mb,Nc =',Mb,Nc ! IF (Nb.NE.NI-1) print *,'barrier: Nb,NI =',Nb,NI - DO J = 2, NI + DO J = 2, NI DO I = indI (J - 1) + 1 , indI (J) - L = mXedni(I) + L = mXedni(I) mINFI(L) = INFIN(J-1) SQ0 = SQRT(mBIG(L,L)) mA(L) = -xCut*SQ0 mB(L) = xCut*SQ0 IF (mINFI(L).GE.0) THEN IF (mINFI(L).NE.0) THEN - mA(L) = Blo (1, J - 1)-mCm(L) + mA(L) = Blo (1, J - 1)-mCm(L) DO K = 1, Mb1 - mA(L) = mA(L)+Blo(K+1,J-1)*xc(K) + mA(L) = mA(L)+Blo(K+1,J-1)*xc(K) ENDDO ! K - ! This can only be done if + ! This can only be done if if (mA(L)< -xCut*SQ0) mINFI(L) = mINFI(L)-2 ENDIF IF (mINFI(L).NE.1) THEN - mB(L) = Bup (1, J - 1)-mCm(L) + mB(L) = Bup (1, J - 1)-mCm(L) DO K = 1, Mb1 mB(L) = mB(L)+Bup(K+1,J-1)*xc(K) - ENDDO + ENDDO if (xCut*SQ0B(I) or -! -! b) Cm(I)+x1*B1(I)+C*SQ(I)B(I) or +! +! b) Cm(I)+x1*B1(I)+C*SQ(I)-1) THEN - !BdSQ0 = B1(I) + !BdSQ0 = B1(I) !CSQ = xCut * SQ(I) BdSQ0 = BIG(IK,I) CSQ = xCut * BIG(I,IK) @@ -1170,8 +1170,8 @@ ELSE BJ = (B(I) - Cm(I) + CSQ)/BdSQ0 FINB = 1 - ENDIF - IF (FINA.GT.0) BJ = MAX(AJ,BJ) + ENDIF + IF (FINA.GT.0) BJ = MAX(AJ,BJ) END IF ELSEIF (BdSQ0 < -LTOL) THEN IF ( INFI .NE. 0 ) THEN @@ -1181,7 +1181,7 @@ BJ = (A(I) - Cm(I) - CSQ)/BdSQ0 FINB = 1 ENDIF - IF (FINA.GT.0) BJ = MAX(AJ,BJ) + IF (FINA.GT.0) BJ = MAX(AJ,BJ) END IF IF ( INFI .NE. 1 ) THEN IF (FINA.EQ.1) THEN @@ -1192,7 +1192,7 @@ ENDIF IF (FINB.GT.0) AJ = MIN(AJ,BJ) END IF - END IF + END IF ENDIF END DO ! IF (FINA>0 .AND. FINB>0) THEN @@ -1209,48 +1209,48 @@ ! USE GLOBALDATA, ONLY : XCEPS2 ! USE GLOBALCONST IMPLICIT NONE - INTEGER, INTENT(in) :: Nt,Nd + INTEGER, INTENT(in) :: Nt,Nd DOUBLE PRECISION, DIMENSION(:,:), INTENT(inout) :: R - INTEGER, DIMENSION(: ), INTENT(inout) :: index1 - INTEGER, INTENT(out) :: INFORM + INTEGER, DIMENSION(: ), INTENT(inout) :: index1 + INTEGER, INTENT(out) :: INFORM ! local variables DOUBLE PRECISION, DIMENSION(:), allocatable :: SQ INTEGER, DIMENSION(1) :: m INTEGER :: M1,K,I,J,Ntdc,Ntd,Nc, LO DOUBLE PRECISION :: LTOL, maxSQ -! if any Var(Xc(j)|Xc(1),...,Xc(j-1)) <= XCEPS2 then return NAN - double precision :: XCEPS2 +! if any Var(Xc(j)|Xc(1),...,Xc(j-1)) <= XCEPS2 then return NAN + double precision :: XCEPS2 !CVSRTXC calculate the conditional covariance matrix of Xt and Xd given Xc ! as well as the cholesky factorization for the Xc variable(s) ! The Xc variables are sorted by the largest conditional covariance -! +! ! R = In : Cov(X) where X=[Xt Xd Xc] is stochastic vector ! Out: sorted Conditional Covar. matrix, i.e., -! [ Cov([Xt,Xd] | Xc) Shape N X N (N=Ntdc=Nt+Nd+Nc) -! index1 = In/Out : permutation vector giving the indices to the variables +! [ Cov([Xt,Xd] | Xc) Shape N X N (N=Ntdc=Nt+Nd+Nc) +! index1 = In/Out : permutation vector giving the indices to the variables ! original place. Size Ntdc ! INFORM = Out, Returns ! 0 If Normal termination. ! 1 If R is degenerate, i.e., Cov(Xc) is singular. -! -! R=Cov([Xt,Xd,Xc]) is a covariance matrix of the stochastic +! +! R=Cov([Xt,Xd,Xc]) is a covariance matrix of the stochastic ! vector X=[Xt Xd Xc] where the variables Xt, Xd and Xc have the size -! Nt, Nd and Nc, respectively. +! Nt, Nd and Nc, respectively. ! Xc are the conditional variables. -! Xd and Xt are the variables to integrate. +! Xd and Xt are the variables to integrate. !(Xd,Xt = variables in the jacobian and indicator respectively) ! ! Note: CVSRTXC only works on the upper triangular part of R - + INFORM = 0 Ntdc = size(R,DIM=1) Ntd = Nt + Nd Nc = Ntdc - Ntd - + IF (Nc < 1) RETURN - - - + + + ALLOCATE(SQ(1:Ntdc)) maxSQ = gZERO DO I = 1, Ntdc @@ -1264,10 +1264,10 @@ LO = 1 K = Ntdc DO I = 1, Nc ! Condsort Xc - m = K+1-MAXLOC(SQ(K:Ntd+1:-1)) + m = K+1-MAXLOC(SQ(K:Ntd+1:-1)) M1 = m(1) IF (SQ(m1)<=XCEPS2) THEN -! PRINT *,'CVSRTXC: Degenerate case of Xc(Nc-J+1) for J=',ix +! PRINT *,'CVSRTXC: Degenerate case of Xc(Nc-J+1) for J=',ix !CALL mexprintf('CVSRTXC: Degenerate case of Xc(Nc-J+1)') INFORM = 1 GOTO 200 ! RETURN !degenerate case @@ -1301,7 +1301,7 @@ R(J,J) = SQ(J) R(LO:J-1,J) = R(LO:J-1,J) - R(LO:J-1,K)*R(J,K) ENDIF - END DO + END DO K = K - 1 ENDDO 200 DEALLOCATE(SQ) @@ -1318,17 +1318,17 @@ ! CALL RCSCALE( k, k0, N1, N,K1, CDI,Cm,R,A, B, INFIN,index1,Y) ! ! chkLim = TRUE if check if variable K is redundant -! FALSE +! FALSE ! K = index to variable which is deterministic,i.e., ! STD(Xk|X1,...Xr) = 0 -! N1 = Number of significant variables of [Xt,Xd] +! N1 = Number of significant variables of [Xt,Xd] ! N = length(Xt)+length(Xd) ! K1 = index to current variable we are conditioning on. ! CDI = Cholesky diagonal elements which contains either ! CDI(J) = STD(Xj | X1,...,Xj-1,Xc) if Xj is stochastic given ! X1,...Xj, Xc ! or -! CDI(J) = COV(Xj,Xk | X1,..,Xk-1,Xc )/STD(Xk | X1,..,Xk-1,Xc) +! CDI(J) = COV(Xj,Xk | X1,..,Xk-1,Xc )/STD(Xk | X1,..,Xk-1,Xc) ! if Xj is determinstically determined given X1,..,Xk,Xc ! for some k LTOL) .OR. (isXt)) THEN + IF ( (R(I,I) > LTOL) .OR. (isXt)) THEN DO J = 1,I-1 isXd = (INDEX1(J)>Nt) IF ( (R(J,J) <= LTOL) .AND.isXd) THEN CALL RCSWAP(J, I, N, N, R,INDEX1,Cm, A, B, INFI) - !GO TO 10 + !GO TO 10 CYCLE LP3 ENDIF END DO ENDIF -! 10 - END DO LP3 -! +! 10 + END DO LP3 +! ! Move any doubly infinite limits or any redundant of Xt to the next ! innermost positions. -! +! LP4: DO I = N-INFISD, N1+1, -1 isXd = (INDEX1(I)>Nt) IF ( ((INFI(I) > -1).AND.(R(I,I) > LTOL)) - & .OR. isXd) THEN + & .OR. isXd) THEN DO J = 1,I-1 isXt = (INDEX1(J)<=Nt) - IF ( (INFI(J) < 0 .OR. (R(J,J)<= LTOL)) + IF ( (INFI(J) < 0 .OR. (R(J,J)<= LTOL)) & .AND. (isXt)) THEN CALL RCSWAP( J, I, N,N, R,INDEX1,Cm, A, B, INFI) - !GO TO 15 + !GO TO 15 CYCLE LP4 ENDIF END DO ENDIF -!15 +!15 END DO LP4 ! CALL mexprintf('Before sorting') ! CALL PRINTCOF(N,A,B,INFI,R,INDEX1) ! CALL PRINTVEC(CDI,'CDI') ! CALL PRINTVEC(Cm,'Cm') - + IF ( N1 <= 0 ) GOTO 200 -! +! ! Sort remaining limits and determine Cholesky factor. -! +! Y(1:N1) = gZERO K = 1 Ndleft = Nd - INFISD Nullity = 0 - DO WHILE (K .LE. N1) - + DO WHILE (K .LE. N1) + ! IF (Ndim.EQ.3) EPSL = MAX(EPS2,1D-10) ! Determine the integration limits for variable with minimum ! expected probability and interchange that variable with Kth. - + K0 = K - Nullity PRBMIN = gTWO JMIN = K @@ -1707,7 +1707,7 @@ TMP = TMP + R(I,J)*Y(I) END DO SUMSQ = SQRT( R(J,J)) - + IF (INFI(J)>-1) THEN ! May have infinite int. limits if Nd>0 IF (INFI(J).NE.0) THEN @@ -1721,7 +1721,7 @@ AA = (Cm(J)+TMP)/SUMSQ ! inflection point CALL EXLMS(AA,AJ,BJ,INFI(J),D,E,Ca,Pa) PRBJ = E - D - ELSE + ELSE !CALL MVNLMS( AJ, BJ, INFI(J), D, E ) CALL MVNLIMITS(AJ,BJ,INFI(J),APJ,PRBJ) ENDIF @@ -1734,20 +1734,20 @@ CVDIAG = SUMSQ ENDIF ENDIF - END DO + END DO END IF -! +! ! Compute Ith column of Cholesky factor. ! Compute expected value for Ith integration variable (without ! considering the jacobian) and ! scale Ith covariance matrix row and limits. -! -! 40 +! +! 40 IF ( CVDIAG.GT.TOL) THEN isXd = (INDEX1(JMIN)>Nt) IF (isXd) THEN - Ndleft = Ndleft - 1 - ELSEIF (BCVSRT.EQV..FALSE..AND.(PRBMIN+LTOL>=gONE)) THEN + Ndleft = Ndleft - 1 + ELSEIF (BCVSRT.EQV..FALSE..AND.(PRBMIN+LTOL>=gONE)) THEN !BCVSRT.EQ. J = 1 AJ = R(J,JMIN)*xCut @@ -1766,12 +1766,12 @@ INFJ = INFI(JMIN) AJ = A(JMIN)+AJ BJ = B(JMIN)+BJ - + D = gZERO DO J = 2, K0-1 D = D + ABS(R(J,JMIN)) END DO - + AJ = (AJ + D*xCut)/CVDIAG BJ = (BJ - D*xCut)/CVDIAG CALL ADJLIMITS(AJ,BJ,INFJ) @@ -1782,15 +1782,15 @@ CALL RCSWAP( JMIN,N1,N1,N,R,INDEX1,Cm,A,B,INFI) ! move conditional standarddeviations R(JMIN,1:K0-1) = R(N1,1:K0-1) - - Y(JMIN) = Y(N1) + + Y(JMIN) = Y(N1) ENDIF R(1:N1,N1) = gZERO R(N1,1:N1) = gZERO Y(N1) = gZERO INFIS = INFIS+1 N1 = N1-1 - GOTO 100 + GOTO 100 END IF ENDIF NDIM = NDIM + 1 !Number of relevant dimensions to integrate @@ -1802,24 +1802,24 @@ CALL SWAP(R(K,J),R(JMIN,J)) END DO END IF - - R(K0,K) = CVDIAG + + R(K0,K) = CVDIAG CDI(K) = CVDIAG ! Store the diagonal element DO I = K0+1,K R(I,K) = gZERO; R(K,I) = gZERO END DO - K1 = K + K1 = K I = K1 + 1 - DO WHILE (I <= N1) + DO WHILE (I <= N1) TMP = ZERO DO J = 1, K0 - 1 !tmp = tmp + L(i,j).*L(k1,j) - TMP = TMP + R(J,I)*R(J,K1) + TMP = TMP + R(J,I)*R(J,K1) END DO ! Cov(Xk,Xi|X1,X2,...Xk-1)/STD(Xk|X1,X2,...Xk-1) - R(K0,I) = (R(K1,I) - TMP) /CVDIAG + R(K0,I) = (R(K1,I) - TMP) /CVDIAG ! Var(Xi|X1,X2,...Xk) R(I,I) = R(I,I) - R(K0,I) * R(K0,I) @@ -1829,8 +1829,8 @@ !CALL mexprintf('Singular') isXd = (index1(I)>Nt) if (isXd) then - Ndleft = Ndleft - 1 - ELSEIF (BCVSRT.EQV..FALSE.) THEN + Ndleft = Ndleft - 1 + ELSEIF (BCVSRT.EQV..FALSE.) THEN ! BCVSRT.EQ. J = 1 AJ = R(J,I)*xCut @@ -1849,12 +1849,12 @@ INFJ = INFI(I) AJ = A(I)+AJ BJ = B(I)+BJ - + D = gZERO DO J = 2, K0 D = D + ABS(R(J,I)) END DO - + AJ = (AJ + D*xCut)-mXcutOff BJ = (BJ - D*xCut)+mXcutOff !call printvar(Aj,'Aj') @@ -1867,18 +1867,18 @@ CALL RCSWAP( I,N1,N1,N,R,INDEX1,Cm,A,B,INFI) ! move conditional standarddeviations R(I,1:K0-1) = R(N1,1:K0-1) - - Y(I) = Y(N1) + + Y(I) = Y(N1) ENDIF R(1:N1,N1) = gZERO R(N1,1:N1) = gZERO Y(N1) = gZERO INFIS = INFIS+1 N1 = N1-1 - + !CALL mexprintf('covsrt updated N1') !call printvar(INFIS,' Infis') - GOTO 75 + GOTO 75 END IF END IF IF (mNIT>100) THEN @@ -1901,9 +1901,9 @@ & R,A,B,INFI,INDEX1) if (L.ne.INFIS) THEN K = K - 1 - I = I - 1 + I = I - 1 ENDIF - END IF + END IF I = I + 1 75 CONTINUE END DO @@ -1916,26 +1916,26 @@ IF (INFJ.NE.0) FINA = 1 IF (INFJ.NE.1) FINB = 1 ENDIF - CALL C1C2(K1+1,N1,K0,A,B,INFI, Y, R, + CALL C1C2(K1+1,N1,K0,A,B,INFI, Y, R, & AMIN, BMIN, FINA,FINB) INFJ = 2*FINA+FINB-1 - CALL MVNLIMITS(AMIN,BMIN,INFJ,APJ,PRBMIN) + CALL MVNLIMITS(AMIN,BMIN,INFJ,APJ,PRBMIN) ENDIF - + Y(K0) = gettmean(AMIN,BMIN,INFJ,PRBMIN) - - R( K0, K1 ) = R( K0, K1 ) / CVDIAG + + R( K0, K1 ) = R( K0, K1 ) / CVDIAG DO J = 1, K0 - 1 ! conditional covariances - R( J, K1 ) = R( J, K1 ) / CVDIAG + R( J, K1 ) = R( J, K1 ) / CVDIAG ! conditional standard dev.s used in regression eq. - R( K1, J ) = R( K1, J ) / CVDIAG + R( K1, J ) = R( K1, J ) / CVDIAG END DO - + A( K1 ) = A( K1 )/CVDIAG B( K1 ) = B( K1 )/CVDIAG - + K = K + 1 100 CONTINUE ELSE @@ -1944,7 +1944,7 @@ I = K DO WHILE (I <= N1) ! Scale covariance matrix rows and limits -! If the conditional covariance matrix diagonal entry is zero, +! If the conditional covariance matrix diagonal entry is zero, ! permute limits and/or rows, if necessary. chkLim = ((index1(I)<=Nt).AND.(BCVSRT.EQV..FALSE.)) L = INFIS @@ -1955,7 +1955,7 @@ Nullity = N1 - K0 + 1 GOTO 200 !RETURN END IF - END DO + END DO 200 CONTINUE IF (Ndim .GT. 0) THEN ! N10 IF (INFI(J).NE.0) THEN AJ = ( A(J) - TMP )/SUMSQ @@ -2201,20 +2201,20 @@ CVDIAG = SUMSQ ENDIF ENDIF - END DO + END DO END IF -! +! ! Compute Ith column of Cholesky factor. ! Compute expected value for Ith integration variable (without ! considering the jacobian) and ! scale Ith covariance matrix row and limits. -! -!40 +! +!40 IF ( CVDIAG.GT.TOL) THEN IF (INDEX1(JMIN).GT.Nt) THEN Ndleft = Ndleft-1 ELSE - IF (BCVSRT.EQV..FALSE..AND.(PRBMIN+LTOL.GE.gONE)) THEN + IF (BCVSRT.EQV..FALSE..AND.(PRBMIN+LTOL.GE.gONE)) THEN !BCVSRT.EQ. I = 1 AJ = R(I,JMIN)*xCut @@ -2239,7 +2239,7 @@ D = D + ABS(R(I,JMIN)) END DO - + AJ = (AJ + D*xCut)/CVDIAG BJ = (BJ - D*xCut)/CVDIAG @@ -2250,21 +2250,21 @@ IF ( JMIN < N1 ) THEN CALL RCSWAP( JMIN, N1, N1,N, R,INDEX1,Cm, A, B, INFI) ! SWAP conditional standarddeviations - DO I = 1,K0-1 + DO I = 1,K0-1 CALL SWAP(R(JMIN,I),R(N1,I)) END DO CALL SWAP(Y(N1),Y(JMIN)) ENDIF INFIS = INFIS+1 N1 = N1-1 - GOTO 100 - END IF + GOTO 100 + END IF ENDIF ENDIF NDIM = NDIM + 1 !Number of relevant dimensions to integrate IF ( K < JMIN ) THEN - + CALL RCSWAP( K, JMIN, N1,N, R,INDEX1,Cm, A, B, INFI) ! SWAP conditional standarddeviations DO J=1,K0-1 @@ -2272,8 +2272,8 @@ END DO CALL SWAP(Y(K),Y(JMIN)) END IF - - + + R(K0,K:N1) = R(K0,K:N1)/CVDIAG R(K0,K) = CVDIAG CDI(K) = CVDIAG ! Store the diagonal element @@ -2281,10 +2281,10 @@ R(I,K) = ZERO R(K,I) = ZERO END DO - + K1 = K !IF (K .EQ. N1) GOTO 200 - + ! Cov(Xi,Xj|Xk,Xk+1,..,Xn)= ! Cov(Xi,Xj|Xk+1,..,Xn) - ! Cov(Xi,Xk|Xk+1,..Xn)*Cov(Xj,Xk|Xk+1,..Xn) @@ -2306,7 +2306,7 @@ CALL SWAP(R(K,J),R(I,J)) END DO CALL SWAP(Y(K),Y(I)) - ENDIF + ENDIF isXd = (INDEX1(K).GT.Nt) IF (isXd) Ndleft = Ndleft-1 chkLim = ((.not.isXd).AND.(BCVSRT.EQV..FALSE.)) @@ -2314,9 +2314,9 @@ CALL RCSCALE(chkLim,K,K0,N1,N,K1,INFIS,CDI,Cm, & R,A,B,INFI,INDEX1,Y) IF (L.NE.INFIS) I = I - 1 - END IF + END IF I = I +1 - END DO + END DO INFJ = INFI(K1) IF (K0 == 1) THEN FINA = 0 @@ -2325,15 +2325,15 @@ IF (INFJ.NE.0) FINA = 1 IF (INFJ.NE.1) FINB = 1 ENDIF - CALL C1C2(K1+1,N1,K0,A,B,INFI, Y, R, + CALL C1C2(K1+1,N1,K0,A,B,INFI, Y, R, & AMIN, BMIN, FINA,FINB) INFJ = 2*FINA+FINB-1 - CALL MVNLIMITS(AMIN,BMIN,INFJ,APJ,PRBMIN) + CALL MVNLIMITS(AMIN,BMIN,INFJ,APJ,PRBMIN) ENDIF Y(K0) = GETTMEAN(AMIN,BMIN,INFJ,PRBMIN) - ! conditional mean (expectation) - ! E(Y(K+1:N)|Y(1),Y(2),...,Y(K)) + ! conditional mean (expectation) + ! E(Y(K+1:N)|Y(1),Y(2),...,Y(K)) Y(K+1:N1) = Y(K+1:N1)+Y(K0)*R(K0,K+1:N1) R(K0,K1) = R(K0,K1)/CVDIAG ! conditional covariances DO J = 1, K0 - 1 @@ -2345,13 +2345,13 @@ K = K + 1 100 CONTINUE - ELSE + ELSE R(K:N1,K:N1) = gZERO ! CALL PRINTCOF(N,A,B,INFI,R,INDEX1) I = K DO WHILE (I <= N1) ! Scale covariance matrix rows and limits -! If the conditional covariance matrix diagonal entry is zero, +! If the conditional covariance matrix diagonal entry is zero, ! permute limits and/or rows, if necessary. chkLim = ((index1(I)<=Nt).AND.(BCVSRT.EQV..FALSE.)) L = INFIS @@ -2360,10 +2360,10 @@ if (L.EQ.INFIS) I = I + 1 END DO Nullity = N1 - K0 + 1 - GOTO 200 !RETURN + GOTO 200 !RETURN END IF - END DO - + END DO + 200 CONTINUE IF (Ndim .GT. 0) THEN ! N1