[r-cran-spc] 15/17: New upstream version 0.5.3
Andreas Tille
tille at debian.org
Sat Oct 21 06:30:49 UTC 2017
This is an automated email from the git hooks/post-receive script.
tille pushed a commit to branch master
in repository r-cran-spc.
commit 956de04860da650f455ad74d42275a8e745b9520
Author: Andreas Tille <tille at debian.org>
Date: Sat Oct 21 08:28:09 2017 +0200
New upstream version 0.5.3
---
DESCRIPTION | 24 +
MD5 | 193 +
NAMESPACE | 25 +
R/dphat.R | 28 +
R/lns2ewma.arl.R | 36 +
R/lns2ewma.crit.R | 53 +
R/mewma.ad.R | 37 +
R/mewma.arl.R | 36 +
R/mewma.arl.f.R | 206 +
R/mewma.crit.R | 16 +
R/mewma.psi.R | 31 +
R/p.ewma.arl.R | 19 +
R/phat.ewma.arl.R | 42 +
R/phat.ewma.crit.R | 31 +
R/phat.ewma.lambda.R | 32 +
R/pphat.R | 29 +
R/qphat.R | 25 +
R/quadrature.nodes.weights.R | 15 +
R/s.res.ewma.arl.R | 29 +
R/scusum.arl.R | 42 +
R/scusum.crit.R | 51 +
R/sewma.arl.R | 38 +
R/sewma.arl.prerun.R | 35 +
R/sewma.crit.R | 67 +
R/sewma.crit.prerun.R | 45 +
R/sewma.q.R | 22 +
R/sewma.q.crit.R | 43 +
R/sewma.q.crit.prerun.R | 47 +
R/sewma.q.prerun.R | 26 +
R/sewma.sf.R | 21 +
R/sewma.sf.prerun.R | 24 +
R/tol.lim.fac.R | 19 +
R/x.res.ewma.arl.R | 24 +
R/xDcusum.arl.R | 31 +
R/xDewma.arl.R | 36 +
R/xDgrsr.arl.R | 37 +
R/xDshewhartrunsrules.arl.R | 18 +
R/xDshewhartrunsrulesFixedm.arl.R | 28 +
R/xcusum.ad.R | 21 +
R/xcusum.arl.R | 26 +
R/xcusum.crit.L0L1.R | 36 +
R/xcusum.crit.L0h.R | 31 +
R/xcusum.crit.R | 20 +
R/xcusum.q.R | 15 +
R/xcusum.sf.R | 15 +
R/xewma.ad.R | 31 +
R/xewma.arl.R | 38 +
R/xewma.arl.prerun.R | 32 +
R/xewma.crit.R | 31 +
R/xewma.crit.prerun.R | 66 +
R/xewma.q.R | 24 +
R/xewma.q.crit.R | 32 +
R/xewma.q.crit.prerun.R | 72 +
R/xewma.q.prerun.R | 35 +
R/xewma.sf.R | 24 +
R/xewma.sf.prerun.R | 34 +
R/xgrsr.ad.R | 17 +
R/xgrsr.arl.R | 21 +
R/xgrsr.crit.R | 19 +
R/xs.res.ewma.arl.R | 37 +
R/xs.res.ewma.pms.R | 41 +
R/xsewma.arl.R | 46 +
R/xsewma.crit.R | 51 +
R/xsewma.q.R | 40 +
R/xsewma.q.crit.R | 37 +
R/xsewma.sf.R | 32 +
R/xshewhart.ar1.arl.R | 10 +
R/xshewhartrunsrules.ad.R | 25 +
R/xshewhartrunsrules.arl.R | 21 +
R/xshewhartrunsrules.crit.R | 20 +
R/xshewhartrunsrules.matrix.R | 163 +
R/xtcusum.arl.R | 24 +
R/xtewma.ad.R | 32 +
R/xtewma.arl.R | 40 +
R/xtewma.q.R | 26 +
R/xtewma.q.crit.R | 32 +
R/xtewma.sf.R | 25 +
debian/README.test | 5 -
debian/changelog | 61 -
debian/compat | 1 -
debian/control | 29 -
debian/copyright | 29 -
debian/rules | 4 -
debian/source/format | 1 -
debian/watch | 2 -
man/dphat.Rd | 73 +
man/lns2ewma.crit.Rd | 73 +
man/lns2sewma.arl.Rd | 94 +
man/mewma.arl.Rd | 125 +
man/mewma.crit.Rd | 34 +
man/mewma.psi.Rd | 42 +
man/p.ewma.arl.Rd | 78 +
man/phat.ewma.arl.Rd | 116 +
man/quadrature.nodes.weights.Rd | 37 +
man/scusum.arl.Rd | 67 +
man/scusum.crit.Rd | 57 +
man/sewma.arl.Rd | 109 +
man/sewma.arl.prerun.Rd | 53 +
man/sewma.crit.Rd | 157 +
man/sewma.crit.prerun.Rd | 72 +
man/sewma.q.Rd | 92 +
man/sewma.q.prerun.Rd | 76 +
man/sewma.sf.Rd | 56 +
man/sewma.sf.prerun.Rd | 60 +
man/tol.lim.fact.Rd | 73 +
man/xDcusum.arl.Rd | 137 +
man/xDewma.arl.Rd | 252 +
man/xDgrsr.arl.Rd | 101 +
man/xDshewhartrunsrules.arl.Rd | 87 +
man/xcusum.ad.Rd | 78 +
man/xcusum.arl.Rd | 179 +
man/xcusum.crit.L0L1.Rd | 87 +
man/xcusum.crit.L0h.Rd | 41 +
man/xcusum.crit.Rd | 34 +
man/xcusum.q.Rd | 42 +
man/xcusum.sf.Rd | 41 +
man/xewma.ad.Rd | 89 +
man/xewma.arl.Rd | 338 +
man/xewma.arl.prerun.Rd | 111 +
man/xewma.crit.Rd | 51 +
man/xewma.q.Rd | 100 +
man/xewma.q.prerun.Rd | 120 +
man/xewma.sf.Rd | 70 +
man/xewma.sf.prerun.Rd | 103 +
man/xgrsr.ad.Rd | 89 +
man/xgrsr.arl.Rd | 133 +
man/xgrsr.crit.Rd | 53 +
man/xsewma.arl.Rd | 95 +
man/xsewma.crit.Rd | 85 +
man/xsewma.q.Rd | 83 +
man/xsewma.sf.Rd | 62 +
man/xshewhart.ar1.arl.Rd | 70 +
man/xshewhartrunsrules.arl.Rd | 113 +
man/xsresewma.arl.Rd | 211 +
man/xtcusum.arl.Rd | 56 +
man/xtewma.ad.Rd | 56 +
man/xtewma.arl.Rd | 81 +
man/xtewma.q.Rd | 73 +
man/xtewma.sf.Rd | 59 +
src/allspc.c | 19372 ++++++++++++++++++++++++++++++++++++
src/ewma_p_arl_be.c | 13 +
src/ewma_phat_arl_coll.c | 25 +
src/ewma_phat_crit_coll.c | 15 +
src/ewma_phat_lambda_coll.c | 15 +
src/lns2ewma_arl.c | 20 +
src/lns2ewma_crit.c | 44 +
src/mewma_ad.c | 11 +
src/mewma_arl.c | 70 +
src/mewma_arl_f.c | 120 +
src/mewma_crit.c | 11 +
src/mewma_psi.c | 35 +
src/phat_cdf.c | 15 +
src/phat_pdf.c | 15 +
src/phat_qf.c | 15 +
src/quadrature_nodes_weights.c | 30 +
src/scusum_arl.c | 31 +
src/scusum_crit.c | 26 +
src/sewma_arl.c | 36 +
src/sewma_arl_prerun.c | 24 +
src/sewma_crit.c | 73 +
src/sewma_crit_prerun.c | 48 +
src/sewma_q.c | 24 +
src/sewma_q_crit.c | 45 +
src/sewma_q_crit_prerun.c | 51 +
src/sewma_q_prerun.c | 25 +
src/sewma_res_arl.c | 13 +
src/sewma_sf.c | 43 +
src/sewma_sf_prerun.c | 55 +
src/tol_lim_fac.c | 16 +
src/xDcusum_arl.c | 25 +
src/xDewma_arl.c | 50 +
src/xDgrsr_arl.c | 24 +
src/xcusum_ad.c | 24 +
src/xcusum_arl.c | 42 +
src/xcusum_crit.c | 13 +
src/xcusum_q.c | 14 +
src/xcusum_sf.c | 19 +
src/xewma_ad.c | 38 +
src/xewma_arl.c | 66 +
src/xewma_arl_prerun.c | 47 +
src/xewma_crit.c | 13 +
src/xewma_q.c | 31 +
src/xewma_q_prerun.c | 47 +
src/xewma_res_arl.c | 12 +
src/xewma_sf.c | 40 +
src/xewma_sf_prerun.c | 97 +
src/xgrsr_ad.c | 16 +
src/xgrsr_arl.c | 28 +
src/xgrsr_crit.c | 16 +
src/xsewma_arl.c | 27 +
src/xsewma_crit.c | 55 +
src/xsewma_q.c | 25 +
src/xsewma_q_crit.c | 46 +
src/xsewma_res_arl.c | 19 +
src/xsewma_res_pms.c | 19 +
src/xsewma_sf.c | 32 +
src/xshewhart_ar1_arl.c | 11 +
src/xtcusum_arl.c | 17 +
src/xtewma_ad.c | 33 +
src/xtewma_arl.c | 34 +
src/xtewma_q.c | 24 +
src/xtewma_sf.c | 39 +
202 files changed, 29206 insertions(+), 132 deletions(-)
diff --git a/DESCRIPTION b/DESCRIPTION
new file mode 100644
index 0000000..416787e
--- /dev/null
+++ b/DESCRIPTION
@@ -0,0 +1,24 @@
+Package: spc
+Version: 0.5.3
+Date: 2016-02-10
+Title: Statistical Process Control -- Collection of Some Useful
+ Functions
+Author: Sven Knoth
+Maintainer: Sven Knoth <Sven.Knoth at gmx.de>
+Depends: R (>= 1.8.0)
+Description: Evaluation of control charts by means of
+ the zero-state, steady-state ARL (Average Run Length) and RL quantiles.
+ Setting up control charts for given in-control ARL. The control charts
+ under consideration are one- and two-sided EWMA, CUSUM, and
+ Shiryaev-Roberts schemes for monitoring the mean of normally
+ distributed independent data. ARL calculation
+ of the same set of schemes under drift are added.
+ Other charts and parameters are in preparation.
+ Further SPC areas will be covered as well
+ (sampling plans, capability indices ...).
+License: GPL (>= 2)
+URL: http://www.r-project.org
+NeedsCompilation: yes
+Packaged: 2016-02-05 14:49:17 UTC; knoth
+Repository: CRAN
+Date/Publication: 2016-02-08 13:37:59
diff --git a/MD5 b/MD5
new file mode 100644
index 0000000..493c356
--- /dev/null
+++ b/MD5
@@ -0,0 +1,193 @@
+6c7f056e082899a4ede80570f416535a *DESCRIPTION
+52b9bc90dded7a5478eca569c3802b10 *NAMESPACE
+938e63b937546368d2a3ad73dbc1a749 *R/dphat.R
+46823b56986ca3813c49e4fc8eb421eb *R/lns2ewma.arl.R
+0e2143506950183c7381613da155171f *R/lns2ewma.crit.R
+72a97f0a99f28290f4b993eb35405a55 *R/mewma.ad.R
+eff9aaa3257443b75311852629504916 *R/mewma.arl.R
+c2f2bf8b2d1cc2587c2e12eeec538387 *R/mewma.arl.f.R
+e68659aaacd0fe568034de97d3ced575 *R/mewma.crit.R
+d635b9dbb2f078b5fd208327b7f9d678 *R/mewma.psi.R
+086bea677bfa69d34d721ca739b8387f *R/p.ewma.arl.R
+e9cfc122ce8e168cc01df062d400d6bf *R/phat.ewma.arl.R
+a65306a9a11b5e3dac9128f086615469 *R/phat.ewma.crit.R
+cde50d6572735dec15253ac814d1294b *R/phat.ewma.lambda.R
+8493c6ffe635deab1f9b9120b14e7330 *R/pphat.R
+76dbd6c5db0fb64dfe91f76b9aab6312 *R/qphat.R
+85f5c1605413c07024e732ffc33fb789 *R/quadrature.nodes.weights.R
+317e34aaffbe5a167d6f84b92b225dc1 *R/s.res.ewma.arl.R
+fcca944c36e65ab9046977f17f0cd706 *R/scusum.arl.R
+c738ce11a5abce3a5756649839160bd5 *R/scusum.crit.R
+2acc113d9f2281a5ef782528fd90df65 *R/sewma.arl.R
+f0409e488a90344e564cb55f89445e74 *R/sewma.arl.prerun.R
+f3f68cd4d3b1d75b7f22b145115e4540 *R/sewma.crit.R
+c5bcbcb0cd59edcaed4670bea5008eb1 *R/sewma.crit.prerun.R
+b49219549f661cd0ec55ecbfa905bb93 *R/sewma.q.R
+8350a1a84ae6212b6b25fb45475acaae *R/sewma.q.crit.R
+e526b39efbc216bba1632d9b83ab8522 *R/sewma.q.crit.prerun.R
+db8fbd6c63492a8a5ae16732e32d95f3 *R/sewma.q.prerun.R
+2d6e3631fff009282f8df33565f3c7d8 *R/sewma.sf.R
+83d34c77f784b344f4dd063e0f487500 *R/sewma.sf.prerun.R
+fd57e3a90136ae5fca614785a32eb051 *R/tol.lim.fac.R
+cfee1a6bf5558cf8fa9d8ebe13a5a64b *R/x.res.ewma.arl.R
+4b7c2c8735cbd08cd1d5b8956260c8cf *R/xDcusum.arl.R
+d6682d01336ddd3a6e9543534fd03ccc *R/xDewma.arl.R
+e4c99cfb1af2723fd0ead1f9972032ab *R/xDgrsr.arl.R
+9d934ae10d381a8c6cba9bb95ac550be *R/xDshewhartrunsrules.arl.R
+94c819e0b4d5321fc2c8d37847674ce2 *R/xDshewhartrunsrulesFixedm.arl.R
+a5c7c2978c97e15c3e71db7e970714e1 *R/xcusum.ad.R
+6de6a8e9011734b608c9438ae9233cc9 *R/xcusum.arl.R
+3ece9667f05deb05a7ecf3bff05bec59 *R/xcusum.crit.L0L1.R
+159d295a0d1998df9504da0a0a820fde *R/xcusum.crit.L0h.R
+dc00420d8558cd9aa8a72799d57792ec *R/xcusum.crit.R
+f402ec38d884f261dc9ba5b74716d8ac *R/xcusum.q.R
+185c396ccf056bd67841612b7db5c376 *R/xcusum.sf.R
+35ee63dccee47665a0f6ec3b58a56fe4 *R/xewma.ad.R
+370e31d24f67acf39f935bfc77f9a88f *R/xewma.arl.R
+2384b100e60076bede8e4d667fbe29b9 *R/xewma.arl.prerun.R
+bcf9da17e5c79decfc7fe43c321cec0a *R/xewma.crit.R
+6eddc14fa12e5345561913a549b852f3 *R/xewma.crit.prerun.R
+cf4addd85eec5780753b88bd9e2af27d *R/xewma.q.R
+f5c770a08813cb160003470d1808f8ad *R/xewma.q.crit.R
+f6a968ae9d298c40c5585b00db74b8f3 *R/xewma.q.crit.prerun.R
+5738bac113bb0816739ea94fc33491c5 *R/xewma.q.prerun.R
+63bc340f0e5f72bd03910aac54b87dc8 *R/xewma.sf.R
+b84367be01626eb8912c9fb3cf3aa12b *R/xewma.sf.prerun.R
+3266bb62646ca179fbda8b5d98e155f6 *R/xgrsr.ad.R
+f94cb6ba4c3c528b98b09e3d53e95846 *R/xgrsr.arl.R
+ef4268f136ee02ccadc72b02e66759ff *R/xgrsr.crit.R
+30199f064e29b335f1cf70fb054d148b *R/xs.res.ewma.arl.R
+48049b56879a2d94d06d60ad44a2f440 *R/xs.res.ewma.pms.R
+3bd74fbfc2191fedce471f23d056bb17 *R/xsewma.arl.R
+7555235086a9b36f11505121fcb4d223 *R/xsewma.crit.R
+97b870b8e3fb5ee15acaba3236f6c7c8 *R/xsewma.q.R
+bdc534ec6379c94bcf559f279d14e49f *R/xsewma.q.crit.R
+f35fe332fd717ed54d72ee9c7b69b015 *R/xsewma.sf.R
+b9faf08ba81def9017f9ae184c03a9c8 *R/xshewhart.ar1.arl.R
+24bbe9df9f8a6abe6c497ed01a17d397 *R/xshewhartrunsrules.ad.R
+4facffeca81aa3f9ac0f2b9e8089902d *R/xshewhartrunsrules.arl.R
+6301fa5dedf8ba0804e7a03914836094 *R/xshewhartrunsrules.crit.R
+886226d03f84cfbcef6d779d76df6c1b *R/xshewhartrunsrules.matrix.R
+e3adc64172316afd9a2ad78b611cb797 *R/xtcusum.arl.R
+b342f3113b2c398924824e5c15c0162a *R/xtewma.ad.R
+3271e757c33e48d87e87f773ad9f6364 *R/xtewma.arl.R
+ed29d98eef38e0ae9c70d81016ef3a4b *R/xtewma.q.R
+456f24087f1d58b0bee856fe348ec065 *R/xtewma.q.crit.R
+a4f288e5b90e0ad70393a46f64c89695 *R/xtewma.sf.R
+08424d9ece6e6b1be221fdda65e878d0 *man/dphat.Rd
+271ba55c1ce16a250f99878b44cdb563 *man/lns2ewma.crit.Rd
+88c66319a2af8f03cd10de612085d4cd *man/lns2sewma.arl.Rd
+b0472b08082e44819247c6429df4f9a7 *man/mewma.arl.Rd
+b5010cff3d7f8e4325d4f332af3cc235 *man/mewma.crit.Rd
+623eb1c5b2ee8a9595976ab2678d350d *man/mewma.psi.Rd
+033dc9ed7c40653ab7774c5e1ce0d3ae *man/p.ewma.arl.Rd
+7bdda3d7ac509853fab1dc68a1e99ba3 *man/phat.ewma.arl.Rd
+d57dfa5c57e9ec103545a443d203d675 *man/quadrature.nodes.weights.Rd
+0d471bf118ec7405bbdc4fd8106c70c9 *man/scusum.arl.Rd
+686d334f1eeb578afbdeb7f56ccb9249 *man/scusum.crit.Rd
+015f2d7adf1b312393a1deff41b82f0b *man/sewma.arl.Rd
+88486e28395605d39cec22b4189ae192 *man/sewma.arl.prerun.Rd
+6b79d31a43f78798b0b9a973afddaf63 *man/sewma.crit.Rd
+68095ff731ea8d0188595143ea8e83ae *man/sewma.crit.prerun.Rd
+d672fd509f2abcbff612643366cbd6b3 *man/sewma.q.Rd
+a2a2d1f99d9d899af01cf9a5e8170911 *man/sewma.q.prerun.Rd
+1b5002479922de9c6d0a529df85fb448 *man/sewma.sf.Rd
+32a93216099543d787804a2280ee3dc6 *man/sewma.sf.prerun.Rd
+7640f6bb7702bfb6c0bae1cfe1118a63 *man/tol.lim.fact.Rd
+e06f37c1ade9acc3a5ed5765775df56a *man/xDcusum.arl.Rd
+59f2f599371c9489d68d9f31a0e343b6 *man/xDewma.arl.Rd
+6ffba75547def5cb7dc49d23b0bdc617 *man/xDgrsr.arl.Rd
+e3a1ea345ab1806c88b68f4ac70e9d82 *man/xDshewhartrunsrules.arl.Rd
+c6364ba0d27305c53a5f9726e21cb9ba *man/xcusum.ad.Rd
+cf68f8128736d06285e30ec9ffedb28d *man/xcusum.arl.Rd
+5628878c49afd037b1a17fdbd56620a8 *man/xcusum.crit.L0L1.Rd
+7833ee5a4777ec8c983e416db55aa11a *man/xcusum.crit.L0h.Rd
+f35459613a412ea993676ce3a6ead850 *man/xcusum.crit.Rd
+e5459a7bf1a11e07e20e1e2635092c07 *man/xcusum.q.Rd
+08f2cec21bdf235a8c7ffb5981930203 *man/xcusum.sf.Rd
+f67cefd8835b8230cb0c16dd65517579 *man/xewma.ad.Rd
+b53830c8001bc5f2c0b59ec61d0bdf5b *man/xewma.arl.Rd
+ea602bd2f4981650e51ddd94074b8f81 *man/xewma.arl.prerun.Rd
+b4138765aae313c0febf5058939bb9d8 *man/xewma.crit.Rd
+2f76da8ad4be6d7f2f209281416af874 *man/xewma.q.Rd
+b2c99083aa297992cd4c79692e3865ea *man/xewma.q.prerun.Rd
+81c4afc665901d85eee2116bed7edd53 *man/xewma.sf.Rd
+3f432ef08d8578afed11119d5bd9eb53 *man/xewma.sf.prerun.Rd
+7c1c2e57c40e68820004d82a2fcad405 *man/xgrsr.ad.Rd
+3d2057b862920530a53f0b19f0b54462 *man/xgrsr.arl.Rd
+65b0074e43108c025e6f4164afa4c23b *man/xgrsr.crit.Rd
+7a9b9c5f142ac513e3ca0f1a9d9474cf *man/xsewma.arl.Rd
+cc442af0a42b56cd24b45c6f8fe1c3e7 *man/xsewma.crit.Rd
+5598a54fa64b9e912bc51c68f527d4cb *man/xsewma.q.Rd
+d77c99948c4c0bbefd8df24282a53cc3 *man/xsewma.sf.Rd
+1e1b2afd78d8b0b2d11c9ba2ce1aa396 *man/xshewhart.ar1.arl.Rd
+c4a5ce003421597f181f44fded11fe3e *man/xshewhartrunsrules.arl.Rd
+590dffc5dfd1d2cafa16d816ce1c913c *man/xsresewma.arl.Rd
+a6ed29f1da028de10edce1926c8773a7 *man/xtcusum.arl.Rd
+23e1abd7d33a2a0600b67190d5fa4068 *man/xtewma.ad.Rd
+a0761716e88359aaced32bc28b90f70c *man/xtewma.arl.Rd
+394e66d297405c8be74ecb9803bea1a8 *man/xtewma.q.Rd
+ff3072d7d7328bec15ae828ba355df3d *man/xtewma.sf.Rd
+3a2d5892e12ec5f00c5ef5844ba4d5dc *src/allspc.c
+7f3ebbeabd48d8d15b5155cb2d627b45 *src/ewma_p_arl_be.c
+13a4e7af8e9d8ae22430511758649191 *src/ewma_phat_arl_coll.c
+e05ec9bd7cc1f2fd026b563a2e430edb *src/ewma_phat_crit_coll.c
+30d2f093b1f54044ea0899dda2f1bd36 *src/ewma_phat_lambda_coll.c
+75d7d4568b9a704e70851104f1247547 *src/lns2ewma_arl.c
+cdec3fd6820823e934b178111270db95 *src/lns2ewma_crit.c
+c2a96de10e7799e646c895faa6577557 *src/mewma_ad.c
+80a51e1645fa8894b6c100055bd37ca0 *src/mewma_arl.c
+920643c294114fbc2ae329ce97e66282 *src/mewma_arl_f.c
+e055bc9dc17c7f2e40dcdf45e2dc05b6 *src/mewma_crit.c
+4b3ca88dfd78cb7856e9322fe19ada66 *src/mewma_psi.c
+a343f3f97264c33987e3b423a0520782 *src/phat_cdf.c
+f98c7e364dd47f9e7a63bb27c484ce83 *src/phat_pdf.c
+3cf82dbe65d6accc2443aa9cfd28c5fa *src/phat_qf.c
+78d94b0dd1f7e7721c825665080cd93b *src/quadrature_nodes_weights.c
+1138bbdb1fb193171d577c20cb8bb54b *src/scusum_arl.c
+7043fc65d170cec221f04e13ae36914c *src/scusum_crit.c
+f2ff01ced990ba425fd4e712f65012bc *src/sewma_arl.c
+4c920acf8afa10f0d6bde407839da097 *src/sewma_arl_prerun.c
+f62e235bcfffdaaf07a9293ea85261f8 *src/sewma_crit.c
+d6da86484517aebe4dd0d4dabb4deaaf *src/sewma_crit_prerun.c
+548c06b8ece5ee78db8a79efb6d9b6d0 *src/sewma_q.c
+95bde8f159dcff0f056bb59fd0d3d6e8 *src/sewma_q_crit.c
+1c3dd3c3597a61b3f2bfb7dae0867fce *src/sewma_q_crit_prerun.c
+8c01dd8052ec29bb2b8bc0a144c7aed4 *src/sewma_q_prerun.c
+dfa00954609e5b3a509a286ed48501e3 *src/sewma_res_arl.c
+ecf78a7adca417976353fd6cd0b1f297 *src/sewma_sf.c
+df8e9c91ce841335e4538292f8510f50 *src/sewma_sf_prerun.c
+7d5d3b5fb77da4bc0112145513e70b07 *src/tol_lim_fac.c
+60be25c27a4db0a21d84d8853c9f79f9 *src/xDcusum_arl.c
+e30b38fec4ae87f8ae199bf0a30b6016 *src/xDewma_arl.c
+29e58e38907104709cb82387da0f5935 *src/xDgrsr_arl.c
+71f32a11f8a81361e2c6b7f7bb4f58a4 *src/xcusum_ad.c
+663e56b59a15d512e2a43e8ab826e1a6 *src/xcusum_arl.c
+eeb348dfb7c4f3b49786d5c77a56029a *src/xcusum_crit.c
+5159145d823621d789a60d0f9afcd8f0 *src/xcusum_q.c
+c80a83da167cb4812d40b0ea4dce8f4e *src/xcusum_sf.c
+6bfecdcf8570db9c713673bbc5c50c1e *src/xewma_ad.c
+ef94dc6fc6abc008d3200fe9074f7359 *src/xewma_arl.c
+07fc786c9edbae9df4f6a405b644c0bb *src/xewma_arl_prerun.c
+924e49d6f154bc51d6e70083c531a661 *src/xewma_crit.c
+e7d23cc20775cadaae418303bfbc8f3c *src/xewma_q.c
+b621caf1355258ad4d164cc8e7c98973 *src/xewma_q_prerun.c
+901a9013eafee36e06a00884b00e73d9 *src/xewma_res_arl.c
+b50ac513bfd8b342ab58aa4e8160a549 *src/xewma_sf.c
+89fe3b240172c25c37237050cb4ed78a *src/xewma_sf_prerun.c
+21ea2dd23de83ac4d3a8337d247c98f3 *src/xgrsr_ad.c
+2bbc7b00f38bc2db07f67f287c1dd30c *src/xgrsr_arl.c
+963ff7aedda3bb085e576d835bab6c01 *src/xgrsr_crit.c
+1a6b03d4e482ef7fafc01e085afc49f0 *src/xsewma_arl.c
+46db106c68df8db6a078b69f6cf46244 *src/xsewma_crit.c
+ce6904e1ee2dd0804d1dbcf0eaec6458 *src/xsewma_q.c
+ec842eafa53b5f1322273285e64c1648 *src/xsewma_q_crit.c
+37996b63005a89201f5562c9061fc442 *src/xsewma_res_arl.c
+56cd4e09f23003a9b6b16f0f4b7eb66f *src/xsewma_res_pms.c
+925ce8aa0806911a53fe25042e0d6c2b *src/xsewma_sf.c
+feb70c2804fbe8ead56e7c6f2d7737b7 *src/xshewhart_ar1_arl.c
+2b775e05f140e34e322e2875ed100cc2 *src/xtcusum_arl.c
+8116ba9aa9671a9465dd2d96b256fe92 *src/xtewma_ad.c
+3ad3c9275a1a7ac90db34cd62d2af180 *src/xtewma_arl.c
+1c9024238bf1e399728043b268d0eeeb *src/xtewma_q.c
+5523b0f49d7bd96031aa3e0ec4791e50 *src/xtewma_sf.c
diff --git a/NAMESPACE b/NAMESPACE
new file mode 100644
index 0000000..1d0643b
--- /dev/null
+++ b/NAMESPACE
@@ -0,0 +1,25 @@
+useDynLib(spc)
+## imports
+import("stats")
+## exports
+export("xshewhartrunsrules.ad", "xshewhartrunsrules.arl", "xshewhartrunsrules.crit", "xshewhartrunsrules.matrix",
+ "xshewhart.ar1.arl",
+ "xewma.ad", "xewma.arl", "xewma.crit", "xewma.q", "xewma.sf", "xewma.q.crit",
+ "xcusum.ad", "xcusum.arl", "xcusum.crit.L0h", "xcusum.crit.L0L1", "xcusum.crit", "xcusum.q", "xcusum.sf",
+ "xgrsr.ad", "xgrsr.arl", "xgrsr.crit",
+ "sewma.arl", "sewma.crit", "sewma.sf", "sewma.q.crit", "sewma.q",
+ "sewma.sf.prerun", "sewma.arl.prerun", "sewma.q.crit.prerun", "sewma.q.prerun", "sewma.crit.prerun",
+ "lns2ewma.arl", "lns2ewma.crit",
+ "scusum.arl", "scusum.crit",
+ "mewma.arl", "mewma.crit", "mewma.psi", "mewma.arl.f", "mewma.ad",
+ "xsewma.arl", "xsewma.crit", "xsewma.sf", "xsewma.q.crit", "xsewma.q",
+ "xewma.arl.prerun", "xewma.q.prerun", "xewma.sf.prerun",
+ "xewma.crit.prerun", "xewma.q.crit.prerun",
+ "xtewma.arl", "xtewma.ad", "xtewma.sf", "xtewma.q", "xtewma.q.crit",
+ "xtcusum.arl",
+ "xDcusum.arl", "xDewma.arl", "xDgrsr.arl", "xDshewhartrunsrules.arl", "xDshewhartrunsrulesFixedm.arl",
+ "p.ewma.arl",
+ "phat.ewma.arl", "phat.ewma.crit", "phat.ewma.lambda", "dphat", "pphat", "qphat",
+ "s.res.ewma.arl", "x.res.ewma.arl", "xs.res.ewma.arl", "xs.res.ewma.pms",
+ "quadrature.nodes.weights",
+ "tol.lim.fac")
diff --git a/R/dphat.R b/R/dphat.R
new file mode 100644
index 0000000..a911830
--- /dev/null
+++ b/R/dphat.R
@@ -0,0 +1,28 @@
+dphat <- function(x, n, mu=0, sigma=1, type="known", LSL=-3, USL=3, nodes=30) {
+ if ( n < 1 )
+ stop("n must be >= 1")
+ if ( sigma<1e-10 )
+ stop("sigma much too small")
+ ctyp <- -1 + pmatch(type, c("known", "estimated"))
+ if ( is.na(ctyp) )
+ stop("invalid sigma mode")
+ if ( LSL >= USL )
+ stop("wrong relationship between lower and upper specification limits (LSL must be smaller than USL)")
+ if ( nodes<2 )
+ stop("far too less nodes")
+
+ p.star <- pnorm( LSL/sigma ) + pnorm( -USL/sigma )
+ if ( type == "estimated" ) p.star <- 0
+
+ pdf <- rep(NA, length(x))
+ for ( i in 1:length(x) ) {
+ pdf[i] <- 0
+ if ( p.star<x[i] && x[i]<1 )
+ pdf[i] <- .C("phat_pdf",
+ as.double(x[i]), as.integer(n), as.double(mu), as.double(sigma), as.integer(ctyp),
+ as.double(LSL), as.double(USL), as.integer(nodes),
+ ans=double(length=1), PACKAGE="spc")$ans
+ }
+ names(pdf) <- "pdf"
+ pdf
+}
diff --git a/R/lns2ewma.arl.R b/R/lns2ewma.arl.R
new file mode 100644
index 0000000..55e4dc7
--- /dev/null
+++ b/R/lns2ewma.arl.R
@@ -0,0 +1,36 @@
+# Computation of EWMA ARLs (variance monitoring) based on ln S^2
+lns2ewma.arl <- function(l, cl, cu, sigma, df, hs=NULL, sided="upper", r=40) {
+
+ #mitte <- -1/df - 1/3/df^2 + 2/15/df^4 # approx following Crowder/Hamilton
+ mitte <- log(2/df) + digamma(df/2)
+
+ if ( is.null(cl) ) cl <- mitte
+
+ if ( is.null(cu) ) cu <- mitte
+
+ if ( is.null(hs) ) hs <- mitte
+
+ if ( l<=0 || l>1 ) stop("l has to be between 0 and 1")
+
+ #if ( cu < mitte ) stop(paste("cu has to be larger than", mitte))
+ #if ( cl > mitte ) stop(paste("cl has to be smaller than", mitte))
+
+ if ( sigma<=0 ) stop("sigma must be positive")
+
+ if ( df<1 ) stop("df must be larger than or equal to 1")
+
+ if ( hs<cl-1e-9 | hs>cu+1e-9 ) stop("wrong headstart")
+
+ ctyp <- pmatch(sided, c("upper", "lower", "two")) - 1
+ if ( is.na(ctyp) ) stop("invalid ewma type")
+
+ if ( r<10 ) stop("r is too small")
+
+ arl <- .C("lns2ewma_arl", as.integer(ctyp), as.double(l),
+ as.double(cl), as.double(cu), as.double(hs),
+ as.double(sigma), as.integer(df), as.integer(r),
+ ans=double(length=1),PACKAGE="spc")$ans
+
+ names(arl) <- "arl"
+ return (arl)
+}
diff --git a/R/lns2ewma.crit.R b/R/lns2ewma.crit.R
new file mode 100644
index 0000000..e967543
--- /dev/null
+++ b/R/lns2ewma.crit.R
@@ -0,0 +1,53 @@
+# Computation of EWMA critical values for given ARL (variance monitoring) based on ln S^2
+lns2ewma.crit <- function(l, L0, df, sigma0=1, cl=NULL, cu=NULL, hs=NULL, sided="upper", mode="fixed", r=40) {
+
+ #mitte <- -1/df - 1/3/df^2 + 2/15/df^4 # approx following Crowder/Hamilton
+ mitte <- log(2/df) + digamma(df/2)
+
+ if ( is.null(hs) ) hs <- mitte
+ cu0 <- cl0 <- 0
+
+ if ( l<=0 || l>1 ) stop("l has to be between 0 and 1")
+
+ if ( L0<1 ) stop("L0 is too small")
+
+ if ( df<1 ) stop("df must be positive")
+
+ if ( sigma0<=0 ) stop("sigma0 must be positive")
+
+ if ( sided=="upper" ) {
+ if ( is.null(cl) ) cl <- mitte
+ #if ( cl > mitte + 1e-9 ) stop(paste("cl has to be smaller than", mitte))
+ cl0 <- cl
+ if ( hs<cl0-1e-9 ) stop("hs must not be smaller than cl")
+ }
+ if ( sided=="lower" ) {
+ if ( is.null(cu) ) cu <- mitte
+ #if ( cu < mitte - 1e-9 ) stop(paste("cu has to be larger than", mitte))
+ cu0 <- cu
+ if ( hs>cu0+1e-9 ) stop("hs must not be larger than cu")
+ }
+ if (sided=="two" & mode=="fixed") {
+ if ( is.null(cu) ) stop("set cu")
+ #if ( cu < mitte - 1e-9 ) stop(paste("cu has to be larger than", mitte))
+ cu0 <- cu
+ if ( hs>cu0+1e-9 ) stop("hs must not be larger than cu")
+ }
+
+ ctyp <- pmatch(sided, c("upper", "lower", "two")) - 1
+ if (is.na(ctyp)) stop("invalid ewma type")
+
+ ltyp <- pmatch(mode, c("fixed", "unbiased", "eq.tails", "vanilla")) - 1
+ if (is.na(ltyp)) stop("invalid limits type")
+
+ if ( r<10 ) stop("r is too small")
+
+ c <- .C("lns2ewma_crit", as.integer(ctyp), as.integer(ltyp), as.double(l),
+ as.double(L0), as.double(cl0), as.double(cu0), as.double(hs),
+ as.double(sigma0), as.integer(df), as.integer(r),
+ ans=double(length=2),PACKAGE="spc")$ans
+
+ names(c) <- c("cl", "cu")
+ return (c)
+}
+
diff --git a/R/mewma.ad.R b/R/mewma.ad.R
new file mode 100644
index 0000000..2509feb
--- /dev/null
+++ b/R/mewma.ad.R
@@ -0,0 +1,37 @@
+# Computation of MEWMA steady-state ARLs (multivariate mean monitoring)
+mewma.ad <- function(l, cE, p, delta=0, r=20, n=20, type="cond", hs=0, ntype=NULL, qm0=20, qm1=qm0) {
+ if ( l<=0 | l>1 ) stop("l has to be between 0 and 1")
+ if ( cE<=0 ) stop("threshold c has to be positive")
+ if ( p<1 ) stop("wrong dimension parameter")
+ if ( delta<0 ) stop("wrong magnitude value")
+ if ( r<4 ) stop("resolution too small")
+ if ( n<5 ) stop("more quadrature nodes needed")
+ itype <- pmatch(tolower(type), c("cond", "cycl")) - 1
+ if ( is.na(itype) ) stop("wrong type of steady-state density")
+ if ( hs<0 ) stop("wrong head start value")
+ if ( r<4 ) stop("resolution too small")
+ if ( qm0<5 ) stop("more quadrature nodes needed")
+ if ( qm1<5 ) stop("more quadrature nodes needed")
+
+ if ( is.null(ntype) ) {
+ if ( delta <1e-10 ) {
+ ntype <- "gl2"
+ } else {
+ if ( p==2 ) {
+ ntype <- "gl3"
+ } else {
+ ntype <- "gl5"
+ }
+ }
+ }
+
+ qtyp <- pmatch(tolower(ntype), c("gl", "co", "ra", "cc", "mc", "sr", "co2", "gl2", "gl3", "gl4", "gl5", "co3", "co4")) - 1
+ if ( is.na(qtyp) ) stop("invalid type of numerical algorithm")
+
+ ad <- .C("mewma_ad", as.double(l), as.double(cE), as.integer(p), as.double(delta), as.integer(r),
+ as.integer(n), as.integer(itype), double(hs), as.integer(qtyp), as.integer(qm0), as.integer(qm1),
+ ans=double(length=1), PACKAGE="spc")$ans
+
+ names(ad) <- NULL
+ ad
+}
\ No newline at end of file
diff --git a/R/mewma.arl.R b/R/mewma.arl.R
new file mode 100644
index 0000000..0d3b8e9
--- /dev/null
+++ b/R/mewma.arl.R
@@ -0,0 +1,36 @@
+# Computation of MEWMA ARLs (multivariate mean monitoring)
+mewma.arl <- function(l, cE, p, delta=0, hs=0, r=20, ntype=NULL, qm0=20, qm1=qm0) {
+ if ( l<=0 | l>1 ) stop("l has to be between 0 and 1")
+ if ( cE<=0 ) stop("threshold c has to be positive")
+ if ( p<1 ) stop("wrong dimension parameter")
+ if ( delta<0 ) stop("wrong magnitude value")
+ if ( hs<0 ) stop("wrong head start value")
+ if ( r<4 ) stop("resolution too small")
+ if ( qm0<5 ) stop("more quadrature nodes needed")
+ if ( qm1<5 ) stop("more quadrature nodes needed")
+
+ if ( is.null(ntype) ) {
+ if ( delta <1e-10 ) {
+ ntype <- "gl2"
+ } else {
+ #if ( p %in% c(2,4) ) {
+ if ( p==2 ) {
+ ntype <- "gl3"
+ } else {
+ ntype <- "gl5"
+ }
+ }
+ }
+
+ qtyp <- pmatch(tolower(ntype), c("gl", "co", "ra", "cc", "mc", "sr", "co2", "gl2", "gl3", "gl4", "gl5", "co3", "co4")) - 1
+ if ( is.na(qtyp) ) stop("invalid type of numerical algorithm")
+
+ arl <- .C("mewma_arl", as.double(l), as.double(cE),
+ as.integer(p), as.double(delta),
+ as.double(hs), as.integer(r),
+ as.integer(qtyp), as.integer(qm0), as.integer(qm1),
+ ans=double(length=1), PACKAGE="spc")$ans
+
+ names(arl) <- NULL
+ arl
+}
\ No newline at end of file
diff --git a/R/mewma.arl.f.R b/R/mewma.arl.f.R
new file mode 100644
index 0000000..9a729cd
--- /dev/null
+++ b/R/mewma.arl.f.R
@@ -0,0 +1,206 @@
+# Computation of MEWMA ARLs (multivariate mean monitoring), returns function
+mewma.arl.f <- function(l, cE, p, delta=0, r=20, ntype=NULL, qm0=20, qm1=qm0) {
+ if ( l<=0 | l>1 ) stop("l has to be between 0 and 1")
+ if ( cE<=0 ) stop("threshold c has to be positive")
+ if ( p<1 ) stop("wrong dimension parameter")
+ if ( delta<0 ) stop("wrong magnitude value")
+
+ if ( r<4 ) stop("resolution too small")
+ if ( qm0<5 ) stop("more quadrature nodes needed")
+ if ( qm1<5 ) stop("more quadrature nodes needed")
+
+ if ( is.null(ntype) ) {
+ if ( delta <1e-10 ) {
+ ntype <- "gl2"
+ } else {
+ #if ( p %in% c(2,4) ) {
+ if ( p==2 ) {
+ ntype <- "gl3"
+ } else {
+ ntype <- "gl5"
+ }
+ }
+ }
+
+ # collocation basis of Chebshev polynomials
+ Tn <- Vectorize(function(z, n) {
+ if ( n==0 ) result <- 1
+ if ( n==1 ) result <- z
+ if ( n==2 ) result <- 2*z^2 - 1
+ if ( n==3 ) result <- 4*z^3 - 3*z
+ if ( n==4 ) result <- 8*z^4 - 8*z^2 + 1
+ if ( n==5 ) result <- 16*z^5 - 20*z^3 + 5*z
+ if ( n>5 ) result <- cos( n*acos(z) )
+ result
+ })
+
+ qtyp <- pmatch(tolower(ntype), c("gl", "co", "ra", "cc", "mc", "sr", "co2", "gl2", "gl3", "gl4", "gl5", "co3", "co4")) - 1
+ if ( is.na(qtyp) ) stop("invalid type of numerical algorithm")
+
+ if ( abs(delta) < 1e-10 ) { # in-control
+ LENGTH <- 3*r
+ zeug <- .C("mewma_arl_f", as.double(l), as.double(cE), as.integer(p), as.double(delta),
+ as.integer(r), as.integer(qtyp), as.integer(qm0), as.integer(qm1),
+ ans=double(length=LENGTH), PACKAGE="spc")$ans
+
+ g <- zeug[1:r]
+ w <- zeug[1:r + r]
+ z <- zeug[1:r + 2*r]
+
+ # helper functions
+ cE <- cE * l/(2-l)
+ l2 <- ( (1-l)/l )^2
+ fchi <- function(a, u) dchisq( u/l^2, p, ncp=l2*a ) / l^2
+ FCHI <- function(a, u) pchisq( u/l^2, p, ncp=l2*a )
+
+ if ( qtyp %in% c(0,2,5) ) arl <- Vectorize(function(a) 1 + sum( w * fchi(a, z) * g ), "a") # ordinary GL or Radau or Simpson rule Nystroem
+ if ( qtyp==7 ) arl <- Vectorize(function(a) 1 + sum( w * fchi(a, z^2) * g * 2*z ), "a") # GL Nystroem with ()^2 substitution
+ if ( qtyp==1 ) arl <- Vectorize(function(a) sum( Tn( (2*a-cE)/cE, 0:(r-1) ) * g ), "a") # collocation
+ if ( qtyp==3 ) arl <- Vectorize(function(a) 1 + sum( w * fchi(a, z^2) * g ) * cE/2 , "a") # Clenshaw-Curtis
+ if ( qtyp==4 ) arl <- Vectorize(function(a) 1 + sum( ( FCHI(a, z^2) - FCHI(a, c(0, z[-length(z)]^2)) ) * g), "a") # Markov chain (Runger/Prabhu)
+
+ } else { # out-of-control
+ if ( qtyp==4 ) {
+ cE_ <- sqrt( cE * l/(2-l) )
+ w <- 2*cE_/( 2*r + 1 )
+ ii <- function(ix, iy) (ix-r)^2 + iy^2 < cE_^2/w^2
+ CIRC <- as.vector( t(outer( 0:(2*r), 0:r, ii)) )
+ dQ <- sum(CIRC)
+ LENGTH <- dQ
+ } else {
+ r2 <- r^2
+ LENGTH <- r2 + 4*r
+ }
+ zeug <- .C("mewma_arl_f", as.double(l), as.double(cE), as.integer(p), as.double(delta),
+ as.integer(r), as.integer(qtyp), as.integer(qm0), as.integer(qm1),
+ ans=double(length=LENGTH), PACKAGE="spc")$ans
+ if ( qtyp!=4 ) {
+ g <- zeug[1:r2]
+ w0 <- zeug[1:r + r2]
+ z0 <- zeug[1:r + r2 + r]
+ w1 <- zeug[1:r + r2 + 2*r]
+ z1 <- zeug[1:r + r2 + 3*r]
+ } else {
+ g <- zeug[1:dQ]
+ }
+
+ # helpers
+ l2 <- ( (1-l)/l )^2
+ h <- cE * l/(2-l)
+ rdc <- l * sqrt( delta/h )
+ sig <- l / sqrt( h )
+
+ if ( qtyp %in% c(0, 2, 3, 5) ) arl <- Vectorize(function(a, b) { # ordinary GL or Radau or CC or Simpson rule Nystroem
+ if ( abs(h-a) < 1e-10 ) a_ <- 1 else a_ <- ( a - b^2/delta ) / ( h - b^2/delta )
+ b_ <- b / sqrt( delta * h )
+ m <- rdc + (1-l)*b_
+ eta <- l2 * h * (1-b_^2) * a_
+ if ( eta < 1e-10 ) eta <- 0
+ result <- 1
+ for ( i in 1:r ) {
+ korr <- h * (1-z1[i]^2) / l^2
+ outer <- korr * w1[i] * dnorm( z1[i], mean=m, sd=sig)
+ inner <- sum( w0 * dchisq( korr*z0, p-1, eta) * g[ (i-1)*r + 1:r ] )
+ result <- result + inner * outer
+ }
+ result
+ })
+
+ if ( qtyp==7 ) arl <- Vectorize(function(a, b) { # GL Nystroem with ()^2 substitution
+ if ( abs(h-a) < 1e-10 ) a_ <- 1 else a_ <- ( a - b^2/delta ) / ( h - b^2/delta )
+ b_ <- b / sqrt( delta * h )
+ m <- rdc + (1-l)*b_
+ eta <- l2 * h * (1-b_^2) * a_
+ if ( eta < 1e-10 ) eta <- 0
+ result <- 1
+ for ( i in 1:r ) {
+ korr <- h * (1-z1[i]^2) / l^2
+ outer <- korr * w1[i] * dnorm( z1[i], mean=m, sd=sig)
+ inner <- sum( w0 * dchisq( korr*z0^2, p-1, eta) * 2*z0 * g[ (i-1)*r + 1:r ] )
+ result <- result + inner * outer
+ }
+ result
+ })
+
+ if ( qtyp==8 ) arl <- Vectorize(function(a, b) { # GL Nystroem with ()^2 plus sin() substitution
+ if ( abs(h-a) < 1e-10 ) a_ <- 1 else a_ <- ( a - b^2/delta ) / ( h - b^2/delta )
+ b_ <- b / sqrt( delta * h )
+ m <- rdc + (1-l)*b_
+ eta <- l2 * h * (1-b_^2) * a_
+ if ( eta < 1e-10 ) eta <- 0
+ result <- 1
+ for ( i in 1:r ) {
+ korr <- h * ( 1 - sin(z1[i])^2 ) / l^2
+ outer <- korr * w1[i] * dnorm( sin(z1[i]), mean=m, sd=sig) * cos(z1[i])
+ inner <- sum( w0 * dchisq( korr*z0^2, p-1, eta) * 2*z0 * g[ (i-1)*r + 1:r ] )
+ result <- result + inner * outer
+ }
+ result
+ })
+
+ if ( qtyp==9 ) arl <- Vectorize(function(a, b) { # GL Nystroem with ()^2 plus tan() substitution
+ if ( abs(h-a) < 1e-10 ) a_ <- 1 else a_ <- ( a - b^2/delta ) / ( h - b^2/delta )
+ b_ <- b / sqrt( delta * h )
+ m <- rdc + (1-l)*b_
+ eta <- l2 * h * (1-b_^2) * a_
+ if ( eta < 1e-10 ) eta <- 0
+ result <- 1
+ for ( i in 1:r ) {
+ korr <- h * ( 1 - tan(z1[i])^2 ) / l^2
+ outer <- korr * w1[i] * dnorm( tan(z1[i]), mean=m, sd=sig) / cos(z1[i])^2
+ inner <- sum( w0 * dchisq( korr*z0^2, p-1, eta) * 2*z0 * g[ (i-1)*r + 1:r ] )
+ result <- result + inner * outer
+ }
+ result
+ })
+
+ if ( qtyp==10 ) arl <- Vectorize(function(a, b) { # GL Nystroem with ()^2 plus sinh() substitution
+ norm <- sinh(1)
+ if ( abs(h-a) < 1e-10 ) a_ <- 1 else a_ <- ( a - b^2/delta ) / ( h - b^2/delta )
+ b_ <- b / sqrt( delta * h )
+ m <- rdc + (1-l)*b_
+ eta <- l2 * h * (1-b_^2) * a_
+ if ( eta < 1e-10 ) eta <- 0
+ result <- 1
+ for ( i in 1:r ) {
+ korr <- h * ( 1 - (sinh(z1[i])/norm)^2 ) / l^2
+ outer <- korr * w1[i] * dnorm( sinh(z1[i])/norm, mean=m, sd=sig) * cosh(z1[i])/norm
+ inner <- sum( w0 * dchisq( korr*z0^2, p-1, eta) * 2*z0 * g[ (i-1)*r + 1:r ] )
+ result <- result + inner * outer
+ }
+ result
+ })
+
+ if ( qtyp %in% c(1, 6, 11, 12) ) arl <- Vectorize(function(a, b) { # collocation
+ if ( abs(h-a) < 1e-10 ) a_ <- 1 else a_ <- ( a - b^2/delta ) / ( h - b^2/delta )
+ b_ <- b / sqrt( delta * h )
+ result <- 0
+ for ( i in 1:r ) {
+ outer <- Tn( 2*a_-1, i-1 )
+ inner <- sum( Tn( b_, 0:(r-1)) * g[ (i-1)*r + 1:r ] )
+ result <- result + inner * outer
+ }
+ result
+ })
+
+ if ( qtyp==4 ) arl <- Vectorize(function(a, b) { # Markov chain (Runger/Prabhu)
+ #a <- sqrt(a)
+ cE_ <- sqrt( cE * l/(2-l) )
+ w <- 2*cE_/( 2*r + 1 )
+ wl <- w^2 / l^2
+ ii <- function(ix, iy) (ix-r)^2 + iy^2 < cE_^2/w^2
+ Vf <- function(iy,jy) pchisq( (jy+.5)^2*wl, p-1, ncp=(iy*w)^2*l2) - as.numeric(jy>0)*pchisq( (jy-.5)^2*wl, p-1, ncp=(iy*w)^2*l2)
+ Hf <- function(ix,jx) pnorm( (-cE_+(jx+1)*w-(1-l)*(-cE_+(ix+.5)*w) )/l, mean=delta) - pnorm( (-cE_+jx*w-(1-l)*(-cE_+(ix+.5)*w) )/l, mean=delta)
+ CIRC <- as.vector( t(outer( 0:(2*r), 0:r, ii)) )
+ Vv <- Vf( a/w, 0:r )
+ Hv <- Hf( (b+cE_)/w-.5, 0:(2*r) )
+ dQ <- sum(CIRC)
+ Qv <- as.vector( Vv %o% Hv )
+ Qv_ <- Qv[ CIRC ]
+ result <- 1 + sum( Qv_ * g )
+ })
+
+ }
+
+ arl
+}
diff --git a/R/mewma.crit.R b/R/mewma.crit.R
new file mode 100644
index 0000000..06d4aa0
--- /dev/null
+++ b/R/mewma.crit.R
@@ -0,0 +1,16 @@
+# Computation of MEWMA threshold (multivariate mean monitoring)
+mewma.crit <- function(l, L0, p, hs=0, r=20) {
+ if ( l<=0 | l>1 ) stop("l has to be between 0 and 1")
+ if ( L0<1 ) stop("L0 is too small")
+ if ( p<1 ) stop("wrong dimension parameter")
+ if ( hs<0 ) stop("wrong head start value")
+ if ( r<4 ) stop("resolution too small")
+
+ h <- .C("mewma_crit", as.double(l), as.double(L0),
+ as.integer(p), as.double(hs),
+ as.integer(r),
+ ans=double(length=1), PACKAGE="spc")$ans
+
+ names(h) <- NULL
+ h
+}
\ No newline at end of file
diff --git a/R/mewma.psi.R b/R/mewma.psi.R
new file mode 100644
index 0000000..21d0cca
--- /dev/null
+++ b/R/mewma.psi.R
@@ -0,0 +1,31 @@
+# Computation of MEWMA steady-state pdf (multivariate mean monitoring)
+mewma.psi <- function(l, cE, p, type="cond", hs=0, r=20) {
+ if ( l<=0 | l>1 ) stop("l has to be between 0 and 1")
+ if ( cE<=0 ) stop("threshold c has to be positive")
+ if ( p<1 ) stop("wrong dimension parameter")
+ if ( hs<0 ) stop("wrong head start value")
+ if ( r<4 ) stop("resolution too small")
+
+ itype <- pmatch(tolower(type), c("cond", "cycl")) - 1
+ if ( is.na(itype) ) stop("wrong type of steady-state density")
+
+ zeug <- .C("mewma_psi", as.double(l), as.double(cE), as.integer(p), as.integer(itype), as.double(hs), as.integer(r),
+ ans=double(length=3*r+1), PACKAGE="spc")$ans
+
+ zahl <- zeug[1]
+ PSI <- zeug[1:r + 1]
+ w <- zeug[1:r + r+1]
+ z <- zeug[1:r + 2*r+1]
+
+ l2 <- ( (1-l)/l )^2
+ fchi <- function(u, a) 2*a * dchisq( u^2/l^2, p, ncp=l2*a^2)/l^2
+
+ if ( itype == 0 ) psi <- Vectorize(function(x) sum( w * PSI * fchi(sqrt(x), z))/zahl, "x")
+
+ if ( itype == 1 ) {
+ if ( hs < 1e-9 ) psi <- Vectorize(function(x) dchisq( x/l^2, p)/l^2 / zahl + sum( w * PSI * fchi(sqrt(x), z) ), "x")
+ if ( hs >= 1e-9 ) psi <- Vectorize(function(x) fchi(sqrt(x), hs) / zahl + sum( w * PSI * fchi(sqrt(x), z) ), "x")
+ }
+
+ psi
+}
\ No newline at end of file
diff --git a/R/p.ewma.arl.R b/R/p.ewma.arl.R
new file mode 100644
index 0000000..73dc15b
--- /dev/null
+++ b/R/p.ewma.arl.R
@@ -0,0 +1,19 @@
+# Computation of attribute p EWMA ARLs
+p.ewma.arl <- function(lambda, ucl, n, p, z0, d.res=1, r.mode="ieee.round", i.mode="integer") {
+ i.r.mode <- -2 + pmatch(r.mode, c("gan.floor", "floor", "ceil", "ieee.round", "round", "mix"))
+ i.i.mode <- -1 + pmatch(i.mode, c("integer", "half"))
+ if ( lambda <= 0 || lambda > 1 ) stop("lambda has to be between 0 and 1")
+ if ( ucl < 0 ) stop("ucl must be larger than 0")
+ if ( n < 1 ) stop("n must be >= 1")
+ if ( 0 > p | p > 1 ) stop("wrong value for p")
+ if ( z0 < 0 | z0 > ucl ) stop("wrong headstart")
+ if ( d.res < 1 ) stop("d.res too small")
+ if ( is.na(i.r.mode) ) stop("invalid round mode")
+ if ( is.na(i.i.mode) ) stop("invalid interval mode")
+ arl <- .C("ewma_p_arl_be",
+ as.double(lambda), as.double(ucl), as.integer(n), as.double(p), as.double(z0), as.integer(d.res),
+ as.integer(i.r.mode), as.integer(i.i.mode),
+ ans=double(length=1), PACKAGE="spc")$ans
+ names(arl) <- "arl"
+ return (arl)
+}
\ No newline at end of file
diff --git a/R/phat.ewma.arl.R b/R/phat.ewma.arl.R
new file mode 100644
index 0000000..4fbd572
--- /dev/null
+++ b/R/phat.ewma.arl.R
@@ -0,0 +1,42 @@
+# Computation of EWMA phat ARLs
+phat.ewma.arl <- function(lambda, ucl, mu, n, z0, sigma=1, type="known", LSL=-3, USL=3, N=15, qm=25, ntype="coll") {
+ if ( lambda <= 0 || lambda > 1 )
+ stop("lambda has to be between 0 and 1")
+ p.star <- pnorm( LSL ) + pnorm( -USL )
+ if ( type == "known" ) {
+ if ( ucl <= p.star )
+ stop("ucl must be larger than p.star")
+ }
+ if ( type == "estimated" ) {
+ p.star <- 0
+ if ( ucl <= 0 )
+ stop("ucl must be positive")
+ }
+ if ( ucl >= 1 )
+ stop("ucl must be smaller than 1")
+ if ( n < 1 )
+ stop("n must be >= 1")
+ if ( z0 < p.star | z0 > ucl )
+ stop("wrong headstart")
+ if ( sigma<1e-12 )
+ stop("sigma much too small")
+ ctyp <- -1 + pmatch(tolower(type), c("known", "estimated"))
+ if ( is.na(ctyp) )
+ stop("invalid sigma mode")
+ if ( LSL >= USL )
+ stop("wrong relationship between lower and upper specification limits (LSL must be smaller than USL)")
+ if ( N < 2 )
+ stop("N too small")
+ if ( qm < 5 )
+ stop("qm too small")
+ ntyp <- -1 + pmatch(tolower(ntype), c("coll", "markov"))
+ if ( is.na(ntyp) )
+ stop("wrong label for numerical algorithm")
+ arl <- .C("ewma_phat_arl_coll",
+ as.double(lambda), as.double(ucl), as.double(mu), as.double(sigma), as.integer(n),
+ as.double(z0), as.integer(ctyp), as.double(LSL), as.double(USL),
+ as.integer(N), as.integer(qm), as.integer(ntyp),
+ ans=double(length=1), PACKAGE="spc")$ans
+ names(arl) <- "arl"
+ arl
+}
\ No newline at end of file
diff --git a/R/phat.ewma.crit.R b/R/phat.ewma.crit.R
new file mode 100644
index 0000000..72147f5
--- /dev/null
+++ b/R/phat.ewma.crit.R
@@ -0,0 +1,31 @@
+# Computation of EWMA phat upper control limits
+phat.ewma.crit <- function(lambda, L0, mu, n, z0, sigma=1, type="known", LSL=-3, USL=3, N=15, qm=25) {
+ if ( lambda <= 0 || lambda > 1 )
+ stop("lambda has to be between 0 and 1")
+ p.star <- pnorm( LSL/sigma ) + pnorm( -USL/sigma )
+ if ( type == "estimated" )
+ p.star <- 0
+ if ( L0 < 1 )
+ stop("L0 is too small")
+ if ( n < 1 )
+ stop("n must be >= 1")
+ if ( z0 < p.star & z0 >= 1 )
+ stop("wrong headstart")
+ if ( sigma<1e-10 )
+ stop("sigma much too small")
+ ctyp <- -1 + pmatch(type, c("known", "estimated"))
+ if ( is.na(ctyp) )
+ stop("invalid sigma mode")
+ if ( LSL >= USL )
+ stop("wrong relationship between lower and upper specification limits (LSL must be smaller than USL)")
+ if ( N < 3 )
+ stop("N too small")
+ if ( qm < 5 )
+ stop("qm too small")
+ ucl <- .C("ewma_phat_crit_coll",
+ as.double(lambda), as.double(L0), as.double(mu), as.double(sigma), as.integer(n),
+ as.double(z0), as.integer(ctyp), as.double(LSL), as.double(USL), as.integer(N), as.integer(qm),
+ ans=double(length=1), PACKAGE="spc")$ans
+ names(ucl) <- "ucl"
+ ucl
+}
\ No newline at end of file
diff --git a/R/phat.ewma.lambda.R b/R/phat.ewma.lambda.R
new file mode 100644
index 0000000..b6aaeed
--- /dev/null
+++ b/R/phat.ewma.lambda.R
@@ -0,0 +1,32 @@
+# Computation of EWMA phat lambda minimizing certain out-of-control ARL
+phat.ewma.lambda <- function(L0, mu, n, z0, sigma=1, type="known", max_l=1, min_l=.001, LSL=-3, USL=3, qm=25) {
+ p.star <- pnorm( LSL/sigma ) + pnorm( -USL/sigma )
+ if ( type == "estimated" )
+ p.star <- 0
+ if ( L0 < 1 )
+ stop("L0 is too small")
+ if ( n < 1 )
+ stop("n must be >= 1")
+ if ( z0 < p.star & z0 >= 1 )
+ stop("wrong headstart")
+ if ( sigma<1e-12 )
+ stop("sigma much too small")
+ ctyp <- -1 + pmatch(type, c("known", "estimated"))
+ if ( is.na(ctyp) )
+ stop("invalid sigma mode")
+ if ( max_l < min_l | max_l > 1 )
+ stop("wrong value for max_l (or min_l)")
+ if ( min_l < 1e-4 )
+ stop("min_l too small")
+ if ( LSL >= USL )
+ stop("wrong relationship between lower and upper specification limits (LSL must be smaller than USL)")
+ if ( qm < 5 )
+ stop("qm too small")
+ lambda <- .C("ewma_phat_lambda_coll",
+ as.double(L0), as.double(mu), as.double(sigma), as.integer(ctyp),
+ as.double(max_l), as.double(min_l), as.integer(n), as.double(z0),
+ as.double(LSL), as.double(USL), as.integer(qm),
+ ans=double(length=1), PACKAGE="spc")$ans
+ names(lambda) <- "lambda"
+ lambda
+}
\ No newline at end of file
diff --git a/R/pphat.R b/R/pphat.R
new file mode 100644
index 0000000..9a07fbe
--- /dev/null
+++ b/R/pphat.R
@@ -0,0 +1,29 @@
+pphat <- function(q, n, mu=0, sigma=1, type="known", LSL=-3, USL=3, nodes=30) {
+ if ( n < 1 )
+ stop("n must be >= 1")
+ if ( sigma<1e-10 )
+ stop("sigma much too small")
+ ctyp <- -1 + pmatch(type, c("known", "estimated"))
+ if ( is.na(ctyp) )
+ stop("invalid sigma mode")
+ if ( LSL >= USL )
+ stop("wrong relationship between lower and upper specification limits (LSL must be smaller than USL)")
+ if ( nodes<2 )
+ stop("far too less nodes")
+
+ p.star <- pnorm( LSL/sigma ) + pnorm( -USL/sigma )
+ if ( type == "estimated" ) p.star <- 0
+
+ cdf <- rep(NA, length(q))
+ for ( i in 1:length(q) ) {
+ cdf[i] <- 0
+ if ( q[i] >= 1 ) cdf[i] <- 1
+ if ( p.star<q[i] && q[i]<1 )
+ cdf[i] <- .C("phat_cdf",
+ as.double(q[i]), as.integer(n), as.double(mu), as.double(sigma), as.integer(ctyp),
+ as.double(LSL), as.double(USL), as.integer(nodes),
+ ans=double(length=1), PACKAGE="spc")$ans
+ }
+ names(cdf) <- NULL
+ cdf
+}
\ No newline at end of file
diff --git a/R/qphat.R b/R/qphat.R
new file mode 100644
index 0000000..ed90f5d
--- /dev/null
+++ b/R/qphat.R
@@ -0,0 +1,25 @@
+qphat <- function(p, n, mu=0, sigma=1, type="known", LSL=-3, USL=3, nodes=30) {
+ if ( n < 1 )
+ stop("n must be >= 1")
+ if ( sigma<1e-10 )
+ stop("sigma much too small")
+ ctyp <- -1 + pmatch(type, c("known", "estimated"))
+ if ( is.na(ctyp) )
+ stop("invalid sigma mode")
+ if ( LSL >= USL )
+ stop("wrong relationship between lower and upper specification limits (LSL must be smaller than USL)")
+ if ( nodes<2 )
+ stop("far too less nodes")
+
+ qf <- rep(NA, length(p))
+ for ( i in 1:length(p) ) {
+ qf[i] <- NA
+ if ( 0<p[i] && p[i]<1 )
+ qf[i] <- .C("phat_qf",
+ as.double(p[i]), as.integer(n), as.double(mu), as.double(sigma), as.integer(ctyp),
+ as.double(LSL), as.double(USL), as.integer(nodes),
+ ans=double(length=1), PACKAGE="spc")$ans
+ }
+ names(qf) <- "qf"
+ qf
+}
\ No newline at end of file
diff --git a/R/quadrature.nodes.weights.R b/R/quadrature.nodes.weights.R
new file mode 100644
index 0000000..2e90653
--- /dev/null
+++ b/R/quadrature.nodes.weights.R
@@ -0,0 +1,15 @@
+quadrature.nodes.weights <- function(n, type="GL", x1=-1, x2=1) {
+ if ( n < 1 ) stop("n has to be a natural number")
+ qtyp <- pmatch(type, c("GL", "Ra")) - 1
+ if ( is.na(qtyp) ) stop("invalid quadrature type")
+ if ( x1 >= x2 ) stop("x1 must be smaller than x2")
+
+ nw <- .C("quadrature_nodes_weights",
+ as.integer(n),
+ as.double(x1), as.double(x2),
+ as.integer(qtyp),
+ ans=double(length=2*n), PACKAGE="spc")$ans
+
+ qnw <- data.frame(nodes=nw[1:n], weights=nw[-(1:n)])
+ qnw
+}
\ No newline at end of file
diff --git a/R/s.res.ewma.arl.R b/R/s.res.ewma.arl.R
new file mode 100644
index 0000000..6fb55c8
--- /dev/null
+++ b/R/s.res.ewma.arl.R
@@ -0,0 +1,29 @@
+# Computation of res-EWMA ARLs (scale monitoring)
+s.res.ewma.arl <- function(l,cu,sigma,mu=0,alpha=0,n=5,hs=1,r=40,qm=30) {
+ if ( l <= 0 || l > 1 )
+ stop("l has to be between 0 and 1")
+ if ( cu <= 0 )
+ warning("usually, cu has to be positive")
+ if ( sigma <= 0 )
+ stop("sigma must be positive")
+ if ( abs(alpha) > 1 )
+ warning("nonstationary AR(1) process")
+ if ( n < 2 )
+ warning("n is too small")
+ n <- round(n)
+ if ( abs(hs) > cu )
+ warning("unusual headstart")
+ if ( r < 4 )
+ stop("r is too small")
+ if ( qm < 10 )
+ stop("qm is too small")
+ ctyp <- 1 # later more
+ arl <- .C("s_res_ewma_arl",as.double(alpha),as.integer(n-1),
+ as.integer(ctyp),as.double(l),
+ as.double(cu),as.double(hs),
+ as.double(sigma),as.double(mu),as.integer(r),as.integer(qm),
+ ans=double(length=1),PACKAGE="spc")$ans
+ names(arl) <- "arl"
+ return (arl)
+}
+
diff --git a/R/scusum.arl.R b/R/scusum.arl.R
new file mode 100644
index 0000000..60178ae
--- /dev/null
+++ b/R/scusum.arl.R
@@ -0,0 +1,42 @@
+# Computation of CUSUM ARLs (variance monitoring)
+scusum.arl <- function(k, h, sigma, df, hs=0, sided="upper", k2=NULL, h2=NULL, hs2=0, r=40, qm=30, version=2) {
+ if ( k<0 )
+ stop("k has to be non-negative")
+ if ( h<=0 )
+ stop("h has to be positive")
+ if ( hs<0 | hs>h )
+ stop("wrong headstart")
+ if ( sided=="two" ) {
+ if ( is.null(k2) | is.null(h2) )
+ stop("in case of a two-sided CUSUM scheme one has to define two sets of (k,h,hs)")
+ if ( k2<0 )
+ stop("k2 has to be non-negative")
+ if ( h2<=0 )
+ stop("h2 has to be positive")
+ if ( hs2<0 | hs2>h2 )
+ stop("wrong headstart")
+ }
+
+ if ( sigma<=0 )
+ stop("sigma must be positive")
+ if ( df<1 )
+ stop("df must be larger than or equal to 1")
+
+ ctyp <- pmatch(sided, c("upper", "lower", "two")) - 1
+ if ( is.na(ctyp) )
+ stop("invalid cusum type")
+ if ( r<10 )
+ stop("r is too small")
+ if ( qm<10 )
+ stop("qm is too small")
+
+ arl <- .C("scusum_arl", as.integer(ctyp),
+ as.double(k), as.double(h), as.double(hs),
+ as.double(sigma), as.integer(df),
+ as.double(k2), as.double(h2), as.double(hs2),
+ as.integer(r), as.integer(qm), as.integer(version),
+ ans=double(length=1), PACKAGE="spc")$ans
+ names(arl) <- "arl"
+
+ arl
+}
diff --git a/R/scusum.crit.R b/R/scusum.crit.R
new file mode 100644
index 0000000..99f1229
--- /dev/null
+++ b/R/scusum.crit.R
@@ -0,0 +1,51 @@
+# Computation of CUSUM decision intervals -- alarm thresholds -- (variance monitoring)
+scusum.crit <- function(k, L0, sigma, df, hs=0, sided="upper", mode="eq.tails", k2=NULL, hs2=0, r=40, qm=30) {
+ if ( k<0 )
+ stop("k has to be non-negative")
+ if ( L0<1 )
+ stop("L0 is too small")
+ if ( hs<0 )
+ stop("wrong headstart")
+ if ( sided=="two" ) {
+ if ( is.null(k2) )
+ stop("in case of a two-sided CUSUM scheme one has to define two reference values")
+ if ( k2<0 )
+ stop("k2 has to be non-negative")
+ if ( hs2<0 )
+ stop("wrong headstart")
+ }
+
+ if ( sigma<=0 )
+ stop("sigma must be positive")
+ if ( df<1 )
+ stop("df must be larger than or equal to 1")
+
+ ctyp <- pmatch(sided, c("upper", "lower", "two")) - 1
+ if ( is.na(ctyp) )
+ stop("invalid cusum type")
+ ltyp <- pmatch(mode, c("eq.tails", "unbiased")) - 1
+ if ( is.na(ltyp) )
+ stop("invalid limits cusum type")
+ if ( r<10 )
+ stop("r is too small")
+ if ( qm<10 )
+ stop("qm is too small")
+
+ a.length <- 1
+ if ( sided=="two" ) a.length <- 2
+
+ h <- .C("scusum_crit", as.integer(ctyp),
+ as.double(k), as.double(L0), as.double(hs),
+ as.double(sigma), as.integer(df), as.integer(ltyp),
+ as.double(k2), as.double(hs2),
+ as.integer(r), as.integer(qm),
+ ans=double(length=a.length), PACKAGE="spc")$ans
+
+ if ( sided=="two" ) {
+ names(h) <- c("hl","hu")
+ } else {
+ names(h) <- "h"
+ }
+
+ h
+}
diff --git a/R/sewma.arl.R b/R/sewma.arl.R
new file mode 100644
index 0000000..e242764
--- /dev/null
+++ b/R/sewma.arl.R
@@ -0,0 +1,38 @@
+# Computation of EWMA ARLs (variance monitoring)
+sewma.arl <- function(l, cl, cu, sigma, df, s2.on=TRUE, hs=NULL, sided="upper", r=40, qm=30) {
+ mitte <- sqrt( 2/df ) * gamma( (df+1)/2 )/ gamma( df/2 )
+ if ( is.null(hs) ) {
+ if ( s2.on ) { hs <- 1 } else { hs <- mitte }
+ }
+
+ if ( l<=0 || l>1 )
+ stop("l has to be between 0 and 1")
+ if ( cu<=0 )
+ stop("cu has to be positive")
+ if ( cl<0 )
+ stop("cl has to be non-negative")
+ if ( sigma<=0 )
+ stop("sigma must be positive")
+ if ( df<1 )
+ stop("df must be larger than or equal to 1")
+ s_squared <- as.numeric(s2.on)
+ if ( !(s_squared %in% c(0,1)) )
+ stop("wrong value for s2.on")
+
+ if ( hs<cl | hs>cu )
+ stop("wrong headstart")
+ ctyp <- pmatch(sided, c("upper", "Rupper", "two", "Rlower")) - 1
+ if (is.na(ctyp))
+ stop("invalid ewma type")
+ if (r<10)
+ stop("r is too small")
+ if (qm<10)
+ stop("qm is too small")
+ arl <- .C("sewma_arl",as.integer(ctyp),as.double(l),
+ as.double(cl),as.double(cu),as.double(hs),
+ as.double(sigma),as.integer(df),as.integer(r),as.integer(qm),
+ as.integer(s_squared),
+ ans=double(length=1),PACKAGE="spc")$ans
+ names(arl) <- "arl"
+ return (arl)
+}
diff --git a/R/sewma.arl.prerun.R b/R/sewma.arl.prerun.R
new file mode 100644
index 0000000..53f3985
--- /dev/null
+++ b/R/sewma.arl.prerun.R
@@ -0,0 +1,35 @@
+# Computation of EWMA ARLs (variance monitoring) with pre-run uncertainty
+sewma.arl.prerun <- function(l, cl, cu, sigma, df1, df2, hs=1, sided="upper", r=40, qm=30, qm.sigma=30, truncate=1e-10) {
+ if ( l<=0 || l>1 )
+ stop("l has to be between 0 and 1")
+ if ( cl<0 )
+ stop("cl has to be non-negative")
+ if ( cu<=0 )
+ stop("cu has to be positive")
+ if ( sigma<=0 )
+ stop("sigma must be positive")
+ if ( df1<1 )
+ stop("df1 must be larger than or equal to 1")
+ if ( df2<1 )
+ stop("df2 must be larger than or equal to 1")
+ if ( hs<cl | hs>cu )
+ stop("wrong headstart")
+ ctyp <- pmatch(sided, c("upper", "Rupper", "two", "Rlower")) - 1
+ if (is.na(ctyp))
+ stop("invalid ewma type")
+ if ( r<10 )
+ stop("r is too small")
+ if ( qm<10 )
+ stop("qm is too small")
+ if ( qm.sigma<4 )
+ stop("qm.sigma is too small")
+ if ( truncate < 0 | truncate >= 0.5 )
+ stop("wrong value for truncate (should follow 0 < truncate < 0.5)")
+ arl <- .C("sewma_arl_prerun", as.integer(ctyp), as.double(l),
+ as.double(cl), as.double(cu), as.double(hs),
+ as.double(sigma), as.integer(df1), as.integer(r), as.integer(qm),
+ as.integer(df2), as.integer(qm.sigma), as.double(truncate),
+ ans=double(length=1),PACKAGE="spc")$ans
+ names(arl) <- "arl"
+ return (arl)
+}
diff --git a/R/sewma.crit.R b/R/sewma.crit.R
new file mode 100644
index 0000000..b94dbc0
--- /dev/null
+++ b/R/sewma.crit.R
@@ -0,0 +1,67 @@
+# Computation of EWMA critical values for given ARL (variance monitoring)
+sewma.crit <- function(l, L0, df, sigma0=1, cl=NULL, cu=NULL, hs=NULL, s2.on=TRUE, sided="upper", mode="fixed", ur=4, r=40, qm=30) {
+
+ mitte <- sqrt( 2/df ) * gamma( (df+1)/2 )/ gamma( df/2 )
+ if ( is.null(hs) ) {
+ if ( s2.on ) { hs <- 1 } else { hs <- mitte }
+ }
+
+ cu0 <- cl0 <- 0
+ if ( l<=0 | l>1 )
+ stop("l has to be between 0 and 1")
+ if ( L0<1 )
+ stop("L0 is too small")
+ if ( df<1 )
+ stop("df must be positive")
+ if ( sigma0<=0 )
+ stop("sigma0 must be positive")
+ if ( sided=="Rupper" ) {
+ if ( is.null(cl) )
+ stop("set cl")
+ if ( cl<=0 )
+ stop("cl must be positive")
+ cl0 <- cl
+ if ( hs<cl0 )
+ stop("hs must not be smaller than cl")
+ }
+ if ( sided=="Rlower" ) {
+ if ( is.null(cu) )
+ stop("set cu")
+ if ( cu<sigma0 )
+ stop(paste("cu must be larger than sigma0 =", sigma0))
+ cu0 <- cu
+ if ( hs>cu0 )
+ stop("hs must not be larger than cu")
+ }
+ if ( sided=="two" & mode=="fixed" ) {
+ if ( is.null(cu) )
+ stop("set cu")
+ if ( cu<sigma0 )
+ stop(paste("cu must be larger than sigma0 =", sigma0))
+ cu0 <- cu
+ if ( hs>cu0 )
+ stop("hs must not be larger than cu")
+ }
+ s_squared <- as.numeric(s2.on)
+ if ( !(s_squared %in% c(0,1)) )
+ stop("wrong value for s2.on")
+
+ ctyp <- pmatch(sided, c("upper", "Rupper", "two", "Rlower")) - 1
+ if (is.na(ctyp))
+ stop("invalid ewma type")
+ ltyp <- pmatch(mode, c("fixed", "unbiased", "eq.tails", "vanilla")) - 1
+ if ( is.na(ltyp) )
+ stop("invalid limits type")
+ if ( r<10 )
+ stop("r is too small")
+ if ( qm<10 )
+ stop("qm is too small")
+ c <- .C("sewma_crit",as.integer(ctyp),as.integer(ltyp),as.double(l),
+ as.double(L0),as.double(cl0),as.double(cu0),as.double(hs),
+ as.double(sigma0),as.integer(df),as.integer(r),as.integer(qm),
+ as.double(ur),as.integer(s_squared),
+ ans=double(length=2),PACKAGE="spc")$ans
+ names(c) <- c("cl", "cu")
+ return (c)
+}
+
diff --git a/R/sewma.crit.prerun.R b/R/sewma.crit.prerun.R
new file mode 100644
index 0000000..74ff11f
--- /dev/null
+++ b/R/sewma.crit.prerun.R
@@ -0,0 +1,45 @@
+# Computation of EWMA critical values for given ARL (variance monitoring) with pre-run uncertainty
+sewma.crit.prerun <- function(l, L0, df1, df2, sigma0=1, cl=NULL, cu=NULL, hs=1, sided="upper", mode="fixed", r=40, qm=30, qm.sigma=30, truncate=1e-10, tail_approx=TRUE, c.error=1e-10, a.error=1e-9) {
+ cu0 <- cl0 <- 0
+ if ( l<=0 | l>1 ) stop("l has to be between 0 and 1")
+ if ( L0<1 ) stop("L0 is too small")
+ if ( df1<1 ) stop("df1 must be positive")
+ if ( df2<1 ) stop("df2 must be positive")
+ if ( sigma0<=0 ) stop("sigma0 must be positive")
+ if ( sided=="Rupper" ) {
+ if ( is.null(cl) ) stop("set cl")
+ if ( cl<=0 ) stop("cl must be positive")
+ cl0 <- cl
+ if ( hs<cl0 ) stop("hs must not be smaller than cl")
+ }
+ if ( sided=="Rlower" ) {
+ if ( is.null(cu) ) stop("set cu")
+ if ( cu<sigma0 ) stop(paste("cu must be larger than sigma0 =", sigma0))
+ cu0 <- cu
+ if ( hs>cu0 ) stop("hs must not be larger than cu")
+ }
+ if ( sided=="two" & mode=="fixed" ) {
+ if ( is.null(cu) ) stop("set cu")
+ if ( cu<sigma0 ) stop(paste("cu must be larger than sigma0 =", sigma0))
+ cu0 <- cu
+ if ( hs>cu0 ) stop("hs must not be larger than cu")
+ }
+ ctyp <- pmatch(sided, c("upper", "Rupper", "two", "Rlower")) - 1
+ if ( is.na(ctyp) ) stop("invalid ewma type")
+ ltyp <- pmatch(mode, c("fixed", "unbiased")) - 1
+ if ( is.na(ltyp) ) stop("invalid limits type")
+ if ( r<10 ) stop("r is too small")
+ if ( qm<10 ) stop("qm is too small")
+ if ( qm.sigma<4 ) stop("qm.sigma is too small")
+ if ( truncate < 0 | truncate >= 0.5 ) stop("wrong value for truncate (should follow 0 < truncate < 0.5)")
+ c <- .C("sewma_crit_prerun",
+ as.integer(ctyp), as.integer(ltyp), as.double(l), as.integer(L0),
+ as.double(cl0), as.double(cu0), as.double(hs), as.double(sigma0),
+ as.integer(df1), as.integer(r), as.integer(qm),
+ as.integer(df2), as.integer(qm.sigma), as.double(truncate), as.integer(tail_approx),
+ as.double(c.error), as.double(a.error),
+ ans=double(length=2),PACKAGE="spc")$ans
+ names(c) <- c("cl", "cu")
+ return (c)
+}
+
diff --git a/R/sewma.q.R b/R/sewma.q.R
new file mode 100644
index 0000000..bce89fd
--- /dev/null
+++ b/R/sewma.q.R
@@ -0,0 +1,22 @@
+# Computation of EWMA quantiles (variance monitoring)
+sewma.q <- function(l, cl, cu, sigma, df, alpha, hs=1, sided="upper", r=40, qm=30) {
+ if ( l <= 0 | l > 1 ) stop("l (lambda) has to be between 0 and 1")
+ if ( cu<=0 ) stop("cu has to be positive")
+ if ( cl<0 ) stop("cl has to be non-negative")
+ if ( sided!="upper" & cl<1e-6 ) stop("cl is too small")
+ if ( sigma<=0 ) stop("sigma must be positive")
+ if ( df<1 ) stop("df must be larger than or equal to 1")
+ if ( alpha <= 0 | alpha >= 1) stop("quantile level alpha must be in (0,1)")
+ if ( hs<cl | hs>cu ) stop("wrong headstart hs")
+ ctyp <- pmatch(sided, c("upper","Rupper","two","Rlower")) - 1
+ if (is.na(ctyp)) stop("invalid ewma type")
+ if ( r<10 ) stop("r is too small")
+ if ( qm<5 ) stop("qm is too small")
+ quant <- .C("sewma_q",
+ as.integer(ctyp), as.double(l), as.double(cl), as.double(cu),
+ as.double(alpha), as.double(hs), as.integer(r), as.double(sigma),
+ as.integer(df), as.integer(qm),
+ ans=double(length=1),PACKAGE="spc")$ans
+ names(quant) <- "q"
+ quant
+}
diff --git a/R/sewma.q.crit.R b/R/sewma.q.crit.R
new file mode 100644
index 0000000..00d7eb8
--- /dev/null
+++ b/R/sewma.q.crit.R
@@ -0,0 +1,43 @@
+# Computation of EWMA critical values for given QRL (variance monitoring)
+sewma.q.crit <- function(l, L0, alpha, df, sigma0=1, cl=NULL, cu=NULL, hs=1, sided="upper", mode="fixed", ur=4, r=40, qm=30, c.error=1e-12, a.error=1e-9) {
+ cu0 <- cl0 <- 0
+ if ( l<=0 | l>1 ) stop("l has to be between 0 and 1")
+ if ( L0<1 ) stop("L0 is too small")
+ if ( alpha<=0 | alpha>=1 ) stop("quantile level alpha must be in (0,1)")
+ if ( df<1 ) stop("df must be positive")
+ if ( sigma0<=0 ) stop("sigma0 must be positive")
+ if ( sided=="Rupper" ) {
+ if ( is.null(cl) ) stop("set cl")
+ if ( cl<=0 ) stop("cl must be positive")
+ cl0 <- cl
+ if ( hs<cl0 ) stop("hs must not be smaller than cl")
+ }
+ if ( sided=="Rlower" ) {
+ if ( is.null(cu) ) stop("set cu")
+ if ( cu<sigma0 ) stop(paste("cu must be larger than sigma0 =", sigma0))
+ cu0 <- cu
+ if ( hs>cu0 ) stop("hs must not be larger than cu")
+ }
+ if ( sided=="two" & mode=="fixed" ) {
+ if ( is.null(cu) ) stop("set cu")
+ if ( cu<sigma0 ) stop(paste("cu must be larger than sigma0 =", sigma0))
+ cu0 <- cu
+ if ( hs>cu0 ) stop("hs must not be larger than cu")
+ }
+ ctyp <- pmatch(sided, c("upper", "Rupper", "two", "Rlower")) - 1
+ if ( is.na(ctyp) ) stop("invalid ewma type")
+ ltyp <- pmatch(mode, c("fixed", "unbiased", "classic")) - 1
+ if ( is.na(ltyp) ) stop("invalid limits type")
+ if ( r<10 ) stop("r is too small")
+ if ( qm<10 ) stop("qm is too small")
+ c <- .C("sewma_q_crit",
+ as.integer(ctyp), as.integer(ltyp), as.double(l),
+ as.integer(L0), as.double(alpha),
+ as.double(cl0), as.double(cu0), as.double(hs),
+ as.double(sigma0), as.integer(df), as.integer(r), as.integer(qm), as.double(ur),
+ as.double(c.error), as.double(a.error),
+ ans=double(length=2),PACKAGE="spc")$ans
+ names(c) <- c("cl", "cu")
+ return (c)
+}
+
diff --git a/R/sewma.q.crit.prerun.R b/R/sewma.q.crit.prerun.R
new file mode 100644
index 0000000..5bdbc10
--- /dev/null
+++ b/R/sewma.q.crit.prerun.R
@@ -0,0 +1,47 @@
+# Computation of EWMA critical values for given QRL (variance monitoring) with pre-run uncertainty
+sewma.q.crit.prerun <- function(l, L0, alpha, df1, df2, sigma0=1, cl=NULL, cu=NULL, hs=1, sided="upper", mode="fixed", r=40, qm=30, qm.sigma=30, truncate=1e-10,
+ tail_approx=TRUE, c.error=1e-10, a.error=1e-9) {
+ cu0 <- cl0 <- 0
+ if ( l<=0 | l>1 ) stop("l has to be between 0 and 1")
+ if ( L0<1 ) stop("L0 is too small")
+ if ( alpha<=0 | alpha>=1 ) stop("quantile level alpha must be in (0,1)")
+ if ( df1<1 ) stop("df1 must be positive")
+ if ( df2<1 ) stop("df2 must be positive")
+ if ( sigma0<=0 ) stop("sigma0 must be positive")
+ if ( sided=="Rupper" ) {
+ if ( is.null(cl) ) stop("set cl")
+ if ( cl<=0 ) stop("cl must be positive")
+ cl0 <- cl
+ if ( hs<cl0 ) stop("hs must not be smaller than cl")
+ }
+ if ( sided=="Rlower" ) {
+ if ( is.null(cu) ) stop("set cu")
+ if ( cu<sigma0 ) stop(paste("cu must be larger than sigma0 =", sigma0))
+ cu0 <- cu
+ if ( hs>cu0 ) stop("hs must not be larger than cu")
+ }
+ if ( sided=="two" & mode=="fixed" ) {
+ if ( is.null(cu) ) stop("set cu")
+ if ( cu<sigma0 ) stop(paste("cu must be larger than sigma0 =", sigma0))
+ cu0 <- cu
+ if ( hs>cu0 ) stop("hs must not be larger than cu")
+ }
+ ctyp <- pmatch(sided, c("upper", "Rupper", "two", "Rlower")) - 1
+ if ( is.na(ctyp) ) stop("invalid ewma type")
+ ltyp <- pmatch(mode, c("fixed", "unbiased")) - 1
+ if ( is.na(ltyp) ) stop("invalid limits type")
+ if ( r<10 ) stop("r is too small")
+ if ( qm<10 ) stop("qm is too small")
+ if ( qm.sigma<4 ) stop("qm.sigma is too small")
+ if ( truncate < 0 | truncate >= 0.5 ) stop("wrong value for truncate (should follow 0 < truncate < 0.5)")
+ c <- .C("sewma_q_crit_prerun",
+ as.integer(ctyp), as.integer(ltyp), as.double(l), as.integer(L0), as.double(alpha),
+ as.double(cl0), as.double(cu0), as.double(hs), as.double(sigma0),
+ as.integer(df1), as.integer(r), as.integer(qm),
+ as.integer(df2), as.integer(qm.sigma), as.double(truncate), as.integer(tail_approx),
+ as.double(c.error), as.double(a.error),
+ ans=double(length=2),PACKAGE="spc")$ans
+ names(c) <- c("cl", "cu")
+ return (c)
+}
+
diff --git a/R/sewma.q.prerun.R b/R/sewma.q.prerun.R
new file mode 100644
index 0000000..3f51d00
--- /dev/null
+++ b/R/sewma.q.prerun.R
@@ -0,0 +1,26 @@
+# Computation of EWMA quantiles (variance monitoring) with pre-run uncertainty
+sewma.q.prerun <- function(l, cl, cu, sigma, df1, df2, alpha, hs=1, sided="upper", r=40, qm=30, qm.sigma=30, truncate=1e-10) {
+ if ( l <= 0 | l > 1 ) stop("l (lambda) has to be between 0 and 1")
+ if ( cu<=0 ) stop("cu has to be positive")
+ if ( cl<0 ) stop("cl has to be non-negative")
+ if ( sided!="upper" & cl<1e-6 ) stop("cl is too small")
+ if ( sigma<=0 ) stop("sigma must be positive")
+ if ( df1<1 ) stop("df1 must be larger than or equal to 1")
+ if ( df2<1 ) stop("df2 must be larger than or equal to 1")
+ if ( alpha <= 0 | alpha >= 1) stop("quantile level alpha must be in (0,1)")
+ if ( hs<cl | hs>cu ) stop("wrong headstart hs")
+ ctyp <- pmatch(sided, c("upper","Rupper","two","Rlower")) - 1
+ if (is.na(ctyp)) stop("invalid ewma type")
+ if ( r<10 ) stop("r is too small")
+ if ( qm<5 ) stop("qm is too small")
+ if ( qm.sigma<4 ) stop("qm.sigma is too small")
+ if ( truncate < 0 | truncate >= 0.5 ) stop("wrong value for truncate (should follow 0 < truncate < 0.5)")
+ quant <- .C("sewma_q_prerun",
+ as.integer(ctyp), as.double(l), as.double(cl), as.double(cu),
+ as.double(alpha), as.double(hs), as.double(sigma),
+ as.integer(df1), as.integer(r), as.integer(qm),
+ as.integer(df2), as.integer(qm.sigma), as.double(truncate),
+ ans=double(length=1),PACKAGE="spc")$ans
+ names(quant) <- "q"
+ quant
+}
\ No newline at end of file
diff --git a/R/sewma.sf.R b/R/sewma.sf.R
new file mode 100644
index 0000000..4fd2f28
--- /dev/null
+++ b/R/sewma.sf.R
@@ -0,0 +1,21 @@
+# Computation of EWMA survival function (variance monitoring)
+sewma.sf <- function(n, l, cl, cu, sigma, df, hs=1, sided="upper", r=40, qm=30) {
+ if ( n < 1 ) stop("n has to be a natural number")
+ if ( l <= 0 | l > 1 ) stop("l (lambda) has to be between 0 and 1")
+ if ( cu<=0 ) stop("cu has to be positive")
+ if ( cl<0 ) stop("cl has to be non-negative")
+ if ( sided!="upper" & cl<1e-6 ) stop("cl is too small")
+ if ( sigma<=0 ) stop("sigma must be positive")
+ if ( df<1 ) stop("df must be larger than or equal to 1")
+ if ( hs<cl | hs>cu ) stop("wrong headstart hs")
+ if ( r<10 ) stop("r is too small")
+ ctyp <- pmatch(sided, c("upper","Rupper","two","Rlower")) - 1
+ if (is.na(ctyp)) stop("invalid ewma type")
+ if ( qm<5 ) stop("qm is too small")
+ sf <- .C("sewma_sf",
+ as.integer(ctyp), as.double(l), as.double(cl), as.double(cu), as.double(hs), as.integer(r),
+ as.double(sigma), as.integer(df), as.integer(qm), as.integer(n),
+ ans=double(length=n),PACKAGE="spc")$ans
+ names(sf) <- NULL
+ sf
+}
diff --git a/R/sewma.sf.prerun.R b/R/sewma.sf.prerun.R
new file mode 100644
index 0000000..2fc9fcb
--- /dev/null
+++ b/R/sewma.sf.prerun.R
@@ -0,0 +1,24 @@
+# Computation of EWMA survival function (variance monitoring) with pre-run uncertainty
+sewma.sf.prerun <- function(n, l, cl, cu, sigma, df1, df2, hs=1, sided="upper", qm=30, qm.sigma=30, truncate=1e-10, tail_approx=TRUE) {
+ if ( n < 1 ) stop("n has to be a natural number")
+ if ( l <= 0 | l > 1 ) stop("l (lambda) has to be between 0 and 1")
+ if ( cu<=0 ) stop("cu has to be positive")
+ if ( cl<0 ) stop("cl has to be non-negative")
+ if ( sided!="upper" & cl<1e-6 ) stop("cl is too small")
+ if ( sigma<=0 ) stop("sigma must be positive")
+ if ( df1<1 ) stop("df1 must be larger than or equal to 1")
+ if ( df2<1 ) stop("df2 must be larger than or equal to 1")
+ if ( hs<cl | hs>cu ) stop("wrong headstart hs")
+ ctyp <- pmatch(sided, c("upper","Rupper","two","Rlower")) - 1
+ if (is.na(ctyp)) stop("invalid ewma type")
+ if ( qm<5 ) stop("qm is too small")
+ if ( qm.sigma<4 ) stop("qm.sigma is too small")
+ if ( truncate < 0 | truncate >= 0.5 ) stop("wrong value for truncate (should follow 0 < truncate < 0.5)")
+ sf <- .C("sewma_sf_prerun",
+ as.integer(ctyp), as.double(l), as.double(cl), as.double(cu), as.double(hs),
+ as.double(sigma), as.integer(df1), as.integer(qm), as.integer(n),
+ as.integer(df2), as.integer(qm.sigma), as.double(truncate), as.integer(tail_approx),
+ ans=double(length=n),PACKAGE="spc")$ans
+ names(sf) <- NULL
+ sf
+}
diff --git a/R/tol.lim.fac.R b/R/tol.lim.fac.R
new file mode 100644
index 0000000..6ac8f24
--- /dev/null
+++ b/R/tol.lim.fac.R
@@ -0,0 +1,19 @@
+# Computation of 2-sided tolerance limits factors
+tol.lim.fac <- function(n,p,a,mode="WW",m=30) {
+ if (n<2)
+ stop("n has to be larger than 1")
+ if (p<=0 | p>=1)
+ stop("p has to be in (0,1)")
+ if (a<=0 | a>=1)
+ stop("a has to be in (0,1)")
+ mtype <- pmatch(mode, c("WW", "exact")) - 1
+ if (is.na(mtype))
+ stop("invalid mode type")
+ if (m<10)
+ stop("m has to be at least 10")
+ tlf <- .C("tol_lim_fac",as.integer(n),as.double(p),
+ as.double(a),as.integer(mtype),as.integer(m),
+ ans=double(length=1),PACKAGE="spc")$ans
+ names(tlf) <- "k"
+ return (tlf)
+}
diff --git a/R/x.res.ewma.arl.R b/R/x.res.ewma.arl.R
new file mode 100644
index 0000000..881fe18
--- /dev/null
+++ b/R/x.res.ewma.arl.R
@@ -0,0 +1,24 @@
+# Computation of res-EWMA ARLs (mean monitoring)
+x.res.ewma.arl <- function(l, c, mu, alpha=0, n=5, hs=0, r=40) {
+ if ( l <= 0 || l > 1 )
+ stop("l has to be between 0 and 1")
+ if ( c <= 0 )
+ warning("usually, c has to be positive")
+ if ( abs(alpha) > 1 )
+ warning("nonstationary AR(1) process")
+ if ( n < 1 )
+ warning("n is too small")
+ n <- round(n)
+ if ( abs(hs) > c )
+ warning("unusual headstart")
+ if ( r < 4 )
+ stop("r is too small")
+ ctyp <- 1 # later more
+ arl <- .C("x_res_ewma_arl",as.double(alpha),as.integer(n),
+ as.integer(ctyp),as.double(l),
+ as.double(c),as.double(hs),
+ as.double(mu),as.integer(r),
+ ans=double(length=1),PACKAGE="spc")$ans
+ names(arl) <- "arl"
+ return (arl)
+}
\ No newline at end of file
diff --git a/R/xDcusum.arl.R b/R/xDcusum.arl.R
new file mode 100644
index 0000000..1a6d094
--- /dev/null
+++ b/R/xDcusum.arl.R
@@ -0,0 +1,31 @@
+# Computation of CUSUM ARLs (drift monitoring)
+xDcusum.arl <- function(k, h, delta, hs=0, sided="one", mode="Gan", m=NULL, q=1, r=30, with0=FALSE) {
+ if (k<0)
+ stop("k has to be non-negative")
+ if (h<=0)
+ stop("h has to be positive")
+ if ( hs<0 | (sided=="two" & hs>h/2+k) | (sided=="one" & hs>h/2+k) )
+ stop("wrong headstart")
+ if (r<4)
+ stop("r is too small")
+ if ( is.null(m) ) {
+ m <- 0
+ } else {
+ if ( m<1 ) stop("m is too small")
+ }
+ ctyp <- pmatch(sided, c("one", "two")) - 1
+ if (is.na(ctyp))
+ stop("invalid cusum type")
+ cmode <- pmatch(mode, c("Gan", "Knoth")) - 1
+ if (is.na(cmode))
+ stop("invalid algorithm mode")
+ q <- round(q)
+ if (q<1)
+ stop("wrong change point position (q)")
+ arl <- .C("xDcusum_arl",as.integer(ctyp),as.double(k),
+ as.double(h),as.double(hs),as.double(delta),as.integer(m),
+ as.integer(r),as.integer(with0),as.integer(cmode),as.integer(q),
+ ans=double(length=1),PACKAGE="spc")$ans
+ names(arl) <- "arl"
+ return (arl)
+}
diff --git a/R/xDewma.arl.R b/R/xDewma.arl.R
new file mode 100644
index 0000000..8e8b87c
--- /dev/null
+++ b/R/xDewma.arl.R
@@ -0,0 +1,36 @@
+# Computation of EWMA ARLs (drift monitoring)
+xDewma.arl <- function(l, c, delta, zr=0, hs=0, sided="one", limits="fix", mode="Gan", m=NULL, q=1, r=40, with0=FALSE) {
+ if (l<=0 || l>1)
+ stop("l has to be between 0 and 1")
+ if (c<=0)
+ stop("c has to be positive")
+ if (zr>c & sided=="one")
+ stop("wrong reflexion border")
+ if ( (sided=="two" & abs(hs)>c) | (sided=="one" & (hs<zr | hs>c)) )
+ stop("wrong headstart")
+ if (r<4)
+ stop("r is too small")
+ ctyp <- pmatch(sided, c("one", "two")) - 1
+ if (is.na(ctyp))
+ stop("invalid ewma type")
+ ltyp <- -1 + pmatch(limits,
+ c("fix","vacl","fir","both","Steiner","Knoth","fink","fixW","fixC"))
+ if (is.na(ltyp))
+ stop("invalid limits type")
+ cmode <- pmatch(mode, c("Gan", "Knoth", "Waldmann")) - 1
+ if (is.na(cmode))
+ stop("invalid algorithm mode")
+ if ( is.null(m) ) {
+ m <- 0
+ } else { if ( m<1 ) stop("m is too small") }
+ q <- round(q)
+ if (q<1)
+ stop("wrong change point position (q)")
+ arl <- .C("xDewma_arl",as.integer(ctyp),as.double(l),
+ as.double(c),as.double(zr),as.double(hs),
+ as.double(delta),as.integer(ltyp),as.integer(m),as.integer(r),
+ as.integer(with0),as.integer(cmode),as.integer(q),
+ ans=double(length=1),PACKAGE="spc")$ans
+ names(arl) <- "arl"
+ return (arl)
+}
diff --git a/R/xDgrsr.arl.R b/R/xDgrsr.arl.R
new file mode 100644
index 0000000..aad507e
--- /dev/null
+++ b/R/xDgrsr.arl.R
@@ -0,0 +1,37 @@
+# Computation of GRSR (Girshick, Rubin, Shiryaev, Roberts) ARLs (drift monitoring)
+xDgrsr.arl <- function(k, g, delta, zr=0, hs=NULL, sided="one", m=NULL, mode="Gan", q=1, r=30, with0=FALSE) {
+ if (k<0)
+ stop("k has to be non-negative")
+ if (g<=0)
+ stop("g has to be positive")
+ if (zr>g)
+ stop("zr has to be smaller than g")
+ if ( !is.null(hs) ) {
+ if ( hs>g )
+ stop("wrong headstart")
+ } else {
+ hs <- 2*g # mimics hs = -inf
+ }
+ ctyp <- pmatch(sided, c("one", "two")) - 1
+ if (is.na(ctyp))
+ stop("invalid grsr type")
+ if (r<4)
+ stop("r is too small")
+ if ( is.null(m) ) {
+ m <- 0
+ } else {
+ if ( m<1 ) stop("m is too small")
+ }
+ cmode <- pmatch(mode, c("Gan", "Knoth")) - 1
+ if (is.na(cmode))
+ stop("invalid algorithm mode")
+ q <- round(q)
+ if (q<1)
+ stop("wrong change point position (q)")
+ arl <- .C("xDgrsr_arl",as.double(k),
+ as.double(g),as.double(zr),as.double(hs),as.double(delta),as.integer(m),
+ as.integer(r),as.integer(with0),as.integer(cmode),as.integer(q),
+ ans=double(length=1),PACKAGE="spc")$ans
+ names(arl) <- "arl"
+ return (arl)
+}
diff --git a/R/xDshewhartrunsrules.arl.R b/R/xDshewhartrunsrules.arl.R
new file mode 100644
index 0000000..b291e4d
--- /dev/null
+++ b/R/xDshewhartrunsrules.arl.R
@@ -0,0 +1,18 @@
+
+xDshewhartrunsrules.arl <- function(delta, c=1, m=NULL, type="12") {
+ eps <- 1e-6
+ if ( is.null(m) ) {
+ m <- 4
+ arl1 <- xDshewhartrunsrulesFixedm.arl(delta, c=c, m=m, type=type)
+ arl2 <- arl1 + 2*eps
+ while ( abs(arl2-arl1)>eps & m<1e4 ) {
+ m <- round(1.5 * m)
+ arl1 <- xDshewhartrunsrulesFixedm.arl(delta, c=c, m=m, type=type)
+ arl2 <- xDshewhartrunsrulesFixedm.arl(delta, c=c, m=m+1, type=type)
+ }
+ arl <- arl1
+ } else {
+ arl <- xDshewhartrunsrulesFixedm.arl(delta, c=c, m=m, type=type)
+ }
+ arl
+}
\ No newline at end of file
diff --git a/R/xDshewhartrunsrulesFixedm.arl.R b/R/xDshewhartrunsrulesFixedm.arl.R
new file mode 100644
index 0000000..4da40a3
--- /dev/null
+++ b/R/xDshewhartrunsrulesFixedm.arl.R
@@ -0,0 +1,28 @@
+
+xDshewhartrunsrulesFixedm.arl <- function(delta, c=1, m=100, type="12") {
+ mus <- (1:m)*delta
+
+# Shewhart chart
+ if (type=="1") {
+ p0 <- pnorm( 3*c, mean=mus ) - pnorm( -3*c, mean=mus)
+ arls <- 1/(1-p0[m])
+ for ( i in (m-1):1 ) arls <- 1 + p0[i]*arls
+ }
+
+# ditto with runs rules
+ if (type!="1") {
+ Q <- xshewhartrunsrules.matrix(mus[m], c=c, type=type)
+ dimQ <- nrow(Q)
+ one <- rep(1, dimQ)
+ I <- diag(1, dimQ)
+ arls <- solve(I-Q, one)
+
+ for ( i in (m-1):1 ) {
+ Q <- xshewhartrunsrules.matrix(mus[i], c=c, type=type)
+ arls <- 1 + (Q %*% arls)[,1]
+ }
+ }
+
+ arl <- arls[1]
+ arl
+}
\ No newline at end of file
diff --git a/R/xcusum.ad.R b/R/xcusum.ad.R
new file mode 100644
index 0000000..0cb5644
--- /dev/null
+++ b/R/xcusum.ad.R
@@ -0,0 +1,21 @@
+# Computation of CUSUM steady-state ARLs (mean monitoring)
+xcusum.ad <- function(k, h, mu1, mu0 = 0, sided = "one", r = 30) {
+ if (k<0)
+ stop("k has to be non-negative")
+ if (h<=0)
+ stop("h has to be positive")
+ if (r<4)
+ stop("r is too small")
+ if (r>30 & r<=50 & sided=="two")
+ warning("computation needs some time")
+ if (r>50 & sided=="two")
+ warning("ought to be restricted to very fast CPUs")
+ ctyp <- pmatch(sided, c("one", "two", "Crosier")) - 1
+ if (is.na(ctyp))
+ stop("invalid cusum type")
+ ad <- .C("xcusum_ad",as.integer(ctyp),as.double(k),
+ as.double(h),as.double(mu0),as.double(mu1),as.integer(r),
+ ans=double(length=1),PACKAGE="spc")$ans
+ names(ad) <- "ad"
+ return(ad)
+}
diff --git a/R/xcusum.arl.R b/R/xcusum.arl.R
new file mode 100644
index 0000000..cf99bab
--- /dev/null
+++ b/R/xcusum.arl.R
@@ -0,0 +1,26 @@
+# Computation of CUSUM ARLs (mean monitoring)
+xcusum.arl <- function(k, h, mu, hs=0, sided="one", method="igl", q=1, r=30) {
+ if (k<0)
+ stop("k has to be non-negative")
+ if (h<=0)
+ stop("h has to be positive")
+ if ( hs<0 | (sided=="two" & hs>h/2+k) | (sided=="one" & hs>h) )
+ stop("wrong headstart")
+ if (r<4)
+ stop("r is too small")
+ ctyp <- pmatch(sided, c("one", "two", "Crosier")) - 1
+ if (is.na(ctyp))
+ stop("invalid cusum type")
+ mtyp <- pmatch(method, c("igl", "mc")) - 1
+ if (is.na(mtyp))
+ stop("invalid method")
+ q <- round(q)
+ if (q<1)
+ stop("wrong change point position (q)")
+ arl <- .C("xcusum_arl",
+ as.integer(ctyp), as.double(k), as.double(h), as.double(hs), as.double(mu),
+ as.integer(q), as.integer(r), as.integer(mtyp),
+ ans=double(length=q), PACKAGE="spc")$ans
+ names(arl) <- NULL
+ return (arl)
+}
diff --git a/R/xcusum.crit.L0L1.R b/R/xcusum.crit.L0L1.R
new file mode 100644
index 0000000..7de86da
--- /dev/null
+++ b/R/xcusum.crit.L0L1.R
@@ -0,0 +1,36 @@
+
+# Computation of CUSUM k (reference value) and threshold h for given in-control ARL L0 and out-of-control ARL L1 (mean monitoring)
+# Ewan & Kemp 1960 or Kemp 1962
+
+xcusum.crit.L0L1 <- function(L0, L1, hs = 0, sided="one", r = 30, L1.eps=1e-6, k.eps=1e-8) {
+ k1 <- 0
+ L1_1 <- L1 + 1
+ while ( L1_1 > L1 ) {
+ k1 <- k1 + .1
+ h1 <- xcusum.crit(k1, L0, hs=hs, sided=sided, r=r)
+ L1_1 <- xcusum.arl(k1, h1, 2*k1, hs=hs, sided=sided, r=r)
+ }
+ while ( L1_1 < L1 & k1 > 0.01 ) {
+ k1 <- k1 - .01
+ h1 <- xcusum.crit(k1, L0, hs=hs, sided=sided, r=r)
+ L1_1 <- xcusum.arl(k1, h1, 2*k1, hs=hs, sided=sided, r=r)
+ }
+ k2 <- k1 + .01
+ h2 <- xcusum.crit(k2, L0, hs=hs, sided=sided, r=r)
+ L1_2 <- xcusum.arl(k2, h2, 2*k2, hs=hs, sided=sided, r=r)
+ dk <- 1
+ while ( abs(L1-L1_2) > L1.eps & abs(dk) > k.eps ) {
+ k3 <- k1 + ( L1 - L1_1 ) / ( L1_2 - L1_1 ) * ( k2 - k1 )
+ h3 <- xcusum.crit(k3, L0, hs=hs, sided=sided, r=r)
+ L1_3 <- xcusum.arl(k3, h3, 2*k3, hs=hs, sided=sided, r=r)
+ # secant rule
+ dk <- k3-k2
+ k1 <- k2
+ L1_1 <- L1_2
+ k2 <- k3
+ L1_2 <- L1_3
+ }
+ result <- c(k3, h3)
+ names(result) <- c("k", "h")
+ result
+}
diff --git a/R/xcusum.crit.L0h.R b/R/xcusum.crit.L0h.R
new file mode 100644
index 0000000..8509e3d
--- /dev/null
+++ b/R/xcusum.crit.L0h.R
@@ -0,0 +1,31 @@
+
+# Computation of CUSUM k (reference value) for given in-control ARL and threshold h (mean monitoring)
+
+xcusum.crit.L0h <- function(L0, h, hs=0, sided="one", r=30, L0.eps=1e-6, k.eps=1e-8) {
+ h.max <- xcusum.crit(0, L0, 0)
+ if ( h.max < h ) stop("h too large or L0 far too small")
+ k1 <- 0
+ L0_1 <- 0
+ while ( L0_1 < L0 ) {
+ k1 <- k1 + .1
+ L0_1 <- xcusum.arl(k1, h, 0, hs=hs, sided=sided, r=r)
+ }
+ while ( L0_1 > L0 & k1 > 0.01) {
+ k1 <- k1 - .01
+ L0_1 <- xcusum.arl(k1, h, 0, hs=hs, sided=sided, r=r)
+ }
+ k2 <- k1 + .01
+ L0_2 <- xcusum.arl(k2, h, 0, hs=hs, r=r)
+ dk <- 1
+ while ( abs(L0-L0_2) > L0.eps & abs(dk) > k.eps ) {
+ k3 <- k1 + ( L0 - L0_1 ) / ( L0_2 - L0_1 ) * ( k2 - k1 )
+ L0_3 <- xcusum.arl(k3, h, 0, hs=hs, sided=sided, r=r)
+ # secant rule
+ dk <- k3-k2
+ k1 <- k2
+ L0_1 <- L0_2
+ k2 <- k3
+ L0_2 <- L0_3
+ }
+ k3
+}
diff --git a/R/xcusum.crit.R b/R/xcusum.crit.R
new file mode 100644
index 0000000..545bacf
--- /dev/null
+++ b/R/xcusum.crit.R
@@ -0,0 +1,20 @@
+# Computation of CUSUM decision limits for given ARL (mean monitoring)
+xcusum.crit <- function(k, L0, mu0 = 0, hs = 0, sided = "one", r = 30) {
+ if (k<0)
+ stop("k has to be non-negative")
+ if (L0<1)
+ stop("L0 is too small")
+ if (hs<0)
+ stop("wrong headstart")
+ if (r<4)
+ stop("r is too small")
+ ctyp <- pmatch(sided, c("one", "two", "Crosier")) - 1
+ if (is.na(ctyp))
+ stop("invalid cusum type")
+ h <- .C("xcusum_crit",as.integer(ctyp),as.double(k),
+ as.double(L0),as.double(hs),as.double(mu0),as.integer(r),
+ ans=double(length=1),PACKAGE="spc")$ans
+ names(h) <- "h"
+ return (h)
+}
+
diff --git a/R/xcusum.q.R b/R/xcusum.q.R
new file mode 100644
index 0000000..000d526
--- /dev/null
+++ b/R/xcusum.q.R
@@ -0,0 +1,15 @@
+# Computation of CUSUM quantiles (mean monitoring)
+xcusum.q <- function(k, h, mu, alpha, hs=0, sided="one", r=40) {
+ if ( k < 0 ) stop("k has to be non-negative")
+ if ( h <= 0 ) stop("h has to be positive")
+ if ( hs<0 | (sided=="two" & hs>h/2+k) | (sided=="one" & hs>h/2+k) ) stop("wrong headstart")
+ if ( alpha <= 0 | alpha >= 1) stop("quantile level alpha must be in (0,1)")
+ ctyp <- pmatch(sided, c("one", "two")) - 1
+ if ( is.na(ctyp) ) stop("invalid cusum type")
+ if ( r < 4 ) stop("r (dimension of Markov chain) is too small")
+ quant <- .C("xcusum_q",
+ as.integer(ctyp), as.double(k),as.double(h), as.double(alpha), as.double(hs), as.double(mu), as.integer(r),
+ ans=double(length=1),PACKAGE="spc")$ans
+ names(quant) <- "q"
+ quant
+}
diff --git a/R/xcusum.sf.R b/R/xcusum.sf.R
new file mode 100644
index 0000000..9573938
--- /dev/null
+++ b/R/xcusum.sf.R
@@ -0,0 +1,15 @@
+# Computation of CUSUM survival function (mean monitoring)
+xcusum.sf <- function(k, h, mu, n, hs=0, sided="one", r=40) {
+ if ( k < 0 ) stop("k has to be non-negative")
+ if ( h <= 0 ) stop("h has to be positive")
+ if ( hs < 0 | (sided=="two" & hs>h/2+k) | (sided=="one" & hs>h/2+k) ) stop("wrong headstart")
+ if ( n < 1 ) stop("n has to be a natural number")
+ ctyp <- pmatch(sided, c("one", "two")) - 1
+ if ( is.na(ctyp) ) stop("invalid cusum type")
+ if ( r < 4 ) stop("r is too small")
+ sf <- .C("xcusum_sf",
+ as.integer(ctyp), as.double(k), as.double(h), as.double(hs), as.double(mu), as.integer(r), as.integer(n),
+ ans=double(length=n),PACKAGE="spc")$ans
+ names(sf) <- NULL
+ sf
+}
diff --git a/R/xewma.ad.R b/R/xewma.ad.R
new file mode 100644
index 0000000..eb305ba
--- /dev/null
+++ b/R/xewma.ad.R
@@ -0,0 +1,31 @@
+# Computation of EWMA steady-state ARLs (mean monitoring)
+xewma.ad <- function(l, c, mu1, mu0=0, zr=0, z0=0, sided="one", limits="fix", steady.state.mode="conditional", r=40) {
+ if ( l<=0 || l>1 ) stop("l has to be between 0 and 1")
+
+ if ( c<=0 ) warning("usually, c has to be positive")
+
+ if ( zr>c & sided=="one" ) stop("wrong reflexion border")
+
+ if ( r<4 ) stop("r is too small")
+
+ ctyp <- pmatch(sided, c("one", "two")) - 1
+ if (is.na(ctyp)) stop("invalid ewma type")
+
+ ltyp <- pmatch(limits, c("fix","vacl","fir","both","Steiner","stat")) - 1
+ if ( is.na(ltyp) ) stop("invalid limits type")
+
+ if ( (sided=="one") & !(limits %in% c("fix", "vacl", "stat")) )
+ stop("not supported for one-sided EWMA (not reasonable or not implemented yet")
+
+ styp <- pmatch(steady.state.mode, c("conditional", "cyclical")) - 1
+ if (is.na(styp)) stop("invalid steady.state.mode")
+
+ if ( abs(z0) > abs(c) ) stop("wrong restarting value")
+
+ ad <- .C("xewma_ad", as.integer(ctyp), as.double(l),
+ as.double(c), as.double(zr), as.double(mu0), as.double(mu1), as.double(z0),
+ as.integer(ltyp), as.integer(styp), as.integer(r),
+ ans=double(length=1), PACKAGE="spc")$ans
+ names(ad) <- "ad"
+ return (ad)
+}
diff --git a/R/xewma.arl.R b/R/xewma.arl.R
new file mode 100644
index 0000000..63e1164
--- /dev/null
+++ b/R/xewma.arl.R
@@ -0,0 +1,38 @@
+# Computation of EWMA ARLs (mean monitoring)
+xewma.arl <- function(l, c, mu, zr=0, hs=0, sided="one", limits="fix", q=1, r=40) {
+ if ( l<=0 | l>2 )
+ stop("l has to be between 0 and 2")
+ if ( c<=0 )
+ warning("usually, c has to be positive")
+ if ( zr>c & sided=="one" )
+ stop("wrong reflexion border")
+ if ( (sided=="two" & abs(hs)>c) | (sided=="one" & (hs<zr | hs>c)) )
+ warning("unusual headstart")
+ if ( r<4 )
+ stop("r is too small")
+ ctyp <- pmatch(sided, c("one", "two")) - 1
+ if ( is.na(ctyp) )
+ stop("invalid ewma type")
+ ltyp <- -1 + pmatch(limits,
+ c("fix", "vacl", "fir", "both", "Steiner", "stat", "fink", "limit", "fixW", "fixC"))
+ if ( is.na(ltyp) )
+ stop("invalid limits type")
+ if ( (sided=="one") & !(limits %in% c("fix", "vacl", "stat", "limit", "fixW")) )
+ stop("not supported for one-sided EWMA (not reasonable or not implemented yet")
+ q <- round(q)
+ if ( q<1 )
+ stop("wrong change point position (q)")
+ if ( limits=="fix" & q>1 ) {
+ arl <- .C("xewma_arl",as.integer(ctyp),as.double(l),
+ as.double(c),as.double(zr),as.double(hs),
+ as.double(mu),as.integer(ltyp),as.integer(r),as.integer(q),
+ ans=double(length=q), PACKAGE="spc")$ans
+ } else {
+ arl <- .C("xewma_arl",as.integer(ctyp),as.double(l),
+ as.double(c),as.double(zr),as.double(hs),
+ as.double(mu),as.integer(ltyp),as.integer(r),as.integer(q),
+ ans=double(length=1), PACKAGE="spc")$ans
+ }
+ names(arl) <- NULL
+ return (arl)
+}
diff --git a/R/xewma.arl.prerun.R b/R/xewma.arl.prerun.R
new file mode 100644
index 0000000..7f60c71
--- /dev/null
+++ b/R/xewma.arl.prerun.R
@@ -0,0 +1,32 @@
+# Computation of EWMA ARLs (mean monitoring) under specified pr-run scenarios
+xewma.arl.prerun <- function(l, c, mu, zr=0, hs=0, sided="two", limits="fix", q=1, size=100, df=NULL, estimated="mu", qm.mu=30, qm.sigma=30, truncate=1e-10) {
+ if ( l<=0 | l>1 ) stop("l has to be between 0 and 1")
+ if ( c<=0 ) warning("usually, c has to be positive")
+ if ( zr>c & sided=="one" ) stop("wrong reflexion border")
+ if ( (sided=="two" & abs(hs)>c) | (sided=="one" & (hs<zr | hs>c)) ) warning("unusual headstart")
+ ctyp <- pmatch(sided, c("one", "two")) - 1
+ if (is.na(ctyp)) stop("invalid ewma type")
+ ltyp <- -1 + pmatch(limits, c("fix", "vacl", "fir", "both", "Steiner", "stat"))
+ if (is.na(ltyp)) stop("invalid limits type")
+ if ( (sided=="one") & !(limits %in% c("fix", "vacl", "stat", "limit", "fixW")) )
+ stop("not supported for one-sided EWMA (not reasonable or not implemented yet")
+ q <- round(q)
+ if ( q<1 ) stop("wrong change point position (q)")
+ if ( size<2 ) stop("pre run size too small")
+ if ( is.null(df) ) df = size - 1
+ if ( df<1 ) stop("degrees of freedom (df) too small")
+ emode <- -1 + pmatch(estimated, c("mu", "sigma", "both"))
+ if (is.na(emode)) stop("invalid to be estimated type")
+ if ( qm.mu<4 ) stop("qm.mu is too small")
+ if ( qm.sigma<4 ) stop("qm.sigma is too small")
+ if ( truncate < 0 | truncate >= 0.5 ) stop("wrong value for truncate (should follow 0 < truncate < 0.5)")
+ arl <- .C("xewma_arl_prerun",
+ as.integer(ctyp), as.double(l), as.double(c),
+ as.double(zr), as.double(hs), as.double(mu),
+ as.integer(ltyp), as.integer(q),
+ as.integer(size), as.integer(df),
+ as.integer(emode), as.integer(qm.mu), as.integer(qm.sigma), as.double(truncate),
+ ans=double(length=1), PACKAGE="spc")$ans
+ names(arl) <- "arl"
+ return (arl)
+}
diff --git a/R/xewma.crit.R b/R/xewma.crit.R
new file mode 100644
index 0000000..57ae657
--- /dev/null
+++ b/R/xewma.crit.R
@@ -0,0 +1,31 @@
+# Computation of EWMA critical values for given ARL (mean monitoring)
+xewma.crit <- function(l,L0,mu0=0,zr=0,hs=0,sided="one",limits="fix",r=40,c0=NULL) {
+ if ( l<=0 | l>2 )
+ stop("l has to be between 0 and 2")
+ if ( L0<1 )
+ stop("L0 is too small")
+ if ( r<4 )
+ stop("r is too small")
+ if ( sided=="one" & hs<zr )
+ warning("unusual headstart")
+ ctyp <- pmatch(sided, c("one", "two")) - 1
+ if ( is.na(ctyp) )
+ stop("invalid ewma type")
+ ltyp <- pmatch(limits, c("fix","vacl","fir","both","Steiner","stat")) - 1
+ if ( is.na(ltyp) )
+ stop("invalid limits type")
+ if ( (sided=="one") & !(limits %in% c("fix", "vacl", "stat")) )
+ stop("not supported for one-sided EWMA (not reasonable or not implemented yet")
+ if ( is.null(c0) ) {
+ if ( sided=="one" ) c0 <- zr - 1
+ if ( sided=="two" ) c0 <- -1
+ }
+ c <- .C("xewma_crit",as.integer(ctyp),as.double(l),
+ as.double(L0),as.double(zr),as.double(hs),
+ as.double(mu0),as.integer(ltyp),as.integer(r),
+ as.double(c0),
+ ans=double(length=1),PACKAGE="spc")$ans
+ names(c) <- "c"
+ return (c)
+}
+
diff --git a/R/xewma.crit.prerun.R b/R/xewma.crit.prerun.R
new file mode 100644
index 0000000..ab96ce0
--- /dev/null
+++ b/R/xewma.crit.prerun.R
@@ -0,0 +1,66 @@
+xewma.crit.prerun <- function(l, L0, mu, zr=0, hs=0, sided="two", limits="fix", size=100, df=NULL, estimated="mu", qm.mu=30, qm.sigma=30,
+ truncate=1e-10, c.error=1e-12, L.error=1e-9, OUTPUT=FALSE) {
+
+ if ( OUTPUT ) cat("\nc\t\tL\n")
+
+ c2 <- xewma.crit(l, L0, mu0=mu, zr=zr, hs=hs, sided=sided, limits=limits)
+ L2 <- xewma.arl.prerun(l, c2, mu, zr=zr, hs=hs, sided=sided, limits=limits, q=1, size=size, df=df, estimated=estimated, qm.mu=qm.mu, qm.sigma=qm.sigma, truncate=truncate)
+ if ( OUTPUT ) cat(paste(c2,"\t",L2,"\n"))
+
+ if ( L2 < L0 ) {
+ while ( L2 < L0 ) {
+ L1 <- L2
+ c2 <- c2 + .5
+ L2 <- xewma.arl.prerun(l, c2, mu, zr=zr, hs=hs, sided=sided, limits=limits, q=1, size=size, df=df, estimated=estimated, qm.mu=qm.mu, qm.sigma=qm.sigma, truncate=truncate)
+ if ( OUTPUT ) cat(paste(c2,"\t",L2,"\n"))
+ }
+ c1 <- c2 - .5
+ } else {
+ while ( L2 >= L0 ) {
+ L1 <- L2
+ c2 <- c2 - .5
+ L2 <- xewma.arl.prerun(l, c2, mu, zr=zr, hs=hs, sided=sided, limits=limits, q=1, size=size, df=df, estimated=estimated, qm.mu=qm.mu, qm.sigma=qm.sigma, truncate=truncate)
+ if ( OUTPUT ) cat(paste(c2,"\t",L2,"\n"))
+ }
+ c1 <- c2 + .5
+ }
+
+ if ( size < 51 ) {
+ if ( qm.mu < 70 ) qm.mu <- 70
+ if ( qm.mu < 70 ) qm.mu <- 70
+ if ( size < 31 ) {
+ if ( qm.mu < 90 ) qm.mu <- 90
+ if ( qm.mu < 90 ) qm.mu <- 90
+ }
+ if ( L2 < L0 ) {
+ while ( L2 < L0 ) {
+ L1 <- L2
+ c2 <- c2 + .1
+ L2 <- xewma.arl.prerun(l, c2, mu, zr=zr, hs=hs, sided=sided, limits=limits, q=1, size=size, df=df, estimated=estimated, qm.mu=qm.mu, qm.sigma=qm.sigma, truncate=truncate)
+ if ( OUTPUT ) cat(paste(c2,"\t",L2,"\n"))
+ }
+ c1 <- c2 - .1
+ } else {
+ while ( L2 >= L0 ) {
+ L1 <- L2
+ c2 <- c2 - .1
+ L2 <- xewma.arl.prerun(l, c2, mu, zr=zr, hs=hs, sided=sided, limits=limits, q=1, size=size, df=df, estimated=estimated, qm.mu=qm.mu, qm.sigma=qm.sigma, truncate=truncate)
+ if ( OUTPUT ) cat(paste(c2,"\t",L2,"\n"))
+ }
+ c1 <- c2 + .1
+ }
+ }
+
+ L.error_ <- 1; c.error_ <- 1
+ while ( L.error_ > L.error & c.error_ > c.error ) {
+ c3 <- c1 + (L0 - L1)/(L2 - L1)*(c2 - c1)
+ L3 <- xewma.arl.prerun(l, c3, mu, zr=zr, hs=hs, sided=sided, limits=limits, q=1, size=size, df=df, estimated=estimated, qm.mu=qm.mu, qm.sigma=qm.sigma, truncate=truncate)
+ if ( OUTPUT ) cat(paste(c3,"\t",L3,"\n"))
+ c1 <- c2; c2 <- c3
+ L1 <- L2; L2 <- L3
+ L.error_ <- abs(L2 - L0); c.error_ <- abs(c2 - c1)
+ }
+
+ names(c3) <- "c"
+ c3
+}
diff --git a/R/xewma.q.R b/R/xewma.q.R
new file mode 100644
index 0000000..0316a6e
--- /dev/null
+++ b/R/xewma.q.R
@@ -0,0 +1,24 @@
+# Computation of EWMA quantiles (mean monitoring)
+xewma.q <- function(l, c, mu, alpha, zr=0, hs=0, sided="two", limits="fix", q=1, r=40) {
+ if ( l <= 0 | l > 1 ) stop("l (lambda) has to be between 0 and 1")
+ if ( c<=0 ) warning("usually, c has to be positive")
+ if ( alpha <= 0 | alpha >= 1) stop("quantile level alpha must be in (0,1)")
+ if ( zr > c & sided == "one") stop("wrong reflexion border")
+ if ( (sided == "two" & abs(hs) > c) | (sided == "one" & ( hs < zr | hs > c )) )
+ warning("unusual headstart")
+ ctyp <- pmatch(sided, c("one", "two")) - 1
+ if ( is.na(ctyp) ) stop("invalid ewma type")
+ ltyp <- -1 + pmatch(limits, c("fix", "vacl", "fir", "both", "Steiner", "stat", "test"))
+ if (is.na(ltyp)) stop("invalid limits type")
+ if ( (sided=="one") & !( limits %in% c("fix", "vacl", "stat") ) )
+ stop("not supported for one-sided EWMA (not reasonable or not implemented yet")
+ if ( r < 4 ) stop("r is too small")
+ q <- round(q)
+ if ( q<1 ) stop("wrong change point position (q)")
+ quant <- .C("xewma_q",
+ as.integer(ctyp), as.double(l), as.double(c), as.double(alpha), as.double(zr), as.double(hs), as.double(mu),
+ as.integer(ltyp), as.integer(r), as.integer(q),
+ ans=double(length=1),PACKAGE="spc")$ans
+ names(quant) <- "q"
+ quant
+}
diff --git a/R/xewma.q.crit.R b/R/xewma.q.crit.R
new file mode 100644
index 0000000..be9567f
--- /dev/null
+++ b/R/xewma.q.crit.R
@@ -0,0 +1,32 @@
+xewma.q.crit <- function(l, L0, mu, alpha, zr=0, hs=0, sided="two", limits="fix", r=40, c.error=1e-12, a.error=1e-9, OUTPUT=FALSE) {
+
+ c2 <- 0
+ p2 <- 1
+ if ( OUTPUT ) cat("\nc\t\tp\n")
+ while ( p2 > alpha ) {
+ p1 <- p2
+ c2 <- c2 + .5
+ p2 <- 1 - xewma.sf(l, c2, mu, L0, zr=zr, hs=hs, sided=sided, limits=limits, q=1, r=r)[L0]
+ if ( OUTPUT ) cat(paste(c2,"\t",p2,"\n"))
+ }
+ while ( p2 <= alpha & c2 > .02 ) {
+ p1 <- p2
+ c2 <- c2 - .02
+ p2 <- 1 - xewma.sf(l, c2, mu, L0, zr=zr, hs=hs, sided=sided, limits=limits, q=1, r=r)[L0]
+ if ( OUTPUT ) cat(paste(c2,"\t",p2,"\n"))
+ }
+ c1 <- c2 + .02
+
+ a.error_ <- 1; c.error_ <- 1
+ while ( a.error_ > a.error & c.error_ > c.error ) {
+ c3 <- c1 + (alpha - p1)/(p2 - p1)*(c2 - c1)
+ p3 <- 1 - xewma.sf(l, c3, mu, L0, zr=zr, hs=hs, sided=sided, limits=limits, q=1, r=r)[L0]
+ if ( OUTPUT ) cat(paste(c3,"\t",p3,"\n"))
+ c1 <- c2; c2 <- c3
+ p1 <- p2; p2 <- p3
+ a.error_ <- abs(p2 - alpha); c.error_ <- abs(c2 - c1)
+ }
+
+ names(c3) <- "c"
+ c3
+}
diff --git a/R/xewma.q.crit.prerun.R b/R/xewma.q.crit.prerun.R
new file mode 100644
index 0000000..f1028c5
--- /dev/null
+++ b/R/xewma.q.crit.prerun.R
@@ -0,0 +1,72 @@
+xewma.q.crit.prerun <- function(l, L0, mu, p, zr=0, hs=0, sided="two", limits="fix", size=100, df=NULL, estimated="mu", qm.mu=30, qm.sigma=30,
+ truncate=1e-10, bound=1e-10, c.error=1e-10, p.error=1e-9, OUTPUT=FALSE) {
+
+ if ( OUTPUT ) cat("\nc\t\tp\n")
+
+ c2 <- xewma.q.crit(l, L0, mu, p, zr=zr, hs=hs, sided=sided, limits=limits, OUTPUT=FALSE)
+ p2 <- 1 - xewma.sf.prerun(l, c2, mu, L0, zr=zr, hs=hs, sided=sided, limits=limits, q=1,
+ size=size, df=df, estimated=estimated, qm.mu=qm.mu, qm.sigma=qm.sigma, truncate=truncate, bound=bound)[L0]
+ if ( OUTPUT ) cat(paste(c2,"\t",p2,"\n"))
+
+ if ( p2 > p ) {
+ while ( p2 > p ) {
+ p1 <- p2
+ c2 <- c2 + .5
+ p2 <- 1 - xewma.sf.prerun(l, c2, mu, L0, zr=zr, hs=hs, sided=sided, limits=limits, q=1,
+ size=size, df=df, estimated=estimated, qm.mu=qm.mu, qm.sigma=qm.sigma, truncate=truncate, bound=bound)[L0]
+ if ( OUTPUT ) cat(paste(c2,"\t",p2,"\n"))
+ }
+ c1 <- c2 - .5
+ } else {
+ while ( p2 <= p ) {
+ p1 <- p2
+ c2 <- c2 - .5
+ p2 <- 1 - xewma.sf.prerun(l, c2, mu, L0, zr=zr, hs=hs, sided=sided, limits=limits, q=1,
+ size=size, df=df, estimated=estimated, qm.mu=qm.mu, qm.sigma=qm.sigma, truncate=truncate, bound=bound)[L0]
+ if ( OUTPUT ) cat(paste(c2,"\t",p2,"\n"))
+ }
+ c1 <- c2 + .5
+ }
+
+ if ( size < 41 ) {
+ if ( qm.mu < 70 ) qm.mu <- 70
+ if ( qm.mu < 70 ) qm.mu <- 70
+ if ( size < 21 ) {
+ if ( qm.mu < 90 ) qm.mu <- 90
+ if ( qm.mu < 90 ) qm.mu <- 90
+ }
+ if ( p2 > p ) {
+ while ( p2 > p ) {
+ p1 <- p2
+ c2 <- c2 + .1
+ p2 <- 1 - xewma.sf.prerun(l, c2, mu, L0, zr=zr, hs=hs, sided=sided, limits=limits, q=1,
+ size=size, df=df, estimated=estimated, qm.mu=qm.mu, qm.sigma=qm.sigma, truncate=truncate, bound=bound)[L0]
+ if ( OUTPUT ) cat(paste(c2,"\t",p2,"\n"))
+ }
+ c1 <- c2 - .1
+ } else {
+ while ( p2 <= p ) {
+ p1 <- p2
+ c2 <- c2 - .1
+ p2 <- 1 - xewma.sf.prerun(l, c2, mu, L0, zr=zr, hs=hs, sided=sided, limits=limits, q=1,
+ size=size, df=df, estimated=estimated, qm.mu=qm.mu, qm.sigma=qm.sigma, truncate=truncate, bound=bound)[L0]
+ if ( OUTPUT ) cat(paste(c2,"\t",p2,"\n"))
+ }
+ c1 <- c2 + .1
+ }
+ }
+
+ p.error_ <- 1; c.error_ <- 1
+ while ( p.error_ > p.error & c.error_ > c.error ) {
+ c3 <- c1 + (p - p1)/(p2 - p1)*(c2 - c1)
+ p3 <- 1 - xewma.sf.prerun(l, c3, mu, L0, zr=zr, hs=hs, sided=sided, limits=limits, q=1,
+ size=size, df=df, estimated=estimated, qm.mu=qm.mu, qm.sigma=qm.sigma, truncate=truncate, bound=bound)[L0]
+ if ( OUTPUT ) cat(paste(c3,"\t",p3,"\n"))
+ c1 <- c2; c2 <- c3
+ p1 <- p2; p2 <- p3
+ p.error_ <- abs(p2 - p); c.error_ <- abs(c2 - c1)
+ }
+
+ names(c3) <- "c"
+ c3
+}
diff --git a/R/xewma.q.prerun.R b/R/xewma.q.prerun.R
new file mode 100644
index 0000000..4e02a56
--- /dev/null
+++ b/R/xewma.q.prerun.R
@@ -0,0 +1,35 @@
+# Computation of EWMA quantiles (mean monitoring) under specified pr-run scenarios
+xewma.q.prerun <- function(l, c, mu, p, zr=0, hs=0, sided="two", limits="fix", q=1, size=100, df=NULL, estimated="mu", qm.mu=30, qm.sigma=30, truncate=1e-10, bound=1e-10) {
+ if ( l <= 0 | l > 1 ) stop("l (lambda) has to be between 0 and 1")
+ if ( c<=0 ) warning("usually, c has to be positive")
+ if ( p <= 0 | p >= 1) stop("quantile level p must be in (0,1)")
+ if ( zr > c & sided == "one") stop("wrong reflexion border")
+ if ( (sided == "two" & abs(hs) > c) | (sided == "one" & ( hs < zr | hs > c )) )
+ stop("wrong headstart")
+ ctyp <- pmatch(sided, c("one", "two")) - 1
+ if ( is.na(ctyp) ) stop("invalid ewma type")
+ ltyp <- -1 + pmatch(limits, c("fix", "vacl", "fir", "both", "Steiner", "stat"))
+ if (is.na(ltyp)) stop("invalid limits type")
+ if ( (sided=="one") & !( limits %in% c("fix", "vacl", "stat") ) )
+ stop("not supported for one-sided EWMA (not reasonable or not implemented yet")
+ q <- round(q)
+ if ( q<1 ) stop("wrong change point position (q)")
+ if ( size<2 ) stop("pre run size too small")
+ if ( is.null(df) ) df = size - 1
+ if ( df<1 ) stop("degrees of freedom (df) too small")
+ emode <- -1 + pmatch(estimated, c("mu", "sigma", "both"))
+ if (is.na(emode)) stop("invalid to be estimated type")
+ if ( qm.mu<4 ) stop("qm.mu is too small")
+ if ( qm.sigma<4 ) stop("qm.sigma is too small")
+ if ( truncate < 0 | truncate >= 0.5 ) stop("wrong value for truncate (should follow 0 < truncate < 0.5)")
+ if ( bound < 0 | bound >= 0.001 ) stop("wrong value for bound (should follow 0 < truncate < 0.001)")
+ quant <- .C("xewma_q_prerun",
+ as.integer(ctyp), as.double(l), as.double(c),
+ as.double(p), as.double(zr), as.double(hs),
+ as.double(mu), as.integer(ltyp),
+ as.integer(q), as.integer(size), as.integer(df), as.integer(emode),
+ as.integer(qm.mu), as.integer(qm.sigma), as.double(truncate), as.double(bound),
+ ans=double(length=1),PACKAGE="spc")$ans
+ names(quant) <- "q"
+ quant
+}
diff --git a/R/xewma.sf.R b/R/xewma.sf.R
new file mode 100644
index 0000000..9a4997e
--- /dev/null
+++ b/R/xewma.sf.R
@@ -0,0 +1,24 @@
+# Computation of EWMA survival function (mean monitoring)
+xewma.sf <- function(l, c, mu, n, zr=0, hs=0, sided="one", limits="fix", q=1, r=40) {
+ if ( l <= 0 | l > 1 ) stop("l (lambda) has to be between 0 and 1")
+ if ( c <= 0 ) warning("usually, c has to be positive")
+ if ( n < 1 ) stop("n has to be a natural number")
+ if ( zr > c & sided == "one") stop("wrong reflexion border")
+ if ( (sided == "two" & abs(hs) > c) | (sided == "one" & ( hs < zr | hs > c )) )
+ warning("unusual headstart")
+ ctyp <- pmatch(sided, c("one", "two")) - 1
+ if ( is.na(ctyp) ) stop("invalid ewma type")
+ ltyp <- -1 + pmatch(limits, c("fix", "vacl", "fir", "both", "Steiner", "stat", "test"))
+ if (is.na(ltyp)) stop("invalid limits type")
+ if ( (sided=="one") & !( limits %in% c("fix", "vacl", "stat") ) )
+ stop("not supported for one-sided EWMA (not reasonable or not implemented yet")
+ if ( r < 4 ) stop("r is too small")
+ q <- round(q)
+ if ( q<1 ) stop("wrong change point position (q)")
+ sf <- .C("xewma_sf",
+ as.integer(ctyp), as.double(l), as.double(c), as.double(zr), as.double(hs), as.double(mu),
+ as.integer(ltyp), as.integer(r), as.integer(q), as.integer(n),
+ ans=double(length=n),PACKAGE="spc")$ans
+ names(sf) <- NULL
+ sf
+}
diff --git a/R/xewma.sf.prerun.R b/R/xewma.sf.prerun.R
new file mode 100644
index 0000000..e136557
--- /dev/null
+++ b/R/xewma.sf.prerun.R
@@ -0,0 +1,34 @@
+# Computation of EWMA survival function (mean monitoring) under specified pre-run scenarios
+xewma.sf.prerun <- function(l, c, mu, n, zr=0, hs=0, sided="one", limits="fix", q=1, size=100, df=NULL, estimated="mu", qm.mu=30, qm.sigma=30, truncate=1e-10, tail_approx=TRUE, bound=1e-10) {
+ if ( l <= 0 | l > 1 ) stop("l (lambda) has to be between 0 and 1")
+ if ( c <= 0 ) warning("usually, c has to be positive")
+ if ( n < 1 ) stop("n has to be a natural number")
+ if ( zr > c & sided == "one") stop("wrong reflexion border")
+ if ( (sided == "two" & abs(hs) > c) | (sided == "one" & ( hs < zr | hs > c )) )
+ stop("wrong headstart")
+ ctyp <- pmatch(sided, c("one", "two")) - 1
+ if ( is.na(ctyp) ) stop("invalid ewma type")
+ ltyp <- -1 + pmatch(limits, c("fix", "vacl", "fir", "both", "Steiner", "stat"))
+ if (is.na(ltyp)) stop("invalid limits type")
+ if ( (sided=="one") & !( limits %in% c("fix", "vacl", "stat") ) )
+ stop("not supported for one-sided EWMA (not reasonable or not implemented yet")
+ q <- round(q)
+ if ( q<1 ) stop("wrong change point position (q)")
+ if ( size<2 ) stop("pre run size too small")
+ if ( is.null(df) ) df = size - 1
+ if ( df<1 ) stop("degrees of freedom (df) too small")
+ emode <- -1 + pmatch(estimated, c("mu", "sigma", "both"))
+ if (is.na(emode)) stop("invalid to be estimated type")
+ if ( qm.mu<4 ) stop("qm.mu is too small")
+ if ( qm.sigma<4 ) stop("qm.sigma is too small")
+ if ( truncate < 0 | truncate >= 0.5 ) stop("wrong value for truncate (should follow 0 < truncate < 0.5)")
+ if ( bound < 0 | bound >= 0.001 ) stop("wrong value for bound (should follow 0 < truncate < 0.001)")
+ sf <- .C("xewma_sf_prerun",
+ as.integer(ctyp), as.double(l), as.double(c), as.double(zr), as.double(hs), as.double(mu),
+ as.integer(ltyp), as.integer(q), as.integer(n),
+ as.integer(size), as.integer(df), as.integer(emode),
+ as.integer(qm.mu), as.integer(qm.sigma), as.double(truncate), as.integer(tail_approx), as.double(bound),
+ ans=double(length=n),PACKAGE="spc")$ans
+ names(sf) <- NULL
+ sf
+}
\ No newline at end of file
diff --git a/R/xgrsr.ad.R b/R/xgrsr.ad.R
new file mode 100644
index 0000000..4b99c5f
--- /dev/null
+++ b/R/xgrsr.ad.R
@@ -0,0 +1,17 @@
+# Computation of GRSR (Girshick, Rubin, Shiryaev, Roberts) steady-state ARLs (mean monitoring)
+xgrsr.ad <- function(k, g, mu1, mu0=0, zr=0, sided="one", MPT=FALSE, r=30) {
+ if (k<0)
+ stop("k has to be non-negative")
+ if (g<0)
+ stop("g has to be positive")
+ if (r<4)
+ stop("r is too small")
+ ctyp <- pmatch(sided, c("one", "two")) - 1
+ if (is.na(ctyp))
+ stop("invalid grsr type")
+ ad <- .C("xgrsr_ad",as.integer(ctyp),as.double(k),
+ as.double(g),as.double(mu0),as.double(mu1),as.double(zr),as.integer(r),as.integer(MPT),
+ ans=double(length=1),PACKAGE="spc")$ans
+ names(ad) <- "ad"
+ return(ad)
+}
diff --git a/R/xgrsr.arl.R b/R/xgrsr.arl.R
new file mode 100644
index 0000000..a97f336
--- /dev/null
+++ b/R/xgrsr.arl.R
@@ -0,0 +1,21 @@
+# Computation of GRSR (Girshick, Rubin, Shiryaev, Roberts) ARLs (mean monitoring)
+xgrsr.arl <- function(k, g, mu, zr=0, hs=NULL, sided="one", q=1, MPT=FALSE, r=30) {
+ if ( k < 0 ) stop("k has to be non-negative")
+ if ( g < 0 ) stop("g has to be positive")
+ if ( !is.null(hs) ) {
+ if ( hs > g ) stop("wrong headstart")
+ } else {
+ hs <- 2*g
+ }
+ q <- round(q)
+ if ( q < 1 ) stop("wrong change point position (q)")
+ if ( r < 4 ) stop("r is too small")
+ ctyp <- pmatch(sided, c("one", "two")) - 1
+ if ( is.na(ctyp) ) stop("invalid grsr type")
+ arl <- .C("xgrsr_arl",
+ as.integer(ctyp), as.double(k), as.double(g),
+ as.double(zr), as.double(hs), as.double(mu), as.integer(q), as.integer(r), as.integer(MPT),
+ ans=double(length=q), PACKAGE="spc")$ans
+ names(arl) <- NULL
+ return (arl)
+}
\ No newline at end of file
diff --git a/R/xgrsr.crit.R b/R/xgrsr.crit.R
new file mode 100644
index 0000000..0c452e8
--- /dev/null
+++ b/R/xgrsr.crit.R
@@ -0,0 +1,19 @@
+# Computation of GRSR (Girshick, Rubin, Shiryaev, Roberts) alarm threshold for given ARL (mean monitoring)
+xgrsr.crit <- function(k, L0, mu0=0, zr=0, hs=NULL, sided="one", MPT=FALSE, r=30) {
+ if ( k<0 ) stop("k has to be non-negative")
+ if ( L0<1 ) stop("L0 is too small")
+ if ( !is.null(hs) ) {
+ if ( hs>log(L0) ) stop("wrong headstart")
+ } else {
+ hs <- 2*L0
+ }
+ if ( r<4 ) stop("r is too small")
+
+ g <- .C("xgrsr_crit",as.double(k),
+ as.double(L0),as.double(zr),as.double(hs),as.double(mu0),as.integer(r),as.integer(MPT),
+ ans=double(length=1),PACKAGE="spc")$ans
+
+ names(g) <- "g"
+ return (g)
+}
+
diff --git a/R/xs.res.ewma.arl.R b/R/xs.res.ewma.arl.R
new file mode 100644
index 0000000..367785d
--- /dev/null
+++ b/R/xs.res.ewma.arl.R
@@ -0,0 +1,37 @@
+# Computation of res-EWMA ARLs (simultaneous mean & variance monitoring)
+xs.res.ewma.arl <- function(lx, cx, ls, csu, mu, sigma, alpha=0, n=5,
+ hsx=0, rx=40, hss=1, rs=40, qm=30) {
+ if ( lx<=0 || lx>1 )
+ stop("lx has to be between 0 and 1")
+ if ( ls<=0 || ls>1 )
+ stop("ls has to be between 0 and 1")
+ if ( cx <= 0 )
+ stop("cx has to be positive")
+ if ( csu <= 0 )
+ stop("csu has to be positive")
+ if ( sigma <= 0 )
+ stop("sigma must be positive")
+ if ( abs(alpha)>1 )
+ warning("nonstationary AR(1) process")
+ if ( n < 2 )
+ warning("n is too small")
+ n <- round(n)
+ if ( abs(hsx) > cx )
+ stop("wrong headstart hsx")
+ if ( hss < 0 | hss > csu )
+ stop("wrong headstart hss")
+ if ( rx < 5 )
+ stop("rx is too small")
+ if ( rs < 10 )
+ stop("rs is too small")
+ if ( qm < 5 )
+ stop("qm is too small")
+ ctyp <- 1 # later more
+ arl <- .C("xsewma_res_arl",as.double(alpha),as.integer(n-1),as.integer(ctyp),
+ as.double(lx),as.double(cx),as.double(hsx),as.integer(rx),
+ as.double(ls),as.double(csu),as.double(hss),as.integer(rs),
+ as.double(mu),as.double(sigma),as.integer(qm),
+ ans=double(length=1),PACKAGE="spc")$ans
+ names(arl) <- "arl"
+ return (arl)
+}
diff --git a/R/xs.res.ewma.pms.R b/R/xs.res.ewma.pms.R
new file mode 100644
index 0000000..d73b2fe
--- /dev/null
+++ b/R/xs.res.ewma.pms.R
@@ -0,0 +1,41 @@
+# Computation of res-EWMA PMS (simultaneous mean & variance monitoring)
+# PMS = probability of misleading signal
+xs.res.ewma.pms <- function(lx, cx, ls, csu, mu, sigma, type="3", alpha=0, n=5,
+ hsx=0, rx=40, hss=1, rs=40, qm=30) {
+ if ( lx <= 0 || lx > 1 )
+ stop("lx has to be between 0 and 1")
+ if ( ls <= 0 || ls > 1 )
+ stop("ls has to be between 0 and 1")
+ if ( cx <= 0 )
+ stop("cx has to be positive")
+ if ( csu <= 0 )
+ stop("csu has to be positive")
+ if ( sigma <= 0 )
+ stop("sigma must be positive")
+ if ( !(type %in% c("3", "4")) )
+ stop("wrong PMS type")
+ vice_versa <- as.numeric(type) - 3
+ if ( abs(alpha) > 1 )
+ warning("nonstationary AR(1) process")
+ if ( n < 1 )
+ warning("n is too small")
+ n <- round(n)
+ if ( abs(hsx) > cx )
+ stop("wrong headstart hsx")
+ if ( hss < 0 | hss > csu )
+ stop("wrong headstart hss")
+ if ( rx < 5 )
+ stop("rx is too small")
+ if ( rs <10 )
+ stop("rs is too small")
+ if ( qm < 5 )
+ stop("qm is too small")
+ ctyp <- 1 # later more
+ pms <- .C("xsewma_res_pms",as.double(alpha),as.integer(n-1),as.integer(ctyp),
+ as.double(lx),as.double(cx),as.double(hsx),as.integer(rx),
+ as.double(ls),as.double(csu),as.double(hss),as.integer(rs),
+ as.double(mu),as.double(sigma),as.integer(qm),as.integer(vice_versa),
+ ans=double(length=1),PACKAGE="spc")$ans
+ names(pms) <- "pms"
+ return (pms)
+}
\ No newline at end of file
diff --git a/R/xsewma.arl.R b/R/xsewma.arl.R
new file mode 100644
index 0000000..8ba18bc
--- /dev/null
+++ b/R/xsewma.arl.R
@@ -0,0 +1,46 @@
+# Computation of EWMA ARLs (simultaneous mean & variance monitoring)
+xsewma.arl <- function(lx, cx, ls, csu, df, mu, sigma,
+ hsx=0, Nx=40,
+ csl=0, hss=1, Ns=40,
+ s2.on=TRUE, sided="upper", qm=30) {
+ if (lx<=0 | lx>1)
+ stop("lx has to be between 0 and 1")
+ if (ls<=0 | ls>1)
+ stop("ls has to be between 0 and 1")
+ if (cx<=0)
+ stop("cx has to be positive")
+ if (csu<=0)
+ stop("csu has to be positive")
+ if (csl<0)
+ stop("clu has to be non-negative")
+ if ( sigma<=0 )
+ stop("sigma must be positive")
+ if ( df<1 )
+ stop("df must be larger than or equal to 1")
+ s_squared <- as.numeric(s2.on)
+ if ( !(s_squared %in% c(0,1)) )
+ stop("wrong value for s2.on")
+ if ( abs(hsx)>cx )
+ stop("wrong headstart hsx")
+ if ( hss<csl | hss>csu )
+ stop("wrong headstart hss")
+ if (Nx<5)
+ stop("Nx is too small")
+ if (Ns<10)
+ stop("Ns is too small")
+ if (qm<5)
+ stop("qm is too small")
+ ctyp <- pmatch(sided, c("upper","Rupper","two","lower")) - 1
+ if (is.na(ctyp))
+ stop("invalid ewma type")
+ arl <- .C("xsewma_arl",as.integer(ctyp),
+ as.double(lx),as.double(cx),as.double(hsx),as.integer(Nx),
+ as.double(ls),as.double(csl),as.double(csu),as.double(hss),
+ as.integer(Ns),
+ as.double(mu),as.double(sigma),
+ as.integer(df),as.integer(qm),
+ as.integer(s_squared),
+ ans=double(length=1),PACKAGE="spc")$ans
+ names(arl) <- "arl"
+ return (arl)
+}
diff --git a/R/xsewma.crit.R b/R/xsewma.crit.R
new file mode 100644
index 0000000..83aa636
--- /dev/null
+++ b/R/xsewma.crit.R
@@ -0,0 +1,51 @@
+# Computation of EWMA critical values for given ARL
+# (simultaneous mean and variance monitoring)
+xsewma.crit <- function(lx, ls, L0, df, mu0=0, sigma0=1, cu=NULL, hsx=0, hss=1,
+ s2.on=TRUE, sided="upper", mode="fixed",
+ Nx=30, Ns=40, qm=30)
+{
+ if (lx<=0 || lx>1)
+ stop("lx has to be between 0 and 1")
+ if (ls<=0 || ls>1)
+ stop("ls has to be between 0 and 1")
+ if (L0<1)
+ stop("L0 is too small")
+ if (sigma0<=0)
+ stop("sigma0 must be positive")
+ if (mode=="fixed" & sided=="two") {
+ if (is.null(cu)) stop("set cu")
+ if (cu<sigma0) stop("cu is too small")
+ if (cu<=0) stop("cu must be positive")
+ if (hss>cu) stop("hs must be smaller than cu")
+ cu0 <- cu
+ } else {
+ cu0 <- 0
+ }
+ if (df<1)
+ stop("df must be positive")
+ s_squared <- as.numeric(s2.on)
+ if ( !(s_squared %in% c(0,1)) )
+ stop("wrong value for s2.on")
+ ctyp <- pmatch(sided, c("upper","Rupper","two","lower")) - 1
+ if (is.na(ctyp))
+ stop("invalid ewma type")
+ ltyp <- pmatch(mode, c("fixed","unbiased")) - 1
+ if (is.na(ltyp))
+ stop("invalid limits type")
+ if (Nx<5)
+ stop("r.x is too small")
+ if (Ns<10)
+ stop("r.s is too small")
+ if (qm<10)
+ stop("qm is too small")
+ c <- .C("xsewma_crit",as.integer(ctyp),as.integer(ltyp),
+ as.double(lx),as.double(ls),
+ as.double(L0),as.double(cu0),as.double(hsx),as.double(hss),
+ as.double(mu0),as.double(sigma0),
+ as.integer(df),as.integer(Nx),as.integer(Ns),
+ as.integer(qm),
+ ans=double(length=3),PACKAGE="spc")$ans
+ names(c) <- c("cx","cl","cu")
+ return (c)
+}
+
diff --git a/R/xsewma.q.R b/R/xsewma.q.R
new file mode 100644
index 0000000..2f0c5d3
--- /dev/null
+++ b/R/xsewma.q.R
@@ -0,0 +1,40 @@
+# Computation of EWMA RL quantiles (simultaneous mean & variance monitoring)
+xsewma.q <- function(lx, cx, ls, csu, df, alpha, mu, sigma, hsx=0, Nx=40, csl=0, hss=1, Ns=40, sided="upper", qm=30) {
+ if ( lx<=0 | lx>1 )
+ stop("lx has to be between 0 and 1")
+ if ( ls<=0 | ls>1 )
+ stop("ls has to be between 0 and 1")
+ if ( cx<=0 )
+ stop("cx has to be positive")
+ if ( csu<=0 )
+ stop("csu has to be positive")
+ if ( df<1 )
+ stop("df must be larger than or equal to 1")
+ if ( alpha <= 0 | alpha >= 1)
+ stop("quantile level alpha must be in (0,1)")
+ if ( sigma<=0 )
+ stop("sigma must be positive")
+ if ( abs(hsx)>cx )
+ stop("wrong headstart hsx")
+ if ( Nx<5 )
+ stop("Nx is too small")
+ if ( csl<0 )
+ stop("clu has to be non-negative")
+ if ( hss<csl | hss>csu )
+ stop("wrong headstart hss")
+ if ( Ns<10 )
+ stop("Ns is too small")
+ ctyp <- pmatch(sided, c("upper","two")) - 1
+ if (is.na(ctyp))
+ stop("invalid ewma type")
+ if ( qm<5 )
+ stop("qm is too small")
+ quant <- .C("xsewma_q",as.integer(ctyp),as.double(alpha),
+ as.double(lx),as.double(cx),as.double(hsx),as.integer(Nx),
+ as.double(ls),as.double(csl),as.double(csu),as.double(hss),as.integer(Ns),
+ as.double(mu),as.double(sigma),
+ as.integer(df),as.integer(qm),
+ ans=double(length=1),PACKAGE="spc")$ans
+ names(quant) <- "q"
+ quant
+}
diff --git a/R/xsewma.q.crit.R b/R/xsewma.q.crit.R
new file mode 100644
index 0000000..bd4cd9d
--- /dev/null
+++ b/R/xsewma.q.crit.R
@@ -0,0 +1,37 @@
+# Computation of EWMA critical values for given QRL
+# (simultaneous mean and variance monitoring)
+xsewma.q.crit <- function(lx, ls, L0, alpha, df, mu0=0, sigma0=1, csu=NULL, hsx=0, hss=1, sided="upper", mode="fixed", Nx=20, Ns=40, qm=30, c.error=1e-12, a.error=1e-9)
+{
+ if (lx<=0 || lx>1) stop("lx has to be between 0 and 1")
+ if (ls<=0 || ls>1) stop("ls has to be between 0 and 1")
+ if (L0<1) stop("L0 is too small")
+ if ( alpha<=0 | alpha>=1 ) stop("quantile level alpha must be in (0,1)")
+ if ( df<1 ) stop("df must be positive")
+ if ( sigma0<=0 ) stop("sigma0 must be positive")
+ if ( mode=="fixed" & sided=="two" ) {
+ if ( is.null(csu) ) stop("set csu")
+ if ( csu<sigma0 ) stop("csu is too small")
+ if ( csu<=0 ) stop("csu must be positive")
+ if ( hss>csu ) stop("hs must be smaller than csu")
+ cu0 <- csu
+ } else {
+ cu0 <- 0
+ }
+ ctyp <- pmatch(sided, c("upper","two")) - 1
+ if ( is.na(ctyp) ) stop("invalid ewma type")
+ ltyp <- pmatch(mode, c("fixed","unbiased")) - 1
+ if ( is.na(ltyp) ) stop("invalid limits type")
+ if ( Nx<5 ) stop("Nx is too small")
+ if ( Ns<10 ) stop("Ns is too small")
+ if ( qm<10 ) stop("qm is too small")
+ c <- .C("xsewma_q_crit", as.integer(ctyp), as.integer(ltyp),
+ as.double(lx), as.double(ls),
+ as.double(L0), as.double(alpha),
+ as.double(cu0), as.double(hsx), as.double(hss),
+ as.double(mu0), as.double(sigma0), as.integer(df), as.integer(Nx), as.integer(Ns), as.integer(qm),
+ as.double(c.error), as.double(a.error),
+ ans=double(length=3),PACKAGE="spc")$ans
+ names(c) <- c("cx", "csl","csu")
+ return (c)
+}
+
diff --git a/R/xsewma.sf.R b/R/xsewma.sf.R
new file mode 100644
index 0000000..78a22a4
--- /dev/null
+++ b/R/xsewma.sf.R
@@ -0,0 +1,32 @@
+# Computation of EWMA survival function (simultaneous mean & variance monitoring)
+xsewma.sf <- function(n, lx, cx, ls, csu, df, mu, sigma,
+ hsx=0, Nx=40,
+ csl=0, hss=1, Ns=40,
+ sided="upper", qm=30) {
+
+ if ( n < 1 ) stop("n has to be a natural number")
+ if ( lx<=0 | lx>1 ) stop("lx has to be between 0 and 1")
+ if ( ls<=0 | ls>1 ) stop("ls has to be between 0 and 1")
+ if ( cx<=0 ) stop("cx has to be positive")
+ if ( csu<=0 ) stop("csu has to be positive")
+ if ( csl<0 ) stop("csl has to be non-negative")
+ if ( sigma<=0 ) stop("sigma must be positive")
+ if ( df<1 ) stop("df must be larger than or equal to 1")
+ if ( abs(hsx)>cx ) stop("wrong headstart hsx")
+ if ( hss<csl | hss>csu ) stop("wrong headstart hss")
+ if ( Nx<5 ) stop("Nx is too small")
+ if ( Ns<10 ) stop("Ns is too small")
+ if ( qm<5 ) stop("qm is too small")
+ ctyp <- pmatch(sided, c("upper","Rupper","two","lower")) - 1
+ if (is.na(ctyp)) stop("invalid ewma type")
+
+ sf <- .C("xsewma_sf", as.integer(ctyp),
+ as.double(lx),as.double(cx),as.double(hsx),as.integer(Nx),
+ as.double(ls),as.double(csl),as.double(csu),as.double(hss),as.integer(Ns),
+ as.double(mu),as.double(sigma),as.integer(df),as.integer(qm),
+ as.integer(n),
+ ans=double(length=n),PACKAGE="spc")$ans
+
+ names(sf) <- NULL
+ sf
+}
diff --git a/R/xshewhart.ar1.arl.R b/R/xshewhart.ar1.arl.R
new file mode 100644
index 0000000..dd892ca
--- /dev/null
+++ b/R/xshewhart.ar1.arl.R
@@ -0,0 +1,10 @@
+# Computation of the ARL for modified Shewhart charts, AR(1) data
+xshewhart.ar1.arl <- function(alpha, cS, delta=0, N1=50, N2=30) {
+ if ( abs(alpha) >= 1 ) stop("alpha has to be between -1 and 1")
+ if ( cS <= 0 ) stop("cS has to be positive")
+ arl <- .C("xshewhart_ar1_arl",
+ as.double(alpha), as.double(cS), as.double(delta),
+ as.integer(N1), as.integer(N2), ans=double(length=1), PACKAGE="spc")$ans
+ names(arl) <- NULL
+ arl
+}
diff --git a/R/xshewhartrunsrules.ad.R b/R/xshewhartrunsrules.ad.R
new file mode 100644
index 0000000..73c3111
--- /dev/null
+++ b/R/xshewhartrunsrules.ad.R
@@ -0,0 +1,25 @@
+
+xshewhartrunsrules.ad <- function(mu1, mu0=0, c=1, type="12") {
+
+# Shewhart chart
+ if (type=="1") {
+ p0 <- pnorm( 3*c, mean=mu1 ) - pnorm( -3*c, mean=mu1)
+ ad <- 1/(1-p0)
+ }
+
+# ditto with runs rules
+ if (type!="1") {
+ Q1 <- xshewhartrunsrules.matrix(mu1, c=c, type=type)
+ dimQ <- nrow(Q1)
+ one <- rep(1, dimQ)
+ I <- diag(1, dimQ)
+ arls <- solve(I-Q1, one)
+
+ Q0 <- xshewhartrunsrules.matrix(mu0, c=c, type=type)
+ psi <- Re(eigen(t(Q0))$vectors[,1])
+
+ ad <- sum(psi * arls)/sum(psi)
+ }
+
+ ad
+}
\ No newline at end of file
diff --git a/R/xshewhartrunsrules.arl.R b/R/xshewhartrunsrules.arl.R
new file mode 100644
index 0000000..07bf860
--- /dev/null
+++ b/R/xshewhartrunsrules.arl.R
@@ -0,0 +1,21 @@
+
+xshewhartrunsrules.arl <- function(mu, c=1, type="12") {
+
+# Shewhart chart
+ if (type=="1") {
+ p0 <- pnorm( 3*c, mean=mu ) - pnorm( -3*c, mean=mu)
+ arls <- 1/(1-p0)
+ }
+
+# ditto with runs rules
+ if (type!="1") {
+ Q <- xshewhartrunsrules.matrix(mu, c=c, type=type)
+ dimQ <- nrow(Q)
+ one <- rep(1, dimQ)
+ I <- diag(1, dimQ)
+ arls <- solve(I-Q, one)
+ }
+
+ arl <- arls[1]
+ arl
+}
\ No newline at end of file
diff --git a/R/xshewhartrunsrules.crit.R b/R/xshewhartrunsrules.crit.R
new file mode 100644
index 0000000..a4320d4
--- /dev/null
+++ b/R/xshewhartrunsrules.crit.R
@@ -0,0 +1,20 @@
+
+xshewhartrunsrules.crit <- function(L0, mu=0, type="12") {
+ if (type=="14" & L0>255) {
+ stop("L0 too large for type=\"14\"")
+ } else {
+ c1 <- 1
+ c2 <- 1.5
+ arl1 <- xshewhartrunsrules.arl(mu,c=c1,type=type)
+ arl2 <- xshewhartrunsrules.arl(mu,c=c2,type=type)
+ a.error <- 1; c.error <- 1
+ while ( a.error>1e-6 && c.error>1e-8 ) {
+ c3 <- c1 + (L0-arl1)/(arl2-arl1)*(c2-c1)
+ arl3 <- xshewhartrunsrules.arl(mu,c=c3,type=type)
+ c1 <- c2; c2 <- c3
+ arl1 <- arl2; arl2 <- arl3
+ a.error <- abs(arl2-L0); c.error <- abs(c2-c1)
+ }
+ }
+ c3
+}
\ No newline at end of file
diff --git a/R/xshewhartrunsrules.matrix.R b/R/xshewhartrunsrules.matrix.R
new file mode 100644
index 0000000..44ec4f4
--- /dev/null
+++ b/R/xshewhartrunsrules.matrix.R
@@ -0,0 +1,163 @@
+
+xshewhartrunsrules.matrix <- function(mu, c=1, type="12") {
+ # Shewhart chart
+ if (type=="1") {
+ p0 <- pnorm( 3*c, mean=mu ) - pnorm( -3*c, mean=mu)
+ Q <- p0
+ }
+
+ # 2 of 3 beyond +-2 sigma
+ if (type=="12") {
+ dimQ <- 7
+ pl <- pnorm( -2*c, mean=mu ) - pnorm( -3*c, mean=mu)
+ p0 <- pnorm( 2*c, mean=mu ) - pnorm( -2*c, mean=mu)
+ pr <- pnorm( 3*c, mean=mu ) - pnorm( 2*c, mean=mu)
+
+# 1 2 3 4 5 6 7
+# 0000 1000 0100 0010 0001 1001 0110
+# 1 0000 p0 pl 0 pr 0 0 0
+# 2 1000 0 0 p0 0 0 0 pr
+# 3 0100 p0 0 0 pr 0 0 0
+# 4 0010 0 0 0 0 p0 pl 0
+# 5 0001 p0 pl 0 0 0 0 0
+# 6 1001 0 0 p0 0 0 0 0
+# 7 0110 0 0 0 0 p0 0 0
+
+ Q <- diag(0,dimQ)
+
+ Q[1,2] <- pl; Q[1,1] <- p0; Q[1,4] <- pr
+ Q[2,3] <- p0; Q[2,7] <- pr
+ Q[3,1] <- p0; Q[3,4] <- pr
+ Q[4,6] <- pl; Q[4,5] <- p0
+ Q[5,2] <- pl; Q[5,1] <- p0
+ Q[6,3] <- p0
+ Q[7,5] <- p0
+ }
+
+ # 4 of 5 beyond +-1 sigma
+ if (type=="13") {
+ dimQ <- 29
+ pl <- pnorm( -c, mean=mu ) - pnorm( -3*c, mean=mu)
+ p0 <- pnorm( c, mean=mu ) - pnorm( -c, mean=mu)
+ pr <- pnorm( 3*c, mean=mu ) - pnorm( c, mean=mu)
+
+ Q <- diag(0,dimQ)
+
+ Q[ 1, 2] <- pl; Q[ 1, 1] <- p0; Q[ 1,11] <- pr
+ Q[ 2, 4] <- pl; Q[ 2, 3] <- p0; Q[ 2,12] <- pr
+ Q[ 3, 5] <- pl; Q[ 3, 1] <- p0; Q[ 3,11] <- pr
+ Q[ 4, 7] <- pl; Q[ 4, 6] <- p0; Q[ 4,13] <- pr
+ Q[ 5, 8] <- pl; Q[ 5, 3] <- p0; Q[ 5,12] <- pr
+ Q[ 6, 9] <- pl; Q[ 6, 1] <- p0; Q[ 6,11] <- pr
+ Q[ 7,10] <- p0; Q[ 7,14] <- pr
+ Q[ 8, 6] <- p0; Q[ 8,13] <- pr
+ Q[ 9, 3] <- p0; Q[ 9,12] <- pr
+ Q[10, 1] <- p0; Q[10,11] <- pr
+ Q[11,16] <- pl; Q[11,15] <- p0; Q[11,19] <- pr
+ Q[12,17] <- pl; Q[12,15] <- p0; Q[12,19] <- pr
+ Q[13,18] <- pl; Q[13,15] <- p0; Q[13,19] <- pr
+ Q[14,15] <- p0; Q[14,19] <- pr
+ Q[15, 2] <- pl; Q[15, 1] <- p0; Q[15,20] <- pr
+ Q[16, 4] <- pl; Q[16, 3] <- p0; Q[16,21] <- pr
+ Q[17, 8] <- pl; Q[17, 3] <- p0; Q[17,21] <- pr
+ Q[18, 3] <- p0; Q[18,21] <- pr
+ Q[19,23] <- pl; Q[19,22] <- p0; Q[19,24] <- pr
+ Q[20,16] <- pl; Q[20,15] <- p0; Q[20,25] <- pr
+ Q[21,17] <- pl; Q[21,15] <- p0; Q[21,25] <- pr
+ Q[22, 2] <- pl; Q[22, 1] <- p0; Q[22,26] <- pr
+ Q[23, 4] <- pl; Q[23, 3] <- p0; Q[23,27] <- pr
+ Q[24,29] <- pl; Q[24,28] <- p0
+ Q[25,23] <- pl; Q[25,22] <- p0
+ Q[26,16] <- pl; Q[26,15] <- p0
+ Q[27,17] <- pl; Q[27,15] <- p0
+ Q[28, 2] <- pl; Q[28, 1] <- p0
+ Q[29, 4] <- pl; Q[29, 3] <- p0
+ }
+
+ # 8 on the same side
+ if (type=="14") {
+ dimQ <- 15
+ pl <- pnorm( 0, mean=mu ) - pnorm( -3*c, mean=mu)
+ pr <- pnorm( 3*c, mean=mu ) - pnorm( 0, mean=mu)
+
+ Q <- diag(0,dimQ)
+
+ Q[ 1, 2] <- pl; Q[ 1, 9] <- pr
+ Q[ 2, 3] <- pl; Q[ 2, 9] <- pr
+ Q[ 3, 4] <- pl; Q[ 3, 9] <- pr
+ Q[ 4, 5] <- pl; Q[ 4, 9] <- pr
+ Q[ 5, 6] <- pl; Q[ 5, 9] <- pr
+ Q[ 6, 7] <- pl; Q[ 6, 9] <- pr
+ Q[ 7, 8] <- pl; Q[ 7, 9] <- pr
+ Q[ 8, 9] <- pr
+ Q[ 9, 2] <- pl; Q[ 9,10] <- pr
+ Q[10, 2] <- pl; Q[10,11] <- pr
+ Q[11, 2] <- pl; Q[11,12] <- pr
+ Q[12, 2] <- pl; Q[12,13] <- pr
+ Q[13, 2] <- pl; Q[13,14] <- pr
+ Q[14, 2] <- pl; Q[14,15] <- pr
+ Q[15, 2] <- pl;
+ }
+
+ # ... on the same side (general approach)
+ if ( regexpr("SameSide", type)>0 ) {
+ anzahl <- as.numeric(gsub("SameSide", "", type))
+ dimQ <- 2*anzahl - 1
+ hdQ <- anzahl - 1
+ pl <- pnorm( 0, mean=mu ) - pnorm( -3*c, mean=mu)
+ pr <- pnorm( 3*c, mean=mu ) - pnorm( 0, mean=mu)
+ Q <- diag(0, dimQ)
+ for ( i in 1:hdQ ) {
+ Q[i,i+1] <- pl
+ Q[hdQ+i+1,2] <- pl
+ Q[i,hdQ+2] <- pr
+ Q[hdQ+i,hdQ+i+1] <- pr
+ }
+ }
+
+ # 2 of 2 beyond +-2 sigma
+ if (type=="15") {
+ dimQ <- 3
+ pl <- pnorm( -2*c, mean=mu ) - pnorm( -3*c, mean=mu)
+ p0 <- pnorm( 2*c, mean=mu ) - pnorm( -2*c, mean=mu)
+ pr <- pnorm( 3*c, mean=mu ) - pnorm( 2*c, mean=mu)
+
+# 1 2 3
+# 00 10 01
+# 1 00 p0 pr pl
+# 2 10 p0 0 pl
+# 3 01 p0 pr 0
+
+ Q <- diag(0,dimQ)
+
+ Q[1,2] <- pl; Q[1,1] <- p0; Q[1,3] <- pr
+ Q[2,1] <- p0; Q[2,3] <- pr
+ Q[3,2] <- pl; Q[3,1] <- p0;
+ }
+
+ # 3 of 3 beyond +-3 sigma
+ if (type=="19") {
+ dimQ <- 5
+ pl <- pnorm( -3*c, mean=mu )
+ p0 <- pnorm( 3*c, mean=mu ) - pnorm( -3*c, mean=mu)
+ pr <- 1 - pnorm( 3*c, mean=mu)
+
+# 1 2 3 4 5
+# 0000 1000 1100 0010 0011
+# 1 0000 p0 pr 0 pl 0
+# 2 1000 p0 0 pr pl 0
+# 3 1100 p0 0 0 pl 0
+# 4 0010 p0 pr 0 0 pl
+# 5 0011 p0 pr 0 0 0
+
+ Q <- diag(0,dimQ)
+
+ Q[1,4] <- pl; Q[1,1] <- p0; Q[1,2] <- pr
+ Q[2,4] <- pl; Q[2,1] <- p0; Q[2,3] <- pr
+ Q[3,4] <- pl; Q[3,1] <- p0;
+ Q[4,5] <- pl; Q[4,1] <- p0; Q[4,2] <- pr
+ Q[5,1] <- p0; Q[5,2] <- pr
+ }
+
+ Q
+}
\ No newline at end of file
diff --git a/R/xtcusum.arl.R b/R/xtcusum.arl.R
new file mode 100644
index 0000000..52289a9
--- /dev/null
+++ b/R/xtcusum.arl.R
@@ -0,0 +1,24 @@
+# Computation of CUSUM ARLs (mean monitoring, t distributed data)
+xtcusum.arl <- function(k, h, df, mu, hs=0, sided="one", mode="tan", r=30) {
+ if ( k < 0 )
+ stop("k has to be non-negative")
+ if ( h <= 0 )
+ stop("h has to be positive")
+ if ( df < 1 )
+ stop("df must be greater or equal to 1")
+ if ( hs < 0 | ( sided=="two" & hs>h/2+k ) | ( sided=="one" & hs>h ) )
+ stop("wrong headstart")
+ ntyp <- -1 + pmatch(mode, c("identity", "sin", "sinh", "tan"))
+ if ( is.na(ntyp) )
+ stop("substitution type not provided (yet)")
+ if ( r < 4 )
+ stop("r is too small")
+ ctyp <- pmatch(sided, c("one", "two")) - 1
+ if (is.na(ctyp))
+ stop("invalid cusum type")
+ arl <- .C("xtcusum_arl",
+ as.integer(ctyp), as.double(k), as.double(h), as.double(hs), as.integer(df), double(mu), as.integer(r), as.integer(ntyp),
+ ans=double(length=1), PACKAGE="spc")$ans
+ names(arl) <- NULL
+ return (arl)
+}
\ No newline at end of file
diff --git a/R/xtewma.ad.R b/R/xtewma.ad.R
new file mode 100644
index 0000000..97c51ef
--- /dev/null
+++ b/R/xtewma.ad.R
@@ -0,0 +1,32 @@
+# Computation of EWMA steady-state ARLs (mean monitoring, t distributed data)
+xtewma.ad <- function(l, c, df, mu1, mu0=0, zr=0, z0=0, sided="one", limits="fix", steady.state.mode="conditional", mode="tan", r=40) {
+ if ( l<=0 || l>1 ) warning("l has to be between 0 and 1")
+
+ if ( c<=0 ) warning("usually, c has to be positive")
+
+ if ( zr>c & sided=="one" ) stop("wrong reflexion border")
+
+ if ( r<4 ) stop("r is too small")
+
+ ctyp <- pmatch(sided, c("one", "two")) - 1
+ if (is.na(ctyp)) stop("invalid ewma type")
+
+ ltyp <- pmatch(limits, c("fix","vacl")) - 1
+ if ( is.na(ltyp) ) stop("invalid limits type")
+
+
+ styp <- pmatch(steady.state.mode, c("conditional", "cyclical")) - 1
+ if (is.na(styp)) stop("invalid steady.state.mode")
+
+ if ( abs(z0) > abs(c) ) stop("wrong restarting value")
+
+ ntyp <- -1 + pmatch(mode, c("identity", "sin", "sinh", "tan"))
+ if ( is.na(ntyp) ) stop("substitution type not provided (yet)")
+
+ ad <- .C("xtewma_ad", as.integer(ctyp), as.double(l),
+ as.double(c), as.double(zr), as.integer(df), as.double(mu0), as.double(mu1), as.double(z0),
+ as.integer(ltyp), as.integer(styp), as.integer(r), as.integer(ntyp),
+ ans=double(length=1), PACKAGE="spc")$ans
+ names(ad) <- "ad"
+ return (ad)
+}
diff --git a/R/xtewma.arl.R b/R/xtewma.arl.R
new file mode 100644
index 0000000..3e41412
--- /dev/null
+++ b/R/xtewma.arl.R
@@ -0,0 +1,40 @@
+# Computation of EWMA ARLs (mean monitoring, t distributed data)
+xtewma.arl <- function(l, c, df, mu, zr=0, hs=0, sided="two", limits="fix", mode="tan", q=1, r=40) {
+ if ( l<=0 || l>1 )
+ warning("l is typically between 0 and 1 -- you should really know what you do")
+ if ( c<=0 )
+ warning("usually, c has to be positive")
+ if ( df < 1 )
+ stop("df must be greater or equal to 1")
+ if ( zr>c & sided=="one" )
+ stop("wrong reflexion border")
+ if ( (sided=="two" & abs(hs)>c) | (sided=="one" & (hs<zr | hs>c)) )
+ warning("unusual headstart")
+ if ( r<4 )
+ stop("r is too small")
+ ctyp <- pmatch(sided, c("one", "two")) - 1
+ if ( is.na(ctyp) )
+ stop("invalid ewma type")
+ ltyp <- -1 + pmatch(limits, c("fix", "vacl"))
+ if ( is.na(ltyp) )
+ stop("invalid limits type")
+ ntyp <- -1 + pmatch(mode, c("identity", "sin", "sinh", "tan"))
+ if ( is.na(ntyp) )
+ stop("substitution type not provided (yet)")
+ q <- round(q)
+ if ( q<1 )
+ stop("wrong change point position (q)")
+ if ( limits=="fix" & q>1 ) {
+ arl <- .C("xtewma_arl",as.integer(ctyp),as.double(l),
+ as.double(c),as.double(zr),as.double(hs),as.integer(df),
+ as.double(mu),as.integer(ltyp),as.integer(r),as.integer(ntyp),as.integer(q),
+ ans=double(length=q), PACKAGE="spc")$ans
+ } else {
+ arl <- .C("xtewma_arl",as.integer(ctyp),as.double(l),
+ as.double(c),as.double(zr),as.double(hs),as.integer(df),
+ as.double(mu),as.integer(ltyp),as.integer(r),as.integer(ntyp),as.integer(q),
+ ans=double(length=1), PACKAGE="spc")$ans
+ }
+ names(arl) <- NULL
+ return (arl)
+}
diff --git a/R/xtewma.q.R b/R/xtewma.q.R
new file mode 100644
index 0000000..6692915
--- /dev/null
+++ b/R/xtewma.q.R
@@ -0,0 +1,26 @@
+# Computation of EWMA quantiles (mean monitoring, t distributed data)
+xtewma.q <- function(l, c, df, mu, alpha, zr=0, hs=0, sided="two", limits="fix", mode="tan", q=1, r=40) {
+ if ( l <= 0 | l > 1 ) warning("l is typically between 0 and 1 -- you should really know what you do")
+ if ( c<=0 ) warning("usually, c has to be positive")
+ if ( df < 1 ) stop("df must be greater or equal to 1")
+ if ( alpha <= 0 | alpha >= 1) stop("quantile level alpha must be in (0,1)")
+ if ( zr > c & sided == "one") stop("wrong reflexion border")
+ if ( (sided == "two" & abs(hs) > c) | (sided == "one" & ( hs < zr | hs > c )) )
+ warning("unusual headstart")
+ ctyp <- pmatch(sided, c("one", "two")) - 1
+ if ( is.na(ctyp) ) stop("invalid ewma type")
+ ltyp <- -1 + pmatch(limits, c("fix", "vacl"))
+ if (is.na(ltyp)) stop("invalid limits type")
+ ntyp <- -1 + pmatch(mode, c("identity", "sin", "sinh", "tan"))
+ if ( is.na(ntyp) ) stop("substitution type not provided (yet)")
+ if ( r < 4 ) stop("r is too small")
+ q <- round(q)
+ if ( q<1 ) stop("wrong change point position (q)")
+ quant <- .C("xtewma_q",
+ as.integer(ctyp), as.double(l), as.double(c), as.double(alpha), as.double(zr),
+ as.double(hs), as.integer(df), as.double(mu),
+ as.integer(ltyp), as.integer(r), as.integer(ntyp), as.integer(q),
+ ans=double(length=1),PACKAGE="spc")$ans
+ names(quant) <- "q"
+ quant
+}
diff --git a/R/xtewma.q.crit.R b/R/xtewma.q.crit.R
new file mode 100644
index 0000000..cdb6996
--- /dev/null
+++ b/R/xtewma.q.crit.R
@@ -0,0 +1,32 @@
+xtewma.q.crit <- function(l, L0, df, mu, alpha, zr=0, hs=0, sided="two", limits="fix", mode="tan", r=40, c.error=1e-12, a.error=1e-9, OUTPUT=FALSE) {
+
+ c2 <- 0
+ p2 <- 1
+ if ( OUTPUT ) cat("\nc\t\tp\n")
+ while ( p2 > alpha ) {
+ p1 <- p2
+ c2 <- c2 + .5
+ p2 <- 1 - xtewma.sf(l, c2, df, mu, L0, zr=zr, hs=hs, sided=sided, limits=limits, q=1, r=r)[L0]
+ if ( OUTPUT ) cat(paste(c2,"\t",p2,"\n"))
+ }
+ while ( p2 <= alpha & c2 > .02 ) {
+ p1 <- p2
+ c2 <- c2 - .02
+ p2 <- 1 - xtewma.sf(l, c2, df, mu, L0, zr=zr, hs=hs, sided=sided, limits=limits, q=1, r=r)[L0]
+ if ( OUTPUT ) cat(paste(c2,"\t",p2,"\n"))
+ }
+ c1 <- c2 + .02
+
+ a.error_ <- 1; c.error_ <- 1
+ while ( a.error_ > a.error & c.error_ > c.error ) {
+ c3 <- c1 + (alpha - p1)/(p2 - p1)*(c2 - c1)
+ p3 <- 1 - xtewma.sf(l, c3, df, mu, L0, zr=zr, hs=hs, sided=sided, limits=limits, q=1, r=r)[L0]
+ if ( OUTPUT ) cat(paste(c3,"\t",p3,"\n"))
+ c1 <- c2; c2 <- c3
+ p1 <- p2; p2 <- p3
+ a.error_ <- abs(p2 - alpha); c.error_ <- abs(c2 - c1)
+ }
+
+ names(c3) <- "c"
+ c3
+}
diff --git a/R/xtewma.sf.R b/R/xtewma.sf.R
new file mode 100644
index 0000000..382f65a
--- /dev/null
+++ b/R/xtewma.sf.R
@@ -0,0 +1,25 @@
+# Computation of EWMA survival function (mean monitoring)
+xtewma.sf <- function(l, c, df, mu, n, zr=0, hs=0, sided="two", limits="fix", mode="tan", q=1, r=40) {
+ if ( l<=0 || l>1 ) warning("l is typically between 0 and 1 -- you should really know what you do")
+ if ( c <= 0 ) warning("usually, c has to be positive")
+ if ( df < 1 ) stop("df must be greater or equal to 1")
+ if ( n < 1 ) stop("n has to be a natural number")
+ if ( zr > c & sided == "one") stop("wrong reflexion border")
+ if ( (sided == "two" & abs(hs) > c) | (sided == "one" & ( hs < zr | hs > c )) )
+ warning("unusual headstart")
+ ctyp <- pmatch(sided, c("one", "two")) - 1
+ if ( is.na(ctyp) ) stop("invalid ewma type")
+ ltyp <- -1 + pmatch(limits, c("fix", "vacl"))
+ if (is.na(ltyp)) stop("invalid limits type")
+ ntyp <- -1 + pmatch(mode, c("identity", "sin", "sinh", "tan"))
+ if ( is.na(ntyp) ) stop("substitution type not provided (yet)")
+ if ( r < 4 ) stop("r is too small")
+ q <- round(q)
+ if ( q<1 ) stop("wrong change point position (q)")
+ sf <- .C("xtewma_sf",
+ as.integer(ctyp), as.double(l), as.double(c), as.double(zr), as.double(hs), as.integer(df), as.double(mu),
+ as.integer(ltyp), as.integer(r), as.integer(ntyp), as.integer(q), as.integer(n),
+ ans=double(length=n),PACKAGE="spc")$ans
+ names(sf) <- NULL
+ sf
+}
diff --git a/debian/README.test b/debian/README.test
deleted file mode 100644
index 61fabef..0000000
--- a/debian/README.test
+++ /dev/null
@@ -1,5 +0,0 @@
-Notes on how this package can be tested.
-────────────────────────────────────────
-
-This package can be tested by loading it into R with the command
-‘library(spc)’ in order to confirm its integrity.
diff --git a/debian/changelog b/debian/changelog
deleted file mode 100644
index aa91e81..0000000
--- a/debian/changelog
+++ /dev/null
@@ -1,61 +0,0 @@
-r-cran-spc (1:0.5.3-1) unstable; urgency=medium
-
- * New upstream version
- * Convert to dh-r
- * Canonical homepage for CRAN
-
- -- Andreas Tille <tille at debian.org> Tue, 08 Nov 2016 08:19:53 +0100
-
-r-cran-spc (1:0.5.1-1) unstable; urgency=medium
-
- * New upstream version
- * cme fix dpkg-control
-
- -- Andreas Tille <tille at debian.org> Fri, 07 Aug 2015 12:58:19 +0200
-
-r-cran-spc (1:0.5.0-1) unstable; urgency=medium
-
- * New upstream version
- * cme fix dpkg-control
-
- -- Andreas Tille <tille at debian.org> Sat, 28 Jun 2014 07:57:02 +0200
-
-r-cran-spc (1:0.4.2-1) unstable; urgency=low
-
- * New upstream version
- * debian/control:
- - Standards-Version: 3.9.4 (no changes needed)
- - DM-Upload-Allowed removed
- - debhelper 9 (also debian/compat)
- - normalised
- * debian/copyright: DEP5
- * debian/rules: Drop unneeded code to create R:Depends variable
-
- -- Andreas Tille <tille at debian.org> Fri, 17 May 2013 13:42:08 +0200
-
-r-cran-spc (1:0.4.1-1) unstable; urgency=low
-
- * New upstream version
- * Rebuild against latest R
- Closes: #646045
- * Standards-Version: 3.9.2 (no changes needed)
- * Debhelper 8 (control+compat)
- * Fixed Vcs fields
- * debian/source/format: 3.0 (quilt)
-
- -- Andreas Tille <tille at debian.org> Tue, 25 Oct 2011 12:08:37 +0200
-
-r-cran-spc (1:0.3-1) unstable; urgency=low
-
- * New upstream version
- * Fixed cut-n-pasto in debian/rules
- * Standards-Version: 3.8.4 (No changes needed)
- * Changed Section from science to gnu-r
-
- -- Andreas Tille <tille at debian.org> Wed, 10 Feb 2010 14:17:35 +0100
-
-r-cran-spc (0.21-1) unstable; urgency=low
-
- * Initial release (Closes: #512430).
-
- -- Andreas Tille <tille at debian.org> Fri, 16 Jan 2009 20:43:13 +0100
diff --git a/debian/compat b/debian/compat
deleted file mode 100644
index ec63514..0000000
--- a/debian/compat
+++ /dev/null
@@ -1 +0,0 @@
-9
diff --git a/debian/control b/debian/control
deleted file mode 100644
index a8c8255..0000000
--- a/debian/control
+++ /dev/null
@@ -1,29 +0,0 @@
-Source: r-cran-spc
-Maintainer: Debian Science Team <debian-science-maintainers at lists.alioth.debian.org>
-Uploaders: Andreas Tille <tille at debian.org>
-Section: gnu-r
-Priority: optional
-Build-Depends: debhelper (>= 9),
- dh-r,
- r-base-dev
-Standards-Version: 3.9.8
-Vcs-Browser: https://anonscm.debian.org/viewvc/debian-science/packages/R/r-cran-spc/trunk/
-Vcs-Svn: svn://anonscm.debian.org/debian-science/packages/R/r-cran-spc/trunk/
-Homepage: https://cran.r-project.org/package=spc
-
-Package: r-cran-spc
-Architecture: any
-Depends: ${shlibs:Depends},
- ${misc:Depends},
- ${R:Depends}
-Recommends: ${R:Recommends}
-Suggests: ${R:Suggests}
-Description: GNU R Statistical Process Control
- Evaluation of control charts by means of the zero-state, steady-state ARL
- (Average Run Length). Setting up control charts for given in-control ARL
- and plotting of the related figures. The control charts under consideration
- are one- and two-sided EWMA and CUSUM charts for monitoring the mean of
- normally distributed independent data. Now, the ARL calculation of
- EWMA-S^2 control charts is added. Other charts and parameters are in
- preparation. Further SPC areas will be covered as well (sampling plans,
- capability indices ...).
diff --git a/debian/copyright b/debian/copyright
deleted file mode 100644
index b73986b..0000000
--- a/debian/copyright
+++ /dev/null
@@ -1,29 +0,0 @@
-Format: https://www.debian.org/doc/packaging-manuals/copyright-format/1.0/
-Upstream-Name: spc
-Upstream-Contact: Sven Knoth <Sven.Knoth at gmx.de>
-Source: https://cran.r-project.org/package=spc
-
-Files: *
-Copyright: (C) 2007-2016 Sven Knoth
-License: GPL-2+
-
-Files: debian/*
-Copyright: 2009-2016 Andreas Tille <tille at debian.org>
-License: GPL-2+
-
-License: GPL-2+
- This program is free software; you can redistribute it and/or modify
- it under the terms of the GNU General Public License as published by
- the Free Software Foundation; either version.
- .
- This program is distributed in the hope that it will be useful,
- but WITHOUT ANY WARRANTY; without even the implied warranty of
- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- GNU General Public License for more details.
- .
- You should have received a copy of the GNU General Public License along
- with this program; if not, write to the Free Software Foundation, Inc.,
- 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
- .
- On Debian systems, the complete text of the GNU General Public
- License can be found in `/usr/share/common-licenses/GPL-3'.
diff --git a/debian/rules b/debian/rules
deleted file mode 100755
index 68d9a36..0000000
--- a/debian/rules
+++ /dev/null
@@ -1,4 +0,0 @@
-#!/usr/bin/make -f
-
-%:
- dh $@ --buildsystem R
diff --git a/debian/source/format b/debian/source/format
deleted file mode 100644
index 163aaf8..0000000
--- a/debian/source/format
+++ /dev/null
@@ -1 +0,0 @@
-3.0 (quilt)
diff --git a/debian/watch b/debian/watch
deleted file mode 100644
index 823b65b..0000000
--- a/debian/watch
+++ /dev/null
@@ -1,2 +0,0 @@
-version=3
-http://cran.r-project.org/src/contrib/spc_([-\d.]*)\.tar\.gz
diff --git a/man/dphat.Rd b/man/dphat.Rd
new file mode 100644
index 0000000..4b008d7
--- /dev/null
+++ b/man/dphat.Rd
@@ -0,0 +1,73 @@
+\name{dphat}
+\alias{dphat}
+\alias{pphat}
+\alias{qphat}
+\title{Percent defective for normal samples}
+\description{Density, distribution function and quantile function
+for the sample percent defective calculated on normal samples
+with mean equal to \code{mu} and standard deviation equal to \code{sigma}.}
+\usage{dphat(x, n, mu=0, sigma=1, type="known", LSL=-3, USL=3, nodes=30)
+
+pphat(q, n, mu=0, sigma=1, type="known", LSL=-3, USL=3, nodes=30)
+
+qphat(p, n, mu=0, sigma=1, type="known", LSL=-3, USL=3, nodes=30)}
+\arguments{
+\item{x, q}{vector of quantiles.}
+\item{p}{vector of probabilities.}
+\item{n}{sample size.}
+\item{mu, sigma}{parameters of the underlying normal distribution.}
+\item{type}{choose whether the standard deviation is given and fixed (\code{"known"}) or estimated and potententially monitored (\code{"estimated"}).}
+\item{LSL,USL}{lower and upper specification limit, respectively.}
+\item{nodes}{number of quadrature nodes needed for \code{type="estimated"}.}
+}
+\details{Bruhn-Suhr/Krumbholz (1990) derived the cumulative distribution function
+of the sample percent defective calculated on normal samples to applying them for a new variables sampling plan.
+These results were heavily used in Krumbholz/Z\"{o}ller (1995) for Shewhart and in Knoth/Steinmetz (2013) for EWMA control charts.
+For algorithmic details see, essentially, Bruhn-Suhr/Krumbholz (1990).
+Two design variants are treated: The simple case, \code{type="known"}, with known normal variance and the presumably much
+more relevant and considerably intricate case, \code{type="estimated"}, where both parameters of
+the normal distribution are unknown. Basically, given lower and upper specification limits and the normal distribution,
+one estimates the expected yield based on a normal sample of size \code{n}.
+}
+\value{Returns vector of pdf, cdf or qf values for the statistic phat.}
+\references{
+M. Bruhn-Suhr and W. Krumbholz (1990),
+A new variables sampling plan for normally distributed lots with unknown standard deviation and double specification limits,
+\emph{Statistical Papers} 31(1), 195-207.
+
+W. Krumbholz and A. Z\"{o}ller (1995),
+\code{p}-Karten vom Shewhartschen Typ f\"{u}r die messende Pr\"{u}fung,
+\emph{Allgemeines Statistisches Archiv} 79, 347-360.
+
+S. Knoth and S. Steinmetz (2013),
+EWMA \code{p} charts under sampling by variables,
+\emph{International Journal of Production Research} 51(13), 3795-3807.
+}
+\author{Sven Knoth}
+\seealso{
+\code{phat.ewma.arl} for routines using the herewith considered phat statistic.}
+\examples{
+# Figures 1 (c) and (d) from Knoth/Steinmetz (2013)
+n <- 5
+LSL <- -3
+USL <- 3
+
+par(mar=c(5, 5, 1, 1) + 0.1)
+
+p.star <- 2*pnorm( (LSL-USL)/2 ) # for p <= p.star pdf and cdf vanish
+
+p_ <- seq(p.star+1e-10, 0.07, 0.0001) # define support of Figure 1
+
+# Figure 1 (c)
+pp_ <- pphat(p_, n)
+plot(p_, pp_, type="l", xlab="p", ylab=expression(P( hat(p) <= p )),
+ xlim=c(0, 0.06), ylim=c(0,1), lwd=2)
+abline(h=0:1, v=p.star, col="grey")
+
+# Figure 1 (d)
+dp_ <- dphat(p_, n)
+plot(p_, dp_, type="l", xlab="p", ylab="f(p)", xlim=c(0, 0.06),
+ ylim=c(0,50), lwd=2)
+abline(h=0, v=p.star, col="grey")
+}
+\keyword{ts}
\ No newline at end of file
diff --git a/man/lns2ewma.crit.Rd b/man/lns2ewma.crit.Rd
new file mode 100644
index 0000000..4d9ea44
--- /dev/null
+++ b/man/lns2ewma.crit.Rd
@@ -0,0 +1,73 @@
+\name{lns2ewma.crit}
+\alias{lns2ewma.crit}
+\title{Compute critical values of EWMA ln \eqn{S^2}{S^2} control charts (variance charts)}
+\description{Computation of the critical values (similar to alarm limits)
+for different types of EWMA control charts
+(based on the log of the sample variance \eqn{S^2}) monitoring normal variance.}
+\usage{lns2ewma.crit(l,L0,df,sigma0=1,cl=NULL,cu=NULL,hs=NULL,sided="upper",mode="fixed",r=40)}
+\arguments{
+\item{l}{smoothing parameter lambda of the EWMA control chart.}
+\item{L0}{in-control ARL.}
+\item{df}{actual degrees of freedom, corresponds to subsample size
+(for known mean it is equal to the subsample size,
+for unknown mean it is equal to subsample size minus one.}
+\item{sigma0}{in-control standard deviation.}
+\item{cl}{deployed for \code{sided}=\code{"upper"}, that is, upper variance control chart with
+lower reflecting barrier \code{cl}.}
+\item{cu}{for two-sided (\code{sided}=\code{"two"}) and fixed upper control limit (\code{mode}=\code{"fixed"}),
+for all other cases \code{cu} is ignored.}
+\item{hs}{so-called headstart (enables fast initial response) -- the default value (hs=NULL) corresponds to the
+in-control mean of ln \eqn{S^2}{S^2}.}
+\item{sided}{distinguishes between one- and two-sided two-sided EWMA-\eqn{S^2}{S^2} control charts by choosing
+\code{"upper"} (upper chart with reflection at \code{cl}),
+\code{"lower"} (lower chart with reflection at \code{cu}), and \code{"two"} (two-sided chart), respectively.}
+\item{mode}{only deployed for \code{sided}=\code{"two"} -- with \code{"fixed"} an upper control limit (see \code{cu})
+is set and only the lower is
+calculated to obtain the in-control ARL \code{L0}, while with \code{"unbiased"} a certain unbiasedness of the ARL
+function is guaranteed (here, both the
+lower and the upper control limit are calculated). With \code{"vanilla"} limits symmetric around the in-control
+mean of ln \eqn{S^2}{S^2}
+are determined, while for \code{"eq.tails"} the in-control ARL values of two single EWMA variance charts
+(decompose the two-sided scheme into one lower and one upper scheme) are matched.}
+\item{r}{dimension of the resulting linear equation system: the larger the more accurate.}
+}
+\details{
+\code{lns2ewma.crit} determines the critical values (similar to alarm limits) for given in-control ARL \code{L0}
+by applying secant rule and using \code{lns2ewma.arl()}.
+In case of \code{sided}=\code{"two"} and \code{mode}=\code{"unbiased"}
+a two-dimensional secant rule is applied that also ensures that the
+maximum of the ARL function for given standard deviation is attained
+at \code{sigma0}. See Knoth (2010) and the related example.
+}
+\value{Returns the lower and upper control limit \code{cl} and \code{cu}.}
+\references{
+C. A. Acosta-Mej\'ia and J. J. Pignatiello Jr. and B. V. Rao (1999),
+A comparison of control charting procedures for monitoring process dispersion,
+\emph{IIE Transactions 31}, 569-579.
+
+S. V. Crowder and M. D. Hamilton (1992),
+An EWMA for monitoring a process standard deviation,
+\emph{Journal of Quality Technology 24}, 12-21.
+
+S. Knoth (2005),
+Accurate ARL computation for EWMA-\eqn{S^2}{S^2} control charts,
+\emph{Statistics and Computing 15}, 341-352.
+
+S. Knoth (2010),
+Control Charting Normal Variance -- Reflections, Curiosities, and Recommendations,
+in \emph{Frontiers in Statistical Quality Control 9},
+H.-J. Lenz and P.-T. Wilrich (Eds.),
+Physica Verlag, Heidelberg, Germany, 3-18.
+}
+\author{Sven Knoth}
+\seealso{\code{lns2ewma.arl} for calculation of ARL of EWMA ln \eqn{S^2}{S^2} control charts.}
+\examples{
+## Knoth (2005)
+## compare with Table 3 (p. 351)
+L0 <- 200
+l <- .05
+df <- 4
+limits <- lns2ewma.crit(l, L0, df, cl=0, hs=0)
+limits["cu"]
+}
+\keyword{ts}
diff --git a/man/lns2sewma.arl.Rd b/man/lns2sewma.arl.Rd
new file mode 100644
index 0000000..22f4a1a
--- /dev/null
+++ b/man/lns2sewma.arl.Rd
@@ -0,0 +1,94 @@
+\name{lns2ewma.arl}
+\alias{lns2ewma.arl}
+\title{Compute ARLs of EWMA ln \eqn{S^2}{S^2} control charts (variance charts)}
+\description{Computation of the (zero-state) Average Run Length (ARL)
+for different types of EWMA control charts
+(based on the log of the sample variance \eqn{S^2}) monitoring normal variance.}
+\usage{lns2ewma.arl(l,cl,cu,sigma,df,hs=NULL,sided="upper",r=40)}
+\arguments{
+\item{l}{smoothing parameter lambda of the EWMA control chart.}
+\item{cl}{lower control limit of the EWMA control chart.}
+\item{cu}{upper control limit of the EWMA control chart.}
+\item{sigma}{true standard deviation.}
+\item{df}{actual degrees of freedom, corresponds to subsample size (for known mean it is equal to the subsample size,
+for unknown mean it is equal to subsample size minus one.}
+\item{hs}{so-called headstart (enables fast initial response) -- the default value (hs=NULL) corresponds to the in-control
+mean of ln \eqn{S^2}{S^2}.}
+\item{sided}{distinguishes between one- and two-sided two-sided EWMA-\eqn{S^2}{S^2} control charts
+by choosing \code{"upper"} (upper chart with reflection at \code{cl}), \code{"lower"} (lower chart with reflection at \code{cu}),
+and \code{"two"} (two-sided chart), respectively.}
+\item{r}{dimension of the resulting linear equation system: the larger the better.}
+}
+\details{
+\code{lns2ewma.arl} determines the Average Run Length (ARL) by numerically
+solving the related ARL integral equation by means of the Nystroem method
+based on Gauss-Legendre quadrature.}
+\value{Returns a single value which resembles the ARL.}
+\references{
+S. V. Crowder and M. D. Hamilton (1992),
+An EWMA for monitoring a process standard deviation,
+\emph{Journal of Quality Technology 24}, 12-21.
+
+S. Knoth (2005),
+Accurate ARL computation for EWMA-\eqn{S^2}{S^2} control charts,
+\emph{Statistics and Computing 15}, 341-352.
+}
+\author{Sven Knoth}
+\seealso{
+\code{xewma.arl} for zero-state ARL computation of EWMA control charts for monitoring normal mean.
+}
+\examples{
+lns2ewma.ARL <- Vectorize("lns2ewma.arl", "sigma")
+
+## Crowder/Hamilton (1992)
+## moments of ln S^2
+E_log_gamma <- function(df) log(2/df) + digamma(df/2)
+V_log_gamma <- function(df) trigamma(df/2)
+E_log_gamma_approx <- function(df) -1/df - 1/3/df^2 + 2/15/df^4
+V_log_gamma_approx <- function(df) 2/df + 2/df^2 + 4/3/df^3 - 16/15/df^5
+
+## results from Table 3 ( upper chart with reflection at 0 = log(sigma0=1) )
+## original entries are (lambda = 0.05, K = 1.06, df=n-1=4)
+# sigma ARL
+# 1 200
+# 1.1 43
+# 1.2 18
+# 1.3 11
+# 1.4 7.6
+# 1.5 6.0
+# 2 3.2
+
+df <- 4
+lambda <- .05
+K <- 1.06
+cu <- K * sqrt( lambda/(2-lambda) * V_log_gamma_approx(df) )
+
+sigmas <- c(1 + (0:5)/10, 2)
+arls <- round(lns2ewma.ARL(lambda, 0, cu, sigmas, df, hs=0, sided="upper"), digits=1)
+data.frame(sigmas, arls)
+
+## Knoth (2005)
+## compare with Table 3 (p. 351)
+lambda <- .05
+df <- 4
+K <- 1.05521
+cu <- 1.05521 * sqrt( lambda/(2-lambda) * V_log_gamma_approx(df) )
+
+## upper chart with reflection at sigma0=1 in Table 4
+## original entries are
+# sigma ARL_0 ARL_-.267
+# 1 200.0 200.0
+# 1.1 43.04 41.55
+# 1.2 18.10 19.92
+# 1.3 10.75 13.11
+# 1.4 7.63 9.93
+# 1.5 5.97 8.11
+# 2 3.17 4.67
+
+M <- -0.267
+cuM <- lns2ewma.crit(lambda, 200, df, cl=M, hs=M, r=60)[2]
+arls1 <- round(lns2ewma.ARL(lambda, 0, cu, sigmas, df, hs=0, sided="upper"), digits=2)
+arls2 <- round(lns2ewma.ARL(lambda, M, cuM, sigmas, df, hs=M, sided="upper", r=60), digits=2)
+data.frame(sigmas, arls1, arls2)
+}
+\keyword{ts}
diff --git a/man/mewma.arl.Rd b/man/mewma.arl.Rd
new file mode 100644
index 0000000..7bc1dd9
--- /dev/null
+++ b/man/mewma.arl.Rd
@@ -0,0 +1,125 @@
+\name{mewma.arl}
+\alias{mewma.arl}
+\alias{mewma.arl.f}
+\alias{mewma.ad}
+\title{Compute ARLs of MEWMA control charts}
+\description{Computation of the (zero-state) Average Run Length (ARL)
+for multivariate exponentially weighted moving average (MEWMA) charts monitoring multivariate normal mean.}
+\usage{mewma.arl(l, cE, p, delta=0, hs=0, r=20, ntype=NULL, qm0=20, qm1=qm0)
+
+mewma.arl.f(l, cE, p, delta=0, r=20, ntype=NULL, qm0=20, qm1=qm0)
+
+mewma.ad(l, cE, p, delta=0, r=20, n=20, type="cond", hs=0, ntype=NULL, qm0=20, qm1=qm0)}
+\arguments{
+\item{l}{smoothing parameter lambda of the MEWMA control chart.}
+\item{cE}{alarm threshold of the MEWMA control chart.}
+\item{p}{dimension of multivariate normal distribution.}
+\item{delta}{magnitude of the potential change, \code{delta=0} refers to the in-control state.}
+\item{hs}{so-called headstart (enables fast initial response) -- must be non-negative.}
+\item{r}{number of quadrature nodes -- dimension of the resulting linear equation system
+for \code{delta} = 0. For non-zero \code{delta} this dimension is mostly r^2 (Markov chain approximation leads
+to some larger values). Caution: If \code{ntype} is set to \code{"co"} (collocation), then values of \code{r}
+larger than 20 lead to large computing times.
+For the other selections this would happen for values larger than 40.}
+\item{ntype}{choose the numerical algorithm to solve the ARL integral equation. For \code{delta}=0:
+Possible values are
+\code{"gl"}, \code{"gl2"} (gauss-legendre, classic and with variables change: square),
+\code{"co"} (collocation, for \code{delta} > 0 with sin transformation),
+\code{"ra"} (radau),
+\code{"cc"} (clenshaw-curtis),
+\code{"mc"} (markov chain),
+and \code{"sr"} (simpson rule).
+For \code{delta} larger than 0, some more values besides the others are possible:
+\code{"gl3"}, \code{"gl4"}, \code{"gl5"} (gauss-legendre with a further change in variables: sin, tan, sinh),
+\code{"co2"}, \code{"co3"} (collocation with some trimming and tan as quadrature stabilizing transformations, respectively).
+If it is set to \code{NULL} (the default), then for \code{delta}=0 then \code{"gl2"} is chosen.
+If \code{delta} larger than 0, then for \code{p} equal 2 or 4 \code{"gl3"} and for all other values \code{"gl5"} is taken.
+\code{"ra"} denotes the method used in Rigdon (1995a). \code{"mc"} denotes the Markov chain approximation.}
+\item{type}{switch between \code{"cond"} and \code{"cycl"} for differentiating between the conditional
+(no false alarm) and the cyclical (after false alarm re-start in \code{hs}), respectively.}
+\item{n}{number of quadrature nodes for Calculating the steady-state ARL integral(s).}
+\item{qm0,qm1}{number of collocation quadrature nodes for the out-of-control case (\code{qm0} for the inner integral,
+\code{qm1} for the outer one), that is, for positive \code{delta},
+and for the in-control case (now only \code{qm0} is deployed) if via \code{ntype} the collocation procedure is requested.}
+}
+\details{Basically, this is the implementation of different numerical algorithms for
+solving the integral equation for the MEWMA in-control (\code{delta} = 0) ARL introduced in Rigdon (1995a)
+and out-of-control (\code{delta} != 0) ARL in Rigdon (1995b).
+Most of them are nothing else than the Nystroem approach -- the integral is replaced by a suitable quadrature.
+Here, the Gauss-Legendre (more powerful), Radau (used by Rigdon, 1995a), Clenshaw-Curtis, and
+Simpson rule (which is really bad) are provided.
+Additionally, the collocation approach is offered as well, because it is much better for small odd values for \code{p}.
+FORTRAN code for the Radau quadrature based Nystroem of Rigdon (1995a)
+was published in Bodden and Rigdon (1999) -- see also \url{http://lib.stat.cmu.edu/jqt/31-1}.
+Furthermore, FORTRAN code for the Markov chain approximation (in- and out-ot-control)
+could be found at \url{http://lib.stat.cmu.edu/jqt/33-4}.
+The related papers are Runger and Prabhu (1996) and Molnau et al. (2001).
+The idea of the Clenshaw-Curtis quadrature was taken from
+Capizzi and Masarotto (2010), who successfully deployed a modified Clenshaw-Curtis quadrature
+to calculate the ARL of combined (univariate) Shewhart-EWMA charts. It turns out that it works also nicely for the
+MEWMA ARL. The version \code{mewma.arl.f()} without the argument \code{hs} provides the ARL as function of one (in-control)
+or two (out-of-control) arguments.
+}
+\value{Returns a single value which is simply the zero-state ARL.}
+\references{
+Kevin M. Bodden and Steven E. Rigdon (1999),
+A program for approximating the in-control ARL for the MEWMA chart,
+\emph{Journal of Quality Technology 31}, 120-123.
+
+Giovanna Capizzi and Guido Masarotto (2010),
+Evaluation of the run-length distribution for a combined Shewhart-EWMA control chart,
+\emph{Statistics and Computing 20}, 23-33.
+
+Wade E. Molnau et al. (2001),
+A Program for ARL Calculation for Multivariate EWMA Charts,
+\emph{Journal of Quality Technology 33}, 515-521.
+
+Steven E. Rigdon (1995a), An integral equation for the in-control average run length of a multivariate
+exponentially weighted moving average control chart, \emph{J. Stat. Comput. Simulation 52}, 351-365.
+
+Steven E. Rigdon (1995b), A double-integral equation for the average run length of a multivariate
+exponentially weighted moving average control chart, \emph{Stat. Probab. Lett. 24}, 365-373.
+
+George C. Runger and Sharad S. Prabhu (1996),
+A Markov Chain Model for the Multivariate Exponentially Weighted Moving Averages Control Chart,
+\emph{J. Amer. Statist. Assoc. 91}, 1701-1706.
+}
+\author{Sven Knoth}
+\seealso{
+\code{mewma.crit} for getting the alarm threshold to attain a certain in-control ARL.
+}
+\examples{
+# Rigdon (1995b), p. 372, Tab. 1
+r <- 0.1
+p <- 4
+h <- 12.73
+L0a <- mewma.arl(r, h, p) # defaults to "gl2" because of the even p.
+L0b <- mewma.arl(r, h, p, ntype="co")
+L0c <- mewma.arl(r, h, p, r=48, ntype="ra")
+L0d <- mewma.arl(r, h, p, ntype="cc")
+L0e <- mewma.arl(r, h, p, ntype="mc")
+data.frame(L0a, L0b, L0c, L0d, L0e)
+
+# original (Rigdon 1995a) implicite value is 200
+p <- 3
+h <- 14.98
+L0a <- mewma.arl(r, h, p, ntype="gl2")
+L0aa <- mewma.arl(r, h, p, r=48, ntype="gl2")
+L0b <- mewma.arl(r, h, p, ntype="co")
+L0bb <- mewma.arl(r, h, p, r=48, ntype="co")
+L0c <- mewma.arl(r, h, p, r=48, ntype="ra")
+L0d <- mewma.arl(r, h, p, ntype="cc")
+L0dd <- mewma.arl(r, h, p, r=48, ntype="cc")
+L0e <- mewma.arl(r, h, p, ntype="mc")
+L0ee <- mewma.arl(r, h, p, r=48, ntype="mc")
+data.frame(L0a, L0aa, L0b, L0bb, L0c, L0d, L0dd, L0e, L0ee)
+# original (Rigdon 1995a) implicite value is 1000
+
+# Rigdon (1995b), p. 372, Tab. 1
+p <- 5
+h <- 14.56
+L1 <- mewma.arl(r, h, p, delta=1, r=20)
+L1
+# original value is 12.9
+}
+\keyword{ts}
diff --git a/man/mewma.crit.Rd b/man/mewma.crit.Rd
new file mode 100644
index 0000000..0ae9a4f
--- /dev/null
+++ b/man/mewma.crit.Rd
@@ -0,0 +1,34 @@
+\name{mewma.crit}
+\alias{mewma.crit}
+\title{Compute alarm threshold of MEWMA control charts}
+\description{Computation of the alarm threshold for multivariate exponentially weighted
+moving average (MEWMA) charts monitoring multivariate normal mean.}
+\usage{mewma.crit(l, L0, p, hs=0, r=20)}
+\arguments{
+\item{l}{smoothing parameter lambda of the MEWMA control chart.}
+\item{L0}{in-control ARL.}
+\item{p}{dimension of multivariate normal distribution.}
+\item{hs}{so-called headstart (enables fast initial response) -- must be non-negative.}
+\item{r}{number of quadrature nodes -- dimension of the resulting linear equation system.}
+}
+\details{
+\code{mewma.crit} determines the alarm threshold of for given in-control ARL \code{L0}
+by applying secant rule and using \code{mewma.arl()} with \code{ntype="gl2"}.
+}
+\value{Returns a single value which resembles the critical value \code{c}.}
+\references{
+Steven E. Rigdon (1995), An integral equation for the in-control average run length of a multivariate
+exponentially weighted moving average control chart, \emph{J. Stat. Comput. Simulation 52}, 351-365.
+}
+\author{Sven Knoth}
+\seealso{\code{mewma.arl} for zero-state ARL computation.}
+\examples{
+# Rigdon (1995), p. 358, Tab. 1
+p <- 4
+L0 <- 500
+r <- .25
+h4 <- mewma.crit(r, L0, p)
+h4
+## original value is 16.38.
+}
+\keyword{ts}
diff --git a/man/mewma.psi.Rd b/man/mewma.psi.Rd
new file mode 100644
index 0000000..8da37d8
--- /dev/null
+++ b/man/mewma.psi.Rd
@@ -0,0 +1,42 @@
+\name{mewma.psi}
+\alias{mewma.psi}
+\title{Compute steady-state density of the MEWMA statistic}
+\description{Computation of the (zero-state) steady-state density function of the statistic deployed in
+multivariate exponentially weighted moving average (MEWMA) charts monitoring multivariate normal mean.}
+\usage{mewma.psi(l, cE, p, type="cond", hs=0, r=20)}
+\arguments{
+\item{l}{smoothing parameter lambda of the MEWMA control chart.}
+\item{cE}{alarm threshold of the MEWMA control chart.}
+\item{p}{dimension of multivariate normal distribution.}
+\item{type}{switch between \code{"cond"} and \code{"cycl"} for differentiating between the conditional
+(no false alarm) and the cyclical (after false alarm re-start in \code{hs}), respectively.}
+\item{hs}{the re-starting point for the cyclical steady-state framework.}
+\item{r}{number of quadrature nodes.}
+}
+\details{Basically, ideas from Knoth (2015, MEWMA numerics) and Knoth (2014, steady-state ARL concepts) are merged.
+More details will follow.}
+\value{Returns a function.}
+\references{
+Sven Knoth (2014),
+The Case Against the Use of Synthetic Control Charts,
+accepted in \emph{Journal of Quality Technology}.
+
+Sven Knoth (2015),
+ARL numerics for MEWMA charts,
+under revision in \emph{Journal of Quality Technology}.
+}
+\author{Sven Knoth}
+\seealso{
+\code{mewma.arl} for calculating the in-control ARL of MEWMA.
+}
+\examples{
+lambda <- 0.1
+L0 <- 1000
+p <- 3
+h4 <- mewma.crit(lambda, L0, p)
+x_ <- seq(0, h4*lambda/(2-lambda), by=0.002)
+psi <- mewma.psi(lambda, h4, p)
+psi_ <- psi(x_)
+#plot(x_, psi_, type="l", xlab="x", ylab=expression(psi(x)))
+}
+\keyword{ts}
diff --git a/man/p.ewma.arl.Rd b/man/p.ewma.arl.Rd
new file mode 100644
index 0000000..85e4d69
--- /dev/null
+++ b/man/p.ewma.arl.Rd
@@ -0,0 +1,78 @@
+\name{p.ewma.arl}
+\alias{p.ewma.arl}
+\title{Compute ARLs of binomial EWMA p control charts}
+\description{Computation of the (zero-state) Average Run Length (ARL) at given rate \code{p}.}
+\usage{p.ewma.arl(lambda, ucl, n, p, z0, d.res=1, r.mode="ieee.round", i.mode="integer")}
+\arguments{
+\item{lambda}{smoothing parameter of the EWMA p control chart.}
+\item{ucl}{upper control limit of the EWMA p control chart.}
+\item{n}{subgroup size.}
+\item{p}{(failure/success) rate.}
+\item{z0}{so-called headstart (give fast initial response).}
+\item{d.res}{resolution (see details).}
+\item{r.mode}{round mode -- allowed modes are \code{"gan.floor"}, \code{"floor"}, \code{"ceil"},
+\code{"ieee.round"}, \code{"round"}, \code{"mix"}.}
+\item{i.mode}{type of interval center -- \code{"integer"} or \code{"half"} integer.}
+}
+\details{
+The monitored data follow a binomial distribution with size \code{n} and failure/success probability \code{p}.
+The ARL values of the resulting EWMA control chart are determined by Markov chain approximation.
+Here, the original EWMA values are approximated by
+multiples of one over \code{d.res}. Different ways of rounding (see \code{r.mode}) to the next multiple are implemented.
+Besides Gan's paper nothing is published about the numerical subtleties.
+}
+\value{Return single value which resemble the ARL.}
+\references{
+F. F. Gan (1990),
+Monitoring observations generated from a binomial distribution using modified
+exponentially weighted moving average control chart,
+\emph{J. Stat. Comput. Simulation} 37, 45-60.
+
+S. Knoth and S. Steinmetz (2013),
+EWMA \code{p} charts under sampling by variables,
+\emph{International Journal of Production Research} 51, 3795-3807.
+}
+\author{Sven Knoth}
+\seealso{later.}
+\examples{
+## Gan (1990)
+
+# Table 1
+
+n <- 150
+p0 <- .1
+z0 <- n*p0
+
+lambda <- c(1, .51, .165)
+hu <- c(27, 22, 18)
+
+p.value <- .1 + (0:20)/200
+
+p.EWMA.arl <- Vectorize(p.ewma.arl, "p")
+
+arl1.value <- round(p.EWMA.arl(lambda[1], hu[1], n, p.value, z0, r.mode="round"), digits=2)
+arl2.value <- round(p.EWMA.arl(lambda[2], hu[2], n, p.value, z0, r.mode="round"), digits=2)
+arl3.value <- round(p.EWMA.arl(lambda[3], hu[3], n, p.value, z0, r.mode="round"), digits=2)
+
+arls <- matrix(c(arl1.value, arl2.value, arl3.value), ncol=length(lambda))
+rownames(arls) <- p.value
+colnames(arls) <- paste("lambda =", lambda)
+arls
+
+## Knoth/Steinmetz (2013)
+
+n <- 5
+p0 <- 0.02
+z0 <- n*p0
+lambda <- 0.3
+ucl <- 0.649169922 ## in-control ARL 370.4 (determined with d.res = 2^14 = 16384)
+
+res.list <- 2^(1:12)
+arl.list <- NULL
+for ( res in res.list ) {
+ arl <- p.ewma.arl(lambda, ucl, n, p0, z0, d.res=res)
+ arl.list <- c(arl.list, arl)
+}
+cbind(res.list, arl.list)
+}
+\keyword{ts}
diff --git a/man/phat.ewma.arl.Rd b/man/phat.ewma.arl.Rd
new file mode 100644
index 0000000..0bcad2d
--- /dev/null
+++ b/man/phat.ewma.arl.Rd
@@ -0,0 +1,116 @@
+\name{phat.ewma.arl}
+\alias{phat.ewma.arl}
+\alias{phat.ewma.crit}
+\alias{phat.ewma.lambda}
+\title{Compute ARLs of EWMA phat control charts}
+\description{Computation of the (zero-state) Average Run Length (ARL), upper control limit (ucl)
+for given in-control ARL, and lambda for minimal out-of control ARL at given shift.}
+\usage{phat.ewma.arl(lambda, ucl, mu, n, z0, sigma=1, type="known", LSL=-3, USL=3, N=15,
+qm=25, ntype="coll")
+
+phat.ewma.crit(lambda, L0, mu, n, z0, sigma=1, type="known", LSL=-3, USL=3, N=15, qm=25)
+
+phat.ewma.lambda(L0, mu, n, z0, sigma=1, type="known", max_l=1, min_l=.001, LSL=-3, USL=3,
+qm=25)
+}
+\arguments{
+\item{lambda}{smoothing parameter of the EWMA control chart.}
+\item{ucl}{upper control limit of the EWMA phat control chart.}
+\item{L0}{pre-defined in-control ARL (Average Run Length).}
+\item{mu}{true mean or mean where the ARL should be minimized (then the in-control mean is simply 0).}
+\item{n}{subgroup size.}
+\item{z0}{so-called headstart (gives fast initial response).}
+\item{type}{choose whether the standard deviation is given and fixed (\code{"known"}) or estimated and potentially monitored (\code{"estimated"}).}
+\item{sigma}{actual standard deviation of the data -- the in-control value is 1.}
+\item{max_l, min_l}{maximal and minimal value for optimal lambda search.}
+\item{LSL,USL}{lower and upper specification limit, respectively.}
+\item{N}{size of collocation base, dimension of the resulting linear equation system is equal to \code{N}.}
+\item{qm}{number of nodes for collocation quadratures.}
+\item{ntype}{switch between the default method \code{coll} (collocation) and the classic one \code{markov} (Markov chain approximation)
+for calculating the ARL numerically.}
+}
+\details{
+The three implemented functions allow to apply a new type control chart. Basically, lower and upper
+specification limits are given. The monitoring
+vehicle then is the empirical probability that an item will not follow these specification given the
+sequence of sample means. If
+the related EWMA sequence violates the control limits, then the alarm indicates a significant process
+deterioration. For details see the
+paper mentioned in the references. To be able to construct the control charts, see the first example.
+}
+\value{Return single values which resemble the ARL, the critical value, and the optimal lambda, respectively.}
+\references{
+S. Knoth and S. Steinmetz (2013),
+EWMA \code{p} charts under sampling by variables,
+\emph{International Journal of Production Research} 51, 3795-3807.
+}
+\author{Sven Knoth}
+\seealso{
+\code{sewma.arl} for a further collocation based ARL calculation routine.}
+\examples{
+## Simple example to demonstrate the chart.
+
+# some functions
+h.mu <- function(mu) pnorm(LSL-mu) + pnorm(mu-USL)
+ewma <- function(x, lambda=0.1, z0=0) filter(lambda*x, 1-lambda, m="r", init=z0)
+
+# parameters
+LSL <- -3 # lower specification limit
+USL <- 3 # upper specification limit
+n <- 5 # batch size
+lambda <- 0.1 # EWMA smoothing parameter
+L0 <- 1000 # in-control Average Run Length (ARL)
+z0 <- h.mu(0) # start at minimal defect level
+ucl <- phat.ewma.crit(lambda, L0, 0, n, z0, LSL=LSL, USL=USL)
+
+# data
+x0 <- matrix(rnorm(50*n), ncol=5) # in-control data
+x1 <- matrix(rnorm(50*n, mean=0.5), ncol=5)# out-of-control data
+x <- rbind(x0,x1) # all data
+
+# create chart
+xbar <- apply(x, 1, mean)
+phat <- h.mu(xbar)
+z <- ewma(phat, lambda=lambda, z0=z0)
+plot(1:length(z), z, type="l", xlab="batch", ylim=c(0,.02))
+abline(h=z0, col="grey", lwd=.7)
+abline(h=ucl, col="red")
+
+
+## S. Knoth, S. Steinmetz (2013)
+
+# Table 1
+
+lambdas <- c(.5, .25, .2, .1)
+L0 <- 370.4
+n <- 5
+LSL <- -3
+USL <- 3
+
+phat.ewma.CRIT <- Vectorize("phat.ewma.crit", "lambda")
+p.star <- pnorm( LSL ) + pnorm( -USL ) ## lower bound of the chart
+ucls <- phat.ewma.CRIT(lambdas, L0, 0, n, p.star, LSL=LSL, USL=USL)
+print(cbind(lambdas, ucls))
+
+# Table 2
+
+mus <- c((0:4)/4, 1.5, 2, 3)
+phat.ewma.ARL <- Vectorize("phat.ewma.arl", "mu")
+arls <- NULL
+for ( i in 1:length(lambdas) ) {
+ arls <- cbind(arls, round(phat.ewma.ARL(lambdas[i], ucls[i], mus,
+ n, p.star, LSL=LSL, USL=USL), digits=2))
+}
+arls <- data.frame(arls, row.names=NULL)
+names(arls) <- lambdas
+print(arls)
+
+# Table 3
+
+\dontrun{
+mus <- c(.25, .5, 1, 2)
+phat.ewma.LAMBDA <- Vectorize("phat.ewma.lambda", "mu")
+lambdas <- phat.ewma.LAMBDA(L0, mus, n, p.star, LSL=LSL, USL=USL)
+print(cbind(mus, lambdas))}
+}
+\keyword{ts}
diff --git a/man/quadrature.nodes.weights.Rd b/man/quadrature.nodes.weights.Rd
new file mode 100644
index 0000000..8786753
--- /dev/null
+++ b/man/quadrature.nodes.weights.Rd
@@ -0,0 +1,37 @@
+\name{quadrature.nodes.weights}
+\alias{quadrature.nodes.weights}
+\title{Calculate quadrature nodes and weights}
+\description{Computation of the nodes and weights to enable numerical quadrature.}
+\usage{quadrature.nodes.weights(n, type="GL", x1=-1, x2=1)}
+\arguments{
+\item{n}{number of nodes (and weights).}
+\item{type}{quadrature type -- currently Gauss-Legendre, \code{"GL"}, and Radau, \code{"Ra"}, are supported.}
+\item{x1}{lower limit of the integration interval.}
+\item{x2}{upper limit of the integration interval.}
+}
+\details{
+A more detailed description will follow soon. The algorithm for the Gauss-Legendre quadrature was delivered by
+Knut Petras to me, while the one for the Radau quadrature was taken from John Burkardt.
+}
+\value{Returns two vectors which hold the needed quadrature nodes and weights.}
+\references{
+H. Brass and K. Petras (2011),
+\emph{Quadrature Theory. The Theory of Numerical Integration on a Compact Interval,}
+Mathematical Surveys and Monographs, American Mathematical Society.
+}
+\author{Sven Knoth}
+\seealso{
+Many of the ARL routines use the Gauss-Legendre nodes.
+}
+\examples{
+# GL
+n <- 10
+qnw <-quadrature.nodes.weights(n, type="GL")
+qnw
+
+# Radau
+n <- 10
+qnw <-quadrature.nodes.weights(n, type="Ra")
+qnw
+}
+\keyword{ts}
diff --git a/man/scusum.arl.Rd b/man/scusum.arl.Rd
new file mode 100644
index 0000000..d22d895
--- /dev/null
+++ b/man/scusum.arl.Rd
@@ -0,0 +1,67 @@
+\name{scusum.arl}
+\alias{scusum.arl}
+\title{Compute ARLs of CUSUM control charts (variance charts)}
+\description{Computation of the (zero-state) Average Run Length (ARL)
+for different types of CUSUM control charts (based on the sample variance
+\eqn{S^2}) monitoring normal variance.}
+\usage{scusum.arl(k, h, sigma, df, hs=0, sided="upper", k2=NULL,
+h2=NULL, hs2=0, r=40, qm=30, version=2)}
+\arguments{
+\item{k}{reference value of the CUSUM control chart.}
+\item{h}{decision interval (alarm limit, threshold) of the CUSUM control chart.}
+\item{sigma}{true standard deviation.}
+\item{df}{actual degrees of freedom, corresponds to subgroup size (for known mean it is equal to the subgroup size,
+for unknown mean it is equal to subgroup size minus one.}
+\item{hs}{so-called headstart (enables fast initial response).}
+\item{sided}{distinguishes between one- and two-sided two-sided CUSUM-\eqn{S^2}{S^2} control charts
+by choosing \code{"upper"} (upper chart), \code{"lower"} (lower chart), and \code{"two"} (two-sided chart),
+respectively. Note that for the two-sided chart the parameters \code{"k2"} and \code{"h2"} have to be set too.}
+\item{k2}{In case of a two-sided CUSUM chart for variance the reference value of the lower chart.}
+\item{h2}{In case of a two-sided CUSUM chart for variance the decision interval of the lower chart.}
+\item{hs2}{In case of a two-sided CUSUM chart for variance the headstart of the lower chart.}
+\item{r}{Dimension of the resulting linear equation system (highest order of the collocation
+polynomials times number of intervals -- see Knoth 2006).}
+\item{qm}{Number of quadrature nodes for calculating the collocation definite integrals.}
+\item{version}{Distinguish version numbers (1,2,...). For internal use only.}
+}
+\details{
+\code{scusum.arl} determines the Average Run Length (ARL) by numerically
+solving the related ARL integral equation by means of collocation (piecewise Chebyshev polynomials).}
+\value{Returns a single value which resembles the ARL.}
+\references{
+S. Knoth (2005),
+Accurate ARL computation for EWMA-\eqn{S^2}{S^2} control charts,
+\emph{Statistics and Computing 15}, 341-352.
+
+S. Knoth (2006),
+Computation of the ARL for CUSUM-\eqn{S^2}{S^2} schemes,
+\emph{Computational Statistics & Data Analysis 51}, 499-512.
+}
+\author{Sven Knoth}
+\seealso{
+\code{xcusum.arl} for zero-state ARL computation of CUSUM control charts for monitoring normal mean.
+}
+\examples{
+## Knoth (2006)
+## compare with Table 1 (p. 507)
+k <- 1.46 # sigma1 = 1.5
+df <- 1
+h <- 10
+
+# original values
+# sigma coll63 BE Hawkins MC 10^9 (s.e.)
+# 1 260.7369 260.7546 261.32 260.7399 (0.0081)
+# 1.1 90.1319 90.1389 90.31 90.1319 (0.0027)
+# 1.2 43.6867 43.6897 43.75 43.6845 (0.0013)
+# 1.3 26.2916 26.2932 26.32 26.2929 (0.0007)
+# 1.4 18.1231 18.1239 18.14 18.1235 (0.0005)
+# 1.5 13.6268 13.6273 13.64 13.6272 (0.0003)
+# 2 5.9904 5.9910 5.99 5.9903 (0.0001)
+# replicate the column coll63
+sigma <- c(1, 1.1, 1.2, 1.3, 1.4, 1.5, 2)
+arl <- rep(NA, length(sigma))
+for ( i in 1:length(sigma) )
+ arl[i] <- round(scusum.arl(k, h, sigma[i], df, r=63, qm=20, version=2), digits=4)
+data.frame(sigma, arl)
+}
+\keyword{ts}
diff --git a/man/scusum.crit.Rd b/man/scusum.crit.Rd
new file mode 100644
index 0000000..be57173
--- /dev/null
+++ b/man/scusum.crit.Rd
@@ -0,0 +1,57 @@
+\name{scusum.crit}
+\alias{scusum.crit}
+\title{Compute decision intervals of CUSUM control charts (variance charts)}
+\description{omputation of the decision intervals (alarm limits)
+for different types of CUSUM control charts (based on the sample
+variance \eqn{S^2}) monitoring normal variance.}
+\usage{scusum.crit(k, L0, sigma, df, hs=0, sided="upper", mode="eq.tails",
+k2=NULL, hs2=0, r=40, qm=30)}
+\arguments{
+\item{k}{reference value of the CUSUM control chart.}
+\item{L0}{in-control ARL.}
+\item{sigma}{true standard deviation.}
+\item{df}{actual degrees of freedom, corresponds to subgroup size (for known mean it is equal
+to the subgroup size, for unknown mean it is equal to subgroup size minus one.}
+\item{hs}{so-called headstart (enables fast initial response).}
+\item{sided}{distinguishes between one- and two-sided two-sided CUSUM-\eqn{S^2}{S^2} control charts
+by choosing \code{"upper"} (upper chart), \code{"lower"} (lower chart),
+and \code{"two"} (two-sided chart), respectively. Note that for the two-sided chart the parameters
+\code{"k2"} and \code{"h2"} have to be set too.}
+\item{mode}{only deployed for \code{sided}=\code{"two"} -- with \code{"eq.tails"}
+two one-sided CUSUM charts (lower and upper) with the same in-control ARL are coupled.
+With \code{"unbiased"} a certain unbiasedness of the ARL function is guaranteed (here, both the
+lower and the upper control limit are calculated).}
+\item{k2}{in case of a two-sided CUSUM chart for variance the reference value of the lower chart.}
+\item{hs2}{in case of a two-sided CUSUM chart for variance the headstart of the lower chart.}
+\item{r}{Dimension of the resulting linear equation system (highest order of the collocation
+polynomials times number of intervals -- see Knoth 2006).}
+\item{qm}{Number of quadrature nodes for calculating the collocation definite integrals.}
+}
+\details{
+\code{scusum.crit} ddetermines the decision interval (alarm limit)
+for given in-control ARL \code{L0} by applying secant rule and using \code{scusum.arl()}.}
+\value{Returns a single value which resembles the decision interval \code{h}.}
+\references{
+S. Knoth (2005),
+Accurate ARL computation for EWMA-\eqn{S^2}{S^2} control charts,
+\emph{Statistics and Computing 15}, 341-352.
+
+S. Knoth (2006),
+Computation of the ARL for CUSUM-\eqn{S^2}{S^2} schemes,
+\emph{Computational Statistics & Data Analysis 51}, 499-512.
+}
+\author{Sven Knoth}
+\seealso{
+\code{xcusum.arl} for zero-state ARL computation of CUSUM control charts monitoring normal mean.
+}
+\examples{
+## Knoth (2006)
+## compare with Table 1 (p. 507)
+k <- 1.46 # sigma1 = 1.5
+df <- 1
+L0 <- 260.74
+h <- scusum.crit(k, L0, 1, df)
+h
+# original value is 10
+}
+\keyword{ts}
diff --git a/man/sewma.arl.Rd b/man/sewma.arl.Rd
new file mode 100644
index 0000000..6a1caed
--- /dev/null
+++ b/man/sewma.arl.Rd
@@ -0,0 +1,109 @@
+\name{sewma.arl}
+\alias{sewma.arl}
+\title{Compute ARLs of EWMA control charts (variance charts)}
+\description{Computation of the (zero-state) Average Run Length (ARL)
+for different types of EWMA control charts (based on the sample variance
+\eqn{S^2}) monitoring normal variance.}
+\usage{sewma.arl(l,cl,cu,sigma,df,s2.on=TRUE,hs=NULL,sided="upper",r=40,qm=30)}
+\arguments{
+\item{l}{smoothing parameter lambda of the EWMA control chart.}
+\item{cl}{lower control limit of the EWMA control chart.}
+\item{cu}{upper control limit of the EWMA control chart.}
+\item{sigma}{true standard deviation.}
+\item{df}{actual degrees of freedom, corresponds to subgroup
+size (for known mean it is equal to the subgroup size,
+for unknown mean it is equal to subgroup size minus one.}
+\item{s2.on}{distinguishes between \eqn{S^2}{S^2} and \eqn{S}{S} chart.}
+\item{hs}{so-called headstart (enables fast initial response);
+the default (\code{NULL}) yields the expected in-control value of
+\eqn{S^2}{S^2} (1) and \eqn{S}{S} (\eqn{c_4}{c_4}), respectively.}
+\item{sided}{distinguishes between one- and two-sided
+two-sided EWMA-\eqn{S^2}{S^2} control charts
+by choosing \code{"upper"} (upper chart
+without reflection at \code{cl} -- the actual value of
+\code{cl} is not used),
+\code{"Rupper"} (upper chart with reflection at \code{cl}),
+\code{"Rlower"} (lower chart with reflection at \code{cu}),
+and \code{"two"} (two-sided chart),
+respectively.}
+\item{r}{dimension of the resulting linear equation system (highest order of
+the collocation polynomials).}
+\item{qm}{number of quadrature nodes for calculating the collocation
+definite integrals.}
+}
+\details{
+\code{sewma.arl} determines the Average Run Length (ARL) by numerically
+solving the related ARL integral equation by means of
+collocation (Chebyshev polynomials).}
+\value{Returns a single value which resembles the ARL.}
+\references{
+S. Knoth (2005),
+Accurate ARL computation for EWMA-\eqn{S^2}{S^2} control charts,
+\emph{Statistics and Computing 15}, 341-352.
+
+S. Knoth (2006),
+Computation of the ARL for CUSUM-\eqn{S^2}{S^2} schemes,
+\emph{Computational Statistics & Data Analysis 51}, 499-512.
+}
+\author{Sven Knoth}
+\seealso{
+\code{xewma.arl} for zero-state ARL computation of EWMA control charts
+for monitoring normal mean.
+}
+\examples{
+## Knoth (2005)
+## compare with Table 1 (p. 347): 249.9997
+## Monte Carlo with 10^9 replicates: 249.9892 +/- 0.008
+l <- .025
+df <- 1
+cu <- 1 + 1.661865*sqrt(l/(2-l))*sqrt(2/df)
+sewma.arl(l,0,cu,1,df)
+
+## ARL values for upper and lower EWMA charts with reflecting barriers
+## (reflection at in-control level sigma0 = 1)
+## examples from Knoth (2006), Tables 4 and 5
+
+Ssewma.arl <- Vectorize("sewma.arl", "sigma")
+
+## upper chart with reflection at sigma0=1 in Table 4
+## original entries are
+# sigma ARL
+# 1 100.0
+# 1.01 85.3
+# 1.02 73.4
+# 1.03 63.5
+# 1.04 55.4
+# 1.05 48.7
+# 1.1 27.9
+# 1.2 12.9
+# 1.3 7.86
+# 1.4 5.57
+# 1.5 4.30
+# 2 2.11
+
+\dontrun{
+l <- 0.15
+df <- 4
+cu <- 1 + 2.4831*sqrt(l/(2-l))*sqrt(2/df)
+sigmas <- c(1 + (0:5)/100, 1 + (1:5)/10, 2)
+arls <- round(Ssewma.arl(l, 1, cu, sigmas, df, sided="Rupper", r=100), digits=2)
+data.frame(sigmas, arls)}
+
+## lower chart with reflection at sigma0=1 in Table 5
+## original entries are
+# sigma ARL
+# 1 200.04
+# 0.9 38.47
+# 0.8 14.63
+# 0.7 8.65
+# 0.6 6.31
+
+\dontrun{
+l <- 0.115
+df <- 5
+cl <- 1 - 2.0613*sqrt(l/(2-l))*sqrt(2/df)
+sigmas <- c((10:6)/10)
+arls <- round(Ssewma.arl(l, cl, 1, sigmas, df, sided="Rlower", r=100), digits=2)
+data.frame(sigmas, arls)}
+}
+\keyword{ts}
diff --git a/man/sewma.arl.prerun.Rd b/man/sewma.arl.prerun.Rd
new file mode 100644
index 0000000..d80f859
--- /dev/null
+++ b/man/sewma.arl.prerun.Rd
@@ -0,0 +1,53 @@
+\name{sewma.arl.prerun}
+\alias{sewma.arl.prerun}
+\title{Compute ARLs of EWMA control charts (variance charts) in case of estimated parameters}
+\description{Computation of the (zero-state) Average Run Length (ARL)
+for EWMA control charts (based on the sample variance \eqn{S^2})
+monitoring normal variance with estimated parameters.}
+\usage{sewma.arl.prerun(l, cl, cu, sigma, df1, df2, hs=1, sided="upper",
+r=40, qm=30, qm.sigma=30, truncate=1e-10)}
+\arguments{
+\item{l}{smoothing parameter lambda of the EWMA control chart.}
+\item{cl}{lower control limit of the EWMA control chart.}
+\item{cu}{upper control limit of the EWMA control chart.}
+\item{sigma}{true standard deviation.}
+\item{df1}{actual degrees of freedom, corresponds to subgroup size (for known mean it is equal to the subgroup size,
+for unknown mean it is equal to subgroup size minus one.}
+\item{df2}{degrees of freedom of the pre-run variance estimator.}
+\item{hs}{so-called headstart (enables fast initial response).}
+\item{sided}{distinguishes between one- and two-sided two-sided EWMA-\eqn{S^2}{S^2} control charts
+by choosing \code{"upper"} (upper chart without reflection at \code{cl} -- the actual value of
+\code{cl} is not used), \code{"Rupper"} (upper chart with reflection at \code{cl}),\code{"Rlower"}
+(lower chart with reflection at \code{cu}),
+and \code{"two"} (two-sided chart), respectively.}
+\item{r}{dimension of the resulting linear equation system (highest order of the collocation polynomials).}
+\item{qm}{number of quadrature nodes for calculating the collocation definite integrals.}
+\item{qm.sigma}{number of quadrature nodes for convoluting the standard deviation uncertainty.}
+\item{truncate}{size of truncated tail.}
+}
+\details{
+Essentially, the ARL function \code{sewma.arl} is convoluted with the
+distribution of the sample standard deviation.
+For details see Jones/Champ/Rigdon (2001) and Knoth (2014?).}
+\value{Returns a single value which resembles the ARL.}
+\references{
+L. A. Jones, C. W. Champ, S. E. Rigdon (2001),
+The performance of exponentially weighted moving average charts with estimated parameters,
+\emph{Technometrics 43}, 156-167.
+
+S. Knoth (2005),
+Accurate ARL computation for EWMA-\eqn{S^2}{S^2} control charts,
+\emph{Statistics and Computing 15}, 341-352.
+
+S. Knoth (2006),
+Computation of the ARL for CUSUM-\eqn{S^2}{S^2} schemes,
+\emph{Computational Statistics & Data Analysis 51}, 499-512.
+}
+\author{Sven Knoth}
+\seealso{
+\code{sewma.arl} for zero-state ARL function of EWMA control charts w/o pre run uncertainty.
+}
+\examples{
+## Knoth (2014?)
+}
+\keyword{ts}
diff --git a/man/sewma.crit.Rd b/man/sewma.crit.Rd
new file mode 100644
index 0000000..a2b49aa
--- /dev/null
+++ b/man/sewma.crit.Rd
@@ -0,0 +1,157 @@
+\name{sewma.crit}
+\alias{sewma.crit}
+\title{Compute critical values of EWMA control charts (variance charts)}
+\description{Computation of the critical values (similar to alarm limits)
+for different types of EWMA control charts (based on the sample variance
+\eqn{S^2}) monitoring normal variance.}
+\usage{sewma.crit(l,L0,df,sigma0=1,cl=NULL,cu=NULL,hs=NULL,s2.on=TRUE,
+sided="upper",mode="fixed",ur=4,r=40,qm=30)}
+\arguments{
+\item{l}{smoothing parameter lambda of the EWMA control chart.}
+\item{L0}{in-control ARL.}
+\item{df}{actual degrees of freedom, corresponds to subgroup size (for known mean it is equal to the subgroup size,
+for unknown mean it is equal to subgroup size minus one.}
+\item{sigma0}{in-control standard deviation.}
+\item{cl}{deployed for \code{sided}=\code{"Rupper"}, that is, upper variance control chart
+with lower reflecting barrier \code{cl}.}
+\item{cu}{for two-sided (\code{sided}=\code{"two"}) and fixed upper
+control limit (\code{mode}=\code{"fixed"}) a value larger than \code{sigma0}
+has to been given, for all other cases \code{cu} is ignored.}
+\item{hs}{so-called headstart (enables fast initial response); the default (\code{NULL})
+yields the expected in-control value of \eqn{S^2}{S^2} (1) and \eqn{S}{S} (\eqn{c_4}{c_4}),
+respectively.}
+\item{s2.on}{distinguishes between \eqn{S^2}{S^2} and \eqn{S}{S} chart.}
+\item{sided}{distinguishes between one- and two-sided
+two-sided EWMA-\eqn{S^2}{S^2} control charts
+by choosing \code{"upper"} (upper chart
+without reflection at \code{cl} -- the actual value of
+\code{cl} is not used),
+\code{"Rupper"} (upper chart with reflection at \code{cl}),
+\code{"Rlower"} (lower chart with reflection at \code{cu}),
+and \code{"two"} (two-sided chart),
+respectively.}
+\item{mode}{only deployed for \code{sided}=\code{"two"} -- with \code{"fixed"}
+an upper control limit (see \code{cu}) is set and only the lower is
+calculated to obtain the in-control ARL \code{L0}, while with \code{"unbiased"}
+a certain unbiasedness of the ARL function is guaranteed (here, both the
+lower and the upper control limit are calculated). With \code{"vanilla"} limits symmetric
+around 1 (the in-control value of the variance)
+are determined, while for \code{"eq.tails"} the in-control ARL values of two single EWMA
+variance charts (decompose the two-sided
+scheme into one lower and one upper scheme) are matched.}
+\item{ur}{truncation of lower chart for \code{eq.tails} mode.}
+\item{r}{dimension of the resulting linear equation system
+(highest order of the collocation polynomials).}
+\item{qm}{number of quadrature nodes for calculating the collocation definite integrals.}
+}
+\details{
+\code{sewma.crit} determines the critical values (similar to alarm limits)
+for given in-control ARL \code{L0}
+by applying secant rule and using \code{sewma.arl()}.
+In case of \code{sided}=\code{"two"} and \code{mode}=\code{"unbiased"}
+a two-dimensional secant rule is applied that also ensures that the
+maximum of the ARL function for given standard deviation is attained
+at \code{sigma0}. See Knoth (2010) and the related example.
+}
+\value{Returns the lower and upper control limit \code{cl} and \code{cu}.}
+\references{
+H.-J. Mittag and D. Stemann and B. Tewes (1998),
+EWMA-Karten zur \"Uberwachung der Streuung von Qualit\"atsmerkmalen,
+\emph{Allgemeines Statistisches Archiv 82}, 327-338,
+
+C. A. Acosta-Mej\'ia and J. J. Pignatiello Jr. and B. V. Rao (1999),
+A comparison of control charting procedures for monitoring process dispersion,
+\emph{IIE Transactions 31}, 569-579.
+
+S. Knoth (2005),
+Accurate ARL computation for EWMA-\eqn{S^2}{S^2} control charts,
+\emph{Statistics and Computing 15}, 341-352.
+
+S. Knoth (2006a),
+Computation of the ARL for CUSUM-\eqn{S^2}{S^2} schemes,
+\emph{Computational Statistics & Data Analysis 51}, 499-512.
+
+S. Knoth (2006b),
+The art of evaluating monitoring schemes -- how to measure the performance of control charts?
+in \emph{Frontiers in Statistical Quality Control 8},
+H.-J. Lenz and P.-T. Wilrich (Eds.),
+Physica Verlag, Heidelberg, Germany, 74-99.
+
+S. Knoth (2010),
+Control Charting Normal Variance -- Reflections, Curiosities, and Recommendations,
+in \emph{Frontiers in Statistical Quality Control 9},
+H.-J. Lenz and P.-T. Wilrich (Eds.),
+Physica Verlag, Heidelberg, Germany, 3-18.
+}
+\author{Sven Knoth}
+\seealso{\code{sewma.arl} for calculation of ARL of variance charts.}
+\examples{
+## Mittag et al. (1998)
+## compare their upper critical value 2.91 that
+## leads to the upper control limit via the formula shown below
+## (for the usual upper EWMA \eqn{S^2}{S^2}).
+## See Knoth (2006b) for a discussion of this EWMA setup and it's evaluation.
+
+l <- 0.18
+L0 <- 250
+df <- 4
+limits <- sewma.crit(l, L0, df)
+limits["cu"]
+
+limits.cu.mittag_et_al <- 1 + sqrt(l/(2-l))*sqrt(2/df)*2.91
+limits.cu.mittag_et_al
+
+## Knoth (2005)
+## reproduce the critical value given in Figure 2 (c=1.661865) for
+## upper EWMA \eqn{S^2}{S^2} with df=1
+
+l <- 0.025
+L0 <- 250
+df <- 1
+limits <- sewma.crit(l, L0, df)
+cv.Fig2 <- (limits["cu"]-1)/( sqrt(l/(2-l))*sqrt(2/df) )
+cv.Fig2
+
+## the small difference (sixth digit after decimal point) stems from
+## tighter criterion in the secant rule implemented in the R package.
+
+## demo of unbiased ARL curves
+## Deploy, please, not matrix dimensions smaller than 50 -- for the
+## sake of accuracy, the value 80 was used.
+## Additionally, this example needs between 1 and 2 minutes on a 1.6 Ghz box.
+
+\dontrun{
+l <- 0.1
+L0 <- 500
+df <- 4
+limits <- sewma.crit(l, L0, df, sided="two", mode="unbiased", r=80)
+SEWMA.arl <- Vectorize(sewma.arl, "sigma")
+SEWMA.ARL <- function(sigma)
+ SEWMA.arl(l, limits[1], limits[2], sigma, df, sided="two", r=80)
+layout(matrix(1:2, nrow=1))
+curve(SEWMA.ARL, .75, 1.25, log="y")
+curve(SEWMA.ARL, .95, 1.05, log="y")}
+# the above stuff needs about 1 minute
+
+## control limits for upper and lower EWMA charts with reflecting barriers
+## (reflection at in-control level sigma0 = 1)
+## examples from Knoth (2006a), Tables 4 and 5
+
+\dontrun{
+## upper chart with reflection at sigma0=1 in Table 4: c = 2.4831
+l <- 0.15
+L0 <- 100
+df <- 4
+limits <- sewma.crit(l, L0, df, cl=1, sided="Rupper", r=100)
+cv.Tab4 <- (limits["cu"]-1)/( sqrt(l/(2-l))*sqrt(2/df) )
+cv.Tab4
+
+## lower chart with reflection at sigma0=1 in Table 5: c = 2.0613
+l <- 0.115
+L0 <- 200
+df <- 5
+limits <- sewma.crit(l, L0, df, cu=1, sided="Rlower", r=100)
+cv.Tab5 <- -(limits["cl"]-1)/( sqrt(l/(2-l))*sqrt(2/df) )
+cv.Tab5}
+}
+\keyword{ts}
diff --git a/man/sewma.crit.prerun.Rd b/man/sewma.crit.prerun.Rd
new file mode 100644
index 0000000..74ab4eb
--- /dev/null
+++ b/man/sewma.crit.prerun.Rd
@@ -0,0 +1,72 @@
+\name{sewma.crit.prerun}
+\alias{sewma.crit.prerun}
+\title{Compute critical values of of EWMA (variance charts) control charts under pre-run uncertainty}
+\description{Computation of quantiles of the Run Length (RL) for EWMA control
+charts monitoring normal variance.}
+\usage{sewma.crit.prerun(l,L0,df1,df2,sigma0=1,cl=NULL,cu=NULL,hs=1,sided="upper",
+mode="fixed",r=40,qm=30,qm.sigma=30,truncate=1e-10,
+tail_approx=TRUE,c.error=1e-10,a.error=1e-9)}
+\arguments{
+\item{l}{smoothing parameter lambda of the EWMA control chart.}
+\item{L0}{in-control quantile value.}
+\item{df1}{actual degrees of freedom, corresponds to subgroup size
+(for known mean it is equal to the subgroup size,
+for unknown mean it is equal to subgroup size minus one.}
+\item{df2}{degrees of freedom of the pre-run variance estimator.}
+\item{sigma,sigma0}{true and in-control standard deviation, respectively.}
+\item{cl}{deployed for \code{sided}=\code{"Rupper"}, that is, upper variance control chart with lower
+reflecting barrier \code{cl}.}
+\item{cu}{for two-sided (\code{sided}=\code{"two"}) and fixed upper control limit
+(\code{mode}=\code{"fixed"}) a value larger than \code{sigma0}
+has to been given, for all other cases \code{cu} is ignored.}
+\item{hs}{so-called headstart (enables fast initial response).}
+\item{sided}{distinguishes between one- and two-sided two-sided EWMA-\eqn{S^2}{S^2} control charts
+by choosing \code{"upper"} (upper chart without reflection at \code{cl} -- the actual value of \code{cl}
+is not used), \code{"Rupper"} (upper chart with reflection at \code{cl}), \code{"Rlower"} (lower chart
+with reflection at \code{cu}),and \code{"two"} (two-sided chart), respectively.}
+\item{mode}{only deployed for \code{sided}=\code{"two"} -- with \code{"fixed"} an upper control limit
+(see \code{cu}) is set and only the lower is calculated to obtain the in-control ARL \code{L0}, while
+with \code{"unbiased"} a certain unbiasedness of the ARL function is guaranteed (here, both the
+lower and the upper control limit are calculated).}
+\item{r}{dimension of the resulting linear equation system (highest order
+of the collocation polynomials).}
+\item{qm}{number of quadrature nodes for calculating the collocation definite integrals.}
+\item{qm.sigma}{number of quadrature nodes for convoluting the standard deviation uncertainty.}
+\item{truncate}{size of truncated tail.}
+\item{tail_approx}{controls whether the geometric tail approximation is used (is faster) or not.}
+\item{c.error}{error bound for two succeeding values of the critical value
+during applying the secant rule.}
+\item{a.error}{error bound for the quantile level \code{alpha} during applying the secant rule.}
+}
+\details{
+\code{sewma.crit.prerun} determines the critical values (similar to alarm limits)
+for given in-control ARL \code{L0}
+by applying secant rule and using \code{sewma.arl.prerun()}.
+In case of \code{sided}=\code{"two"} and \code{mode}=\code{"unbiased"}
+a two-dimensional secant rule is applied that also ensures that the
+maximum of the ARL function for given standard deviation is attained
+at \code{sigma0}. See Knoth (2010) for some details of the algorithm involved.
+}
+\value{Returns the lower and upper control limit \code{cl} and \code{cu}.}
+\references{
+H.-J. Mittag and D. Stemann and B. Tewes (1998),
+EWMA-Karten zur \"Uberwachung der Streuung von Qualit\"atsmerkmalen,
+\emph{Allgemeines Statistisches Archiv 82}, 327-338,
+S. Knoth (2005),
+Accurate ARL computation for EWMA-\eqn{S^2}{S^2} control charts,
+\emph{Statistics and Computing 15}, 341-352.
+
+S. Knoth (2010),
+Control Charting Normal Variance -- Reflections, Curiosities, and Recommendations,
+in \emph{Frontiers in Statistical Quality Control 9},
+H.-J. Lenz and P.-T. Wilrich (Eds.),
+Physica Verlag, Heidelberg, Germany, 3-18.
+}
+\author{Sven Knoth}
+\seealso{\code{sewma.arl.prerun} for calculation of ARL of variance charts under
+pre-run uncertainty and \code{sewma.crit} for
+the algorithm w/o pre-run uncertainty.}
+\examples{
+## Knoth (2014?)
+}
+\keyword{ts}
\ No newline at end of file
diff --git a/man/sewma.q.Rd b/man/sewma.q.Rd
new file mode 100644
index 0000000..81ea77e
--- /dev/null
+++ b/man/sewma.q.Rd
@@ -0,0 +1,92 @@
+\name{sewma.q}
+\alias{sewma.q}
+\alias{sewma.q.crit}
+\title{Compute RL quantiles of EWMA (variance charts) control charts}
+\description{Computation of quantiles of the Run Length (RL)
+for EWMA control charts monitoring normal variance.}
+\usage{sewma.q(l, cl, cu, sigma, df, alpha, hs=1, sided="upper", r=40, qm=30)
+
+sewma.q.crit(l,L0,alpha,df,sigma0=1,cl=NULL,cu=NULL,hs=1,sided="upper",
+mode="fixed",ur=4,r=40,qm=30,c.error=1e-12,a.error=1e-9)}
+\arguments{
+\item{l}{smoothing parameter lambda of the EWMA control chart.}
+\item{cl}{deployed for \code{sided}=\code{"Rupper"}, that is, upper variance control
+chart with lower reflecting barrier \code{cl}.}
+\item{cu}{for two-sided (\code{sided}=\code{"two"}) and fixed upper control limit
+(\code{mode}=\code{"fixed"}) a value larger than \code{sigma0}
+has to been given, for all other cases \code{cu} is ignored.}
+\item{sigma,sigma0}{true and in-control standard deviation, respectively.}
+\item{df}{actual degrees of freedom, corresponds to subgroup size (for known mean it
+is equal to the subgroup size,
+for unknown mean it is equal to subgroup size minus one.}
+\item{alpha}{quantile level.}
+\item{hs}{so-called headstart (enables fast initial response).}
+\item{sided}{distinguishes between one- and two-sided two-sided EWMA-\eqn{S^2}{S^2}
+control charts by choosing \code{"upper"} (upper chart
+without reflection at \code{cl} -- the actual value of \code{cl} is not used), \code{"Rupper"}
+(upper chart with reflection at \code{cl}),
+\code{"Rlower"} (lower chart with reflection at \code{cu}),and \code{"two"}
+(two-sided chart), respectively.}
+\item{mode}{only deployed for \code{sided}=\code{"two"} -- with \code{"fixed"} an upper
+control limit (see \code{cu}) is set and only the lower is
+calculated to obtain the in-control ARL \code{L0}, while with \code{"unbiased"} a
+certain unbiasedness of the ARL function is guaranteed (here, both the
+lower and the upper control limit are calculated).}
+\item{ur}{truncation of lower chart for \code{classic} mode.}
+\item{r}{dimension of the resulting linear equation system (highest order of the
+collocation polynomials).}
+\item{qm}{number of quadrature nodes for calculating the collocation definite integrals.}
+\item{L0}{in-control quantile value.}
+\item{c.error}{error bound for two succeeding values of the critical value during
+applying the secant rule.}
+\item{a.error}{error bound for the quantile level \code{alpha}
+during applying the secant rule.}
+}
+\details{
+Instead of the popular ARL (Average Run Length) quantiles of the EWMA
+stopping time (Run Length) are determined. The algorithm is based on
+Waldmann's survival function iteration procedure.
+Thereby the ideas presented in Knoth (2007) are used.
+\code{sewma.q.crit} determines the critical values (similar to alarm limits)
+for given in-control RL quantile \code{L0} at level \code{alpha} by applying
+secant rule and using \code{sewma.sf()}.
+In case of \code{sided}=\code{"two"} and \code{mode}=\code{"unbiased"} a two-dimensional
+secant rule is applied that also ensures that the
+minimum of the cdf for given standard deviation is attained at \code{sigma0}.
+}
+\value{Returns a single value which resembles the RL quantile of order \code{alpha} and
+the lower and upper control limit \code{cl} and \code{cu}, respectively.}
+\references{
+H.-J. Mittag and D. Stemann and B. Tewes (1998),
+EWMA-Karten zur \"Uberwachung der Streuung von Qualit\"atsmerkmalen,
+\emph{Allgemeines Statistisches Archiv 82}, 327-338,
+
+C. A. Acosta-Mej\'ia and J. J. Pignatiello Jr. and B. V. Rao (1999),
+A comparison of control charting procedures for monitoring process dispersion,
+\emph{IIE Transactions 31}, 569-579.
+
+S. Knoth (2005),
+Accurate ARL computation for EWMA-\eqn{S^2}{S^2} control charts,
+\emph{Statistics and Computing 15}, 341-352.
+
+S. Knoth (2007),
+Accurate ARL calculation for EWMA control charts monitoring simultaneously normal mean and variance,
+\emph{Sequential Analysis 26}, 251-264.
+
+S. Knoth (2010),
+Control Charting Normal Variance -- Reflections, Curiosities, and Recommendations,
+in \emph{Frontiers in Statistical Quality Control 9},
+H.-J. Lenz and P.-T. Wilrich (Eds.),
+Physica Verlag, Heidelberg, Germany, 3-18.
+
+K.-H. Waldmann (1986),
+Bounds for the distribution of the run length of geometric moving
+average charts, \emph{Appl. Statist. 35}, 151-158.
+}
+\author{Sven Knoth}
+\seealso{\code{sewma.arl} for calculation of ARL of variance charts and
+\code{sewma.sf} for the RL survival function.}
+\examples{
+## Knoth (2014?)
+}
+\keyword{ts}
diff --git a/man/sewma.q.prerun.Rd b/man/sewma.q.prerun.Rd
new file mode 100644
index 0000000..c42dabc
--- /dev/null
+++ b/man/sewma.q.prerun.Rd
@@ -0,0 +1,76 @@
+\name{sewma.q.prerun}
+\alias{sewma.q.prerun}
+\alias{sewma.q.crit.prerun}
+\title{Compute RL quantiles of EWMA (variance charts) control charts under pre-run uncertainty}
+\description{Computation of quantiles of the Run Length (RL) for EWMA control charts monitoring
+normal variance.}
+\usage{sewma.q.prerun(l,cl,cu,sigma,df1,df2,alpha,hs=1,sided="upper",
+r=40,qm=30,qm.sigma=30,truncate=1e-10)
+
+sewma.q.crit.prerun(l,L0,alpha,df1,df2,sigma0=1,cl=NULL,cu=NULL,hs=1,
+sided="upper",mode="fixed",r=40, qm=30,qm.sigma=30,truncate=1e-10,
+tail_approx=TRUE,c.error=1e-10,a.error=1e-9)}
+\arguments{
+\item{l}{smoothing parameter lambda of the EWMA control chart.}
+\item{cl}{deployed for \code{sided}=\code{"Rupper"}, that is, upper variance control chart
+with lower reflecting barrier \code{cl}.}
+\item{cu}{for two-sided (\code{sided}=\code{"two"}) and fixed upper control limit
+(\code{mode}=\code{"fixed"}) a value larger than \code{sigma0}
+has to been given, for all other cases \code{cu} is ignored.}
+\item{sigma,sigma0}{true and in-control standard deviation, respectively.}
+\item{L0}{in-control quantile value.}
+\item{alpha}{quantile level.}
+\item{df1}{actual degrees of freedom, corresponds to subgroup size (for known mean it is
+equal to the subgroup size, for unknown mean it is equal to subgroup size minus one.}
+\item{df2}{degrees of freedom of the pre-run variance estimator.}
+\item{hs}{so-called headstart (enables fast initial response).}
+\item{sided}{distinguishes between one- and two-sided two-sided EWMA-\eqn{S^2}{S^2}
+control charts by choosing \code{"upper"} (upper chart
+without reflection at \code{cl} -- the actual value of \code{cl} is not used),
+\code{"Rupper"} (upper chart with reflection at \code{cl}),
+\code{"Rlower"} (lower chart with reflection at \code{cu}),
+and \code{"two"} (two-sided chart), respectively.}
+\item{mode}{only deployed for \code{sided}=\code{"two"} -- with \code{"fixed"}
+an upper control limit (see \code{cu}) is set and only the lower is
+calculated to obtain the in-control ARL \code{L0}, while with \code{"unbiased"} a certain unbiasedness
+of the ARL function is guaranteed (here, both the
+lower and the upper control limit are calculated).}
+\item{r}{dimension of the resulting linear equation system (highest order
+of the collocation polynomials).}
+\item{qm}{number of quadrature nodes for calculating the collocation definite integrals.}
+\item{qm.sigma}{number of quadrature nodes for convoluting the standard deviation uncertainty.}
+\item{truncate}{size of truncated tail.}
+\item{tail_approx}{controls whether the geometric tail approximation is used (is faster) or not.}
+\item{c.error}{error bound for two succeeding values of the critical value
+during applying the secant rule.}
+\item{a.error}{error bound for the quantile level \code{alpha} during applying the secant rule.}
+}
+\details{
+Instead of the popular ARL (Average Run Length) quantiles of the EWMA
+stopping time (Run Length) are determined. The algorithm is based on
+Waldmann's survival function iteration procedure.
+Thereby the ideas presented in Knoth (2007) are used.
+\code{sewma.q.crit.prerun} determines the critical values (similar to alarm limits)
+for given in-control RL quantile \code{L0} at level \code{alpha} by applying secant
+rule and using \code{sewma.sf()}.
+In case of \code{sided}=\code{"two"} and \code{mode}=\code{"unbiased"}
+a two-dimensional secant rule is applied that also ensures that the
+minimum of the cdf for given standard deviation is attained at \code{sigma0}.
+}
+\value{Returns a single value which resembles the RL quantile of order \code{alpha} and
+the lower and upper control limit \code{cl} and \code{cu}, respectively.}
+\references{
+S. Knoth (2007),
+Accurate ARL calculation for EWMA control charts monitoring simultaneously normal mean and variance,
+\emph{Sequential Analysis 26}, 251-264.
+
+K.-H. Waldmann (1986),
+Bounds for the distribution of the run length of geometric moving
+average charts, \emph{Appl. Statist. 35}, 151-158.
+}
+\author{Sven Knoth}
+\seealso{\code{sewma.q} and \code{sewma.q.crit} for the version w/o pre-run uncertainty.}
+\examples{
+## Knoth (2014?)
+}
+\keyword{ts}
diff --git a/man/sewma.sf.Rd b/man/sewma.sf.Rd
new file mode 100644
index 0000000..9d8786c
--- /dev/null
+++ b/man/sewma.sf.Rd
@@ -0,0 +1,56 @@
+\name{sewma.sf}
+\alias{sewma.sf}
+\title{Compute the survival function of EWMA run length}
+\description{Computation of the survival function of the Run Length (RL)
+for EWMA control charts monitoring normal variance.}
+\usage{sewma.sf(n, l, cl, cu, sigma, df, hs=1, sided="upper", r=40, qm=30)}
+\arguments{
+\item{n}{calculate sf up to value \code{n}.}
+\item{l}{smoothing parameter lambda of the EWMA control chart.}
+\item{cl}{lower control limit of the EWMA control chart.}
+\item{cu}{upper control limit of the EWMA control chart.}
+\item{sigma}{true standard deviation.}
+\item{df}{actual degrees of freedom, corresponds to subgroup size
+(for known mean it is equal to the subgroup size,
+for unknown mean it is equal to subgroup size minus one.}
+\item{hs}{so-called headstart (enables fast initial response).}
+\item{sided}{distinguishes between one- and two-sided two-sided
+EWMA-\eqn{S^2}{S^2} control charts
+by choosing \code{"upper"} (upper chart without reflection at \code{cl} --
+the actual value of \code{cl} is not used),
+\code{"Rupper"} (upper chart with reflection at \code{cl}), \code{"Rlower"}
+(lower chart with reflection at \code{cu}),
+and \code{"two"} (two-sided chart), respectively.}
+\item{r}{dimension of the resulting linear equation system
+(highest order of the collocation polynomials).}
+\item{qm}{number of quadrature nodes for calculating the
+collocation definite integrals.}
+}
+\details{
+The survival function P(L>n) and derived from it also the cdf P(L<=n)
+and the pmf P(L=n) illustrate
+the distribution of the EWMA run length. For large n the
+geometric tail could be exploited. That is,
+with reasonable large n the complete distribution is characterized.
+The algorithm is based on Waldmann's survival function iteration procedure and
+on results in Knoth (2007).
+}
+\value{Returns a vector which resembles the survival function up to a certain point.}
+\references{
+S. Knoth (2007),
+Accurate ARL calculation for EWMA control charts monitoring simultaneously
+normal mean and variance,
+\emph{Sequential Analysis 26}, 251-264.
+
+K.-H. Waldmann (1986),
+Bounds for the distribution of the run length of geometric moving
+average charts, \emph{Appl. Statist. 35}, 151-158.
+}
+\author{Sven Knoth}
+\seealso{
+\code{sewma.arl} for zero-state ARL computation of variance EWMA control charts.
+}
+\examples{
+## Knoth (2014?)
+}
+\keyword{ts}
diff --git a/man/sewma.sf.prerun.Rd b/man/sewma.sf.prerun.Rd
new file mode 100644
index 0000000..e7ea3e6
--- /dev/null
+++ b/man/sewma.sf.prerun.Rd
@@ -0,0 +1,60 @@
+\name{sewma.sf.prerun}
+\alias{sewma.sf.prerun}
+\title{Compute the survival function of EWMA run length}
+\description{Computation of the survival function of the Run Length (RL)
+for EWMA control charts monitoring normal variance.}
+\usage{sewma.sf.prerun(n, l, cl, cu, sigma, df1, df2, hs=1, sided="upper",
+qm=30, qm.sigma=30, truncate=1e-10, tail_approx=TRUE)}
+\arguments{
+\item{n}{calculate sf up to value \code{n}.}
+\item{l}{smoothing parameter lambda of the EWMA control chart.}
+\item{cl}{lower control limit of the EWMA control chart.}
+\item{cu}{upper control limit of the EWMA control chart.}
+\item{sigma}{true standard deviation.}
+\item{df1}{actual degrees of freedom, corresponds to subgroup size
+(for known mean it is equal to the subgroup size,
+for unknown mean it is equal to subgroup size minus one.}
+\item{df2}{degrees of freedom of the pre-run variance estimator.}
+\item{hs}{so-called headstart (enables fast initial response).}
+\item{sided}{distinguishes between one- and two-sided two-sided
+EWMA-\eqn{S^2}{S^2} control charts
+by choosing \code{"upper"} (upper chart without reflection at \code{cl} --
+the actual value of \code{cl} is not used),
+\code{"Rupper"} (upper chart with reflection at \code{cl}), \code{"Rlower"}
+(lower chart with reflection at \code{cu}),
+and \code{"two"} (two-sided chart), respectively.}
+\item{qm}{number of quadrature nodes for calculating the collocation
+definite integrals.}
+\item{qm.sigma}{number of quadrature nodes for convoluting the
+standard deviation uncertainty.}
+\item{truncate}{size of truncated tail.}
+\item{tail_approx}{Controls whether the geometric tail approximation
+is used (is faster) or not.}
+}
+\details{
+The survival function P(L>n) and derived from it also the cdf P(L<=n) and
+the pmf P(L=n) illustrate
+the distribution of the EWMA run length. For large n the geometric tail
+could be exploited. That is,
+with reasonable large n the complete distribution is characterized.
+The algorithm is based on Waldmann's survival function iteration
+procedure and on results in Knoth (2007)...
+}
+\value{Returns a vector which resembles the survival function up to a certain point.}
+\references{
+S. Knoth (2007),
+Accurate ARL calculation for EWMA control charts monitoring simultaneously normal mean and variance,
+\emph{Sequential Analysis 26}, 251-264.
+
+K.-H. Waldmann (1986),
+Bounds for the distribution of the run length of geometric moving
+average charts, \emph{Appl. Statist. 35}, 151-158.
+}
+\author{Sven Knoth}
+\seealso{
+\code{sewma.sf} for the RL survival function of EWMA control charts w/o pre-run uncertainty.
+}
+\examples{
+## Knoth (2014?)
+}
+\keyword{ts}
diff --git a/man/tol.lim.fact.Rd b/man/tol.lim.fact.Rd
new file mode 100644
index 0000000..b2109ee
--- /dev/null
+++ b/man/tol.lim.fact.Rd
@@ -0,0 +1,73 @@
+\name{tol.lim.fac}
+\alias{tol.lim.fac}
+\title{Two-sided tolerance limit factors}
+\description{For constructing tolerance intervals, which
+cover a given proportion \eqn{p}{p} of a normal distribution with
+unknown mean and variance with confidence
+\eqn{1-\alpha}{1-a}, one needs to calculate
+the so-called tolerance limit factors \eqn{k}{k}. These values
+are computed for a given sample size \eqn{n}{n}.}
+\usage{tol.lim.fac(n,p,a,mode="WW",m=30)}
+\arguments{
+\item{n}{sample size.}
+\item{p}{coverage.}
+\item{a}{error probability \eqn{\alpha}{a}, resulting interval covers at least proportion \code{p}
+with confidence of at least \eqn{1-\alpha}{1-a}.}
+\item{mode}{distinguish between Wald/Wolfowitz' approximation method (\code{"WW"}) and the more
+accurate approach (\code{"exact"})
+based on Gauss-Legendre quadrature.}
+\item{m}{number of abscissas for the quadrature (needed only for \code{method="exact"}),
+of course, the larger the more accurate.}
+}
+\details{
+\code{tol.lim.fac} determines tolerance limits factors
+\eqn{k}{k}
+by means of the fast and simple approximation due to
+Wald/Wolfowitz (1946) and of Gauss-Legendre quadrature like Odeh/Owen
+(1980), respectively, who used in fact the Simpson Rule. Then, by
+\eqn{\bar x \pm k \cdot s}{xbar +- k s}
+one can build the tolerance intervals
+which cover at least proportion \eqn{p}{p} of a normal distribution for
+given confidence level of
+\eqn{1-\alpha}{1-a}. \eqn{\bar x}{xbar} and \eqn{s}{s} stand
+for the sample mean and the sample standard deviation, respectively.}
+\value{Returns a single value which resembles the tolerance limit factor.}
+\references{
+A. Wald, J. Wolfowitz (1946), Tolerance limits for a normal distribution,
+\emph{Annals of Mathematical Statistics 17}, 208-215.
+
+R. E. Odeh, D. B. Owen (1980), \emph{Tables for Normal Tolerance Limits},
+Sampling Plans, and Screening, Marcel Dekker, New York.
+}
+\author{Sven Knoth}
+\seealso{
+\code{qnorm} for the ''asymptotic'' case -- cf. second example.
+}
+\examples{
+n <- 2:10
+p <- .95
+a <- .05
+kWW <- sapply(n,p=p,a=a,tol.lim.fac)
+kEX <- sapply(n,p=p,a=a,mode="exact",tol.lim.fac)
+print(cbind(n,kWW,kEX),digits=4)
+## Odeh/Owen (1980), page 98, in Table 3.4.1
+## n factor k
+## 2 36.519
+## 3 9.789
+## 4 6.341
+## 5 5.077
+## 6 4.422
+## 7 4.020
+## 8 3.746
+## 9 3.546
+## 10 3.393
+
+## n -> infty
+n <- 10^{1:7}
+p <- .95
+a <- .05
+kEX <- round(sapply(n,p=p,a=a,mode="exact",tol.lim.fac),digits=4)
+kEXinf <- round(qnorm(1-a/2),digits=4)
+print(rbind(cbind(n,kEX),c("infinity",kEXinf)),quote=FALSE)
+}
+\keyword{ts}
diff --git a/man/xDcusum.arl.Rd b/man/xDcusum.arl.Rd
new file mode 100644
index 0000000..4643b95
--- /dev/null
+++ b/man/xDcusum.arl.Rd
@@ -0,0 +1,137 @@
+\name{xDcusum.arl}
+\alias{xDcusum.arl}
+\title{Compute ARLs of CUSUM control charts under drift}
+\description{Computation of the (zero-state and other) Average Run Length (ARL)
+under drift for one-sided CUSUM control charts monitoring normal mean.}
+\usage{xDcusum.arl(k, h, delta, hs = 0, sided = "one",
+ mode = "Gan", m = NULL, q = 1, r = 30, with0 = FALSE)}
+\arguments{
+\item{k}{reference value of the CUSUM control chart.}
+\item{h}{decision interval (alarm limit, threshold) of the CUSUM control chart.}
+\item{delta}{true drift parameter.}
+\item{hs}{so-called headstart (enables fast initial response).}
+\item{sided}{distinguishes between one- and two-sided CUSUM control chart
+by choosing \code{"one"} and \code{"two"}, respectively. Currentlly,
+the two-sided scheme is not implemented.}
+\item{mode}{decide whether Gan's or Knoth's approach is used. Use
+\code{"Gan"} and \code{"Knoth"}, respectively.}
+\item{m}{parameter used if \code{mode="Gan"}. \code{m} is design
+parameter of Gan's approach. If \code{m=NULL}, then \code{m}
+will increased until the resulting ARL does not change anymore.}
+\item{q}{change point position. For \eqn{q=1} and
+\eqn{\mu=\mu_0} and \eqn{\mu=\mu_1}, the usual
+zero-state ARLs for the in-control and out-of-control case, respectively,
+are calculated. For \eqn{q>1} and \eqn{\mu!=0} conditional delays, that is,
+\eqn{E_q(L-q+1|L\geq)}, will be determined.
+Note that mu0=0 is implicitely fixed. Deploy large \code{q} to mimic
+steady-state. It works only for \code{mode="Knoth"}.}
+\item{r}{number of quadrature nodes, dimension of the resulting linear
+equation system is equal to \code{r+1} (one-sided) or \code{r}
+(two-sided).}
+\item{with0}{defines whether the first observation used for the RL
+calculation follows already 1*delta or still 0*delta.
+With \code{q} additional flexibility is given.}
+}
+\details{
+Based on Gan (1991) or Knoth (2003), the ARL is calculated for
+one-sided CUSUM
+control charts under drift. In case of Gan's framework, the usual
+ARL function with mu=m*delta is determined and recursively via
+m-1, m-2, ... 1 (or 0) the drift ARL determined. The framework
+of Knoth allows to calculate ARLs for varying parameters, such as
+control limits and distributional parameters.
+For details see the cited papers. Note that two-sided CUSUM charts
+under drift are difficult to treat.
+}
+\value{Returns a single value which resembles the ARL.}
+\references{
+F. F. Gan (1992),
+CUSUM control charts under linear drift,
+\emph{Statistician 41}, 71-84.
+
+F. F. Gan (1996),
+Average Run Lengths for Cumulative Sum control chart under linear trend,
+\emph{Applied Statistics 45}, 505-512.
+
+S. Knoth (2003),
+EWMA schemes with non-homogeneous transition kernels,
+\emph{Sequential Analysis 22}, 241-255.
+
+S. Knoth (2012),
+More on Control Charting under Drift,
+in: \emph{Frontiers in Statistical Quality Control 10},
+H.-J. Lenz, W. Schmid and P.-T. Wilrich (Eds.),
+Physica Verlag, Heidelberg, Germany, 53-68.
+
+C. Zou, Y. Liu and Z. Wang (2009),
+Comparisons of control schemes for monitoring
+the means of processes subject to drifts,
+\emph{Metrika 70}, 141-163.
+}
+\author{Sven Knoth}
+\seealso{
+\code{xcusum.arl} and \code{xcusum.ad} for zero-state and
+steady-state ARL computation of CUSUM control charts
+for the classical step change model.
+}
+\examples{
+## Gan (1992)
+## Table 1
+## original values are
+# deltas arl
+# 0.0001 475
+# 0.0005 261
+# 0.0010 187
+# 0.0020 129
+# 0.0050 76.3
+# 0.0100 52.0
+# 0.0200 35.2
+# 0.0500 21.4
+# 0.1000 15.0
+# 0.5000 6.95
+# 1.0000 5.16
+# 3.0000 3.30
+\dontrun{k <- .25
+h <- 8
+r <- 50
+DxDcusum.arl <- Vectorize(xDcusum.arl, "delta")
+deltas <- c(0.0001, 0.0005, 0.001, 0.002, 0.005, 0.01, 0.02, 0.05, 0.1, 0.5, 1, 3)
+arl.like.Gan <-
+ round(DxDcusum.arl(k, h, deltas, r=r, with0=TRUE), digits=2)
+arl.like.Knoth <-
+ round(DxDcusum.arl(k, h, deltas, r=r, mode="Knoth", with0=TRUE), digits=2)
+data.frame(deltas, arl.like.Gan, arl.like.Knoth)}
+
+## Zou et al. (2009)
+## Table 1
+## original values are
+# delta arl1 arl2 arl3
+# 0 ~ 1730
+# 0.0005 345 412 470
+# 0.001 231 275 317
+# 0.005 86.6 98.6 112
+# 0.01 56.9 61.8 69.3
+# 0.05 22.6 21.6 22.7
+# 0.1 15.4 14.7 14.2
+# 0.5 6.60 5.54 5.17
+# 1.0 4.63 3.80 3.45
+# 2.0 3.17 2.67 2.32
+# 3.0 2.79 2.04 1.96
+# 4.0 2.10 1.98 1.74
+\dontrun{
+k1 <- 0.25
+k2 <- 0.5
+k3 <- 0.75
+h1 <- 9.660
+h2 <- 5.620
+h3 <- 3.904
+deltas <- c(0.0005, 0.001, 0.005, 0.01, 0.05, 0.1, 0.5, 1:4)
+arl1 <- c(round(xcusum.arl(k1, h1, 0, r=r), digits=2),
+ round(DxDcusum.arl(k1, h1, deltas, r=r), digits=2))
+arl2 <- c(round(xcusum.arl(k2, h2, 0), digits=2),
+ round(DxDcusum.arl(k2, h2, deltas, r=r), digits=2))
+arl3 <- c(round(xcusum.arl(k3, h3, 0, r=r), digits=2),
+ round(DxDcusum.arl(k3, h3, deltas, r=r), digits=2))
+data.frame(delta=c(0, deltas), arl1, arl2, arl3)}
+}
+\keyword{ts}
diff --git a/man/xDewma.arl.Rd b/man/xDewma.arl.Rd
new file mode 100644
index 0000000..bccc11e
--- /dev/null
+++ b/man/xDewma.arl.Rd
@@ -0,0 +1,252 @@
+\name{xDewma.arl}
+\alias{xDewma.arl}
+\title{Compute ARLs of EWMA control charts under drift}
+\description{Computation of the (zero-state and other)
+Average Run Length (ARL) under drift
+for different types of EWMA control charts monitoring normal mean.}
+\usage{xDewma.arl(l, c, delta, zr = 0, hs = 0, sided = "one", limits = "fix",
+ mode = "Gan", m = NULL, q = 1, r = 40, with0 = FALSE)}
+\arguments{
+\item{l}{smoothing parameter lambda of the EWMA control chart.}
+\item{c}{critical value (similar to alarm limit) of the EWMA control chart.}
+\item{delta}{true drift parameter.}
+\item{zr}{reflection border for the one-sided chart.}
+\item{hs}{so-called headstart (enables fast initial response).}
+\item{sided}{distinguish between one- and two-sided EWMA control chart
+by choosing \code{"one"} and \code{"two"}, respectively.}
+\item{limits}{distinguishes between different control limits behavior.}
+\item{mode}{decide whether Gan's or Knoth's approach is used. Use
+\code{"Gan"} and \code{"Knoth"}, respectively.}
+\item{m}{parameter used if \code{mode="Gan"}. \code{m} is design
+parameter of Gan's approach. If \code{m=NULL}, then \code{m}
+will increased until the resulting ARL does not change anymore.}
+\item{q}{change point position. For \eqn{q=1} and
+\eqn{\mu=\mu_0} and \eqn{\mu=\mu_1}, the usual
+zero-state ARLs for the in-control and out-of-control case, respectively,
+are calculated. For \eqn{q>1} and \eqn{\mu!=0} conditional delays, that is,
+\eqn{E_q(L-q+1|L\geq)}, will be determined.
+Note that mu0=0 is implicitely fixed. Deploy large \code{q} to mimic
+steady-state. It works only for \code{mode="Knoth"}.}
+\item{r}{number of quadrature nodes, dimension of the resulting linear
+equation system is equal to \code{r+1} (one-sided) or \code{r}
+(two-sided).}
+\item{with0}{defines whether the first observation used for the RL calculation
+follows already 1*delta or still 0*delta.
+With \code{q} additional flexibility is given.}
+}
+\details{
+Based on Gan (1991) or Knoth (2003), the ARL is calculated for EWMA
+control charts under drift. In case of Gan's framework, the usual
+ARL function with mu=m*delta is determined and recursively via
+m-1, m-2, ... 1 (or 0) the drift ARL determined. The framework
+of Knoth allows to calculate ARLs for varying parameters, such as
+control limits and distributional parameters.
+For details see the cited papers.
+}
+\value{Returns a single value which resembles the ARL.}
+\references{
+F. F. Gan (1991),
+EWMA control chart under linear drift,
+\emph{J. Stat. Comput. Simulation 38}, 181-200.
+
+L. A. Aerne, C. W. Champ and S. E. Rigdon (1991),
+Evaluation of control charts under linear trend,
+\emph{Commun. Stat., Theory Methods 20}, 3341-3349.
+
+S. Knoth (2003),
+EWMA schemes with non-homogeneous transition kernels,
+\emph{Sequential Analysis 22}, 241-255.
+
+H. M. Fahmy and E. A. Elsayed (2006),
+Detection of linear trends in process mean,
+\emph{International Journal of Production Research 44}, 487-504.
+
+S. Knoth (2012),
+More on Control Charting under Drift,
+in: \emph{Frontiers in Statistical Quality Control 10},
+H.-J. Lenz, W. Schmid and P.-T. Wilrich (Eds.),
+Physica Verlag, Heidelberg, Germany, 53-68.
+
+C. Zou, Y. Liu and Z. Wang (2009),
+Comparisons of control schemes for monitoring
+the means of processes subject to drifts,
+\emph{Metrika 70}, 141-163.
+}
+\author{Sven Knoth}
+\seealso{
+\code{xewma.arl} and \code{xewma.ad} for zero-state and
+steady-state ARL computation of EWMA control charts
+for the classical step change model.
+}
+\examples{
+\dontrun{
+DxDewma.arl <- Vectorize(xDewma.arl, "delta")
+## Gan (1991)
+## Table 1
+## original values are
+# delta arlE1 arlE2 arlE3
+# 0 500 500 500
+# 0.0001 482 460 424
+# 0.0010 289 231 185
+# 0.0020 210 162 129
+# 0.0050 126 94.6 77.9
+# 0.0100 81.7 61.3 52.7
+# 0.0500 27.5 21.8 21.9
+# 0.1000 17.0 14.2 15.3
+# 1.0000 4.09 4.28 5.25
+# 3.0000 2.60 2.90 3.43
+#
+lambda1 <- 0.676
+lambda2 <- 0.242
+lambda3 <- 0.047
+h1 <- 2.204/sqrt(lambda1/(2-lambda1))
+h2 <- 1.111/sqrt(lambda2/(2-lambda2))
+h3 <- 0.403/sqrt(lambda3/(2-lambda3))
+deltas <- c(.0001, .001, .002, .005, .01, .05, .1, 1, 3)
+arlE10 <- round(xewma.arl(lambda1, h1, 0, sided="two"), digits=2)
+arlE1 <- c(arlE10, round(DxDewma.arl(lambda1, h1, deltas, sided="two", with0=TRUE),
+ digits=2))
+arlE20 <- round(xewma.arl(lambda2, h2, 0, sided="two"), digits=2)
+arlE2 <- c(arlE20, round(DxDewma.arl(lambda2, h2, deltas, sided="two", with0=TRUE),
+ digits=2))
+arlE30 <- round(xewma.arl(lambda3, h3, 0, sided="two"), digits=2)
+arlE3 <- c(arlE30, round(DxDewma.arl(lambda3, h3, deltas, sided="two", with0=TRUE),
+ digits=2))
+data.frame(delta=c(0, deltas), arlE1, arlE2, arlE3)
+
+## do the same with more digits for the alarm threshold
+L0 <- 500
+h1 <- xewma.crit(lambda1, L0, sided="two")
+h2 <- xewma.crit(lambda2, L0, sided="two")
+h3 <- xewma.crit(lambda3, L0, sided="two")
+lambdas <- c(lambda1, lambda2, lambda3)
+hs <- c(h1, h2, h3) * sqrt(lambdas/(2-lambdas))
+hs
+# compare with Gan's values 2.204, 1.111, 0.403
+round(hs, digits=3)
+
+arlE10 <- round(xewma.arl(lambda1, h1, 0, sided="two"), digits=2)
+arlE1 <- c(arlE10, round(DxDewma.arl(lambda1, h1, deltas, sided="two", with0=TRUE),
+ digits=2))
+arlE20 <- round(xewma.arl(lambda2, h2, 0, sided="two"), digits=2)
+arlE2 <- c(arlE20, round(DxDewma.arl(lambda2, h2, deltas, sided="two", with0=TRUE),
+ digits=2))
+arlE30 <- round(xewma.arl(lambda3, h3, 0, sided="two"), digits=2)
+arlE3 <- c(arlE30, round(DxDewma.arl(lambda3, h3, deltas, sided="two", with0=TRUE),
+ digits=2))
+data.frame(delta=c(0, deltas), arlE1, arlE2, arlE3)
+
+## Aerne et al. (1991) -- two-sided EWMA
+## Table I (continued)
+## original numbers are
+# delta arlE1 arlE2 arlE3
+# 0.000000 465.0 465.0 465.0
+# 0.005623 77.01 85.93 102.68
+# 0.007499 64.61 71.78 85.74
+# 0.010000 54.20 59.74 71.22
+# 0.013335 45.20 49.58 58.90
+# 0.017783 37.76 41.06 48.54
+# 0.023714 31.54 33.95 39.87
+# 0.031623 26.36 28.06 32.68
+# 0.042170 22.06 23.19 26.73
+# 0.056234 18.49 19.17 21.84
+# 0.074989 15.53 15.87 17.83
+# 0.100000 13.07 13.16 14.55
+# 0.133352 11.03 10.94 11.88
+# 0.177828 9.33 9.12 9.71
+# 0.237137 7.91 7.62 7.95
+# 0.316228 6.72 6.39 6.52
+# 0.421697 5.72 5.38 5.37
+# 0.562341 4.88 4.54 4.44
+# 0.749894 4.18 3.84 3.68
+# 1.000000 3.58 3.27 3.07
+#
+lambda1 <- .133
+lambda2 <- .25
+lambda3 <- .5
+cE1 <- 2.856
+cE2 <- 2.974
+cE3 <- 3.049
+deltas <- 10^(-(18:0)/8)
+arlE10 <- round(xewma.arl(lambda1, cE1, 0, sided="two"), digits=2)
+arlE1 <- c(arlE10, round(DxDewma.arl(lambda1, cE1, deltas, sided="two"), digits=2))
+arlE20 <- round(xewma.arl(lambda2, cE2, 0, sided="two"), digits=2)
+arlE2 <- c(arlE20, round(DxDewma.arl(lambda2, cE2, deltas, sided="two"), digits=2))
+arlE30 <- round(xewma.arl(lambda3, cE3, 0, sided="two"), digits=2)
+arlE3 <- c(arlE30, round(DxDewma.arl(lambda3, cE3, deltas, sided="two"), digits=2))
+data.frame(delta=c(0, round(deltas, digits=6)), arlE1, arlE2, arlE3)
+
+
+## Fahmy/Elsayed (2006) -- two-sided EWMA
+## Table 4 (Monte Carlo results, 10^4 replicates, change point at t=51!)
+## original numbers are
+# delta arl s.e.
+# 0.00 365.749 3.598
+# 0.10 12.971 0.029
+# 0.25 7.738 0.015
+# 0.50 5.312 0.009
+# 0.75 4.279 0.007
+# 1.00 3.680 0.006
+# 1.25 3.271 0.006
+# 1.50 2.979 0.005
+# 1.75 2.782 0.004
+# 2.00 2.598 0.005
+#
+lambda <- 0.1
+cE <- 2.7
+deltas <- c(.1, (1:8)/4)
+arlE1 <- c(round(xewma.arl(lambda, cE, 0, sided="two"), digits=3),
+ round(DxDewma.arl(lambda, cE, deltas, sided="two"), digits=3))
+arlE51 <- c(round(xewma.arl(lambda, cE, 0, sided="two", q=51)[51], digits=3),
+ round(DxDewma.arl(lambda, cE, deltas, sided="two", mode="Knoth", q=51),
+ digits=3))
+data.frame(delta=c(0, deltas), arlE1, arlE51)
+
+## additional Monte Carlo results with 10^8 replicates
+# delta arl.q=1 s.e. arl.q=51 s.e.
+# 0.00 368.910 0.036 361.714 0.038
+# 0.10 12.986 0.000 12.781 0.000
+# 0.25 7.758 0.000 7.637 0.000
+# 0.50 5.318 0.000 5.235 0.000
+# 0.75 4.285 0.000 4.218 0.000
+# 1.00 3.688 0.000 3.628 0.000
+# 1.25 3.274 0.000 3.233 0.000
+# 1.50 2.993 0.000 2.942 0.000
+# 1.75 2.808 0.000 2.723 0.000
+# 2.00 2.616 0.000 2.554 0.000
+
+## Zou et al. (2009) -- one-sided EWMA
+## Table 1
+## original values are
+# delta arl1 arl2 arl3
+# 0 ~ 1730
+# 0.0005 317 377 440
+# 0.001 215 253 297
+# 0.005 83.6 92.6 106
+# 0.01 55.6 58.8 66.1
+# 0.05 22.6 21.1 22.0
+# 0.1 15.5 13.9 13.8
+# 0.5 6.65 5.56 5.09
+# 1.0 4.67 3.83 3.43
+# 2.0 3.21 2.74 2.32
+# 3.0 2.86 2.06 1.98
+# 4.0 2.14 2.00 1.83
+l1 <- 0.03479
+l2 <- 0.11125
+l3 <- 0.23052
+c1 <- 2.711
+c2 <- 3.033
+c3 <- 3.161
+zr <- -6
+r <- 50
+deltas <- c(0.0005, 0.001, 0.005, 0.01, 0.05, 0.1, 0.5, 1:4)
+arl1 <- c(round(xewma.arl(l1, c1, 0, zr=zr, r=r), digits=2),
+ round(DxDewma.arl(l1, c1, deltas, zr=zr, r=r), digits=2))
+arl2 <- c(round(xewma.arl(l2, c2, 0, zr=zr), digits=2),
+ round(DxDewma.arl(l2, c2, deltas, zr=zr, r=r), digits=2))
+arl3 <- c(round(xewma.arl(l3, c3, 0, zr=zr, r=r), digits=2),
+ round(DxDewma.arl(l3, c3, deltas, zr=zr, r=r), digits=2))
+data.frame(delta=c(0, deltas), arl1, arl2, arl3)
+}
+}
+\keyword{ts}
diff --git a/man/xDgrsr.arl.Rd b/man/xDgrsr.arl.Rd
new file mode 100644
index 0000000..c6dcd44
--- /dev/null
+++ b/man/xDgrsr.arl.Rd
@@ -0,0 +1,101 @@
+\name{xDgrsr.arl}
+\alias{xDgrsr.arl}
+\title{Compute ARLs of Shiryaev-Roberts schemes under drift}
+\description{Computation of the (zero-state and other)
+Average Run Length (ARL) under drift
+for Shiryaev-Roberts schemes monitoring normal mean.}
+\usage{xDgrsr.arl(k, g, delta, zr = 0, hs = NULL, sided = "one", m = NULL,
+mode = "Gan", q = 1, r = 30, with0 = FALSE)}
+\arguments{
+\item{k}{reference value of the Shiryaev-Roberts scheme.}
+\item{g}{control limit (alarm threshold) of Shiryaev-Roberts scheme.}
+\item{delta}{true drift parameter.}
+\item{zr}{reflection border for the one-sided chart.}
+\item{hs}{so-called headstart (enables fast initial response).}
+\item{sided}{distinguishes between one- and two-sided
+Shiryaev-Roberts schemes
+by choosing \code{"one"} and \code{"two"}, respectively. Currentlly,
+the two-sided scheme is not implemented.}
+\item{m}{parameter used if \code{mode="Gan"}. \code{m} is design
+parameter of Gan's approach. If \code{m=NULL}, then \code{m}
+will increased until the resulting ARL does not change anymore.}
+\item{q}{change point position. For \eqn{q=1} and
+\eqn{\mu=\mu_0} and \eqn{\mu=\mu_1}, the usual
+zero-state ARLs for the in-control and out-of-control case, respectively,
+are calculated. For \eqn{q>1} and \eqn{\mu!=0} conditional delays, that is,
+\eqn{E_q(L-q+1|L\geq)}, will be determined.
+Note that mu0=0 is implicitely fixed. Deploy large \code{q} to mimic
+steady-state. It works only for \code{mode="Knoth"}.}
+\item{mode}{decide whether Gan's or Knoth's approach is used. Use
+\code{"Gan"} and \code{"Knoth"}, respectively.
+\code{"Knoth"} is not implemented yet.}
+\item{r}{number of quadrature nodes, dimension of the resulting linear
+equation system is equal to \code{r+1} (one-sided) or \code{r} (two-sided).}
+\item{with0}{defines whether the first observation used for the RL calculation
+follows already 1*delta or still 0*delta.
+With \code{q} additional flexibility is given.}
+}
+\details{
+Based on Gan (1991) or Knoth (2003), the ARL is calculated for Shiryaev-Roberts schemes under drift.
+In case of Gan's framework, the usual
+ARL function with mu=m*delta is determined and recursively via
+m-1, m-2, ... 1 (or 0) the drift ARL determined. The framework
+of Knoth allows to calculate ARLs for varying parameters, such as
+control limits and distributional parameters.
+For details see the cited papers.
+}
+\value{Returns a single value which resembles the ARL.}
+\references{
+F. F. Gan (1991),
+EWMA control chart under linear drift,
+\emph{J. Stat. Comput. Simulation 38}, 181-200.
+
+S. Knoth (2003),
+EWMA schemes with non-homogeneous transition kernels,
+\emph{Sequential Analysis 22}, 241-255.
+
+S. Knoth (2012),
+More on Control Charting under Drift,
+in: \emph{Frontiers in Statistical Quality Control 10},
+H.-J. Lenz, W. Schmid and P.-T. Wilrich (Eds.),
+Physica Verlag, Heidelberg, Germany, 53-68.
+
+C. Zou, Y. Liu and Z. Wang (2009),
+Comparisons of control schemes for monitoring
+the means of processes subject to drifts,
+\emph{Metrika 70}, 141-163.
+}
+\author{Sven Knoth}
+\seealso{
+\code{xewma.arl} and \code{xewma.ad} for zero-state and
+steady-state ARL computation of EWMA control charts
+for the classical step change model.
+}
+\examples{
+\dontrun{
+## Monte Carlo example with 10^8 replicates
+# delta arl s.e.
+# 0.0001 381.8240 0.0304
+# 0.0005 238.4630 0.0148
+# 0.001 177.4061 0.0097
+# 0.002 125.9055 0.0061
+# 0.005 75.7574 0.0031
+# 0.01 50.2203 0.0018
+# 0.02 32.9458 0.0011
+# 0.05 18.9213 0.0005
+# 0.1 12.6054 0.0003
+# 0.5 5.2157 0.0001
+# 1 3.6537 0.0001
+# 3 2.0289 0.0000
+k <- .5
+L0 <- 500
+zr <- -7
+r <- 50
+g <- xgrsr.crit(k, L0, zr=zr, r=r)
+DxDgrsr.arl <- Vectorize(xDgrsr.arl, "delta")
+deltas <- c(0.0001, 0.0005, 0.001, 0.002, 0.005, 0.01, 0.02, 0.05, 0.1, 0.5, 1, 3)
+arls <- round(DxDgrsr.arl(k, g, deltas, zr=zr, r=r), digits=4)
+data.frame(deltas, arls)
+}
+}
+\keyword{ts}
diff --git a/man/xDshewhartrunsrules.arl.Rd b/man/xDshewhartrunsrules.arl.Rd
new file mode 100644
index 0000000..518488f
--- /dev/null
+++ b/man/xDshewhartrunsrules.arl.Rd
@@ -0,0 +1,87 @@
+\name{xDshewhartrunsrules.arl}
+\alias{xDshewhartrunsrules.arl}
+\alias{xDshewhartrunsrulesFixedm.arl}
+\title{Compute ARLs of Shewhart control charts with and without runs rules
+under drift}
+\description{Computation of the zero-state Average Run Length (ARL)
+under drift for Shewhart control charts with and without runs rules
+monitoring normal mean.}
+\usage{xDshewhartrunsrules.arl(delta, c = 1, m = NULL, type = "12")
+
+xDshewhartrunsrulesFixedm.arl(delta, c = 1, m = 100, type = "12")
+}
+\arguments{
+\item{delta}{true drift parameter.}
+\item{c}{normalizing constant to ensure specific alarming behavior.}
+\item{type}{controls the type of Shewhart chart used, seed details section.}
+\item{m}{parameter of Gan's approach. If \code{m=NULL}, then \code{m} will increased until
+the resulting ARL does not change anymore.}
+}
+\details{
+Based on Gan (1991), the ARL is calculated for
+Shewhart control charts with and without runs rules
+under drift. The usual ARL function with mu=m*delta is determined and recursively via
+m-1, m-2, ... 1 (or 0) the drift ARL determined.
+\code{xDshewhartrunsrulesFixedm.arl} is the actual work horse, while
+\code{xDshewhartrunsrules.arl} provides a convenience wrapper.
+Note that Aerne et al. (1991) deployed a method that is
+quite similar to Gan's algorithm. For \code{type} see
+the help page of \code{xshewhartrunsrules.arl}.
+}
+\value{Returns a single value which resembles the ARL.}
+\references{
+F. F. Gan (1991),
+EWMA control chart under linear drift,
+\emph{J. Stat. Comput. Simulation 38}, 181-200.
+
+L. A. Aerne, C. W. Champ and S. E. Rigdon (1991),
+Evaluation of control charts under linear trend,
+\emph{Commun. Stat., Theory Methods 20}, 3341-3349.
+}
+\author{Sven Knoth}
+\seealso{
+\code{xshewhartrunsrules.arl} for zero-state ARL computation of
+Shewhart control charts with and without runs rules
+for the classical step change model.
+}
+\examples{
+## Aerne et al. (1991)
+## Table I (continued)
+## original numbers are
+# delta arl1of1 arl2of3 arl4of5 arl10
+# 0.005623 136.67 120.90 105.34 107.08
+# 0.007499 114.98 101.23 88.09 89.94
+# 0.010000 96.03 84.22 73.31 75.23
+# 0.013335 79.69 69.68 60.75 62.73
+# 0.017783 65.75 57.38 50.18 52.18
+# 0.023714 53.99 47.06 41.33 43.35
+# 0.031623 44.15 38.47 33.99 36.00
+# 0.042170 35.97 31.36 27.91 29.90
+# 0.056234 29.21 25.51 22.91 24.86
+# 0.074989 23.65 20.71 18.81 20.70
+# 0.100000 19.11 16.79 15.45 17.29
+# 0.133352 15.41 13.61 12.72 14.47
+# 0.177828 12.41 11.03 10.50 12.14
+# 0.237137 9.98 8.94 8.71 10.18
+# 0.316228 8.02 7.25 7.26 8.45
+# 0.421697 6.44 5.89 6.09 6.84
+# 0.562341 5.17 4.80 5.15 5.48
+# 0.749894 4.16 3.92 4.36 4.39
+# 1.000000 3.35 3.22 3.63 3.52
+c1of1 <- 3.069/3
+c2of3 <- 2.1494/2
+c4of5 <- 1.14
+c10 <- 3.2425/3
+DxDshewhartrunsrules.arl <- Vectorize(xDshewhartrunsrules.arl, "delta")
+deltas <- 10^(-(18:0)/8)
+arl1of1 <-
+round(DxDshewhartrunsrules.arl(deltas, c=c1of1, type="1"), digits=2)
+arl2of3 <-
+round(DxDshewhartrunsrules.arl(deltas, c=c2of3, type="12"), digits=2)
+arl4of5 <-
+round(DxDshewhartrunsrules.arl(deltas, c=c4of5, type="13"), digits=2)
+arl10 <-
+round(DxDshewhartrunsrules.arl(deltas, c=c10, type="SameSide10"), digits=2)
+data.frame(delta=round(deltas, digits=6), arl1of1, arl2of3, arl4of5, arl10)
+}
+\keyword{ts}
diff --git a/man/xcusum.ad.Rd b/man/xcusum.ad.Rd
new file mode 100644
index 0000000..4665674
--- /dev/null
+++ b/man/xcusum.ad.Rd
@@ -0,0 +1,78 @@
+\name{xcusum.ad}
+\alias{xcusum.ad}
+\title{Compute steady-state ARLs of CUSUM control charts}
+\description{Computation of the steady-state Average Run Length (ARL)
+for different types of CUSUM control charts monitoring normal mean.}
+\usage{xcusum.ad(k, h, mu1, mu0 = 0, sided = "one", r = 30)}
+\arguments{
+\item{k}{reference value of the CUSUM control chart.}
+\item{h}{decision interval (alarm limit, threshold) of the CUSUM control chart.}
+\item{mu1}{out-of-control mean.}
+\item{mu0}{in-control mean.}
+\item{sided}{distinguish between one-, two-sided and Crosier's modified
+two-sided CUSUM scheme by choosing \code{"one"}, \code{"two"},
+and \code{"Crosier"}, respectively.}
+\item{r}{number of quadrature nodes, dimension of the resulting linear
+equation system is equal to \code{r+1} (one-, two-sided) or \code{2r+1}
+(Crosier).}
+}
+\details{
+\code{xcusum.ad} determines the steady-state Average Run Length (ARL)
+by numerically solving the related ARL integral equation by means
+of the Nystroem method based on Gauss-Legendre quadrature
+and using the power method for deriving the largest in magnitude
+eigenvalue and the related left eigenfunction.
+}
+\value{Returns a single value which resembles the steady-state ARL.}
+\references{
+R. B. Crosier (1986),
+A new two-sided cumulative quality control scheme,
+\emph{Technometrics 28}, 187-194.
+}
+\note{Be cautious in increasing the dimension parameter \code{r} for
+two-sided CUSUM schemes. The resulting matrix dimension is \code{r^2} times
+\code{r^2}. Thus, go beyond 30 only on fast machines. This is the only case,
+were the package routines are based on the Markov chain approach. Moreover,
+the two-sided CUSUM scheme needs a two-dimensional Markov chain.}
+\author{Sven Knoth}
+\seealso{
+\code{xcusum.arl} for zero-state ARL computation and
+\code{xewma.ad} for the steady-state ARL of EWMA control charts.
+}
+\examples{
+## comparison of zero-state (= worst case ) and steady-state performance
+## for one-sided CUSUM control charts
+
+k <- .5
+h <- xcusum.crit(k,500)
+mu <- c(0,.5,1,1.5,2)
+arl <- sapply(mu,k=k,h=h,xcusum.arl)
+ad <- sapply(mu,k=k,h=h,xcusum.ad)
+round(cbind(mu,arl,ad),digits=2)
+
+## Crosier (1986), Crosier's modified two-sided CUSUM
+## He introduced the modification and evaluated it by means of
+## Markov chain approximation
+
+k <- .5
+h2 <- 4
+hC <- 3.73
+mu <- c(0,.25,.5,.75,1,1.5,2,2.5,3,4,5)
+ad2 <- sapply(mu,k=k,h=h2,sided="two",r=20,xcusum.ad)
+adC <- sapply(mu,k=k,h=hC,sided="Crosier",xcusum.ad)
+round(cbind(mu,ad2,adC),digits=2)
+
+## results in the original paper are (in Table 5)
+## 0.00 163. 164.
+## 0.25 71.6 69.0
+## 0.50 25.2 24.3
+## 0.75 12.3 12.1
+## 1.00 7.68 7.69
+## 1.50 4.31 4.39
+## 2.00 3.03 3.12
+## 2.50 2.38 2.46
+## 3.00 2.00 2.07
+## 4.00 1.55 1.60
+## 5.00 1.22 1.29
+}
+\keyword{ts}
diff --git a/man/xcusum.arl.Rd b/man/xcusum.arl.Rd
new file mode 100644
index 0000000..cc34f59
--- /dev/null
+++ b/man/xcusum.arl.Rd
@@ -0,0 +1,179 @@
+\name{xcusum.arl}
+\alias{xcusum.arl}
+\title{Compute ARLs of CUSUM control charts}
+\description{Computation of the (zero-state) Average Run Length (ARL)
+for different types of CUSUM control charts monitoring normal mean.}
+\usage{xcusum.arl(k, h, mu, hs = 0, sided = "one", method = "igl", q = 1, r = 30)}
+\arguments{
+\item{k}{reference value of the CUSUM control chart.}
+\item{h}{decision interval (alarm limit, threshold) of the CUSUM control chart.}
+\item{mu}{true mean.}
+\item{hs}{so-called headstart (give fast initial response).}
+\item{sided}{distinguish between one-, two-sided and Crosier's modified
+two-sided CUSUM scheme by choosing \code{"one"}, \code{"two"},
+and \code{"Crosier"}, respectively.}
+\item{method}{deploy the integral equation (\code{"igl"}) or Markov chain approximation
+(\code{"mc"}) method to calculate the ARL (currently only for two-sided CUSUM implemented).}
+\item{q}{change point position. For \eqn{q=1} and
+\eqn{\mu=\mu_0} and \eqn{\mu=\mu_1}, the usual
+zero-state ARLs for the in-control and out-of-control case, respectively,
+are calculated. For \eqn{q>1} and \eqn{\mu!=0} conditional delays, that is,
+\eqn{E_q(L-q+1|L\ge q)}, will be determined.
+Note that mu0=0 is implicitely fixed.}
+\item{r}{number of quadrature nodes, dimension of the resulting linear
+equation system is equal to \code{r+1} (one-, two-sided) or \code{2r+1}
+(Crosier).}
+}
+\details{
+\code{xcusum.arl} determines the Average Run Length (ARL) by numerically
+solving the related ARL integral equation by means of the Nystroem method
+based on Gauss-Legendre quadrature.
+}
+\value{Returns a vector of length \code{q} which resembles the ARL and the sequence of conditional expected delays for
+\code{q}=1 and \code{q}>1, respectively.}
+\references{
+A. L. Goel, S. M. Wu (1971),
+Determination of A.R.L. and a contour nomogram for CUSUM charts to
+control normal mean, \emph{Technometrics 13}, 221-230.
+
+D. Brook, D. A. Evans (1972),
+An approach to the probability distribution of cusum run length,
+\emph{Biometrika 59}, 539-548.
+
+J. M. Lucas, R. B. Crosier (1982),
+Fast initial response for cusum quality-control schemes:
+Give your cusum a headstart, \emph{Technometrics 24}, 199-205.
+
+L. C. Vance (1986),
+Average run lengths of cumulative sum control charts for controlling
+normal means, \emph{Journal of Quality Technology 18}, 189-193.
+
+K.-H. Waldmann (1986),
+Bounds for the distribution of the run length of one-sided and
+two-sided CUSUM quality control schemes,
+\emph{Technometrics 28}, 61-67.
+
+R. B. Crosier (1986),
+A new two-sided cumulative quality control scheme,
+\emph{Technometrics 28}, 187-194.
+}
+\author{Sven Knoth}
+\seealso{
+\code{xewma.arl} for zero-state ARL computation of EWMA control charts
+and \code{xcusum.ad} for the steady-state ARL.
+}
+\examples{
+## Brook/Evans (1972), one-sided CUSUM
+## Their results are based on the less accurate Markov chain approach.
+
+k <- .5
+h <- 3
+round(c( xcusum.arl(k,h,0), xcusum.arl(k,h,1.5) ),digits=2)
+
+## results in the original paper are L0 = 117.59, L1 = 3.75 (in Subsection 4.3).
+
+## Lucas, Crosier (1982)
+## (one- and) two-sided CUSUM with possible headstarts
+
+k <- .5
+h <- 4
+mu <- c(0,.25,.5,.75,1,1.5,2,2.5,3,4,5)
+arl1 <- sapply(mu,k=k,h=h,sided="two",xcusum.arl)
+arl2 <- sapply(mu,k=k,h=h,hs=h/2,sided="two",xcusum.arl)
+round(cbind(mu,arl1,arl2),digits=2)
+
+## results in the original paper are (in Table 1)
+## 0.00 168. 149.
+## 0.25 74.2 62.7
+## 0.50 26.6 20.1
+## 0.75 13.3 8.97
+## 1.00 8.38 5.29
+## 1.50 4.75 2.86
+## 2.00 3.34 2.01
+## 2.50 2.62 1.59
+## 3.00 2.19 1.32
+## 4.00 1.71 1.07
+## 5.00 1.31 1.01.
+
+## Vance (1986), one-sided CUSUM
+## The first paper on using Nystroem method and Gauss-Legendre quadrature
+## for solving the ARL integral equation (see as well Goel/Wu, 1971)
+
+k <- 0
+h <- 10
+mu <- c(-.25,-.125,0,.125,.25,.5,.75,1)
+round(cbind(mu,sapply(mu,k=k,h=h,xcusum.arl)),digits=2)
+
+## results in the original paper are (in Table 1 incl. Goel/Wu (1971) results)
+## -0.25 2071.51
+## -0.125 400.28
+## 0.0 124.66
+## 0.125 59.30
+## 0.25 36.71
+## 0.50 20.37
+## 0.75 14.06
+## 1.00 10.75.
+
+## Waldmann (1986),
+## one- and two-sided CUSUM
+
+## one-sided case
+
+k <- .5
+h <- 3
+mu <- c(-.5,0,.5)
+round(sapply(mu,k=k,h=h,xcusum.arl),digits=2)
+
+## results in the original paper are 1963, 117.4, and 17.35, resp.
+## (in Tables 3, 1, and 5, resp.).
+
+## two-sided case
+
+k <- .6
+h <- 3
+round(xcusum.arl(k,h,-.2,sided="two"),digits=1) # fits to Waldmann's setup
+
+## result in the original paper is 65.4 (in Table 6).
+
+## Crosier (1986), Crosier's modified two-sided CUSUM
+## He introduced the modification and evaluated it by means of
+## Markov chain approximation
+
+k <- .5
+h <- 3.73
+mu <- c(0,.25,.5,.75,1,1.5,2,2.5,3,4,5)
+round(cbind(mu,sapply(mu,k=k,h=h,sided="Crosier",xcusum.arl)),digits=2)
+
+## results in the original paper are (in Table 3)
+## 0.00 168.
+## 0.25 70.7
+## 0.50 25.1
+## 0.75 12.5
+## 1.00 7.92
+## 1.50 4.49
+## 2.00 3.17
+## 2.50 2.49
+## 3.00 2.09
+## 4.00 1.60
+## 5.00 1.22.
+
+## SAS/QC manual 1999
+## one- and two-sided CUSUM schemes
+
+## one-sided
+
+k <- .25
+h <- 8
+mu <- 2.5
+print(xcusum.arl(k,h,mu),digits=12)
+print(xcusum.arl(k,h,mu,hs=.1),digits=12)
+
+## original results are 4.1500836225 and 4.1061588131.
+
+## two-sided
+
+print(xcusum.arl(k,h,mu,sided="two"),digits=12)
+
+## original result is 4.1500826715.
+}
+\keyword{ts}
diff --git a/man/xcusum.crit.L0L1.Rd b/man/xcusum.crit.L0L1.Rd
new file mode 100644
index 0000000..299ba3f
--- /dev/null
+++ b/man/xcusum.crit.L0L1.Rd
@@ -0,0 +1,87 @@
+\name{xcusum.crit.L0L1}
+\alias{xcusum.crit.L0L1}
+\title{Compute the CUSUM k and h for given in-control ARL L0 and out-of-control L1}
+\description{Computation of the reference value k and the alarm threshold h
+for one-sided CUSUM control charts monitoring normal mean, if the in-control ARL L0 and the out-of-control L1 are given.}
+\usage{xcusum.crit.L0L1(L0, L1, hs=0, sided="one", r=30, L1.eps=1e-6, k.eps=1e-8)}
+\arguments{
+\item{L0}{in-control ARL.}
+\item{L1}{out-of-control ARL.}
+\item{hs}{so-called headstart (enables fast initial response).}
+\item{sided}{distinguishes between one-, two-sided and Crosier's modified
+two-sided CUSUM schemoosing \code{"one"}, \code{"two"}, and \code{"Crosier"}, respectively.}
+\item{r}{number of quadrature nodes, dimension of the resulting linear
+equation system is equal to \code{r+1} (one-, two-sided) or \code{2r+1} (Crosier).}
+\item{L1.eps}{error bound for the L1 error.}
+\item{k.eps}{bound for the difference of two successive values of k.}
+}
+\details{
+\code{xcusum.crit.L0L1} determines the reference value k and the alarm threshold h
+for given in-control ARL \code{L0} and out-of-control ARL \code{L1}
+by applying secant rule and using \code{xcusum.arl()} and \code{xcusum.crit()}.
+These CUSUM design rules were firstly (and quite rarely afterwards) used by Ewan and Kemp.
+}
+\value{Returns two values which resemble the reference value \code{k} and the threshold \code{h}.}
+\references{
+W. D. Ewan and K. W. Kemp (1960),
+Sampling inspection of continuous processes with no autocorrelation between successive results,
+\emph{Biometrika 47}, 363-380.
+
+K. W. Kemp (1962),
+The Use of Cumulative Sums for Sampling Inspection Schemes,
+\emph{Journal of the Royal Statistical Sociecty C, Applied Statistics, 10}, 16-31.
+}
+\author{Sven Knoth}
+\seealso{\code{xcusum.arl} for zero-state ARL and \code{xcusum.crit} for threshold h computation.}
+\examples{
+## Table 2 from Ewan/Kemp (1960) -- one-sided CUSUM
+#
+# A.R.L. at A.Q.L. A.R.L. at A.Q.L. k h
+# 1000 3 1.12 2.40
+# 1000 7 0.65 4.06
+# 500 3 1.04 2.26
+# 500 7 0.60 3.80
+# 250 3 0.94 2.11
+# 250 7 0.54 3.51
+#
+L0.set <- c(1000, 500, 250)
+L1.set <- c(3, 7)
+cat("\nL0\tL1\tk\th\n")
+for ( L0 in L0.set ) {
+ for ( L1 in L1.set ) {
+ result <- round(xcusum.crit.L0L1(L0, L1), digits=2)
+ cat(paste(L0, L1, result[1], result[2], sep="\t"), "\n")
+ }
+}
+#
+# two confirmation runs
+xcusum.arl(0.54, 3.51, 0) # Ewan/Kemp
+xcusum.arl(result[1], result[2], 0) # here
+xcusum.arl(0.54, 3.51, 2*0.54) # Ewan/Kemp
+xcusum.arl(result[1], result[2], 2*result[1]) # here
+#
+## Table II from Kemp (1962) -- two-sided CUSUM
+#
+# Lr k
+# La=250 La=500 La=1000
+# 2.5 1.05 1.17 1.27
+# 3.0 0.94 1.035 1.13
+# 4.0 0.78 0.85 0.92
+# 5.0 0.68 0.74 0.80
+# 6.0 0.60 0.655 0.71
+# 7.5 0.52 0.57 0.62
+# 10.0 0.43 0.48 0.52
+#
+L0.set <- c(250, 500, 1000)
+L1.set <- c(2.5, 3:6, 7.5, 10)
+cat("\nL1\tL0=250\tL0=500\tL0=1000\n")
+for ( L1 in L1.set ) {
+ cat(L1)
+ for ( L0 in L0.set ) {
+ result <- round(xcusum.crit.L0L1(L0, L1, sided="two"), digits=2)
+ cat("\t", result[1])
+ }
+ cat("\n")
+}
+}
+\keyword{ts}
diff --git a/man/xcusum.crit.L0h.Rd b/man/xcusum.crit.L0h.Rd
new file mode 100644
index 0000000..8280232
--- /dev/null
+++ b/man/xcusum.crit.L0h.Rd
@@ -0,0 +1,41 @@
+\name{xcusum.crit.L0h}
+\alias{xcusum.crit.L0h}
+\title{Compute the CUSUM reference value k for given in-control ARL and threshold h}
+\description{Computation of the reference value k
+for one-sided CUSUM control charts monitoring normal mean, if the in-control ARL L0 and
+the alarm threshold h are given.}
+\usage{xcusum.crit.L0h(L0, h, hs=0, sided="one", r=30, L0.eps=1e-6, k.eps=1e-8)}
+\arguments{
+\item{L0}{in-control ARL.}
+\item{h}{alarm level of the CUSUM control chart.}
+\item{hs}{so-called headstart (enables fast initial response).}
+\item{sided}{distinguishes between one-, two-sided and Crosier's modified
+two-sided CUSUM scheme choosing \code{"one"}, \code{"two"}, and \code{"Crosier"}, respectively.}
+\item{r}{number of quadrature nodes, dimension of the resulting linear
+equation system is equal to \code{r+1} (one-, two-sided) or \code{2r+1} (Crosier).}
+\item{L0.eps}{error bound for the L0 error.}
+\item{k.eps}{bound for the difference of two successive values of k.}
+}
+\details{
+\code{xcusum.crit.L0h} determines the reference value k
+for given in-control ARL \code{L0} and alarm level \code{h}
+by applying secant rule and using \code{xcusum.arl()}. Note that
+not for any combination of \code{L0} and \code{h} a solution exists
+-- for given \code{L0} there is a maximal value for \code{h} to get a valid result \code{k}.
+}
+\value{Returns a single value which resembles the reference value \code{k}.}
+%\references{Later...}
+\author{Sven Knoth}
+\seealso{\code{xcusum.arl} for zero-state ARL computation.}
+\examples{
+L0 <- 100
+h.max <- xcusum.crit(0, L0, 0)
+hs <- (300:1)/100
+hs <- hs[hs < h.max]
+ks <- NULL
+for ( h in hs ) ks <- c(ks, xcusum.crit.L0h(L0, h))
+k.max <- qnorm( 1 - 1/L0 )
+plot(hs, ks, type="l", ylim=c(0, max(k.max, ks)), xlab="h", ylab="k")
+abline(h=c(0, k.max), col="red")
+}
+\keyword{ts}
diff --git a/man/xcusum.crit.Rd b/man/xcusum.crit.Rd
new file mode 100644
index 0000000..d22fa65
--- /dev/null
+++ b/man/xcusum.crit.Rd
@@ -0,0 +1,34 @@
+\name{xcusum.crit}
+\alias{xcusum.crit}
+\title{Compute decision intervals of CUSUM control charts}
+\description{Computation of the decision intervals (alarm limits)
+for different types of CUSUM control charts monitoring normal mean.}
+\usage{xcusum.crit(k, L0, mu0 = 0, hs = 0, sided = "one", r = 30)}
+\arguments{
+\item{k}{reference value of the CUSUM control chart.}
+\item{L0}{in-control ARL.}
+\item{mu0}{in-control mean.}
+\item{hs}{so-called headstart (enables fast initial response).}
+\item{sided}{distinguishes between one-, two-sided and Crosier's modified
+two-sided CUSUM scheme by choosing \code{"one"}, \code{"two"}, and \code{"Crosier"}, respectively.}
+\item{r}{number of quadrature nodes, dimension of the resulting linear
+equation system is equal to \code{r+1} (one-, two-sided) or \code{2r+1}
+(Crosier).}
+}
+\details{
+\code{xcusum.crit} determines the decision interval (alarm limit)
+for given in-control ARL \code{L0} by applying secant rule and using \code{xcusum.arl()}.
+}
+\value{Returns a single value which resembles the decision interval
+\code{h}.}
+%\references{Later...}
+\author{Sven Knoth}
+\seealso{\code{xcusum.arl} for zero-state ARL computation.}
+\examples{
+k <- .5
+incontrolARL <- c(500,5000,50000)
+sapply(incontrolARL,k=k,xcusum.crit,r=10) # accuracy with 10 nodes
+sapply(incontrolARL,k=k,xcusum.crit,r=20) # accuracy with 20 nodes
+sapply(incontrolARL,k=k,xcusum.crit) # accuracy with 30 nodes
+}
+\keyword{ts}
diff --git a/man/xcusum.q.Rd b/man/xcusum.q.Rd
new file mode 100644
index 0000000..1ff4210
--- /dev/null
+++ b/man/xcusum.q.Rd
@@ -0,0 +1,42 @@
+\name{xcusum.q}
+\alias{xcusum.q}
+\title{Compute RL quantiles of CUSUM control charts}
+\description{Computation of quantiles of the Run Length (RL)for CUSUM control charts monitoring normal mean.}
+\usage{xcusum.q(k, h, mu, alpha, hs=0, sided="one", r=40)}
+\arguments{
+\item{k}{reference value of the CUSUM control chart.}
+\item{h}{decision interval (alarm limit, threshold) of the CUSUM control chart.}
+\item{mu}{true mean.}
+\item{alpha}{quantile level.}
+\item{hs}{so-called headstart (enables fast initial response).}
+\item{sided}{distinguishes between one- and two-sided CUSUM control chart by choosing \code{"one"} and \code{"two"}, respectively.}
+\item{r}{number of quadrature nodes, dimension of the resulting linear equation system is equal to \code{r+1}.}
+}
+\details{
+Instead of the popular ARL (Average Run Length) quantiles of the CUSUM
+stopping time (Run Length) are determined. The algorithm is based on
+Waldmann's survival function iteration procedure.
+}
+\value{Returns a single value which resembles the RL quantile of order \code{q}.}
+\references{
+K.-H. Waldmann (1986),
+Bounds for the distribution of the run length of one-sided and two-sided CUSUM quality control schemes,
+\emph{Technometrics 28}, 61-67.
+}
+\author{Sven Knoth}
+\seealso{
+\code{xcusum.arl} for zero-state ARL computation of CUSUM control charts.
+}
+\examples{
+## Waldmann (1986), one-sided CUSUM, Table 2
+## original values are 345, 82, 9
+
+XCUSUM.Q <- Vectorize("xcusum.q", "alpha")
+k <- .5
+h <- 3
+mu <- 0 # corresponds to Waldmann's -0.5
+a.list <- c(.95, .5, .05)
+rl.quantiles <- ceiling(XCUSUM.Q(k, h, mu, a.list))
+cbind(a.list, rl.quantiles)
+}
+\keyword{ts}
diff --git a/man/xcusum.sf.Rd b/man/xcusum.sf.Rd
new file mode 100644
index 0000000..cc96192
--- /dev/null
+++ b/man/xcusum.sf.Rd
@@ -0,0 +1,41 @@
+\name{xcusum.sf}
+\alias{xcusum.sf}
+\title{Compute the survival function of CUSUM run length}
+\description{Computation of the survival function of the Run Length (RL) for CUSUM control charts monitoring normal mean.}
+\usage{xcusum.sf(k, h, mu, n, hs=0, sided="one", r=40)}
+\arguments{
+\item{k}{reference value of the CUSUM control chart.}
+\item{h}{decision interval (alarm limit, threshold) of the CUSUM control chart.}
+\item{mu}{true mean.}
+\item{n}{calculate sf up to value \code{n}.}
+\item{hs}{so-called headstart (enables fast initial response).}
+\item{sided}{distinguishes between one- and two-sided CUSUM control chart by choosing \code{"one"} and \code{"two"}, respectively.}
+\item{r}{number of quadrature nodes, dimension of the resulting linear equation system is equal to \code{r+1}.}
+}
+\details{
+The survival function P(L>n) and derived from it also the cdf P(L<=n) and the pmf P(L=n) illustrate
+the distribution of the CUSUM run length. For large n the geometric tail could be exploited. That is,
+with reasonable large n the complete distribution is characterized.
+The algorithm is based on Waldmann's survival function iteration procedure.
+}
+\value{Returns a vector which resembles the survival function up to a certain point.}
+\references{
+K.-H. Waldmann (1986),
+Bounds for the distribution of the run length of one-sided and two-sided CUSUM quality control schemes,
+\emph{Technometrics 28}, 61-67.
+}
+\author{Sven Knoth}
+\seealso{
+\code{xcusum.q} for computation of CUSUM run length quantiles.
+}
+\examples{
+## Waldmann (1986), one-sided CUSUM, Table 2
+
+k <- .5
+h <- 3
+mu <- 0 # corresponds to Waldmann's -0.5
+SF <- xcusum.sf(k, h, 0, 1000)
+plot(1:length(SF), SF, type="l", xlab="n", ylab="P(L>n)", ylim=c(0,1))
+#
+}
+\keyword{ts}
diff --git a/man/xewma.ad.Rd b/man/xewma.ad.Rd
new file mode 100644
index 0000000..8155bfc
--- /dev/null
+++ b/man/xewma.ad.Rd
@@ -0,0 +1,89 @@
+\name{xewma.ad}
+\alias{xewma.ad}
+\title{Compute steady-state ARLs of EWMA control charts}
+\description{Computation of the steady-state Average Run Length (ARL)
+for different types of EWMA control charts monitoring normal mean.}
+\usage{xewma.ad(l, c, mu1, mu0=0, zr=0, z0=0, sided="one", limits="fix",
+steady.state.mode="conditional", r=40)}
+\arguments{
+\item{l}{smoothing parameter lambda of the EWMA control chart.}
+\item{c}{critical value (similar to alarm limit) of the EWMA control chart.}
+\item{mu1}{in-control mean.}
+\item{mu0}{out-of-control mean.}
+\item{zr}{reflection border for the one-sided chart.}
+\item{z0}{restarting value of the EWMA sequence in case of a false alarm in
+\code{steady.state.mode="cyclical"}.}
+\item{sided}{distinguishes between one- and two-sided two-sided EWMA control
+chart by choosing \code{"one"} and \code{"two"}, respectively.}
+\item{limits}{distinguishes between different control limits behavior.}
+\item{steady.state.mode}{distinguishes between two steady-state modes -- conditional and cyclical.}
+\item{r}{number of quadrature nodes, dimension of the resulting linear
+equation system is equal to \code{r+1} (one-sided) or \code{r}
+(two-sided).}
+}
+\details{
+\code{xewma.ad} determines the steady-state Average Run Length (ARL)
+by numerically solving the related ARL integral equation by means
+of the Nystroem method based on Gauss-Legendre quadrature
+and using the power method for deriving the largest in magnitude
+eigenvalue and the related left eigenfunction.
+}
+\value{Returns a single value which resembles the steady-state ARL.}
+\references{
+R. B. Crosier (1986),
+A new two-sided cumulative quality control scheme,
+\emph{Technometrics 28}, 187-194.
+
+S. V. Crowder (1987),
+A simple method for studying run-length distributions of exponentially weighted
+moving average charts,
+\emph{Technometrics 29}, 401-407.
+
+J. M. Lucas and M. S. Saccucci (1990),
+Exponentially weighted moving average control schemes: Properties and enhancements,
+\emph{Technometrics 32}, 1-12.
+}
+\author{Sven Knoth}
+\seealso{
+\code{xewma.arl} for zero-state ARL computation and
+\code{xcusum.ad} for the steady-state ARL of CUSUM control charts.
+}
+\examples{
+## comparison of zero-state (= worst case ) and steady-state performance
+## for two-sided EWMA control charts
+
+l <- .1
+c <- xewma.crit(l,500,sided="two")
+mu <- c(0,.5,1,1.5,2)
+arl <- sapply(mu,l=l,c=c,sided="two",xewma.arl)
+ad <- sapply(mu,l=l,c=c,sided="two",xewma.ad)
+round(cbind(mu,arl,ad),digits=2)
+
+## Lucas/Saccucci (1990)
+## two-sided EWMA
+
+## with fixed limits
+l1 <- .5
+l2 <- .03
+c1 <- 3.071
+c2 <- 2.437
+mu <- c(0,.25,.5,.75,1,1.5,2,2.5,3,3.5,4,5)
+ad1 <- sapply(mu,l=l1,c=c1,sided="two",xewma.ad)
+ad2 <- sapply(mu,l=l2,c=c2,sided="two",xewma.ad)
+round(cbind(mu,ad1,ad2),digits=2)
+
+## original results are (in Table 3)
+## 0.00 499. 480.
+## 0.25 254. 74.1
+## 0.50 88.4 28.6
+## 0.75 35.7 17.3
+## 1.00 17.3 12.5
+## 1.50 6.44 8.00
+## 2.00 3.58 5.95
+## 2.50 2.47 4.78
+## 3.00 1.91 4.02
+## 3.50 1.58 3.49
+## 4.00 1.36 3.09
+## 5.00 1.10 2.55
+}
+\keyword{ts}
diff --git a/man/xewma.arl.Rd b/man/xewma.arl.Rd
new file mode 100644
index 0000000..060c0b8
--- /dev/null
+++ b/man/xewma.arl.Rd
@@ -0,0 +1,338 @@
+\name{xewma.arl}
+\alias{xewma.arl}
+\title{Compute ARLs of EWMA control charts}
+\description{Computation of the (zero-state) Average Run Length (ARL)
+for different types of EWMA control charts monitoring normal mean.}
+\usage{xewma.arl(l,c,mu,zr=0,hs=0,sided="one",limits="fix",q=1,r=40)}
+\arguments{
+\item{l}{smoothing parameter lambda of the EWMA control chart.}
+\item{c}{critical value (similar to alarm limit) of the EWMA control chart.}
+\item{mu}{true mean.}
+\item{zr}{reflection border for the one-sided chart.}
+\item{hs}{so-called headstart (enables fast initial response).}
+\item{sided}{distinguishes between one- and two-sided EWMA control chart
+by choosing \code{"one"} and \code{"two"}, respectively.}
+\item{limits}{distinguishes between different control limits behavior.}
+\item{q}{change point position. For \eqn{q=1} and
+\eqn{\mu=\mu_0} and \eqn{\mu=\mu_1}, the usual
+zero-state ARLs for the in-control and out-of-control case, respectively,
+are calculated. For \eqn{q>1} and \eqn{\mu!=0} conditional delays, that is,
+\eqn{E_q(L-q+1|L\ge q)}, will be determined.
+Note that mu0=0 is implicitely fixed.}
+\item{r}{number of quadrature nodes, dimension of the resulting linear
+equation system is equal to \code{r+1} (one-sided) or \code{r}
+(two-sided).}
+}
+\details{
+In case of the EWMA chart with fixed control limits,
+\code{xewma.arl} determines the Average Run Length (ARL) by numerically
+solving the related ARL integral equation by means of the Nystroem method
+based on Gauss-Legendre quadrature.
+If \code{limits} is not \code{"fix"}, then the method presented in Knoth (2003) is utilized.
+Note that for one-sided EWMA charts (\code{sided}=\code{"one"}), only
+\code{"vacl"} and \code{"stat"} are deployed, while for two-sided ones
+(\code{sided}=\code{"two"}) also \code{"fir"}, \code{"both"}
+(combination of \code{"fir"} and \code{"vacl"}), and \code{"Steiner"} are implemented.
+For details see Knoth (2004).
+}
+\value{Except for the fixed limits EWMA charts it returns a single value which resembles the ARL.
+For fixed limits charts, it returns a vector of length \code{q} which resembles the ARL and the
+sequence of conditional expected delays for
+\code{q}=1 and \code{q}>1, respectively.}
+\references{
+K.-H. Waldmann (1986),
+Bounds for the distribution of the run length of geometric moving
+average charts, \emph{Appl. Statist. 35}, 151-158.
+
+S. V. Crowder (1987),
+A simple method for studying run-length distributions of
+exponentially weighted moving average charts,
+\emph{Technometrics 29}, 401-407.
+
+J. M. Lucas and M. S. Saccucci (1990),
+Exponentially weighted moving average control schemes: Properties
+and enhancements, \emph{Technometrics 32}, 1-12.
+
+S. Chandrasekaran, J. R. English and R. L. Disney (1995),
+Modeling and analysis of EWMA control schemes with variance-adjusted
+control limits, \emph{IIE Transactions 277}, 282-290.
+
+T. R. Rhoads, D. C. Montgomery and C. M. Mastrangelo (1996),
+Fast initial response scheme for exponentially weighted moving average
+control chart, \emph{Quality Engineering 9}, 317-327.
+
+S. H. Steiner (1999),
+EWMA control charts with time-varying control limits and fast initial response,
+\emph{Journal of Quality Technology 31}, 75-86.
+
+S. Knoth (2003),
+EWMA schemes with non-homogeneous transition kernels,
+\emph{Sequential Analysis 22}, 241-255.
+
+S. Knoth (2004),
+Fast initial response features for EWMA Control Charts,
+\emph{Statistical Papers 46}, 47-64.
+}
+\author{Sven Knoth}
+\seealso{
+\code{xcusum.arl} for zero-state ARL computation of CUSUM control charts
+and \code{xewma.ad} for the steady-state ARL.
+}
+\examples{
+## Waldmann (1986), one-sided EWMA
+l <- .75
+round(xewma.arl(l,2*sqrt((2-l)/l),0,zr=-4*sqrt((2-l)/l)),digits=1)
+l <- .5
+round(xewma.arl(l,2*sqrt((2-l)/l),0,zr=-4*sqrt((2-l)/l)),digits=1)
+## original values are 209.3 and 3907.5 (in Table 2).
+
+## Waldmann (1986), two-sided EWMA with fixed control limits
+l <- .75
+round(xewma.arl(l,2*sqrt((2-l)/l),0,sided="two"),digits=1)
+l <- .5
+round(xewma.arl(l,2*sqrt((2-l)/l),0,sided="two"),digits=1)
+## original values are 104.0 and 1952 (in Table 1).
+
+## Crowder (1987), two-sided EWMA with fixed control limits
+l1 <- .5
+l2 <- .05
+c <- 2
+mu <- (0:16)/4
+arl1 <- sapply(mu,l=l1,c=c,sided="two",xewma.arl)
+arl2 <- sapply(mu,l=l2,c=c,sided="two",xewma.arl)
+round(cbind(mu,arl1,arl2),digits=2)
+
+## original results are (in Table 1)
+## 0.00 26.45 127.53
+## 0.25 20.12 43.94
+## 0.50 11.89 18.97
+## 0.75 7.29 11.64
+## 1.00 4.91 8.38
+## 1.25 3.95* 6.56
+## 1.50 2.80 5.41
+## 1.75 2.29 4.62
+## 2.00 1.94 4.04
+## 2.25 1.70 3.61
+## 2.50 1.51 3.26
+## 2.75 1.37 2.99
+## 3.00 1.26 2.76
+## 3.25 1.18 2.56
+## 3.50 1.12 2.39
+## 3.75 1.08 2.26
+## 4.00 1.05 2.15 (* -- in Crowder (1987) typo!?)
+
+## Lucas/Saccucci (1990)
+## two-sided EWMA
+
+## with fixed limits
+l1 <- .5
+l2 <- .03
+c1 <- 3.071
+c2 <- 2.437
+mu <- c(0,.25,.5,.75,1,1.5,2,2.5,3,3.5,4,5)
+arl1 <- sapply(mu,l=l1,c=c1,sided="two",xewma.arl)
+arl2 <- sapply(mu,l=l2,c=c2,sided="two",xewma.arl)
+round(cbind(mu,arl1,arl2),digits=2)
+
+## original results are (in Table 3)
+## 0.00 500. 500.
+## 0.25 255. 76.7
+## 0.50 88.8 29.3
+## 0.75 35.9 17.6
+## 1.00 17.5 12.6
+## 1.50 6.53 8.07
+## 2.00 3.63 5.99
+## 2.50 2.50 4.80
+## 3.00 1.93 4.03
+## 3.50 1.58 3.49
+## 4.00 1.34 3.11
+## 5.00 1.07 2.55
+
+\dontrun{
+## with fir feature
+l1 <- .5
+l2 <- .03
+c1 <- 3.071
+c2 <- 2.437
+hs1 <- c1/2
+hs2 <- c2/2
+mu <- c(0,.5,1,2,3,5)
+arl1 <- sapply(mu,l=l1,c=c1,hs=hs1,sided="two",limits="fir",xewma.arl)
+arl2 <- sapply(mu,l=l2,c=c2,hs=hs2,sided="two",limits="fir",xewma.arl)
+round(cbind(mu,arl1,arl2),digits=2)
+
+## original results are (in Table 5)
+## 0.0 487. 406.
+## 0.5 86.1 18.4
+## 1.0 15.9 7.36
+## 2.0 2.87 3.43
+## 3.0 1.45 2.34
+## 5.0 1.01 1.57
+
+## Chandrasekaran, English, Disney (1995)
+## two-sided EWMA with fixed and variance adjusted limits (vacl)
+
+l1 <- .25
+l2 <- .1
+c1s <- 2.9985
+c1n <- 3.0042
+c2s <- 2.8159
+c2n <- 2.8452
+mu <- c(0,.25,.5,.75,1,2)
+arl1s <- sapply(mu,l=l1,c=c1s,sided="two",xewma.arl)
+arl1n <- sapply(mu,l=l1,c=c1n,sided="two",limits="vacl",xewma.arl)
+arl2s <- sapply(mu,l=l2,c=c2s,sided="two",xewma.arl)
+arl2n <- sapply(mu,l=l2,c=c2n,sided="two",limits="vacl",xewma.arl)
+round(cbind(mu,arl1s,arl1n,arl2s,arl2n),digits=2)
+
+## original results are (in Table 2)
+## 0.00 500. 500. 500. 500.
+## 0.25 170.09 167.54 105.90 96.6
+## 0.50 48.14 45.65 31.08 24.35
+## 0.75 20.02 19.72 15.71 10.74
+## 1.00 11.07 9.37 10.23 6.35
+## 2.00 3.59 2.64 4.32 2.73
+
+## The results in Chandrasekaran, English, Disney (1995) are not
+## that accurate. Let us consider the more appropriate comparison
+
+c1s <- xewma.crit(l1,500,sided="two")
+c1n <- xewma.crit(l1,500,sided="two",limits="vacl")
+c2s <- xewma.crit(l2,500,sided="two")
+c2n <- xewma.crit(l2,500,sided="two",limits="vacl")
+mu <- c(0,.25,.5,.75,1,2)
+arl1s <- sapply(mu,l=l1,c=c1s,sided="two",xewma.arl)
+arl1n <- sapply(mu,l=l1,c=c1n,sided="two",limits="vacl",xewma.arl)
+arl2s <- sapply(mu,l=l2,c=c2s,sided="two",xewma.arl)
+arl2n <- sapply(mu,l=l2,c=c2n,sided="two",limits="vacl",xewma.arl)
+round(cbind(mu,arl1s,arl1n,arl2s,arl2n),digits=2)
+
+## which demonstrate the abilities of the variance-adjusted limits
+## scheme more explicitely.
+
+## Rhoads, Montgomery, Mastrangelo (1996)
+## two-sided EWMA with fixed and variance adjusted limits (vacl),
+## with fir and both features
+
+l <- .03
+c <- 2.437
+mu <- c(0,.5,1,1.5,2,3,4)
+sl <- sqrt(l*(2-l))
+arlfix <- sapply(mu,l=l,c=c,sided="two",xewma.arl)
+arlvacl <- sapply(mu,l=l,c=c,sided="two",limits="vacl",xewma.arl)
+arlfir <- sapply(mu,l=l,c=c,hs=c/2,sided="two",limits="fir",xewma.arl)
+arlboth <- sapply(mu,l=l,c=c,hs=c/2*sl,sided="two",limits="both",xewma.arl)
+round(cbind(mu,arlfix,arlvacl,arlfir,arlboth),digits=1)
+
+## original results are (in Table 1)
+## 0.0 477.3* 427.9* 383.4* 286.2*
+## 0.5 29.7 20.0 18.6 12.8
+## 1.0 12.5 6.5 7.4 3.6
+## 1.5 8.1 3.3 4.6 1.9
+## 2.0 6.0 2.2 3.4 1.4
+## 3.0 4.0 1.3 2.4 1.0
+## 4.0 3.1 1.1 1.9 1.0
+## * -- the in-control values differ sustainably from the true values!
+
+## Steiner (1999)
+## two-sided EWMA control charts with various modifications
+
+## fixed vs. variance adjusted limits
+
+l <- .05
+c <- 3
+mu <- c(0,.25,.5,.75,1,1.5,2,2.5,3,3.5,4)
+arlfix <- sapply(mu,l=l,c=c,sided="two",xewma.arl)
+arlvacl <- sapply(mu,l=l,c=c,sided="two",limits="vacl",xewma.arl)
+round(cbind(mu,arlfix,arlvacl),digits=1)
+
+## original results are (in Table 2)
+## 0.00 1379.0 1353.0
+## 0.25 135.0 127.0
+## 0.50 37.4 32.5
+## 0.75 20.0 15.6
+## 1.00 13.5 9.0
+## 1.50 8.3 4.5
+## 2.00 6.0 2.8
+## 2.50 4.8 2.0
+## 3.00 4.0 1.6
+## 3.50 3.4 1.3
+## 4.00 3.0 1.1
+
+## fir, both, and Steiner's modification
+
+l <- .03
+cfir <- 2.44
+cboth <- 2.54
+cstein <- 2.55
+hsfir <- cfir/2
+hsboth <- cboth/2*sqrt(l*(2-l))
+mu <- c(0,.5,1,1.5,2,3,4)
+arlfir <- sapply(mu,l=l,c=cfir,hs=hsfir,sided="two",limits="fir",xewma.arl)
+arlboth <- sapply(mu,l=l,c=cboth,hs=hsboth,sided="two",limits="both",xewma.arl)
+arlstein <- sapply(mu,l=l,c=cstein,sided="two",limits="Steiner",xewma.arl)
+round(cbind(mu,arlfir,arlboth,arlstein),digits=1)
+
+## original values are (in Table 5)
+## 0.0 383.0 384.0 391.0
+## 0.5 18.6 14.9 13.8
+## 1.0 7.4 3.9 3.6
+## 1.5 4.6 2.0 1.8
+## 2.0 3.4 1.4 1.3
+## 3.0 2.4 1.1 1.0
+## 4.0 1.9 1.0 1.0
+
+## SAS/QC manual 1999
+## two-sided EWMA control charts with fixed limits
+
+l <- .25
+c <- 3
+mu <- 1
+print(xewma.arl(l,c,mu,sided="two"),digits=11)
+
+# original value is 11.154267016.
+
+## Some recent examples for one-sided EWMA charts
+## with varying limits and in the so-called stationary mode
+
+# 1. varying limits = "vacl"
+
+lambda <- .1
+L0 <- 500
+
+## Monte Carlo results (10^9 replicates)
+# mu ARL s.e.
+# 0 500.00 0.0160
+# 0.5 21.637 0.0006
+# 1 6.7596 0.0001
+# 1.5 3.5398 0.0001
+# 2 2.3038 0.0000
+# 2.5 1.7004 0.0000
+# 3 1.3675 0.0000
+
+zr <- -6
+r <- 50
+c <- xewma.crit(lambda, L0, zr=zr, limits="vacl", r=r)
+Mxewma.arl <- Vectorize(xewma.arl, "mu")
+mus <- (0:6)/2
+arls <- round(Mxewma.arl(lambda, c, mus, zr=zr, limits="vacl", r=r), digits=4)
+data.frame(mus, arls)
+
+# 2. stationary mode, i. e. limits = "stat"
+
+## Monte Carlo results (10^9 replicates)
+# mu ARL s.e.
+# 0 500.00 0.0159
+# 0.5 22.313 0.0006
+# 1 7.2920 0.0001
+# 1.5 3.9064 0.0001
+# 2 2.5131 0.0000
+# 2.5 1.7983 0.0000
+# 3 1.4029 0.0000
+
+c <- xewma.crit(lambda, L0, zr=zr, limits="stat", r=r)
+arls <- round(Mxewma.arl(lambda, c, mus, zr=zr, limits="stat", r=r), digits=4)
+data.frame(mus, arls)
+}
+}
+\keyword{ts}
diff --git a/man/xewma.arl.prerun.Rd b/man/xewma.arl.prerun.Rd
new file mode 100644
index 0000000..9311aca
--- /dev/null
+++ b/man/xewma.arl.prerun.Rd
@@ -0,0 +1,111 @@
+\name{xewma.arl.prerun}
+\alias{xewma.arl.prerun}
+\alias{xewma.crit.prerun}
+\title{Compute ARLs of EWMA control charts in case of estimated parameters}
+\description{Computation of the (zero-state) Average Run Length (ARL)
+for different types of EWMA control charts monitoring normal mean
+if the in-control mean, standard deviation, or both are estimated by a pre run.}
+\usage{xewma.arl.prerun(l, c, mu, zr=0, hs=0, sided="two", limits="fix", q=1,
+size=100, df=NULL, estimated="mu", qm.mu=30, qm.sigma=30, truncate=1e-10)
+
+xewma.crit.prerun(l, L0, mu, zr=0, hs=0, sided="two", limits="fix", size=100,
+df=NULL, estimated="mu", qm.mu=30, qm.sigma=30, truncate=1e-10,
+c.error=1e-12, L.error=1e-9, OUTPUT=FALSE)}
+\arguments{
+\item{l}{smoothing parameter lambda of the EWMA control chart.}
+\item{c}{critical value (similar to alarm limit) of the EWMA control chart.}
+\item{mu}{true mean shift.}
+\item{zr}{reflection border for the one-sided chart.}
+\item{hs}{so-called headstart (give fast initial response).}
+\item{sided}{distinguish between one- and two-sided EWMA control chart
+by choosing \code{"one"} and \code{"two"}, respectively.}
+\item{limits}{distinguish between different control limits behavior.}
+\item{q}{change point position. For \eqn{q=1} and
+\eqn{\mu=\mu_0} and \eqn{\mu=\mu_1}, the usual
+zero-state ARLs for the in-control and out-of-control case, respectively,
+are calculated. For \eqn{q>1} and \eqn{\mu!=0} conditional delays, that is,
+\eqn{E_q(L-q+1|L\ge q)}, will be determined.
+Note that mu0=0 is implicitely fixed.}
+\item{size}{pre run sample size.}
+\item{df}{Degrees of freedom of the pre run variance estimator. Typically it is simply \code{size} - 1.
+If the pre run is collected in batches, then also other values are needed.}
+\item{estimated}{name the parameter to be estimated within
+the \code{"mu"}, \code{"sigma"}, \code{"both"}.}
+\item{qm.mu}{number of quadrature nodes for convoluting the mean uncertainty.}
+\item{qm.sigma}{number of quadrature nodes for convoluting the standard deviation uncertainty.}
+\item{truncate}{size of truncated tail.}
+\item{L0}{in-control ARL.}
+\item{c.error}{error bound for two succeeding values of the critical value
+during applying the secant rule.}
+\item{L.error}{error bound for the ARL level \code{L0} during applying the secant rule.}
+\item{OUTPUT}{activate or deactivate additional output.}
+}
+\details{
+Essentially, the ARL function \code{xewma.arl} is convoluted with the
+distribution of the sample mean, standard deviation or both.
+For details see Jones/Champ/Rigdon (2001) and Knoth (2014?).
+}
+\value{Returns a single value which resembles the ARL.}
+\references{
+L. A. Jones, C. W. Champ, S. E. Rigdon (2001),
+The performance of exponentially weighted moving average charts
+with estimated parameters,
+\emph{Technometrics 43}, 156-167.
+
+S. Knoth (2003),
+EWMA schemes with non-homogeneous transition kernels,
+\emph{Sequential Analysis 22}, 241-255.
+
+S. Knoth (2004),
+Fast initial response features for EWMA Control Charts,
+\emph{Statistical Papers 46}, 47-64.
+
+S. Knoth (2014?),
+tbd,
+\emph{tbd}, tbd-tbd.
+}
+\author{Sven Knoth}
+\seealso{
+\code{xewma.arl} for the usual zero-state ARL computation.
+}
+\examples{
+## Jones/Champ/Rigdon (2001)
+
+c4m <- function(m, n) sqrt(2)*gamma( (m*(n-1)+1)/2 )/sqrt( m*(n-1) )/gamma( m*(n-1)/2 )
+
+n <- 5 # sample size
+m <- 20 # pre run with 20 samples of size n = 5
+C4m <- c4m(m, n) # needed for bias correction
+
+# Table 1, 3rd column
+lambda <- 0.2
+L <- 2.636
+
+xewma.ARL <- Vectorize("xewma.arl", "mu")
+xewma.ARL.prerun <- Vectorize("xewma.arl.prerun", "mu")
+
+mu <- c(0, .25, .5, 1, 1.5, 2)
+ARL <- round(xewma.ARL(lambda, L, mu, sided="two"), digits=2)
+p.ARL <- round(xewma.ARL.prerun(lambda, L/C4m, mu, sided="two",
+size=m, df=m*(n-1), estimated="both", qm.mu=70), digits=2)
+
+# Monte-Carlo with 10^8 repetitions: 200.325 (0.020) and 144.458 (0.022)
+cbind(mu, ARL, p.ARL)
+
+\dontrun{
+# Figure 5, subfigure r = 0.2
+mu_ <- (0:85)/40
+ARL_ <- round(xewma.ARL(lambda, L, mu_, sided="two"), digits=2)
+p.ARL_ <- round(xewma.ARL.prerun(lambda, L/C4m, mu_, sided="two",
+size=m, df=m*(n-1), estimated="both"), digits=2)
+
+plot(mu_, ARL_, type="l", xlab=expression(delta), ylab="ARL", xlim=c(0,2))
+abline(v=0, h=0, col="grey", lwd=.7)
+points(mu, ARL, pch=5)
+lines(mu_, p.ARL_, col="blue")
+points(mu, p.ARL, pch=18, col ="blue")
+legend("topright", c("Known", "Estimated"), col=c("black", "blue"),
+lty=1, pch=c(5, 18))
+}
+}
+\keyword{ts}
diff --git a/man/xewma.crit.Rd b/man/xewma.crit.Rd
new file mode 100644
index 0000000..fd6cb43
--- /dev/null
+++ b/man/xewma.crit.Rd
@@ -0,0 +1,51 @@
+\name{xewma.crit}
+\alias{xewma.crit}
+\title{Compute critical values of EWMA control charts}
+\description{Computation of the critical values (similar to alarm limits)
+for different types of EWMA control charts monitoring normal mean.}
+\usage{xewma.crit(l,L0,mu0=0,zr=0,hs=0,sided="one",limits="fix",r=40,c0=NULL)}
+\arguments{
+\item{l}{smoothing parameter lambda of the EWMA control chart.}
+\item{L0}{in-control ARL.}
+\item{mu0}{in-control mean.}
+\item{zr}{reflection border for the one-sided chart.}
+\item{hs}{so-called headstart (enables fast initial response).}
+\item{sided}{distinguishes between one- and two-sided
+two-sided EWMA control chart by choosing \code{"one"} and \code{"two"},
+respectively.}
+\item{limits}{distinguishes between different control limits behavior.}
+\item{r}{number of quadrature nodes, dimension of the resulting linear
+equation system is equal to \code{r+1} (one-sided) or \code{r}
+(two-sided).}
+\item{c0}{starting value for iteration rule.}
+}
+\details{
+\code{xewma.crit} determines the critical values (similar to alarm limits)
+for given in-control ARL \code{L0}
+by applying secant rule and using \code{xewma.arl()}.
+}
+\value{Returns a single value which resembles the critical value
+\code{c}.}
+\references{
+S. V. Crowder (1989), Design of exponentially weighted moving average
+schemes, \emph{Journal of Quality Technology 21}, 155-162.
+}
+\author{Sven Knoth}
+\seealso{\code{xewma.arl} for zero-state ARL computation.}
+\examples{
+l <- .1
+incontrolARL <- c(500,5000,50000)
+sapply(incontrolARL,l=l,sided="two",xewma.crit,r=35) # accuracy with 35 nodes
+sapply(incontrolARL,l=l,sided="two",xewma.crit) # accuracy with 40 nodes
+sapply(incontrolARL,l=l,sided="two",xewma.crit,r=50) # accuracy with 50 nodes
+
+## Crowder (1989)
+## two-sided EWMA control charts with fixed limits
+
+l <- c(.05,.1,.15,.2,.25)
+L0 <- 250
+round(sapply(l,L0=L0,sided="two",xewma.crit),digits=2)
+
+## original values are 2.32, 2.55, 2.65, 2.72, and 2.76.
+}
+\keyword{ts}
diff --git a/man/xewma.q.Rd b/man/xewma.q.Rd
new file mode 100644
index 0000000..1692b5c
--- /dev/null
+++ b/man/xewma.q.Rd
@@ -0,0 +1,100 @@
+\name{xewma.q}
+\alias{xewma.q}
+\alias{xewma.q.crit}
+\title{Compute RL quantiles of EWMA control charts}
+\description{Computation of quantiles of the Run Length (RL)
+for EWMA control charts monitoring normal mean.}
+\usage{xewma.q(l, c, mu, alpha, zr=0, hs=0, sided="two", limits="fix", q=1, r=40)
+
+xewma.q.crit(l, L0, mu, alpha, zr=0, hs=0, sided="two", limits="fix", r=40,
+c.error=1e-12, a.error=1e-9, OUTPUT=FALSE)}
+\arguments{
+\item{l}{smoothing parameter lambda of the EWMA control chart.}
+\item{c}{critical value (similar to alarm limit) of the EWMA control chart.}
+\item{mu}{true mean.}
+\item{alpha}{quantile level.}
+\item{zr}{reflection border for the one-sided chart.}
+\item{hs}{so-called headstart (enables fast initial response).}
+\item{sided}{distinguishes between one- and two-sided EWMA control chart
+by choosing \code{"one"} and \code{"two"}, respectively.}
+\item{limits}{distinguishes between different control limits behavior.}
+\item{q}{change point position. For \eqn{q=1} and
+\eqn{\mu=\mu_0} and \eqn{\mu=\mu_1}, the usual
+zero-state ARLs for the in-control and out-of-control case, respectively,
+are calculated. For \eqn{q>1} and \eqn{\mu!=0} conditional delays, that is,
+\eqn{E_q(L-q+1|L\geq)}, will be determined.
+Note that mu0=0 is implicitely fixed.}
+\item{r}{number of quadrature nodes, dimension of the resulting linear
+equation system is equal to \code{r+1} (one-sided) or \code{r}
+(two-sided).}
+\item{L0}{in-control quantile value.}
+\item{c.error}{error bound for two succeeding values of the critical value
+during applying the secant rule.}
+\item{a.error}{error bound for the quantile level \code{alpha} during applying
+the secant rule.}
+\item{OUTPUT}{activate or deactivate additional output.}
+}
+\details{
+Instead of the popular ARL (Average Run Length) quantiles of the EWMA
+stopping time (Run Length) are determined. The algorithm is based on
+Waldmann's survival function iteration procedure.
+If \code{limits} is not \code{"fix"}, then the method presented
+in Knoth (2003) is utilized.
+Note that for one-sided EWMA charts (\code{sided}=\code{"one"}), only
+\code{"vacl"} and \code{"stat"} are deployed, while for two-sided ones
+(\code{sided}=\code{"two"}) also \code{"fir"}, \code{"both"}
+(combination of \code{"fir"} and \code{"vacl"}), and \code{"Steiner"} are
+implemented. For details see Knoth (2004).
+}
+\value{Returns a single value which resembles the RL quantile of order \code{q}.}
+\references{
+F. F. Gan (1993),
+An optimal design of EWMA control charts based on the median run length,
+\emph{J. Stat. Comput. Simulation 45}, 169-184.
+
+S. Knoth (2003),
+EWMA schemes with non-homogeneous transition kernels,
+\emph{Sequential Analysis 22}, 241-255.
+
+S. Knoth (2004),
+Fast initial response features for EWMA Control Charts,
+\emph{Statistical Papers 46}, 47-64.
+
+K.-H. Waldmann (1986),
+Bounds for the distribution of the run length of geometric moving
+average charts, \emph{Appl. Statist. 35}, 151-158.
+}
+\author{Sven Knoth}
+\seealso{
+\code{xewma.arl} for zero-state ARL computation of EWMA control charts.
+}
+\examples{
+## Gan (1993), two-sided EWMA with fixed control limits
+## some values of his Table 1 -- any median RL should be 500
+XEWMA.Q <- Vectorize("xewma.q", c("l", "c"))
+G.lambda <- c(.05, .1, .15, .2, .25)
+G.h <- c(.441, .675, .863, 1.027, 1.177)
+MEDIAN <- ceiling(XEWMA.Q(G.lambda, G.h/sqrt(G.lambda/(2-G.lambda)),
+0, .5, sided="two"))
+print(cbind(G.lambda, MEDIAN))
+
+## increase accuracy of thresholds
+
+# (i) calculate threshold for given in-control median value by
+# deplyoing secant rule
+XEWMA.q.crit <- Vectorize("xewma.q.crit", "l")
+
+# (ii) re-calculate the thresholds and remove the standardization step
+L0 <- 500
+G.h.new <- XEWMA.q.crit(G.lambda, L0, 0, .5, sided="two")
+G.h.new <- round(G.h.new * sqrt(G.lambda/(2-G.lambda)), digits=5)
+
+# (iii) compare Gan's original values and the new ones with 5 digits
+print(cbind(G.lambda, G.h.new, G.h))
+
+# (iv) calculate the new medians
+MEDIAN <- ceiling(XEWMA.Q(G.lambda, G.h.new/sqrt(G.lambda/(2-G.lambda)),
+0, .5, sided="two"))
+print(cbind(G.lambda, MEDIAN))
+}
+\keyword{ts}
diff --git a/man/xewma.q.prerun.Rd b/man/xewma.q.prerun.Rd
new file mode 100644
index 0000000..40dc690
--- /dev/null
+++ b/man/xewma.q.prerun.Rd
@@ -0,0 +1,120 @@
+\name{xewma.q.prerun}
+\alias{xewma.q.prerun}
+\alias{xewma.q.crit.prerun}
+\title{Compute RL quantiles of EWMA control charts in case of estimated parameters}
+\description{Computation of quantiles of the Run Length (RL)
+for EWMA control charts monitoring normal mean
+if the in-control mean, standard deviation, or both are estimated by a pre run.}
+\usage{xewma.q.prerun(l, c, mu, p, zr=0, hs=0, sided="two", limits="fix", q=1, size=100,
+df=NULL, estimated="mu", qm.mu=30, qm.sigma=30, truncate=1e-10, bound=1e-10)
+
+xewma.q.crit.prerun(l, L0, mu, p, zr=0, hs=0, sided="two", limits="fix", size=100,
+df=NULL, estimated="mu", qm.mu=30, qm.sigma=30, truncate=1e-10, bound=1e-10,
+c.error=1e-10, p.error=1e-9, OUTPUT=FALSE)}
+\arguments{
+\item{l}{smoothing parameter lambda of the EWMA control chart.}
+\item{c}{critical value (similar to alarm limit) of the EWMA control chart.}
+\item{mu}{true mean shift.}
+\item{p}{quantile level.}
+\item{zr}{reflection border for the one-sided chart.}
+\item{hs}{so-called headstart (give fast initial response).}
+\item{sided}{distinguish between one- and two-sided EWMA control chart
+by choosing \code{"one"} and \code{"two"}, respectively.}
+\item{limits}{distinguish between different control limits behavior.}
+\item{q}{change point position. For \eqn{q=1} and
+\eqn{\mu=\mu_0} and \eqn{\mu=\mu_1}, the usual
+zero-state ARLs for the in-control and out-of-control case, respectively,
+are calculated. For \eqn{q>1} and \eqn{\mu!=0} conditional delays, that is,
+\eqn{E_q(L-q+1|L\geq)}, will be determined.
+Note that mu0=0 is implicitely fixed.}
+\item{size}{pre run sample size.}
+\item{df}{Degrees of freedom of the pre run variance estimator. Typically it is simply \code{size} - 1.
+If the pre run is collected in batches, then also other values are needed.}
+\item{estimated}{name the parameter to be estimated within the \code{"mu"}, \code{"sigma"},
+\code{"both"}.}
+\item{qm.mu}{number of quadrature nodes for convoluting the mean uncertainty.}
+\item{qm.sigma}{number of quadrature nodes for convoluting the standard deviation uncertainty.}
+\item{truncate}{size of truncated tail.}
+\item{bound}{control when the geometric tail kicks in; the larger the quicker and less accurate; \code{bound} should be larger than 0 and less than 0.001.}
+\item{L0}{in-control quantile value.}
+\item{c.error}{error bound for two succeeding values of the critical value during
+applying the secant rule.}
+\item{p.error}{error bound for the quantile level \code{p} during applying the secant rule.}
+\item{OUTPUT}{activate or deactivate additional output.}
+}
+\details{
+Essentially, the ARL function \code{xewma.q} is convoluted with the
+distribution of the sample mean, standard deviation or both.
+For details see Jones/Champ/Rigdon (2001) and Knoth (2014?).
+}
+\value{Returns a single value which resembles the RL quantile of order \code{q}.}
+\references{
+L. A. Jones, C. W. Champ, S. E. Rigdon (2001),
+The performance of exponentially weighted moving average charts
+with estimated parameters,
+\emph{Technometrics 43}, 156-167.
+
+S. Knoth (2003),
+EWMA schemes with non-homogeneous transition kernels,
+\emph{Sequential Analysis 22}, 241-255.
+
+S. Knoth (2004),
+Fast initial response features for EWMA Control Charts,
+\emph{Statistical Papers 46}, 47-64.
+
+S. Knoth (2014?),
+tbd,
+\emph{tbd}, tbd-tbd.
+
+K.-H. Waldmann (1986),
+Bounds for the distribution of the run length of geometric moving
+average charts, \emph{Appl. Statist. 35}, 151-158.
+}
+\author{Sven Knoth}
+\seealso{
+\code{xewma.q} for the usual RL quantiles computation of EWMA control charts.
+}
+\examples{
+## Jones/Champ/Rigdon (2001)
+
+c4m <- function(m, n) sqrt(2)*gamma( (m*(n-1)+1)/2 )/sqrt( m*(n-1) )/gamma( m*(n-1)/2 )
+
+n <- 5 # sample size
+m <- 20 # pre run with 20 samples of size n = 5
+C4m <- c4m(m, n) # needed for bias correction
+
+# Table 1, 3rd column
+lambda <- 0.2
+L <- 2.636
+
+xewma.Q <- Vectorize("xewma.q", "mu")
+xewma.Q.prerun <- Vectorize("xewma.q.prerun", "mu")
+
+mu <- c(0, .25, .5, 1, 1.5, 2)
+Q1 <- ceiling(xewma.Q(lambda, L, mu, 0.1, sided="two"))
+Q2 <- ceiling(xewma.Q(lambda, L, mu, 0.5, sided="two"))
+Q3 <- ceiling(xewma.Q(lambda, L, mu, 0.9, sided="two"))
+
+cbind(mu, Q1, Q2, Q3)
+
+\dontrun{
+p.Q1 <- xewma.Q.prerun(lambda, L/C4m, mu, 0.1, sided="two",
+size=m, df=m*(n-1), estimated="both")
+p.Q2 <- xewma.Q.prerun(lambda, L/C4m, mu, 0.5, sided="two",
+size=m, df=m*(n-1), estimated="both")
+p.Q3 <- xewma.Q.prerun(lambda, L/C4m, mu, 0.9, sided="two",
+size=m, df=m*(n-1), estimated="both")
+
+cbind(mu, p.Q1, p.Q2, p.Q3)
+}
+
+## original values are
+# mu Q1 Q2 Q3 p.Q1 p.Q2 p.Q3
+# 0.00 25 140 456 13 73 345
+# 0.25 12 56 174 9 46 253
+# 0.50 7 20 56 6 20 101
+# 1.00 4 7 15 3 7 18
+# 1.50 3 4 7 2 4 8
+# 2.00 2 3 5 2 3 5
+}
+\keyword{ts}
diff --git a/man/xewma.sf.Rd b/man/xewma.sf.Rd
new file mode 100644
index 0000000..e4cf763
--- /dev/null
+++ b/man/xewma.sf.Rd
@@ -0,0 +1,70 @@
+\name{xewma.sf}
+\alias{xewma.sf}
+\title{Compute the survival function of EWMA run length}
+\description{Computation of the survival function of the Run Length (RL) for EWMA control charts monitoring normal mean.}
+\usage{xewma.sf(l, c, mu, n, zr=0, hs=0, sided="one", limits="fix", q=1, r=40)}
+\arguments{
+\item{l}{smoothing parameter lambda of the EWMA control chart.}
+\item{c}{critical value (similar to alarm limit) of the EWMA control chart.}
+\item{mu}{true mean.}
+\item{n}{calculate sf up to value \code{n}.}
+\item{zr}{reflection border for the one-sided chart.}
+\item{hs}{so-called headstart (enables fast initial response).}
+\item{sided}{distinguishes between one- and two-sided EWMA control chart
+by choosing \code{"one"} and \code{"two"}, respectively.}
+\item{limits}{distinguishes between different control limits behavior.}
+\item{q}{change point position. For \eqn{q=1} and
+\eqn{\mu=\mu_0} and \eqn{\mu=\mu_1}, the usual
+zero-state situation for the in-control and out-of-control case, respectively,
+are calculated. Note that mu0=0 is implicitely fixed.}
+\item{r}{number of quadrature nodes, dimension of the resulting linear
+equation system is equal to \code{r+1} (one-sided) or \code{r} (two-sided).}
+}
+\details{
+The survival function P(L>n) and derived from it also the cdf P(L<=n) and the pmf P(L=n) illustrate
+the distribution of the EWMA run length. For large n the geometric tail could be exploited. That is,
+with reasonable large n the complete distribution is characterized.
+The algorithm is based on Waldmann's survival function iteration procedure.
+For varying limits and for change points after 1 the algorithm from Knoth (2004) is applied.
+Note that for one-sided EWMA charts (\code{sided}=\code{"one"}), only
+\code{"vacl"} and \code{"stat"} are deployed, while for two-sided ones
+(\code{sided}=\code{"two"}) also \code{"fir"}, \code{"both"}
+(combination of \code{"fir"} and \code{"vacl"}), and \code{"Steiner"} are implemented.
+For details see Knoth (2004).
+}
+\value{Returns a vector which resembles the survival function up to a certain point.}
+\references{
+F. F. Gan (1993),
+An optimal design of EWMA control charts based on the median run length,
+\emph{J. Stat. Comput. Simulation 45}, 169-184.
+
+S. Knoth (2003),
+EWMA schemes with non-homogeneous transition kernels,
+\emph{Sequential Analysis 22}, 241-255.
+
+S. Knoth (2004),
+Fast initial response features for EWMA Control Charts,
+\emph{Statistical Papers 46}, 47-64.
+
+K.-H. Waldmann (1986),
+Bounds for the distribution of the run length of geometric moving
+average charts, \emph{Appl. Statist. 35}, 151-158.
+}
+\author{Sven Knoth}
+\seealso{
+\code{xewma.arl} for zero-state ARL computation of EWMA control charts.
+}
+\examples{
+## Gan (1993), two-sided EWMA with fixed control limits
+## some values of his Table 1 -- any median RL should be 500
+
+G.lambda <- c(.05, .1, .15, .2, .25)
+G.h <- c(.441, .675, .863, 1.027, 1.177)/sqrt(G.lambda/(2-G.lambda))
+
+for ( i in 1:length(G.lambda) ) {
+ SF <- xewma.sf(G.lambda[i], G.h[i], 0, 1000)
+ if (i==1) plot(1:length(SF), SF, type="l", xlab="n", ylab="P(L>n)")
+ else lines(1:length(SF), SF, col=i)
+}
+}
+\keyword{ts}
diff --git a/man/xewma.sf.prerun.Rd b/man/xewma.sf.prerun.Rd
new file mode 100644
index 0000000..42b2117
--- /dev/null
+++ b/man/xewma.sf.prerun.Rd
@@ -0,0 +1,103 @@
+\name{xewma.sf.prerun}
+\alias{xewma.sf.prerun}
+\title{Compute the survival function of EWMA run length in case of estimated parameters}
+\description{Computation of the survival function of the Run Length (RL) for EWMA
+control charts monitoring normal mean
+if the in-control mean, standard deviation, or both are estimated by a pre run.}
+\usage{xewma.sf.prerun(l, c, mu, n, zr=0, hs=0, sided="one", limits="fix", q=1,
+size=100, df=NULL, estimated="mu", qm.mu=30, qm.sigma=30,
+truncate=1e-10, tail_approx=TRUE, bound=1e-10)}
+\arguments{
+\item{l}{smoothing parameter lambda of the EWMA control chart.}
+\item{c}{critical value (similar to alarm limit) of the EWMA control chart.}
+\item{mu}{true mean.}
+\item{n}{calculate sf up to value \code{n}.}
+\item{zr}{reflection border for the one-sided chart.}
+\item{hs}{so-called headstart (give fast initial response).}
+\item{sided}{distinguish between one- and two-sided EWMA control chart
+by choosing \code{"one"} and \code{"two"}, respectively.}
+\item{limits}{distinguish between different control limits behavior.}
+\item{q}{change point position. For \eqn{q=1} and
+\eqn{\mu=\mu_0} and \eqn{\mu=\mu_1}, the usual
+zero-state situation for the in-control and out-of-control case, respectively,
+are calculated. Note that mu0=0 is implicitely fixed.}
+\item{size}{pre run sample size.}
+\item{df}{degrees of freedom of the pre run variance estimator. Typically it is simply \code{size} - 1.
+If the pre run is collected in batches, then also other
+values are needed.}
+\item{estimated}{name the parameter to be estimated within the \code{"mu"},
+\code{"sigma"}, \code{"both"}.}
+\item{qm.mu}{number of quadrature nodes for convoluting the mean uncertainty.}
+\item{qm.sigma}{number of quadrature nodes for convoluting the standard deviation uncertainty.}
+\item{truncate}{size of truncated tail.}
+\item{tail_approx}{Controls whether the geometric tail approximation is used (is faster) or not.}
+\item{bound}{control when the geometric tail kicks in; the larger the quicker and less accurate; \code{bound} should be larger than 0 and less than 0.001.}
+}
+\details{
+The survival function P(L>n) and derived from it also the cdf P(L<=n) and
+the pmf P(L=n) illustrate the distribution of the EWMA run length...
+}
+\value{Returns a vector which resembles the survival function up to a certain point.}
+\references{
+F. F. Gan (1993),
+An optimal design of EWMA control charts based on the median run length,
+\emph{J. Stat. Comput. Simulation 45}, 169-184.
+
+S. Knoth (2003),
+EWMA schemes with non-homogeneous transition kernels,
+\emph{Sequential Analysis 22}, 241-255.
+
+S. Knoth (2004),
+Fast initial response features for EWMA Control Charts,
+\emph{Statistical Papers 46}, 47-64.
+
+L. A. Jones, C. W. Champ, S. E. Rigdon (2001),
+The performance of exponentially weighted moving average charts
+with estimated parameters,
+\emph{Technometrics 43}, 156-167.
+
+K.-H. Waldmann (1986),
+Bounds for the distribution of the run length of geometric moving
+average charts, \emph{Appl. Statist. 35}, 151-158.
+}
+\author{Sven Knoth}
+\seealso{
+\code{xewma.sf} for the RL survival function of EWMA control charts
+w/o pre run uncertainty.
+}
+\examples{
+## Jones/Champ/Rigdon (2001)
+
+c4m <- function(m, n) sqrt(2)*gamma( (m*(n-1)+1)/2 )/sqrt( m*(n-1) )/gamma( m*(n-1)/2 )
+
+n <- 5 # sample size
+
+# Figure 6, subfigure r=0.1
+lambda <- 0.1
+L <- 2.454
+
+CDF0 <- 1 - xewma.sf(lambda, L, 0, 600, sided="two")
+m <- 10 # pre run size
+CDF1 <- 1 - xewma.sf.prerun(lambda, L/c4m(m,n), 0, 600, sided="two",
+size=m, df=m*(n-1), estimated="both")
+m <- 20
+CDF2 <- 1 - xewma.sf.prerun(lambda, L/c4m(m,n), 0, 600, sided="two",
+size=m, df=m*(n-1), estimated="both")
+m <- 50
+CDF3 <- 1 - xewma.sf.prerun(lambda, L/c4m(m,n), 0, 600, sided="two",
+size=m, df=m*(n-1), estimated="both")
+
+plot(CDF0, type="l", xlab="t", ylab=expression(P(T<=t)), xlim=c(0,500), ylim=c(0,1))
+abline(v=0, h=c(0,1), col="grey", lwd=.7)
+points((1:5)*100, CDF0[(1:5)*100], pch=18)
+lines(CDF1, col="blue")
+points((1:5)*100, CDF1[(1:5)*100], pch=2, col="blue")
+lines(CDF2, col="red")
+points((1:5)*100, CDF2[(1:5)*100], pch=16, col="red")
+lines(CDF3, col="green")
+points((1:5)*100, CDF3[(1:5)*100], pch=5, col="green")
+
+legend("bottomright", c("Known", "m=10, n=5", "m=20, n=5", "m=50, n=5"),
+ col=c("black", "blue", "red", "green"), pch=c(18, 2, 16, 5), lty=1)
+}
+\keyword{ts}
diff --git a/man/xgrsr.ad.Rd b/man/xgrsr.ad.Rd
new file mode 100644
index 0000000..94da80e
--- /dev/null
+++ b/man/xgrsr.ad.Rd
@@ -0,0 +1,89 @@
+\name{xgrsr.ad}
+\alias{xgrsr.ad}
+\title{Compute steady-state ARLs of Shiryaev-Roberts schemes}
+\description{Computation of the steady-state Average Run Length (ARL)
+for Shiryaev-Roberts schemes monitoring normal mean.}
+\usage{xgrsr.ad(k, g, mu1, mu0 = 0, zr = 0, sided = "one", MPT = FALSE, r = 30)}
+\arguments{
+\item{k}{reference value of the Shiryaev-Roberts scheme.}
+\item{g}{control limit (alarm threshold) of Shiryaev-Roberts scheme.}
+\item{mu1}{out-of-control mean.}
+\item{mu0}{in-control mean.}
+\item{zr}{reflection border to enable the numerical algorithms used here.}
+\item{sided}{distinguishes between one- and two-sided schemes by choosing
+\code{"one"} and\code{"two"}, respectively. Currently only one-sided schemes are
+implemented.}
+\item{MPT}{switch between the old implementation (\code{FALSE}) and the new one (\code{TRUE}) that considers the completed
+likelihood ratio. MPT contains the initials of G. Moustakides, A. Polunchenko and A. Tartakovsky.}
+\item{r}{number of quadrature nodes, dimension of the resulting linear
+equation system is equal to \code{r+1}.}
+}
+\details{
+\code{xgrsr.ad} determines the steady-state Average Run Length (ARL) by numerically
+solving the related ARL integral equation by means of the Nystroem method
+based on Gauss-Legendre quadrature.
+}
+\value{Returns a single value which resembles the steady-state ARL.}
+\references{
+S. Knoth (2006),
+The art of evaluating monitoring schemes --
+how to measure the performance of control charts?
+S. Lenz, H. & Wilrich, P. (ed.),
+\emph{Frontiers in Statistical Quality Control 8}, Physica Verlag, Heidelberg, Germany, 74-99.
+
+G. Moustakides, A. Polunchenko, A. Tartakovsky (2009),
+Numerical comparison of CUSUM and Shiryaev-Roberts procedures for
+detectin changes in distributions,
+\emph{Communications in Statistics: Theory and Methods 38}, 3225-3239.
+}
+\author{Sven Knoth}
+\seealso{
+\code{xewma.arl} and \code{xcusum-arl} for zero-state ARL computation of EWMA and CUSUM control charts,
+respectively, and \code{xgrsr.arl} for the zero-state ARL.
+}
+\examples{
+## Small study to identify appropriate reflection border to mimic unreflected schemes
+k <- .5
+g <- log(390)
+zrs <- -(0:10)
+ZRxgrsr.ad <- Vectorize(xgrsr.ad, "zr")
+ads <- ZRxgrsr.ad(k, g, 0, zr=zrs)
+data.frame(zrs, ads)
+
+## Table 2 from Knoth (2006)
+## original values are
+# mu arl
+# 0 689
+# 0.5 30
+# 1 8.9
+# 1.5 5.1
+# 2 3.6
+# 2.5 2.8
+# 3 2.4
+#
+k <- .5
+g <- log(390)
+zr <- -5 # see first example
+mus <- (0:6)/2
+Mxgrsr.ad <- Vectorize(xgrsr.ad, "mu1")
+ads <- round(Mxgrsr.ad(k, g, mus, zr=zr), digits=1)
+data.frame(mus, ads)
+
+## Table 4 from Moustakides et al. (2009)
+## original values are
+# gamma A STADD/steady-state ARL
+# 50 28.02 4.37
+# 100 56.04 5.46
+# 500 280.19 8.33
+# 1000 560.37 9.64
+# 5000 2801.75 12.79
+# 10000 5603.7 14.17
+Gxgrsr.ad <- Vectorize("xgrsr.ad", "g")
+As <- c(28.02, 56.04, 280.19, 560.37, 2801.75, 5603.7)
+gs <- log(As)
+theta <- 1
+zr <- -6
+ads <- round(Gxgrsr.ad(theta/2, gs, theta, zr=zr, r=100), digits=2)
+data.frame(As, ads)
+}
+\keyword{ts}
diff --git a/man/xgrsr.arl.Rd b/man/xgrsr.arl.Rd
new file mode 100644
index 0000000..995f1f1
--- /dev/null
+++ b/man/xgrsr.arl.Rd
@@ -0,0 +1,133 @@
+\name{xgrsr.arl}
+\alias{xgrsr.arl}
+\title{Compute (zero-state) ARLs of Shiryaev-Roberts schemes}
+\description{Computation of the (zero-state) Average Run Length (ARL)
+for Shiryaev-Roberts schemes monitoring normal mean.}
+\usage{xgrsr.arl(k, g, mu, zr = 0, hs=NULL, sided = "one", q = 1, MPT = FALSE, r = 30)}
+\arguments{
+\item{k}{reference value of the Shiryaev-Roberts scheme.}
+\item{g}{control limit (alarm threshold) of Shiryaev-Roberts scheme.}
+\item{mu}{true mean.}
+\item{zr}{reflection border to enable the numerical algorithms used here.}
+\item{hs}{so-called headstart (enables fast initial response). If \code{hs=NULL}, then
+the classical headstart -Inf is used (corresponds to 0 for the non-log scheme).}
+\item{sided}{distinguishes between one- and two-sided schemes by choosing
+\code{"one"} and\code{"two"}, respectively. Currently only one-sided schemes are
+implemented.}
+\item{q}{change point position. For \eqn{q=1} and
+\eqn{\mu=\mu_0} and \eqn{\mu=\mu_1}, the usual
+zero-state ARLs for the in-control and out-of-control case, respectively,
+are calculated. For \eqn{q>1} and \eqn{\mu!=0} conditional delays, that is,
+\eqn{E_q(L-q+1|L\ge q)}, will be determined.
+Note that mu0=0 is implicitely fixed.}
+\item{MPT}{switch between the old implementation (\code{FALSE}) and the new one (\code{TRUE}) that considers the complete
+likelihood ratio. MPT stands for the initials of G. Moustakides, A. Polunchenko and A. Tartakovsky.}
+\item{r}{number of quadrature nodes, dimension of the resulting linear
+equation system is equal to \code{r+1}.}
+}
+\details{
+\code{xgrsr.arl} determines the Average Run Length (ARL) by numerically
+solving the related ARL integral equation by means of the Nystroem method
+based on Gauss-Legendre quadrature.
+}
+\value{Returns a vector of length \code{q} which resembles the ARL and the sequence of conditional expected delays for
+\code{q}=1 and \code{q}>1, respectively.}
+\references{
+S. Knoth (2006),
+The art of evaluating monitoring schemes --
+how to measure the performance of control charts?
+S. Lenz, H. & Wilrich, P. (ed.),
+\emph{Frontiers in Statistical Quality Control 8}, Physica Verlag, Heidelberg, Germany, 74-99.
+
+G. Moustakides, A. Polunchenko, A. Tartakovsky (2009),
+Numerical comparison of CUSUM and Shiryaev-Roberts procedures for detecting changes in distributions,
+\emph{Communications in Statistics: Theory and Methods 38}, 3225-3239.
+}
+\author{Sven Knoth}
+\seealso{
+\code{xewma.arl} and \code{xcusum-arl} for zero-state ARL computation of EWMA and CUSUM control charts,
+respectively, and \code{xgrsr.ad} for the steady-state ARL.
+}
+\examples{
+## Small study to identify appropriate reflection border to mimic unreflected schemes
+k <- .5
+g <- log(390)
+zrs <- -(0:10)
+ZRxgrsr.arl <- Vectorize(xgrsr.arl, "zr")
+arls <- ZRxgrsr.arl(k, g, 0, zr=zrs)
+data.frame(zrs, arls)
+
+## Table 2 from Knoth (2006)
+## original values are
+# mu arl
+# 0 697
+# 0.5 33
+# 1 10.4
+# 1.5 6.2
+# 2 4.4
+# 2.5 3.5
+# 3 2.9
+#
+k <- .5
+g <- log(390)
+zr <- -5 # see first example
+mus <- (0:6)/2
+Mxgrsr.arl <- Vectorize(xgrsr.arl, "mu")
+arls <- round(Mxgrsr.arl(k, g, mus, zr=zr), digits=1)
+data.frame(mus, arls)
+
+XGRSR.arl <- Vectorize("xgrsr.arl", "g")
+zr <- -6
+
+## Table 2 from Moustakides et al. (2009)
+## original values are
+# gamma A ARL/E_infty(L) SADD/E_1(L)
+# 50 47.17 50.29 41.40
+# 100 94.34 100.28 72.32
+# 500 471.70 500.28 209.44
+# 1000 943.41 1000.28 298.50
+# 5000 4717.04 5000.24 557.87
+#10000 9434.08 10000.17 684.17
+
+theta <- .1
+As2 <- c(47.17, 94.34, 471.7, 943.41, 4717.04, 9434.08)
+gs2 <- log(As2)
+arls0 <- round(XGRSR.arl(theta/2, gs2, 0, zr=-5, r=300, MPT=TRUE), digits=2)
+arls1 <- round(XGRSR.arl(theta/2, gs2, theta, zr=-5, r=300, MPT=TRUE), digits=2)
+data.frame(As2, arls0, arls1)
+
+## Table 3 from Moustakides et al. (2009)
+## original values are
+# gamma A ARL/E_infty(L) SADD/E_1(L)
+# 50 37.38 49.45 12.30
+# 100 74.76 99.45 16.60
+# 500 373.81 499.45 28.05
+# 1000 747.62 999.45 33.33
+# 5000 3738.08 4999.45 45.96
+#10000 7476.15 9999.24 51.49
+
+theta <- .5
+As3 <- c(37.38, 74.76, 373.81, 747.62, 3738.08, 7476.15)
+gs3 <- log(As3)
+arls0 <- round(XGRSR.arl(theta/2, gs3, 0, zr=-5, r=70, MPT=TRUE), digits=2)
+arls1 <- round(XGRSR.arl(theta/2, gs3, theta, zr=-5, r=70, MPT=TRUE), digits=2)
+data.frame(As3, arls0, arls1)
+
+## Table 4 from Moustakides et al. (2009)
+## original values are
+# gamma A ARL/E_infty(L) SADD/E_1(L)
+# 50 28.02 49.78 4.98
+# 100 56.04 99.79 6.22
+# 500 280.19 499.79 9.30
+# 1000 560.37 999.79 10.66
+# 5000 2801.85 5000.93 13.86
+#10000 5603.70 9999.87 15.24
+
+theta <- 1
+As4 <- c(28.02, 56.04, 280.19, 560.37, 2801.85, 5603.7)
+gs4 <- log(As4)
+arls0 <- round(XGRSR.arl(theta/2, gs4, 0, zr=-6, r=40, MPT=TRUE), digits=2)
+arls1 <- round(XGRSR.arl(theta/2, gs4, theta, zr=-6, r=40, MPT=TRUE), digits=2)
+data.frame(As4, arls0, arls1)
+}
+\keyword{ts}
diff --git a/man/xgrsr.crit.Rd b/man/xgrsr.crit.Rd
new file mode 100644
index 0000000..3328b25
--- /dev/null
+++ b/man/xgrsr.crit.Rd
@@ -0,0 +1,53 @@
+\name{xgrsr.crit}
+\alias{xgrsr.crit}
+\title{Compute alarm thresholds for Shiryaev-Roberts schemes}
+\description{Computation of the alarm thresholds (alarm limits)
+for Shiryaev-Roberts schemes monitoring normal mean.}
+\usage{xgrsr.crit(k, L0, mu0 = 0, zr = 0, hs = NULL, sided = "one", MPT = FALSE, r = 30)}
+\arguments{
+\item{k}{reference value of the Shiryaev-Roberts scheme.}
+\item{L0}{in-control ARL.}
+\item{mu0}{in-control mean.}
+\item{zr}{reflection border to enable the numerical algorithms used here.}
+\item{hs}{so-called headstart (enables fast initial response). If \code{hs=NULL}, then
+the classical headstart -Inf is used (corresponds to 0 for the non-log scheme).}
+\item{sided}{distinguishes between one- and two-sided schemes by choosing
+\code{"one"} and\code{"two"}, respectively. Currently only one-sided schemes are
+implemented.}
+\item{MPT}{switch between the old implementation (\code{FALSE}) and the new one (\code{TRUE}) that considers the completed
+likelihood ratio. MPT contains the initials of G. Moustakides, A. Polunchenko and A. Tartakovsky.}
+\item{r}{number of quadrature nodes, dimension of the resulting linear
+equation system is equal to \code{r+1}.}
+}
+\details{
+\code{xgrsr.crit} determines the alarm threshold (alarm limit)
+for given in-control ARL \code{L0}
+by applying secant rule and using \code{xgrsr.arl()}.
+}
+\value{Returns a single value which resembles the alarm limit \code{g}.}
+\references{
+G. Moustakides, A. Polunchenko, A. Tartakovsky (2009),
+Numerical comparison of CUSUM and Shiryaev-Roberts procedures for detecting changes in distributions,
+\emph{Communications in Statistics: Theory and Methods 38}, 3225-3239.r.
+}
+\author{Sven Knoth}
+\seealso{\code{xgrsr.arl} for zero-state ARL computation.}
+\examples{
+## Table 4 from Moustakides et al. (2009)
+## original values are
+# gamma/L0 A/exp(g)
+# 50 28.02
+# 100 56.04
+# 500 280.19
+# 1000 560.37
+# 5000 2801.75
+# 10000 5603.7
+theta <- 1
+zr <- -6
+r <- 100
+Lxgrsr.crit <- Vectorize("xgrsr.crit", "L0")
+L0s <- c(50, 100, 500, 1000, 5000, 10000)
+gs <- Lxgrsr.crit(theta/2, L0s, zr=zr, r=r)
+data.frame(L0s, gs, A=round(exp(gs), digits=2))
+}
+\keyword{ts}
diff --git a/man/xsewma.arl.Rd b/man/xsewma.arl.Rd
new file mode 100644
index 0000000..4690fa7
--- /dev/null
+++ b/man/xsewma.arl.Rd
@@ -0,0 +1,95 @@
+\name{xsewma.arl}
+\alias{xsewma.arl}
+\title{Compute ARLs of simultaneous EWMA control charts (mean and variance charts)}
+\description{Computation of the (zero-state) Average Run Length (ARL)
+for different types of simultaneous EWMA control charts
+(based on the sample mean and the sample variance \eqn{S^2})
+monitoring normal mean and variance.}
+\usage{xsewma.arl(lx, cx, ls, csu, df, mu, sigma, hsx=0, Nx=40, csl=0,
+hss=1, Ns=40, s2.on=TRUE, sided="upper", qm=30)}
+\arguments{
+\item{lx}{smoothing parameter lambda of the two-sided mean EWMA chart.}
+\item{cx}{control limit of the two-sided mean EWMA control chart.}
+\item{ls}{smoothing parameter lambda of the variance EWMA chart.}
+\item{csu}{upper control limit of the variance EWMA control chart.}
+\item{df}{actual degrees of freedom, corresponds to subgroup size (for known mean
+it is equal to the subgroup size,
+for unknown mean it is equal to subgroup size minus one.}
+\item{mu}{true mean.}
+\item{sigma}{true standard deviation.}
+\item{hsx}{so-called headstart (enables fast initial response) of the mean chart --
+do not confuse with the true FIR feature considered in xewma.arl; will be updated.}
+\item{Nx}{dimension of the approximating matrix of the mean chart.}
+\item{csl}{lower control limit of the variance EWMA control chart; default value is 0;
+not considered if \code{sided} is \code{"upper"}.}
+\item{hss}{headstart (enables fast initial response) of the variance chart.}
+\item{Ns}{dimension of the approximating matrix of the variance chart.}
+\item{s2.on}{distinguishes between \eqn{S^2}{S^2} and \eqn{S}{S} chart.}
+\item{sided}{distinguishes between one- and two-sided two-sided EWMA-\eqn{S^2}{S^2}
+control charts by choosing \code{"upper"} (upper chart without reflection at \code{cl}
+-- the actual value of \code{cl} is not used), \code{"Rupper"} (upper chart with
+reflection at \code{cl}),
+\code{"Rlower"} (lower chart with reflection at \code{cu}), and \code{"two"}
+(two-sided chart), respectively.}
+\item{qm}{number of quadrature nodes used for the collocation integrals.}
+}
+\details{
+\code{xsewma.arl} determines the Average Run Length (ARL) by
+an extension of Gan's (derived from ideas already published by Waldmann)
+algorithm. The variance EWMA part is treated
+similarly to the ARL calculation method
+deployed for the single variance EWMA charts in Knoth (2005), that is, by means of
+collocation (Chebyshev polynomials). For more details see Knoth (2007).}
+\value{Returns a single value which resembles the ARL.}
+\references{
+K. Waldmann (1986),
+Bounds for the distribution of the run length of geometric moving average charts,
+\emph{J. R. Stat. Soc., Ser. C, Appl. Stat. 35}, 151-158.
+
+F. F. Gan (1995),
+Joint monitoring of process mean and variance using exponentially weighted moving
+average control charts,
+\emph{Technometrics 37}, 446-453.
+
+S. Knoth (2005),
+Accurate ARL computation for EWMA-\eqn{S^2}{S^2} control charts,
+\emph{Statistics and Computing 15}, 341-352.
+
+S. Knoth (2007),
+Accurate ARL calculation for EWMA control charts monitoring simultaneously normal
+mean and variance,
+\emph{Sequential Analysis 26}, 251-264.
+}
+\author{Sven Knoth}
+\seealso{
+\code{xewma.arl} and \code{sewma.arl} for zero-state ARL computation of
+single mean and variance EWMA control charts, respectively.
+}
+\examples{
+## Knoth (2007)
+## collocation results in Table 1
+## Monte Carlo with 10^9 replicates: 252.307 +/- 0.0078
+
+# process parameters
+mu <- 0
+sigma <- 1
+# subgroup size n=5, df=n-1
+df <- 4
+# lambda of mean chart
+lx <- .134
+# c_mu^* = .345476571 = cx/sqrt(n) * sqrt(lx/(2-lx)
+cx <- .345476571*sqrt(df+1)/sqrt(lx/(2-lx))
+# lambda of variance chart
+ls <- .1
+# c_sigma = .477977
+csu <- 1 + .477977
+# matrix dimensions for mean and variance part
+Nx <- 25
+Ns <- 25
+# mode of variance chart
+SIDED <- "upper"
+
+arl <- xsewma.arl(lx, cx, ls, csu, df, mu, sigma, Nx=Nx, Ns=Ns, sided=SIDED)
+arl
+}
+\keyword{ts}
diff --git a/man/xsewma.crit.Rd b/man/xsewma.crit.Rd
new file mode 100644
index 0000000..7fa7e90
--- /dev/null
+++ b/man/xsewma.crit.Rd
@@ -0,0 +1,85 @@
+\name{xsewma.crit}
+\alias{xsewma.crit}
+\title{Compute critical values of simultaneous EWMA control charts (mean and variance charts)}
+\description{Computation of the critical values (similar to alarm limits)
+for different types of simultaneous EWMA control charts
+(based on the sample mean and the sample variance \eqn{S^2})
+monitoring normal mean and variance.}
+\usage{xsewma.crit(lx, ls, L0, df, mu0=0, sigma0=1, cu=NULL, hsx=0,
+hss=1, s2.on=TRUE, sided="upper", mode="fixed", Nx=30, Ns=40, qm=30)}
+\arguments{
+\item{lx}{smoothing parameter lambda of the two-sided mean EWMA chart.}
+\item{ls}{smoothing parameter lambda of the variance EWMA chart.}
+\item{L0}{in-control ARL.}
+\item{mu0}{in-control mean.}
+\item{sigma0}{in-control standard deviation.}
+\item{cu}{for two-sided (\code{sided}=\code{"two"}) and fixed upper
+control limit (\code{mode}=\code{"fixed"}) a value larger than \code{sigma0}
+has to been given, for all other cases \code{cu} is ignored.}
+\item{hsx}{so-called headstart (enables fast initial response) of the mean chart --
+do not confuse with the true FIR feature considered in xewma.arl; will be updated.}
+\item{hss}{headstart (enables fast initial response) of the variance chart.}
+\item{df}{actual degrees of freedom, corresponds to subgroup size
+(for known mean it is equal to the subgroup size,
+for unknown mean it is equal to subgroup size minus one.}
+\item{s2.on}{distinguishes between \eqn{S^2}{S^2} and \eqn{S}{S} chart.}
+\item{sided}{distinguishes between one- and two-sided two-sided EWMA-\eqn{S^2}{S^2}
+control charts by choosing \code{"upper"} (upper chart without reflection at \code{cl}
+-- the actual value of \code{cl} is not used), \code{"Rupper"} (upper chart with
+reflection at \code{cl}), \code{"Rlower"} (lower chart with reflection at \code{cu}),
+and \code{"two"} (two-sided chart), respectively.}
+\item{mode}{only deployed for \code{sided}=\code{"two"} -- with \code{"fixed"}
+an upper control limit (see \code{cu}) is set and only the lower is
+determined to obtain the in-control ARL \code{L0}, while with \code{"unbiased"}
+a certain unbiasedness of the ARL function is guaranteed (here, both the
+lower and the upper control limit are calculated).}
+\item{Nx}{dimension of the approximating matrix of the mean chart.}
+\item{Ns}{dimension of the approximating matrix of the variance chart.}
+\item{qm}{number of quadrature nodes used for the collocation integrals.}
+}
+\details{
+\code{xsewma.crit} determines the critical values (similar to alarm limits)
+for given in-control ARL \code{L0}
+by applying secant rule and using \code{xsewma.arl()}.
+In case of \code{sided}=\code{"two"} and \code{mode}=\code{"unbiased"}
+a two-dimensional secant rule is applied that also ensures that the
+maximum of the ARL function for given standard deviation is attained
+at \code{sigma0}. See Knoth (2007) for details and application.
+}
+\value{Returns the critical value of the two-sided mean EWMA chart and
+the lower and upper controls limit \code{cl} and \code{cu} of the variance EWMA chart.}
+\references{
+
+S. Knoth (2007),
+Accurate ARL calculation for EWMA control charts monitoring simultaneously
+normal mean and variance,
+\emph{Sequential Analysis 26}, 251-264.
+}
+\author{Sven Knoth}
+\seealso{\code{xsewma.arl} for calculation of ARL of simultaneous EWMA charts.}
+\examples{
+## Knoth (2007)
+## results in Table 2
+
+# subgroup size n=5, df=n-1
+df <- 4
+# lambda of mean chart
+lx <- .134
+# lambda of variance chart
+ls <- .1
+# in-control ARL
+L0 <- 252.3
+# matrix dimensions for mean and variance part
+Nx <- 25
+Ns <- 25
+# mode of variance chart
+SIDED <- "upper"
+
+crit <- xsewma.crit(lx, ls, L0, df, sided=SIDED, Nx=Nx, Ns=Ns)
+crit
+
+## output as used in Knoth (2007)
+crit["cx"]/sqrt(df+1)*sqrt(lx/(2-lx))
+crit["cu"] - 1
+}
+\keyword{ts}
diff --git a/man/xsewma.q.Rd b/man/xsewma.q.Rd
new file mode 100644
index 0000000..44be1b2
--- /dev/null
+++ b/man/xsewma.q.Rd
@@ -0,0 +1,83 @@
+\name{xsewma.q}
+\alias{xsewma.q}
+\alias{xsewma.q.crit}
+\title{Compute critical values of simultaneous EWMA control charts
+(mean and variance charts) for given RL quantile}
+\description{Computation of the critical values (similar to alarm limits)
+for different types of simultaneous EWMA control charts
+(based on the sample mean and the sample variance \eqn{S^2})
+monitoring normal mean and variance.}
+\usage{xsewma.q(lx, cx, ls, csu, df, alpha, mu, sigma, hsx=0,
+Nx=40, csl=0, hss=1, Ns=40, sided="upper", qm=30)
+
+xsewma.q.crit(lx, ls, L0, alpha, df, mu0=0, sigma0=1, csu=NULL,
+hsx=0, hss=1, sided="upper", mode="fixed", Nx=20, Ns=40, qm=30,
+c.error=1e-12, a.error=1e-9)}
+\arguments{
+\item{lx}{smoothing parameter lambda of the two-sided mean EWMA chart.}
+\item{cx}{control limit of the two-sided mean EWMA control chart.}
+\item{ls}{smoothing parameter lambda of the variance EWMA chart.}
+\item{csu}{for two-sided (\code{sided}=\code{"two"}) and fixed upper
+control limit (\code{mode}=\code{"fixed"}, only for \code{xsewma.q.crit})
+a value larger than \code{sigma0}
+has to been given, for all other cases \code{cu} is ignored.
+It is the upper control limit of the variance EWMA control chart.}
+\item{L0}{in-control RL quantile at level \code{alpha}.}
+\item{df}{actual degrees of freedom, corresponds to subgroup size
+(for known mean it is equal to the subgroup size,
+for unknown mean it is equal to subgroup size minus one.}
+\item{alpha}{quantile level.}
+\item{mu}{true mean.}
+\item{sigma}{true standard deviation.}
+\item{mu0}{in-control mean.}
+\item{sigma0}{in-control standard deviation.}
+\item{hsx}{so-called headstart (enables fast initial response) of the mean chart --
+do not confuse with the true FIR feature considered in xewma.arl; will be updated.}
+\item{Nx}{dimension of the approximating matrix of the mean chart.}
+\item{csl}{lower control limit of the variance EWMA control chart; default value is 0;
+not considered if \code{sided} is \code{"upper"}.}
+\item{hss}{headstart (enables fast initial response) of the variance chart.}
+\item{Ns}{dimension of the approximating matrix of the variance chart.}
+\item{sided}{distinguishes between one- and two-sided two-sided
+EWMA-\eqn{S^2}{S^2} control charts by choosing \code{"upper"} (upper chart without
+reflection at \code{cl} -- the actual value of of \code{cl} is not used).}
+\item{mode}{only deployed for \code{sided}=\code{"two"} -- with \code{"fixed"}
+an upper control limit (see \code{cu}) is set and only the lower is
+determined to obtain the in-control ARL \code{L0}, while with \code{"unbiased"}
+a certain unbiasedness of the ARL function is guaranteed (here, both the
+lower and the upper control limit are calculated).}
+\item{qm}{number of quadrature nodes used for the collocation integrals.}
+\item{c.error}{error bound for two succeeding values of the critical value
+during applying the secant rule.}
+\item{a.error}{error bound for the quantile level \code{alpha} during
+applying the secant rule.}
+}
+\details{
+Instead of the popular ARL (Average Run Length) quantiles of the EWMA
+stopping time (Run Length) are determined. The algorithm is based on
+Waldmann's survival function iteration procedure and on Knoth (2007).
+\code{xsewma.q.crit} determines the critical values (similar to alarm limits)
+for given in-control RL quantile \code{L0} at level \code{alpha} by applying secant
+rule and using \code{xsewma.sf()}.
+In case of \code{sided}=\code{"two"} and \code{mode}=\code{"unbiased"}
+a two-dimensional secant rule is applied that also ensures that the
+maximum of the RL cdf for given standard deviation is attained at \code{sigma0}.
+}
+\value{Returns a single value which resembles the RL quantile of order \code{alpha} and
+the critical value of the two-sided mean EWMA chart and
+the lower and upper controls limit \code{csl} and \code{csu} of the
+variance EWMA chart, respectively.}
+\references{
+
+S. Knoth (2007),
+Accurate ARL calculation for EWMA control charts monitoring simultaneously
+normal mean and variance,
+\emph{Sequential Analysis 26}, 251-264.
+}
+\author{Sven Knoth}
+\seealso{\code{xsewma.arl} for calculation of ARL of simultaneous EWMA charts and
+\code{xsewma.sf} for the RL survival function.}
+\examples{
+## Knoth (2014?)
+}
+\keyword{ts}
diff --git a/man/xsewma.sf.Rd b/man/xsewma.sf.Rd
new file mode 100644
index 0000000..20b0499
--- /dev/null
+++ b/man/xsewma.sf.Rd
@@ -0,0 +1,62 @@
+\name{xsewma.sf}
+\alias{xsewma.sf}
+\title{Compute the survival function of simultaneous EWMA control
+charts (mean and variance charts)}
+\description{Computation of the survival function of the Run Length (RL)
+for EWMA control charts monitoring simultaneously normal mean and variance.}
+\usage{xsewma.sf(n, lx, cx, ls, csu, df, mu, sigma, hsx=0, Nx=40,
+csl=0, hss=1, Ns=40, sided="upper", qm=30) }
+\arguments{
+\item{n}{calculate sf up to value \code{n}.}
+\item{lx}{smoothing parameter lambda of the two-sided mean EWMA chart.}
+\item{cx}{control limit of the two-sided mean EWMA control chart.}
+\item{ls}{smoothing parameter lambda of the variance EWMA chart.}
+\item{csu}{upper control limit of the variance EWMA control chart.}
+\item{df}{actual degrees of freedom, corresponds to subgroup size (for known mean it is
+equal to the subgroup size, for unknown mean it is equal to subgroup size minus one.}
+\item{mu}{true mean.}
+\item{sigma}{true standard deviation.}
+\item{hsx}{so-called headstart (enables fast initial response) of the mean chart --
+do not confuse with the true FIR feature considered in xewma.arl; will be updated.}
+\item{Nx}{dimension of the approximating matrix of the mean chart.}
+\item{csl}{lower control limit of the variance EWMA control chart; default value is 0;
+not considered if \code{sided} is \code{"upper"}.}
+\item{hss}{headstart (enables fast initial response) of the variance chart.}
+\item{Ns}{dimension of the approximating matrix of the variance chart.}
+\item{sided}{distinguishes between one- and two-sided two-sided
+EWMA-\eqn{S^2}{S^2} control charts by choosing \code{"upper"} (upper chart
+without reflection at \code{cl} -- the actual value of
+\code{cl} is not used), \code{"Rupper"} (upper chart with reflection at \code{cl}),
+\code{"Rlower"} (lower chart with reflection at \code{cu}), and \code{"two"}
+(two-sided chart), respectively.}
+\item{qm}{number of quadrature nodes used for the collocation integrals.}
+}
+\details{
+The survival function P(L>n) and derived from it also the cdf P(L<=n) and
+the pmf P(L=n) illustrate
+the distribution of the EWMA run length. For large n the geometric tail
+could be exploited. That is,
+with reasonable large n the complete distribution is characterized.
+The algorithm is based on Waldmann's survival function iteration procedure and
+on results in Knoth (2007).
+}
+\value{Returns a vector which resembles the survival function up to a certain point.}
+\references{
+S. Knoth (2007),
+Accurate ARL calculation for EWMA control charts monitoring simultaneously
+normal mean and variance,
+\emph{Sequential Analysis 26}, 251-264.
+
+K.-H. Waldmann (1986),
+Bounds for the distribution of the run length of geometric moving
+average charts, \emph{Appl. Statist. 35}, 151-158.
+}
+\author{Sven Knoth}
+\seealso{
+\code{xsewma.arl} for zero-state ARL computation of simultaneous EWMA
+control charts.
+}
+\examples{
+## Knoth (2014?)
+}
+\keyword{ts}
diff --git a/man/xshewhart.ar1.arl.Rd b/man/xshewhart.ar1.arl.Rd
new file mode 100644
index 0000000..b958bc4
--- /dev/null
+++ b/man/xshewhart.ar1.arl.Rd
@@ -0,0 +1,70 @@
+\name{xshewhart.ar1.arl}
+\alias{xshewhart.ar1.arl}
+\title{Compute ARLs of modified Shewhart control charts for AR(1) data}
+\description{Computation of the (zero-state) Average Run Length (ARL)
+for modified Shewhart charts deploywed to the original AR(1) data.}
+\usage{xshewhart.ar1.arl(alpha, cS, delta=0, N1=50, N2=30)}
+\arguments{
+\item{alpha}{lag 1 correlation of the data.}
+\item{cS}{critical value (alias to alarm limit) of the Shewhart control chart.}
+\item{delta}{potential shift in the data (in-control mean is zero.}
+\item{N1}{number of quadrature nodes for solving the ARL integral equation,
+dimension of the resulting linear equation system is \code{N1}.}
+\item{N2}{second number of quadrature nodes for combining the probability density function
+of the first observation following the margin distribution and the solution of the ARL integral equation}.
+}
+\details{
+In case of the EWMA chart with fixed control limits,
+\code{xewma.arl} determines the Average Run Length (ARL) by numerically
+solving the related ARL integral equation by means of the Nystroem method
+based on Gauss-Legendre quadrature.
+If \code{limits} is not \code{"fix"}, then the method presented in Knoth (2003) is utilized.
+Note that for one-sided EWMA charts (\code{sided}=\code{"one"}), only
+\code{"vacl"} and \code{"stat"} are deployed, while for two-sided ones
+(\code{sided}=\code{"two"}) also \code{"fir"}, \code{"both"}
+(combination of \code{"fir"} and \code{"vacl"}), and \code{"Steiner"} are implemented.
+For details see Knoth (2004).
+}
+\value{Following the idea of Schmid (1995), \code{1- alpha} times the data turns out to be an
+EWMA smoothing of the underlying AR(1) residuals. Hence, by combining the solution of
+the EWMA ARL integral equation and the stationary distribution of the AR(1) data
+(normal distribution is assumed) one gets easily the overall ARL.}
+\references{
+S. Knoth, W. Schmid (2004).
+Control charts for time series: A review.
+In \emph{Frontiers in Statistical Quality Control 7},
+edited by H.-J. Lenz, P.-T. Wilrich, 210-236, Physica-Verlag.
+
+H. Kramer, W. Schmid (2000).
+The influence of parameter estimation on the ARL of Shewhart type charts for time series.
+\emph{Statistical Papers 41}(2), 173-196.
+
+W. Schmid (1995).
+On the run length of a Shewhart chart for correlated data.
+\emph{Statistical Papers 36}(1), 111-130.
+}
+\author{Sven Knoth}
+\seealso{
+\code{xewma.arl} for zero-state ARL computation of EWMA control charts.
+}
+\examples{
+## Table 1 in Kramer/Schmid (2000)
+
+cS <- 3.09023
+a <- seq(0, 4, by=.5)
+row1 <- row2 <- row3 <- NULL
+for ( i in 1:length(a) ) {
+ row1 <- c(row1, round(xshewhart.ar1.arl( 0.4, cS, delta=a[i]), digits=2))
+ row2 <- c(row2, round(xshewhart.ar1.arl( 0.2, cS, delta=a[i]), digits=2))
+ row3 <- c(row3, round(xshewhart.ar1.arl(-0.2, cS, delta=a[i]), digits=2))
+}
+
+results <- rbind(row1, row2, row3)
+results
+
+# original values are
+# row1 515.44 215.48 61.85 21.63 9.19 4.58 2.61 1.71 1.29
+# row2 502.56 204.97 56.72 19.13 7.95 3.97 2.33 1.59 1.25
+# row3 502.56 201.41 54.05 17.42 6.89 3.37 2.03 1.46 1.20
+}
+\keyword{ts}
diff --git a/man/xshewhartrunsrules.arl.Rd b/man/xshewhartrunsrules.arl.Rd
new file mode 100644
index 0000000..c3ad1a8
--- /dev/null
+++ b/man/xshewhartrunsrules.arl.Rd
@@ -0,0 +1,113 @@
+\name{xshewhartrunsrules.arl}
+\alias{xshewhartrunsrules.arl}
+\alias{xshewhartrunsrules.crit}
+\alias{xshewhartrunsrules.ad}
+\alias{xshewhartrunsrules.matrix}
+\title{Compute ARLs of Shewhart control charts with and without runs rules}
+\description{Computation of the (zero-state and steady-state) Average Run Length (ARL)
+for Shewhart control charts with and without runs rules
+monitoring normal mean.}
+\usage{xshewhartrunsrules.arl(mu, c = 1, type = "12")
+
+xshewhartrunsrules.crit(L0, mu = 0, type = "12")
+
+xshewhartrunsrules.ad(mu1, mu0 = 0, c = 1, type = "12")
+
+xshewhartrunsrules.matrix(mu, c = 1, type = "12")}
+\arguments{
+\item{mu}{true mean.}
+\item{L0}{pre-defined in-control ARL, that is, determine \code{c} so that the mean
+number of observations until a false alarm is \code{L0}.}
+\item{mu1, mu0}{for the steady-state ARL two means are specified, mu0 is the in-control one
+and usually equal to 0 , and mu1 must be given.}
+\item{c}{normalizing constant to ensure specific alarming behavior.}
+\item{type}{controls the type of Shewhart chart used, seed details section.}
+}
+\details{
+\code{xshewhartrunsrules.arl} determines the zero-state Average Run Length (ARL)
+based on the Markov chain approach given in Champ and Woodall (1987).
+\code{xshewhartrunsrules.matrix} provides the corresponding
+transition matrix that is also used in \code{xDshewhartrunsrules.arl} (ARL for control charting drift).
+\code{xshewhartrunsrules.crit} allows to find the normalization constant \code{c} to
+attain a fixed in-control ARL. Typically this is needed to calibrate the chart.
+With \code{xshewhartrunsrules.ad} the steady-state ARL is calculated.
+With the argument \code{type} certain runs rules could be set. The following list gives an overview.
+
+\itemize{
+\item{"1"}{ The classical Shewhart chart with \code{+/- 3 c sigma} control limits (\code{c} is typically
+equal to 1 and can be changed by the argument \code{c}).}
+\item{"12"}{ The classic and the following runs rule: 2 of 3 are beyond \code{+/- 2 c sigma} on the same
+side of the chart.}
+\item{"13"}{ The classic and the following runs rule: 4 of 5 are beyond \code{+/- 1 c sigma} on the same
+side of the chart.}
+\item{"14"}{ The classic and the following runs rule: 8 of 8 are on the same side of the chart
+(referring to the center line).}}
+}
+\value{Returns a single value which resembles the zero-state or steady-state ARL.
+\code{xshewhartrunsrules.matrix} returns a matrix.}
+\references{
+C. W. Champ and W. H. Woodall (1987),
+Exact results for Shewhart control charts with supplementary runs rules,
+\emph{Technometrics 29}, 393-399.
+}
+\author{Sven Knoth}
+\seealso{
+\code{xDshewhartrunsrules.arl} for zero-state ARL of Shewhart control charts
+with or without runs rules under drift.
+}
+\examples{
+## Champ/Woodall (1987)
+## Table 1
+mus <- (0:15)/5
+Mxshewhartrunsrules.arl <- Vectorize(xshewhartrunsrules.arl, "mu")
+# standard (1 of 1 beyond 3 sigma) Shewhart chart without runs rules
+C1 <- round(Mxshewhartrunsrules.arl(mus, type="1"), digits=2)
+# standard + runs rule: 2 of 3 beyond 2 sigma on the same side
+C12 <- round(Mxshewhartrunsrules.arl(mus, type="12"), digits=2)
+# standard + runs rule: 4 of 5 beyond 1 sigma on the same side
+C13 <- round(Mxshewhartrunsrules.arl(mus, type="13"), digits=2)
+# standard + runs rule: 8 of 8 on the same side of the center line
+C14 <- round(Mxshewhartrunsrules.arl(mus, type="14"), digits=2)
+
+## original results are
+# mus C1 C12 C13 C14
+# 0.0 370.40 225.44 166.05 152.73
+# 0.2 308.43 177.56 120.70 110.52
+# 0.4 200.08 104.46 63.88 59.76
+# 0.6 119.67 57.92 33.99 33.64
+# 0.8 71.55 33.12 19.78 21.07
+# 1.0 43.89 20.01 12.66 14.58
+# 1.2 27.82 12.81 8.84 10.90
+# 1.4 18.25 8.69 6.62 8.60
+# 1.6 12.38 6.21 5.24 7.03
+# 1.8 8.69 4.66 4.33 5.85
+# 2.0 6.30 3.65 3.68 4.89
+# 2.2 4.72 2.96 3.18 4.08
+# 2.4 3.65 2.48 2.78 3.38
+# 2.6 2.90 2.13 2.43 2.81
+# 2.8 2.38 1.87 2.14 2.35
+# 3.0 2.00 1.68 1.89 1.99
+
+data.frame(mus, C1, C12, C13, C14)
+
+## plus calibration, i. e. L0=250 (the maximal value for "14" is 255!
+L0 <- 250
+c1 <- xshewhartrunsrules.crit(L0, type = "1")
+c12 <- xshewhartrunsrules.crit(L0, type = "12")
+c13 <- xshewhartrunsrules.crit(L0, type = "13")
+c14 <- xshewhartrunsrules.crit(L0, type = "14")
+C1 <- round(Mxshewhartrunsrules.arl(mus, c=c1, type="1"), digits=2)
+C12 <- round(Mxshewhartrunsrules.arl(mus, c=c12, type="12"), digits=2)
+C13 <- round(Mxshewhartrunsrules.arl(mus, c=c13, type="13"), digits=2)
+C14 <- round(Mxshewhartrunsrules.arl(mus, c=c14, type="14"), digits=2)
+data.frame(mus, C1, C12, C13, C14)
+
+## and the steady-state ARL
+Mxshewhartrunsrules.ad <- Vectorize(xshewhartrunsrules.ad, "mu1")
+C1 <- round(Mxshewhartrunsrules.ad(mus, c=c1, type="1"), digits=2)
+C12 <- round(Mxshewhartrunsrules.ad(mus, c=c12, type="12"), digits=2)
+C13 <- round(Mxshewhartrunsrules.ad(mus, c=c13, type="13"), digits=2)
+C14 <- round(Mxshewhartrunsrules.ad(mus, c=c14, type="14"), digits=2)
+data.frame(mus, C1, C12, C13, C14)
+}
+\keyword{ts}
diff --git a/man/xsresewma.arl.Rd b/man/xsresewma.arl.Rd
new file mode 100644
index 0000000..affb8f1
--- /dev/null
+++ b/man/xsresewma.arl.Rd
@@ -0,0 +1,211 @@
+\name{x.res.ewma.arl}
+\alias{x.res.ewma.arl}
+\alias{s.res.ewma.arl}
+\alias{xs.res.ewma.arl}
+\alias{xs.res.ewma.pms}
+\title{Compute ARLs of EWMA residual control charts}
+\description{Computation of the (zero-state) Average Run Length (ARL)
+for EWMA residual control charts monitoring normal mean,
+variance, or mean and variance simultaneously. Additionally,
+the probability of misleading signals (PMS) is calculated.}
+\usage{x.res.ewma.arl(l, c, mu, alpha=0, n=5, hs=0, r=40)
+
+s.res.ewma.arl(l, cu, sigma, mu=0, alpha=0, n=5, hs=1, r=40, qm=30)
+
+xs.res.ewma.arl(lx, cx, ls, csu, mu, sigma, alpha=0,
+n=5, hsx=0, rx=40, hss=1, rs=40, qm=30)
+
+xs.res.ewma.pms(lx, cx, ls, csu, mu, sigma, type="3",
+alpha=0, n=5, hsx=0, rx=40, hss=1, rs=40, qm=30)
+}
+\arguments{
+\item{l, lx, ls}{smoothing parameter(s) lambda of the EWMA control chart.}
+\item{c, cu, cx, csu}{critical value (similar to alarm limit) of the EWMA control charts.}
+\item{mu}{true mean.}
+\item{sigma}{true standard deviation.}
+\item{alpha}{the AR(1) coefficient -- first order autocorrelation of the original data.}
+\item{n}{batch size.}
+\item{hs, hsx, hss}{so-called headstart (enables fast initial response).}
+\item{r, rx, rs}{number of quadrature nodes or size of collocation base,
+dimension of the resulting linear
+equation system is equal to \code{r} (two-sided).}
+\item{qm}{number of nodes for collocation quadratures.}
+\item{type}{PMS type, for \code{PMS}="3" (the default) the probability of
+getting a mean signal despite the variance
+changed, and for \code{PMS}="4" the opposite case is dealt with.}
+}
+\details{
+The above list of functions provides the application of
+algorithms developed for iid data to
+the residual case. To be more precise, the underlying model is a sequence of normally
+distributed batches with size \code{n} with autocorrelation within
+the batch and independence between the batches
+(see also the references below). It is restricted to the
+classical EWMA chart types, that
+is two-sided for the mean, upper charts for the variance,
+and all equipped with fixed limits.
+The autocorrelation is modeled by an AR(1) process with parameter
+\code{alpha}. Additionally,
+with \code{xs.res.ewma.pms} the probability of misleading signals
+(PMS) of \code{type} is
+calculated. This is offered exclusively in this small
+collection so that for iid data
+this function has to be used too (with \code{alpha=0}).
+}
+\value{Return single values which resemble the ARL and the PMS, respectively.}
+\references{
+S. Knoth, M. C. Morais, A. Pacheco, W. Schmid (2009),
+Misleading Signals in Simultaneous Residual Schemes for the Mean and
+Variance of a Stationary Process,
+\emph{Commun. Stat., Theory Methods 38}, 2923-2943.
+
+S. Knoth, W. Schmid, A. Schoene (2001),
+Simultaneous Shewhart-Type Charts for the Mean and the Variance of a Time Series,
+\emph{Frontiers of Statistical Quality Control 6,
+A. Lenz, H.-J. & Wilrich, P.-T. (Eds.)}, 6, 61-79.
+
+S. Knoth, W. Schmid (2002)
+Monitoring the mean and the variance of a stationary process,
+\emph{Statistica Neerlandica 56}, 77-100.
+}
+\author{Sven Knoth}
+\seealso{
+\code{xewma.arl}, \code{sewma.arl}, and \code{xsewma.arl} as more
+elaborated functions in the iid case.}
+\examples{
+\dontrun{
+## S. Knoth, W. Schmid (2002)
+
+cat("\nFragments of Table 2 (n=5, lambda.1=lambda.2)\n")
+
+lambdas <- c(.5, .25, .1, .05)
+L0 <- 500
+n <- 5
+
+crit <- NULL
+for ( lambda in lambdas ) {
+ cs <- xsewma.crit(lambda, lambda, L0, n-1)
+ x.e <- round(cs[1], digits=4)
+ names(x.e) <- NULL
+ s.e <- round((cs[3]-1) * sqrt((2-lambda)/lambda)*sqrt((n-1)/2), digits=4)
+ names(s.e) <- NULL
+ crit <- rbind(crit, data.frame(lambda, x.e, s.e))
+}
+
+
+## orinal values are (Markov chain approximation with 50 states)
+# lambda x.e s.e
+# 0.50 3.2765 4.6439
+# 0.25 3.2168 4.0149
+# 0.10 3.0578 3.3376
+# 0.05 2.8817 2.9103
+
+print(crit)
+
+
+cat("\nFragments of Table 4 (n=5, lambda.1=lambda.2=0.1)\n\n")
+
+lambda <- .1
+# the algorithm used in Knoth/Schmid is less accurate -- proceed with their values
+cx <- x.e <- 3.0578
+s.e <- 3.3376
+csu <- 1 + s.e * sqrt(lambda/(2-lambda))*sqrt(2/(n-1))
+
+alpha <- .3
+
+a.values <- c((0:6)/4, 2)
+d.values <- c(1 + (0:5)/10, 1.75 , 2)
+
+arls <- NULL
+for ( delta in d.values ) {
+ row <- NULL
+ for ( mu in a.values ) {
+ arl <- round(xs.res.ewma.arl(lambda, cx, lambda, csu, mu*sqrt(n), delta, alpha=alpha, n=n),
+ digits=2)
+ names(arl) <- NULL
+ row <- c(row, arl)
+ }
+ arls <- rbind(arls, data.frame(t(row)))
+}
+names(arls) <- a.values
+rownames(arls) <- d.values
+
+## orinal values are (now Monte-Carlo with 10^6 replicates)
+# 0 0.25 0.5 0.75 1 1.25 1.5 2
+#1 502.44 49.50 14.21 7.93 5.53 4.28 3.53 2.65
+#1.1 73.19 32.91 13.33 7.82 5.52 4.29 3.54 2.66
+#1.2 24.42 18.88 11.37 7.44 5.42 4.27 3.54 2.67
+#1.3 13.11 11.83 9.09 6.74 5.18 4.17 3.50 2.66
+#1.4 8.74 8.31 7.19 5.89 4.81 4.00 3.41 2.64
+#1.5 6.50 6.31 5.80 5.08 4.37 3.76 3.28 2.59
+#1.75 3.94 3.90 3.78 3.59 3.35 3.09 2.83 2.40
+#2 2.85 2.84 2.80 2.73 2.63 2.51 2.39 2.14
+
+print(arls)
+
+
+## S. Knoth, M. C. Morais, A. Pacheco, W. Schmid (2009)
+
+cat("\nFragments of Table 5 (n=5, lambda=0.1)\n\n")
+
+d.values <- c(1.02, 1 + (1:5)/10, 1.75 , 2)
+
+arl.x <- arl.s <- arl.xs <- PMS.3 <- NULL
+for ( delta in d.values ) {
+ arl.x <- c(arl.x, round(x.res.ewma.arl(lambda, cx/delta, 0, n=n),
+ digits=3))
+ arl.s <- c(arl.s, round(s.res.ewma.arl(lambda, csu, delta, n=n),
+ digits=3))
+ arl.xs <- c(arl.xs, round(xs.res.ewma.arl(lambda, cx, lambda, csu, 0, delta, n=n),
+ digits=3))
+ PMS.3 <- c(PMS.3, round(xs.res.ewma.pms(lambda, cx, lambda, csu, 0, delta, n=n),
+ digits=6))
+}
+
+## orinal values are (Markov chain approximation)
+# delta arl.x arl.s arl.xs PMS.3
+# 1.02 833.086 518.935 323.324 0.381118
+# 1.10 454.101 84.208 73.029 0.145005
+# 1.20 250.665 25.871 24.432 0.071024
+# 1.30 157.343 13.567 13.125 0.047193
+# 1.40 108.112 8.941 8.734 0.035945
+# 1.50 79.308 6.614 6.493 0.029499
+# 1.75 44.128 3.995 3.942 0.021579
+# 2.00 28.974 2.887 2.853 0.018220
+
+print(cbind(delta=d.values, arl.x, arl.s, arl.xs, PMS.3))
+
+
+cat("\nFragments of Table 6 (n=5, lambda=0.1)\n\n")
+
+alphas <- c(-0.9, -0.5, -0.3, 0, 0.3, 0.5, 0.9)
+deltas <- c(0.05, 0.25, 0.5, 0.75, 1, 1.25, 1.5, 2)
+
+PMS.4 <- NULL
+for ( ir in 1:length(deltas) ) {
+ mu <- deltas[ir]*sqrt(n)
+ pms <- NULL
+ for ( alpha in alphas ) {
+ pms <- c(pms, round(xs.res.ewma.pms(lambda, cx, lambda, csu, mu, 1, type="4", alpha=alpha, n=n),
+ digits=6))
+ }
+ PMS.4 <- rbind(PMS.4, data.frame(delta=deltas[ir], t(pms)))
+}
+names(PMS.4) <- c("delta", alphas)
+rownames(PMS.4) <- NULL
+
+## orinal values are (Markov chain approximation)
+# delta -0.9 -0.5 -0.3 0 0.3 0.5 0.9
+# 0.05 0.055789 0.224521 0.279842 0.342805 0.391299 0.418915 0.471386
+# 0.25 0.003566 0.009522 0.014580 0.025786 0.044892 0.066584 0.192023
+# 0.50 0.002994 0.001816 0.002596 0.004774 0.009259 0.015303 0.072945
+# 0.75 0.006967 0.000703 0.000837 0.001529 0.003400 0.006424 0.046602
+# 1.00 0.005098 0.000402 0.000370 0.000625 0.001589 0.003490 0.039978
+# 1.25 0.000084 0.000266 0.000202 0.000300 0.000867 0.002220 0.039773
+# 1.50 0.000000 0.000256 0.000120 0.000163 0.000531 0.001584 0.042734
+# 2.00 0.000000 0.000311 0.000091 0.000056 0.000259 0.001029 0.054543
+
+print(PMS.4)
+}
+}
+\keyword{ts}
diff --git a/man/xtcusum.arl.Rd b/man/xtcusum.arl.Rd
new file mode 100644
index 0000000..4768346
--- /dev/null
+++ b/man/xtcusum.arl.Rd
@@ -0,0 +1,56 @@
+\name{xtcusum.arl}
+\alias{xtcusum.arl}
+\title{Compute ARLs of CUSUM control charts}
+\description{Computation of the (zero-state) Average Run Length (ARL)
+for different types of CUSUM control charts monitoring normal mean.}
+\usage{xtcusum.arl(k, h, df, mu, hs = 0, sided="one", mode="tan", r=30)}
+\arguments{
+\item{k}{reference value of the CUSUM control chart.}
+\item{h}{decision interval (alarm limit, threshold) of the CUSUM control chart.}
+\item{df}{degrees of freedom -- parameter of the t distribution.}
+\item{mu}{true mean.}
+\item{hs}{so-called headstart (give fast initial response).}
+\item{sided}{distinguish between one- and two-sided CUSUM schemes by choosing \code{"one"} and \code{"two"}, respectively.}
+\item{r}{number of quadrature nodes, dimension of the resulting linear equation system is equal to \code{r+1}.}
+\item{mode}{Controls the type of variables substitution that might improve the numerical performance. Currently, \code{"identity"}, \code{"sin"}, \code{"sinh"}, and \code{"tan"} (default) are provided.}
+}
+\details{
+\code{xtcusum.arl} determines the Average Run Length (ARL) by numerically
+solving the related ARL integral equation by means of the Nystroem method
+based on Gauss-Legendre quadrature.
+}
+\value{Returns a single value which resembles the ARL.}
+\references{
+A. L. Goel, S. M. Wu (1971),
+Determination of A.R.L. and a contour nomogram for CUSUM charts to
+control normal mean, \emph{Technometrics 13}, 221-230.
+
+D. Brook, D. A. Evans (1972),
+An approach to the probability distribution of cusum run length,
+\emph{Biometrika 59}, 539-548.
+
+J. M. Lucas, R. B. Crosier (1982),
+Fast initial response for cusum quality-control schemes:
+Give your cusum a headstart, \emph{Technometrics 24}, 199-205.
+
+L. C. Vance (1986),
+Average run lengths of cumulative sum control charts for controlling
+normal means, \emph{Journal of Quality Technology 18}, 189-193.
+
+K.-H. Waldmann (1986),
+Bounds for the distribution of the run length of one-sided and
+two-sided CUSUM quality control schemes,
+\emph{Technometrics 28}, 61-67.
+
+R. B. Crosier (1986),
+A new two-sided cumulative quality control scheme,
+\emph{Technometrics 28}, 187-194.
+}
+\author{Sven Knoth}
+\seealso{
+\code{xtewma.arl} for zero-state ARL computation of EWMA control charts and \code{xtcusum.arl} for the zero-state ARL of CUSUM for normal data.
+}
+\examples{
+## will follow
+}
+\keyword{ts}
diff --git a/man/xtewma.ad.Rd b/man/xtewma.ad.Rd
new file mode 100644
index 0000000..e745ff3
--- /dev/null
+++ b/man/xtewma.ad.Rd
@@ -0,0 +1,56 @@
+\name{xtewma.ad}
+\alias{xtewma.ad}
+\title{Compute steady-state ARLs of EWMA control charts, t distributed data}
+\description{Computation of the steady-state Average Run Length (ARL)
+for different types of EWMA control charts monitoring the mean of t distributed data.}
+\usage{xtewma.ad(l, c, df, mu1, mu0=0, zr=0, z0=0, sided="one", limits="fix",
+steady.state.mode="conditional", mode="tan", r=40)}
+\arguments{
+\item{l}{smoothing parameter lambda of the EWMA control chart.}
+\item{c}{critical value (similar to alarm limit) of the EWMA control chart.}
+\item{df}{degrees of freedom -- parameter of the t distribution.}
+\item{mu1}{in-control mean.}
+\item{mu0}{out-of-control mean.}
+\item{zr}{reflection border for the one-sided chart.}
+\item{z0}{restarting value of the EWMA sequence in case of a false alarm in
+\code{steady.state.mode="cyclical"}.}
+\item{sided}{distinguishes between one- and two-sided two-sided EWMA control
+chart by choosing \code{"one"} and \code{"two"}, respectively.}
+\item{limits}{distinguishes between different control limits behavior.}
+\item{steady.state.mode}{distinguishes between two steady-state modes -- conditional and cyclical.}
+\item{mode}{Controls the type of variables substitution that might improve the numerical performance. Currently,
+\code{"identity"}, \code{"sin"}, \code{"sinh"}, and \code{"tan"} (default) are provided.}
+\item{r}{number of quadrature nodes, dimension of the resulting linear
+equation system is equal to \code{r+1} (one-sided) or \code{r}
+(two-sided).}
+}
+\details{
+\code{xtewma.ad} determines the steady-state Average Run Length (ARL)
+by numerically solving the related ARL integral equation by means
+of the Nystroem method based on Gauss-Legendre quadrature
+and using the power method for deriving the largest in magnitude
+eigenvalue and the related left eigenfunction.
+}
+\value{Returns a single value which resembles the steady-state ARL.}
+\references{
+R. B. Crosier (1986),
+A new two-sided cumulative quality control scheme,
+\emph{Technometrics 28}, 187-194.
+
+S. V. Crowder (1987),
+A simple method for studying run-length distributions of exponentially weighted
+moving average charts,
+\emph{Technometrics 29}, 401-407.
+
+J. M. Lucas and M. S. Saccucci (1990),
+Exponentially weighted moving average control schemes: Properties and enhancements,
+\emph{Technometrics 32}, 1-12.
+}
+\author{Sven Knoth}
+\seealso{
+\code{xtewma.arl} for zero-state ARL computation and
+\code{xewma.ad} for the steady-state ARL for normal data.}
+\examples{
+## will follow
+}
+\keyword{ts}
diff --git a/man/xtewma.arl.Rd b/man/xtewma.arl.Rd
new file mode 100644
index 0000000..bc6c24c
--- /dev/null
+++ b/man/xtewma.arl.Rd
@@ -0,0 +1,81 @@
+\name{xtewma.arl}
+\alias{xtewma.arl}
+\title{Compute ARLs of EWMA control charts, t distributed data}
+\description{Computation of the (zero-state) Average Run Length (ARL)
+for different types of EWMA control charts monitoring the mean of t distributed data.}
+\usage{xtewma.arl(l,c,df,mu,zr=0,hs=0,sided="two",limits="fix",mode="tan",q=1,r=40)}
+\arguments{
+\item{l}{smoothing parameter lambda of the EWMA control chart.}
+\item{c}{critical value (similar to alarm limit) of the EWMA control chart.}
+\item{df}{degrees of freedom -- parameter of the t distribution.}
+\item{mu}{true mean.}
+\item{zr}{reflection border for the one-sided chart.}
+\item{hs}{so-called headstart (enables fast initial response).}
+\item{sided}{distinguishes between one- and two-sided EWMA control chart
+by choosing \code{"one"} and \code{"two"}, respectively.}
+\item{limits}{distinguishes between different control limits behavior.}
+\item{mode}{Controls the type of variables substitution that might improve the numerical performance. Currently,
+\code{"identity"}, \code{"sin"}, \code{"sinh"}, and \code{"tan"} (default) are provided.}
+\item{q}{change point position. For \eqn{q=1} and
+\eqn{\mu=\mu_0} and \eqn{\mu=\mu_1}, the usual
+zero-state ARLs for the in-control and out-of-control case, respectively,
+are calculated. For \eqn{q>1} and \eqn{\mu!=0} conditional delays, that is,
+\eqn{E_q(L-q+1|L\ge q)}, will be determined.
+Note that mu0=0 is implicitely fixed.}
+\item{r}{number of quadrature nodes, dimension of the resulting linear
+equation system is equal to \code{r+1} (one-sided) or \code{r}
+(two-sided).}
+}
+\details{
+In case of the EWMA chart with fixed control limits,
+\code{xtewma.arl} determines the Average Run Length (ARL) by numerically
+solving the related ARL integral equation by means of the Nystroem method
+based on Gauss-Legendre quadrature.
+If \code{limits} is \code{"vacl"}, then the method presented in Knoth (2003) is utilized.
+Other values (normal case) for \code{limits} are not yet supported.
+}
+\value{Except for the fixed limits EWMA charts it returns a single value which resembles the ARL.
+For fixed limits charts, it returns a vector of length \code{q} which resembles the ARL and the
+sequence of conditional expected delays for \code{q}=1 and \code{q}>1, respectively.}
+\references{
+K.-H. Waldmann (1986),
+Bounds for the distribution of the run length of geometric moving
+average charts, \emph{Appl. Statist. 35}, 151-158.
+
+S. V. Crowder (1987),
+A simple method for studying run-length distributions of
+exponentially weighted moving average charts,
+\emph{Technometrics 29}, 401-407.
+
+J. M. Lucas and M. S. Saccucci (1990),
+Exponentially weighted moving average control schemes: Properties
+and enhancements, \emph{Technometrics 32}, 1-12.
+
+C. M. Borror, D. C. Montgomery, and G. C. Runger (1999),
+Robustness of the EWMA control chart to non-normality ,
+\emph{Journal of Quality Technology 31}, 309-316.
+
+S. Knoth (2003),
+EWMA schemes with non-homogeneous transition kernels,
+\emph{Sequential Analysis 22}, 241-255.
+
+S. Knoth (2004),
+Fast initial response features for EWMA Control Charts,
+\emph{Statistical Papers 46}, 47-64.
+}
+\author{Sven Knoth}
+\seealso{
+\code{xewma.arl} for zero-state ARL computation of EWMA control charts in the normal case.
+}
+\examples{
+## Borror/Montgomery/Runger (1999), Table 3
+lambda <- 0.1
+cE <- 2.703
+df <- c(4, 6, 8, 10, 15, 20, 30, 40, 50)
+L0 <- rep(NA, length(df))
+for ( i in 1:length(df) ) {
+ L0[i] <- round(xtewma.arl(lambda, cE*sqrt(df[i]/(df[i]-2)), df[i], 0), digits=0)
+}
+data.frame(df, L0)
+}
+\keyword{ts}
diff --git a/man/xtewma.q.Rd b/man/xtewma.q.Rd
new file mode 100644
index 0000000..898afad
--- /dev/null
+++ b/man/xtewma.q.Rd
@@ -0,0 +1,73 @@
+\name{xtewma.q}
+\alias{xtewma.q}
+\alias{xtewma.q.crit}
+\title{Compute RL quantiles of EWMA control charts}
+\description{Computation of quantiles of the Run Length (RL)
+for EWMA control charts monitoring normal mean.}
+\usage{xtewma.q(l, c, df, mu, alpha, zr=0, hs=0, sided="two", limits="fix", mode="tan",
+q=1, r=40)
+
+xtewma.q.crit(l, L0, df, mu, alpha, zr=0, hs=0, sided="two", limits="fix", mode="tan",
+r=40, c.error=1e-12, a.error=1e-9, OUTPUT=FALSE)}
+\arguments{
+\item{l}{smoothing parameter lambda of the EWMA control chart.}
+\item{c}{critical value (similar to alarm limit) of the EWMA control chart.}
+\item{df}{degrees of freedom -- parameter of the t distribution.}
+\item{mu}{true mean.}
+\item{alpha}{quantile level.}
+\item{zr}{reflection border for the one-sided chart.}
+\item{hs}{so-called headstart (enables fast initial response).}
+\item{sided}{distinguishes between one- and two-sided EWMA control chart
+by choosing \code{"one"} and \code{"two"}, respectively.}
+\item{limits}{distinguishes between different control limits behavior.}
+\item{mode}{Controls the type of variables substitution that might improve the numerical performance. Currently,
+\code{"identity"}, \code{"sin"}, \code{"sinh"}, and \code{"tan"} (default) are provided.}
+\item{q}{change point position. For \eqn{q=1} and
+\eqn{\mu=\mu_0} and \eqn{\mu=\mu_1}, the usual
+zero-state ARLs for the in-control and out-of-control case, respectively,
+are calculated. For \eqn{q>1} and \eqn{\mu!=0} conditional delays, that is,
+\eqn{E_q(L-q+1|L\geq)}, will be determined.
+Note that mu0=0 is implicitely fixed.}
+\item{r}{number of quadrature nodes, dimension of the resulting linear
+equation system is equal to \code{r+1} (one-sided) or \code{r}
+(two-sided).}
+\item{L0}{in-control quantile value.}
+\item{c.error}{error bound for two succeeding values of the critical value
+during applying the secant rule.}
+\item{a.error}{error bound for the quantile level \code{alpha} during applying
+the secant rule.}
+\item{OUTPUT}{activate or deactivate additional output.}
+}
+\details{
+Instead of the popular ARL (Average Run Length) quantiles of the EWMA
+stopping time (Run Length) are determined. The algorithm is based on
+Waldmann's survival function iteration procedure.
+If \code{limits} is \code{"vacl"}, then the method presented in Knoth (2003) is utilized.
+For details see Knoth (2004).
+}
+\value{Returns a single value which resembles the RL quantile of order \code{q}.}
+\references{
+F. F. Gan (1993),
+An optimal design of EWMA control charts based on the median run length,
+\emph{J. Stat. Comput. Simulation 45}, 169-184.
+
+S. Knoth (2003),
+EWMA schemes with non-homogeneous transition kernels,
+\emph{Sequential Analysis 22}, 241-255.
+
+S. Knoth (2004),
+Fast initial response features for EWMA Control Charts,
+\emph{Statistical Papers 46}, 47-64.
+
+K.-H. Waldmann (1986),
+Bounds for the distribution of the run length of geometric moving
+average charts, \emph{Appl. Statist. 35}, 151-158.
+}
+\author{Sven Knoth}
+\seealso{
+\code{xewma.q} for RL quantile computation of EWMA control charts in the normal case.
+}
+\examples{
+## will follow
+}
+\keyword{ts}
diff --git a/man/xtewma.sf.Rd b/man/xtewma.sf.Rd
new file mode 100644
index 0000000..e506a1a
--- /dev/null
+++ b/man/xtewma.sf.Rd
@@ -0,0 +1,59 @@
+\name{xtewma.sf}
+\alias{xtewma.sf}
+\title{Compute the survival function of EWMA run length}
+\description{Computation of the survival function of the Run Length (RL) for EWMA control charts monitoring normal mean.}
+\usage{xtewma.sf(l, c, df, mu, n, zr=0, hs=0, sided="two", limits="fix", mode="tan", q=1, r=40)}
+\arguments{
+\item{l}{smoothing parameter lambda of the EWMA control chart.}
+\item{c}{critical value (similar to alarm limit) of the EWMA control chart.}
+\item{df}{degrees of freedom -- parameter of the t distribution.}
+\item{mu}{true mean.}
+\item{n}{calculate sf up to value \code{n}.}
+\item{zr}{reflection border for the one-sided chart.}
+\item{hs}{so-called headstart (enables fast initial response).}
+\item{sided}{distinguishes between one- and two-sided EWMA control chart
+by choosing \code{"one"} and \code{"two"}, respectively.}
+\item{limits}{distinguishes between different conrol limits behavior.}
+\item{mode}{Controls the type of variables substitution that might improve the numerical performance. Currently,
+\code{"identity"}, \code{"sin"}, \code{"sinh"}, and \code{"tan"} (default) are provided.}
+\item{q}{change point position. For \eqn{q=1} and
+\eqn{\mu=\mu_0} and \eqn{\mu=\mu_1}, the usual
+zero-state situation for the in-control and out-of-control case, respectively,
+are calculated. Note that mu0=0 is implicitely fixed.}
+\item{r}{number of quadrature nodes, dimension of the resulting linear
+equation system is equal to \code{r+1} (one-sided) or \code{r} (two-sided).}
+}
+\details{
+The survival function P(L>n) and derived from it also the cdf P(L<=n) and the pmf P(L=n) illustrate
+the distribution of the EWMA run length. For large n the geometric tail could be exploited. That is,
+with reasonable large n the complete distribution is characterized.
+The algorithm is based on Waldmann's survival function iteration procedure.
+For varying limits and for change points after 1 the algorithm from Knoth (2004) is applied.
+For details see Knoth (2004).
+}
+\value{Returns a vector which resembles the survival function up to a certain point.}
+\references{
+F. F. Gan (1993),
+An optimal design of EWMA control charts based on the median run length,
+\emph{J. Stat. Comput. Simulation 45}, 169-184.
+
+S. Knoth (2003),
+EWMA schemes with non-homogeneous transition kernels,
+\emph{Sequential Analysis 22}, 241-255.
+
+S. Knoth (2004),
+Fast initial response features for EWMA Control Charts,
+\emph{Statistical Papers 46}, 47-64.
+
+K.-H. Waldmann (1986),
+Bounds for the distribution of the run length of geometric moving
+average charts, \emph{Appl. Statist. 35}, 151-158.
+}
+\author{Sven Knoth}
+\seealso{
+\code{xewma.sf} for survival function computation of EWMA control charts in the normal case.
+}
+\examples{
+## will follow
+}
+\keyword{ts}
diff --git a/src/allspc.c b/src/allspc.c
new file mode 100644
index 0000000..43080f3
--- /dev/null
+++ b/src/allspc.c
@@ -0,0 +1,19372 @@
+#include <stdio.h>
+#include <math.h>
+#include <stdlib.h>
+#include <R.h>
+#include <Rmath.h>
+
+#define LOG 0
+#define TAIL 1
+
+#define cusum1 0
+#define cusum2 1
+#define cusumC 2
+#define ewma1 0
+#define ewma2 1
+#define fix 0
+#define vacl 1
+#define fir 2
+#define both 3
+#define steiner 4
+#define stat 5
+#define fink 6
+
+#define FINALeps 1e-12
+#define lmEPS 1e-4
+
+#define IDENTITY 0
+#define SIN 1
+#define SINH 2
+#define TAN 3
+
+/*** export ***/
+
+
+/* CUSUM */
+
+double xc_crit(int ctyp, double k, double L0, double hs, double m0, int N);
+
+/* one-sided CUSUM */
+double xc1_iglarl(double k, double h, double hs, double mu, int N);
+double xc1_iglad (double k, double h, double mu0, double mu1, int N);
+double xc1_iglarl_drift(double k, double h, double hs, double delta, int m, int N, int with0);
+double xc1_iglarl_drift_wo_m(double k, double h, double hs, double delta, int *m, int N, int with0);
+double xc1_iglarlm_drift(double k, double h, double hs, int q, double delta, int N, int nmax, int with0);
+
+double xtc1_iglarl(double k, double h, double hs, int df, double mu, int N, int subst);
+
+double xc1_Wq(double k, double h, double p, double hs, double mu, int N, int nmax);
+double xc1_sf(double k, double h, double hs, double mu, int N, int nmax, double *p0);
+double xc1_arlm(double k, double h, double hs, int q, double mu0, double mu1, int N, int nmax);
+double xc1_arlm_hom(double k, double h, double hs, int q, double mu0, double mu1, int N, double *ced);
+
+/* classical two-sided (2 charts) CUSUM */
+double xc2_iglarl(double k, double h, double hs, double mu, int N);
+double xc2_be_arl(double k, double h, double hs1, double hs2, double mu, int N);
+double xc2_iglad (double k, double h, double mu0, double mu1, int N);
+double xc2_iglarl_drift(double k, double h, double hs, double delta, int m, int N, int drift0); /* it is not accurate */
+double xc2_iglarl_drift_wo_m(double k, double h, double hs, double delta, int *m, int N, int drift0); /* it is not accurate */
+
+double xtc2_iglarl(double k, double h, double hs, int df, double mu, int N, int subst);
+
+/* Crosier's two-sided CUSUM */
+double xcC_iglarl(double k, double h, double hs, double mu, int N);
+double xcC_iglad (double k, double h, double mu0, double mu1, int N);
+
+
+/* variance charts */
+double scU_iglarl_v1(double refk, double h, double hs, double sigma, int df, int N, int qm);
+double scU_iglarl_v2(double refk, double h, double hs, double sigma, int df, int N, int qm);
+double scL_iglarl_v2(double refk, double h, double hs, double sigma, int df, int N, int qm);
+double sc2_iglarl_v2(double refkl, double refku, double hl, double hu, double hsl, double hsu, double sigma, int df, int N, int qm);
+
+double scU_crit(double refk, double L0, double hs, double sigma, int df, int N, int qm);
+double scL_crit(double refk, double L0, double hs, double sigma, int df, int N, int qm);
+double scU_fl_crit(double refkl, double refku, double hl, double L0, double hsl, double hsu, double sigma, int df, int N, int qm);
+double scL_fu_crit(double refkl, double refku, double hu, double L0, double hsl, double hsu, double sigma, int df, int N, int qm);
+int sc2_crit_unbiased(double refkl, double refku, double L0, double *hl, double *hu, double hsl, double hsu, double sigma, int df, int N, int qm);
+/*double sc2_eqtails(double refkl, double refku, double L0, double *hl, double *hu, double hsl, double hsu, double sigma, int df, int N, int qm);*/
+
+
+/* Shiryaev-Roberts (only the one-sided version is implemented) */
+
+double xsr1_crit(double k, double L0, double zr, double hs, double m0, int N, int MPT);
+
+double xsr1_iglarl(double k, double h, double zr, double hs, double mu, int N, int MPT);
+double xsr1_iglad(double k, double h, double zr, double mu0, double mu1, int N, int MPT);
+double xsr1_arlm(double k, double h, double zr, double hs, int q, double mu0, double mu1, int N, int nmax, int MPT);
+double xsr1_arlm_hom(double k, double h, double zr, double hs, int q, double mu0, double mu1, int N, int MPT, double *ced);
+double xsr1_iglarl_drift(double k, double h, double zr, double hs, double delta, int m, int N, int with0);
+double xsr1_iglarl_drift_wo_m(double k, double h, double zr, double hs, double delta, int *m, int N, int with0);
+double xsr1_iglarlm_drift(double k, double h, double zr, double hs, int q, double delta, int N, int nmax, int with0);
+
+
+/* EWMA */
+
+double xe_crit(int ctyp, double l, double L0, double zr, double hs, double m0, int ltyp, int N, double c0);
+double xe_q_crit(int ctyp, double l, int L0, double alpha, double zr, double hs, double m0, int ltyp, int N, double c_error, double a_error);
+
+/* one-sided EWMA */
+double xe1_iglarl(double l, double c, double zr, double hs, double mu, int N);
+double xe1_iglad (double l, double c, double zr, double mu0, double mu1, int N);
+double xe1_arlm(double l, double c, double zr, double hs, int q, double mu0, double mu1, int mode, int N, int nmax);
+double xe1_arlm_hom(double l, double c, double zr, double hs, int q, double mu0, double mu1, int N, double *ced);
+double xe1_Warl(double l, double c, double zr, double hs, double mu, int N, int nmax);
+double xe1_Wq(double l, double c, double p, double zr, double hs, double mu, int N, int nmax);
+double xe1_sf(double l, double c, double zr, double hs, double mu, int N, int nmax, double *p0);
+double xe1_sfm(double l, double c, double zr, double hs, int q, double mu0, double mu1, int mode, int N, int nmax, double *p0);
+double xe1_Wqm(double l, double c, double p, double zr, double hs, int q, double mu0, double mu1, int mode, int N, int nmax);
+double xe1_iglarl_drift(double l, double c, double zr, double hs, double delta, int m, int N, int with0);
+double xe1_iglarl_drift_wo_m(double l, double c, double zr, double hs, double delta, int *m, int N, int with0);
+double xe1_iglarlm_drift(double l, double c, double zr, double hs, int q, double delta, int N, int nmax, int with0);
+
+double xlimit1_arlm(double c, double zr, int q, double mu0, double mu1, int N, int nmax);
+
+/* two-sided EWMA */
+double xe2_iglarl(double l, double c, double hs, double mu, int N);
+double xe2_iglad (double l, double c, double mu0, double mu1, int N);
+double xe2_igladc(double l, double c, double mu0, double mu1, double z0, int N);
+double xe2_arlm(double l, double c, double hs, int q, double mu0, double mu1, int mode, int N, int nmax);
+int xe2_arlm_special(double l, double c, double hs, int q, double mu0, double mu1, int mode, int N, int nmax, double *pair);
+double xe2_arlm_hom(double l, double c, double hs, int q, double mu0, double mu1, int N, double *ced);
+double xe2_Wq(double l, double c, double p, double hs, double mu, int N, int nmax);
+double xe2_sf(double l, double c, double hs, double mu, int N, int nmax, double *p0);
+double xe2_sfm(double l, double c, double hs, int q, double mu0, double mu1, int mode, int N, int nmax, double *p0);
+double xe2_Wqm(double l, double c, double p, double hs, int q, double mu0, double mu1, int mode, int N, int nmax);
+
+double xe2_Warl(double l, double c, double hs, double mu, int N, int nmax); /* Waldmann's ARL procedure */
+double xe2_Carl(double l, double c, double hs, double mu, int N, int qm); /* collocation */
+
+double xe2_iglarl_drift(double l, double c, double hs, double delta, int m, int N, int with0);
+double xe2_iglarl_drift_wo_m(double l, double c, double hs, double delta, int *m, int N, int with0);
+double xe2_iglarlm_drift(double l, double c, double hs, int q, double delta, int N, int nmax, int with0);
+double xe2_Warl_drift(double l, double c, double hs, double delta, int N, int nmax, int with0);
+
+/* functions based on Srivastava & Wu (1997) */
+double xe2_SrWu_crit(double l, double L0);
+double xe2_SrWu_arl(double l, double c, double mu);
+double xe2_SrWu_arl_full(double l, double c, double mu);
+double xe2_SrWu_lambda(double delta, double L0);
+
+/* t distribution */
+double xte2_iglarl(double l, double c, double hs, int df, double mu, int N, int subst);
+double xte2_iglad (double l, double c, int df, double mu0, double mu1, int N, int subst);
+double xte2_igladc(double l, double c, int df, double mu0, double mu1, double z0, int N, int subst);
+double xte2_arlm(double l, double c, double hs, int df, int q, double mu0, double mu1, int mode, int N, int nmax, int subst);
+double xte2_arlm_hom(double l, double c, double hs, int df, int q, double mu0, double mu1, int N, double *ced, int subst);
+double xte2_Wq(double l, double c, double p, double hs, int df, double mu, int N, int nmax, int subst);
+double xte2_sf(double l, double c, double hs, int df, double mu, int N, int nmax, double *p0, int subst);
+double xte2_sfm(double l, double c, double hs, int df, int q, double mu0, double mu1, int mode, int N, int nmax, double *p0, int subst);
+double xte2_Wqm(double l, double c, double p, double hs, int df, int q, double mu0, double mu1, int mode, int N, int nmax, int subst);
+
+
+/* incorporate pre-run uncertainty */
+double xe2_iglarl_prerun_MU(double l, double c, double hs, double mu, int pn, int qm, double truncate);
+double xe2_iglarl_prerun_SIGMA(double l, double c, double hs, double mu, int pn, int qm, double truncate);
+double xe2_iglarl_prerun_BOTH(double l, double c, double hs, double mu, int pn, int df, int qm1, int qm2, double truncate);
+
+double xe2_arlm_prerun_MU(double l, double c, double hs, int q, double mu0, double mu1, int pn, int mode, int nmax, int qm, double truncate);
+double xe2_arlm_prerun_SIGMA(double l, double c, double hs, int q, double mu0, double mu1, int pn, int mode, int nmax, int qm, double truncate);
+double xe2_arlm_prerun_BOTH(double l, double c, double hs, int q, double mu0, double mu1, int pn, int df, int mode, int nmax, int qm1, int qm2, double truncate);
+
+double xe2_sf_deluxe(double l, double c, double hs, double mu, int N, int nmax, double BOUND, double *p0, int *nstop, double *rho);
+double xe2_sf_prerun_MU_deluxe(double l, double c, double hs, double mu, int pn, int nmax, int qm, double truncate, double BOUND, double *p0);
+double xe2_sf_prerun_MU(double l, double c, double hs, double mu, int pn, int nmax, int qm, double truncate, double *p0);
+double xe2_sf_prerun_SIGMA_deluxe(double l, double c, double hs, double mu, int pn, int nmax, int qm, double truncate, double BOUND, double *p0);
+double xe2_sf_prerun_SIGMA(double l, double c, double hs, double mu, int pn, int nmax, int qm, double truncate, double *p0);
+double xe2_sf_prerun_BOTH_deluxe(double l, double c, double hs, double mu, int pn, int df, int nmax, int qm1, int qm2, double truncate, double BOUND, double *p0);
+double xe2_sf_prerun_BOTH(double l, double c, double hs, double mu, int pn, int df, int nmax, int qm1, int qm2, double truncate, double *p0);
+
+double xe2_sfm_simple(double l, double c, double hs, int q, double mu0, double mu1, int mode, int N, int nmax, double *p0);
+double xe2_sfm_deluxe(double l, double c, double hs, int q, double mu0, double mu1, int mode, int N, int nmax, double BOUND, double *p0, int *nstop, double *rho);
+double xe2_sfm_prerun_MU_deluxe(double l, double c, double hs, int q, double mu0, double mu1, int pn, int mode, int nmax, int qm, double truncate, double BOUND, double *p0);
+double xe2_sfm_prerun_MU(double l, double c, double hs, int q, double mu0, double mu1, int pn, int mode, int nmax, int qm, double truncate, double *p0);
+double xe2_sfm_prerun_SIGMA_deluxe(double l, double c, double hs, int q, double mu0, double mu1, int pn, int mode, int nmax, int qm, double truncate, double BOUND, double *p0);
+double xe2_sfm_prerun_SIGMA(double l, double c, double hs, int q, double mu0, double mu1, int pn, int mode, int nmax, int qm, double truncate, double *p0);
+double xe2_sfm_prerun_BOTH_deluxe(double l, double c, double hs, int q, double mu0, double mu1, int pn, int df, int mode, int nmax, int qm1, int qm2, double truncate, double BOUND, double *p0);
+double xe2_sfm_prerun_BOTH(double l, double c, double hs, int q, double mu0, double mu1, int pn, int df, int mode, int nmax, int qm1, int qm2, double truncate, double *p0);
+
+double xe2_Wq_prerun_MU_deluxe(double l, double c, double p, double hs, double mu, int pn, int nmax, int qm, double truncate, double BOUND);
+double xe2_Wq_prerun_SIGMA_deluxe(double l, double c, double p, double hs, double mu, int pn, int nmax, int qm, double truncate, double BOUND);
+double xe2_Wq_prerun_BOTH_deluxe(double l, double c, double p, double hs, double mu, int pn, int df, int nmax, int qm1, int qm2, double truncate, double BOUND);
+
+double xe2_Wqm_prerun_MU_deluxe(double l, double c, double p, double hs, int q, double mu0, double mu1, int pn, int mode, int nmax, int qm, double truncate, double BOUND);
+double xe2_Wqm_prerun_SIGMA_deluxe(double l, double c, double p, double hs, int q, double mu0, double mu1, int pn, int mode, int nmax, int qm, double truncate, double BOUND);
+double xe2_Wqm_prerun_BOTH_deluxe(double l, double c, double p, double hs, int q, double mu0, double mu1, int pn, int df, int mode, int nmax, int qm1, int qm2, double truncate, double BOUND);
+
+
+/* EWMA residual charts */
+
+double xe2_iglarl_RES(double l, double c, double hs, double mu, int N, double alpha, int df);
+double seU_iglarl_RES(double l, double cu, double hs, double sigma, int df, int N, int qm, double alpha, double mu);
+double xseU_arl_RES(double lx, double ls, double cx, double cs, double hsx, double hss, double mu, double sigma, int df, int Nx, int Ns, int nmax, int qm, double alpha);
+double xseU_mu_before_sigma_RES(double lx, double ls, double cx, double cs, double hsx, double hss, double mu, double sigma, int df, int Nx, int Ns, int nmax, int qm, double alpha, int vice_versa);
+
+
+/* Shewhart charts for dependent data */
+double x_shewhart_ar1_arl(double alpha, double cS, double mu, int N1, int N2);
+
+
+/* variance charts */
+double seU_iglarl(double l, double cu, double hs, double sigma, int df, int N, int qm);
+double se2_iglarl(double l, double cl, double cu, double hs, double sigma, int df, int N, int qm);
+double seUR_iglarl(double l, double cl, double cu, double hs, double sigma, int df, int N, int qm);
+double seLR_iglarl(double l, double cl, double cu, double hs, double sigma, int df, int N, int qm);
+
+double stdeU_iglarl(double l, double cu, double hs, double sigma, int df, int N, int qm);
+double stde2_iglarl(double l, double cl, double cu, double hs, double sigma, int df, int N, int qm);
+double stdeUR_iglarl(double l, double cl, double cu, double hs, double sigma, int df, int N, int qm);
+double stdeLR_iglarl(double l, double cl, double cu, double hs, double sigma, int df, int N, int qm);
+
+double lns2ewmaU_arl_igl(double l, double cl, double cu, double hs, double sigma, int df, int N);
+double lns2ewma2_arl_igl(double l, double cl, double cu, double hs, double sigma, int df, int N);
+
+double seU_crit(double l, double L0, double hs, double sigma, int df, int N, int qm);
+double se2lu_crit(double l, double L0, double cl, double hs, double sigma, int df, int N, int qm);
+double se2fu_crit(double l, double L0, double cu, double hs, double sigma, int df, int N, int qm);
+int se2_crit_unbiased(double l, double L0, double *cl, double *cu, double hs, double sigma, int df, int N, int qm);
+int se2_crit_eqtails(double l, double L0, double *cl, double *cu, double hs, double sigma, int df, double ur, int N, int qm);
+double se2_crit_sym(double l, double L0, double hs, double sigma, int df, int N, int qm);
+double seUR_crit(double l, double L0, double cl, double hs, double sigma, int df, int N, int qm);
+double seLR_crit(double l, double L0, double cu, double hs, double sigma, int df, int N, int qm);
+
+double stdeU_crit(double l, double L0, double hs, double sigma, int df, int N, int qm);
+double stde2lu_crit(double l, double L0, double cl, double hs, double sigma, int df, int N, int qm);
+double stde2fu_crit(double l, double L0, double cu, double hs, double sigma, int df, int N, int qm);
+int stde2_crit_unbiased(double l, double L0, double *cl, double *cu, double hs, double sigma, int df, int N, int qm);
+int stde2_crit_eqtails(double l, double L0, double *cl, double *cu, double hs, double sigma, int df, double ur, int N, int qm);
+double stde2_crit_sym(double l, double L0, double hs, double sigma, int df, int N, int qm);
+double stdeUR_crit(double l, double L0, double cl, double hs, double sigma, int df, int N, int qm);
+double stdeLR_crit(double l, double L0, double cu, double hs, double sigma, int df, int N, int qm);
+
+double lns2ewmaU_crit(double l, double L0, double cl, double hs, double sigma, int df, int N);
+double lns2ewma2_crit_cufix(double l, double cu, double L0, double hs, double sigma, int df, int N);
+double lns2ewma2_crit_sym(double l, double L0, double hs, double sigma, int df, int N);
+int lns2ewma2_crit_unbiased(double l, double L0, double *cl, double *cu, double hs, double sigma, int df, int N);
+
+double seU_sf(double l, double cu, double hs, double sigma, int df, int N, int nmax, int qm, double *p0);
+double seU_sf_deluxe(double l, double cu, double hs, double sigma, int df, int N, int nmax, int qm, double *p0, int *nstop, double *rho);
+double se2_sf(double l, double cl, double cu, double hs, double sigma, int df, int N, int nmax, int qm, double *p0);
+double se2_sf_deluxe(double l, double cl, double cu, double hs, double sigma, int df, int N, int nmax, int qm, double *p0, int *nstop, double *rho);
+double seUR_sf(double l, double cl, double cu, double hs, double sigma, int df, int N, int nmax, int qm, double *p0);
+double seUR_sf_deluxe(double l, double cl, double cu, double hs, double sigma, int df, int N, int nmax, int qm, double *p0, int *nstop, double *rho);
+double seLR_sf(double l, double cl, double cu, double hs, double sigma, int df, int N, int nmax, int qm, double *p0);
+double seLR_sf_deluxe(double l, double cl, double cu, double hs, double sigma, int df, int N, int nmax, int qm, double *p0, int *nstop, double *rho);
+
+double seU_q_crit(double l, int L0, double alpha, double hs, double sigma, int df, int N, int qm, double c_error, double a_error);
+double se2lu_q_crit(double l, int L0, double alpha, double cl, double hs, double sigma, int df, int N, int qm, double c_error, double a_error);
+double se2fu_q_crit(double l, int L0, double alpha, double cu, double hs, double sigma, int df, int N, int qm, double c_error, double a_error);
+int se2_q_crit(double l, int L0, double alpha, double *cl, double *cu, double hs, double sigma, int df, int N, int qm, double c_error, double a_error);
+int se2_q_crit_class(double l, int L0, double alpha, double *cl, double *cu, double hs, double sigma, int df, double ur, int N, int qm, double c_error, double a_error);
+double seUR_q_crit(double l, int L0, double alpha, double cl, double hs, double sigma, int df, int N, int qm, double c_error, double a_error);
+double seLR_q_crit(double l, int L0, double alpha, double cu, double hs, double sigma, int df, int N, int qm, double c_error, double a_error);
+
+double seU_Wq(double l, double cu, double p, double hs, double sigma, int df, int N, int nmax, int qm);
+double se2_Wq(double l, double cl, double cu, double p, double hs, double sigma, int df, int N, int nmax, int qm);
+double seUR_Wq(double l, double cl, double cu, double p, double hs, double sigma, int df, int N, int nmax, int qm);
+double seLR_Wq(double l, double cl, double cu, double p, double hs, double sigma, int df, int N, int nmax, int qm);
+
+
+/* MEWMA: Rigdon (1995a,b) */
+double mxewma_arl_0a(double lambda, double ce, int p, double hs, int N); /* GL class */
+double mxewma_arl_0a2(double lambda, double ce, int p, double hs, int N); /* GL mod */
+double mxewma_arl_0b(double lambda, double ce, int p, double hs, int N, int qm); /* collocation */
+double mxewma_arl_0c(double lambda, double ce, int p, double hs, int N); /* Radau (Rigdon) */
+double mxewma_arl_0d(double lambda, double ce, int p, double hs, int N); /* Clenshaw-Curtis */
+double mxewma_arl_0e(double lambda, double ce, int p, double hs, int N); /* Markov chain (Runger/Prabhu) */
+double mxewma_arl_0f(double lambda, double ce, int p, double hs, int N); /* Simpson rule (poor performance) */
+
+double mxewma_arl_f_0a(double lambda, double ce, int p, int N, double *ARL, double *w, double *z);
+double mxewma_arl_f_0a2(double lambda, double ce, int p, int N, double *ARL, double *w, double *z);
+double mxewma_arl_f_0b(double lambda, double ce, int p, int N, int qm, double *ARL);
+double mxewma_arl_f_0c(double lambda, double ce, int p, int N, double *ARL, double *w, double *z);
+double mxewma_arl_f_0d(double lambda, double ce, int p, int N, double *ARL, double *w, double *z);
+double mxewma_arl_f_0e(double lambda, double ce, int p, int N, double *ARL, double *z);
+double mxewma_arl_f_0f(double lambda, double ce, int p, int N, double *ARL, double *w, double *z);
+
+double mxewma_arl_1a (double lambda, double ce, int p, double delta, double hs, int N); /* GL class */
+double mxewma_arl_1a2(double lambda, double ce, int p, double delta, double hs, int N); /* GL mod */
+double mxewma_arl_1a3(double lambda, double ce, int p, double delta, double hs, int N); /* GL again mod sin, default for 2 and 4 */
+double mxewma_arl_1a4(double lambda, double ce, int p, double delta, double hs, int N); /* GL again mod tan */
+double mxewma_arl_1a5(double lambda, double ce, int p, double delta, double hs, int N); /* GL again mod sinh, default for all other p */
+
+double mxewma_arl_f_1a (double lambda, double ce, int p, double delta, int N, double *g, double *w0, double *z0, double *w1, double *z1); /* GL class */
+double mxewma_arl_f_1a2(double lambda, double ce, int p, double delta, int N, double *g, double *w0, double *z0, double *w1, double *z1); /* GL mod */
+double mxewma_arl_f_1a3(double lambda, double ce, int p, double delta, int N, double *g, double *w0, double *z0, double *w1, double *z1); /* GL again mod sin, default for 2 and 4 */
+double mxewma_arl_f_1a4(double lambda, double ce, int p, double delta, int N, double *g, double *w0, double *z0, double *w1, double *z1); /* GL again mod tan */
+double mxewma_arl_f_1a5(double lambda, double ce, int p, double delta, int N, double *g, double *w0, double *z0, double *w1, double *z1); /* GL again mod sinh, default for all other p */
+
+double mxewma_arl_1b(double lambda, double ce, int p, double delta, double hs, int N, int qm0, int qm1); /* collocation */
+double mxewma_arl_1b2(double lambda, double ce, int p, double delta, double hs, int N, int qm0, int qm1); /* collocation, trimmed support of outer integral */
+double mxewma_arl_1b3(double lambda, double ce, int p, double delta, double hs, int N, int qm0, int qm1); /* collocation, tan instead of sin */
+double mxewma_arl_1b4(double lambda, double ce, int p, double delta, double hs, int N, int qm0, int qm1); /* collocation, sinh instead of sin */
+double mxewma_arl_1c(double lambda, double ce, int p, double delta, double hs, int N); /* Radau (Rigdon) */
+double mxewma_arl_1d(double lambda, double ce, int p, double delta, double hs, int N); /* Clenshaw-Curtis */
+double mxewma_arl_1e(double lambda, double ce, int p, double delta, double hs, int N); /* Markov chain (Runger/Prabhu) */
+double mxewma_arl_1f(double lambda, double ce, int p, double delta, double hs, int N); /* Simpson rule (poor performance) */
+
+double mxewma_arl_f_1b (double lambda, double ce, int p, double delta, int N, int qm0, int qm1, double *g); /* collocation with two halfs in the same step + sin() */
+double mxewma_arl_f_1b3(double lambda, double ce, int p, double delta, int N, int qm0, int qm1, double *g); /* collocation with two halfs in the same step */
+double mxewma_arl_f_1b2(double lambda, double ce, int p, double delta, int N, int qm0, int qm1, double *g); /* collocation with shrinked supports of the outer integral */
+double mxewma_arl_f_1b4(double lambda, double ce, int p, double delta, int N, int qm0, int qm1, double *g); /* collocation with two halfs in the same step + sinh() instead of sin() */
+
+double mxewma_arl_f_1c (double lambda, double ce, int p, double delta, int N, double *g, double *w0, double *z0, double *w1, double *z1); /* GL + Radau (Rigdon) */
+double mxewma_arl_f_1d (double lambda, double ce, int p, double delta, int N, double *g, double *w0, double *z0, double *w1, double *z1); /* Clenshaw-Curtis */
+double mxewma_arl_f_1e (double lambda, double ce, int p, double delta, int N, double *g, int *dQ); /* Markov Chain (Runger/Prabhu) */
+double mxewma_arl_f_1f (double lambda, double ce, int p, double delta, int N, double *g, double *w0, double *z0, double *w1, double *z); /* Simpson rule */
+
+double mxewma_crit(double lambda, double L0, int p, double hs, int N);
+
+double mxewma_psi (double lambda, double ce, int p, int N, double *PSI, double *w, double *z);
+double mxewma_psiS(double lambda, double ce, int p, double hs, int N, double *PSI, double *w, double *z);
+
+double mxewma_ad (double lambda, double ce, int p, double delta, int N, int qm2, int psi_type, double hs, int qtype, int qm0, int qm1);
+
+
+/* incorporate pre-run uncertainty */
+double seU_sf_prerun_SIGMA_deluxe(double l, double cu, double hs, double sigma, int df1, int df2, int nmax, int qm1, int qm2, double truncate, double *p0);
+double seU_sf_prerun_SIGMA(double l, double cu, double hs, double sigma, int df1, int df2, int nmax, int qm1, int qm2, double truncate, double *p0);
+double seUR_sf_prerun_SIGMA_deluxe(double l, double cl, double cu, double hs, double sigma, int df1, int df2, int nmax, int qm1, int qm2, double truncate, double *p0);
+double seUR_sf_prerun_SIGMA(double l, double cl, double cu, double hs, double sigma, int df1, int df2, int nmax, int qm1, int qm2, double truncate, double *p0);
+double se2_sf_prerun_SIGMA_deluxe(double l, double cl, double cu, double hs, double sigma, int df1, int df2, int nmax, int qm1, int qm2, double truncate, double *p0);
+double se2_sf_prerun_SIGMA(double l, double cl, double cu, double hs, double sigma, int df1, int df2, int nmax, int qm1, int qm2, double truncate, double *p0);
+double seLR_sf_prerun_SIGMA_deluxe(double l, double cl, double cu, double hs, double sigma, int df1, int df2, int nmax, int qm1, int qm2, double truncate, double *p0);
+double seLR_sf_prerun_SIGMA(double l, double cl, double cu, double hs, double sigma, int df1, int df2, int nmax, int qm1, int qm2, double truncate, double *p0);
+
+double seU_iglarl_prerun_SIGMA(double l, double cu, double hs, double sigma, int df1, int df2, int N, int qm1, int qm2, double truncate);
+double seUR_iglarl_prerun_SIGMA(double l, double cl, double cu, double hs, double sigma, int df1, int df2, int N, int qm1, int qm2, double truncate);
+double se2_iglarl_prerun_SIGMA(double l, double cl, double cu, double hs, double sigma, int df1, int df2, int N, int qm1, int qm2, double truncate);
+double seLR_iglarl_prerun_SIGMA(double l, double cl, double cu, double hs, double sigma, int df1, int df2, int N, int qm1, int qm2, double truncate);
+
+double seU_q_crit_prerun_SIGMA(double l, int L0, double alpha, double hs, double sigma, int df1, int df2, int N, int qm1, int qm2, double truncate, int tail_approx, double c_error, double a_error);
+double se2lu_q_crit_prerun_SIGMA(double l, int L0, double alpha, double cl, double hs, double sigma, int df1, int df2, int N, int qm1, int qm2, double truncate, int tail_approx, double c_error, double a_error);
+double se2fu_q_crit_prerun_SIGMA(double l, int L0, double alpha, double cu, double hs, double sigma, int df1, int df2, int N, int qm1, int qm2, double truncate, int tail_approx, double c_error, double a_error);
+int se2_q_crit_prerun_SIGMA(double l, int L0, double alpha, double *cl, double *cu, double hs, double sigma, int df1, int df2, int N, int qm1, int qm2, double truncate, int tail_approx, double c_error, double a_error);
+double seUR_q_crit_prerun_SIGMA(double l, int L0, double alpha, double cl, double hs, double sigma, int df1, int df2, int N, int qm1, int qm2, double truncate, int tail_approx, double c_error, double a_error);
+double seLR_q_crit_prerun_SIGMA(double l, int L0, double alpha, double cu, double hs, double sigma, int df1, int df2, int N, int qm1, int qm2, double truncate, int tail_approx, double c_error, double a_error);
+
+double seU_Wq_prerun_SIGMA_deluxe(double l, double cu, double p, double hs, double sigma, int df1, int df2, int nmax, int qm1, int qm2, double truncate);
+double seUR_Wq_prerun_SIGMA_deluxe(double l, double cl, double cu, double p, double hs, double sigma, int df1, int df2, int nmax, int qm1, int qm2, double truncate);
+double seLR_Wq_prerun_SIGMA_deluxe(double l, double cl, double cu, double p, double hs, double sigma, int df1, int df2, int nmax, int qm1, int qm2, double truncate);
+
+double se2_Wq_prerun_SIGMA_deluxe(double l, double cl, double cu, double p, double hs, double sigma, int df1, int df2, int nmax, int qm1, int qm2, double truncate);
+
+double seU_crit_prerun_SIGMA(double l, double L0, double hs, double sigma, int df1, int df2, int N, int qm1, int qm2, double truncate);
+double se2lu_crit_prerun_SIGMA(double l, double L0, double cl, double hs, double sigma, int df1, int df2, int N, int qm1, int qm2, double truncate);
+double se2fu_crit_prerun_SIGMA(double l, double L0, double cu, double hs, double sigma, int df1, int df2, int N, int qm1, int qm2, double truncate);
+int se2_crit_prerun_SIGMA(double l, double L0, double *cl, double *cu, double hs, double sigma, int df1, int df2, int N, int qm1, int qm2, double truncate);
+double seUR_crit_prerun_SIGMA(double l, double L0, double cl, double hs, double sigma, int df1, int df2, int N, int qm1, int qm2, double truncate);
+double seLR_crit_prerun_SIGMA(double l, double L0, double cu, double hs, double sigma, int df1, int df2, int N, int qm1, int qm2, double truncate);
+
+
+/* simultaneous EWMA charts */
+double xseU_arl(double lx, double ls, double cx, double cs, double hsx, double hss, double mu, double sigma, int df, int Nx, int Ns, int nmax, int qm);
+double xse2_arl(double lx, double ls, double cx, double csl, double csu, double hsx, double hss, double mu, double sigma, int df, int Nx, int Ns, int nmax, int qm);
+
+int xseU_crit(double lx, double ls, double L0, double *cx, double *cs, double hsx, double hss, double mu, double sigma, int df, int Nx, int Ns, int nmax, int qm);
+int xse2lu_crit(double lx, double ls, double L0, double *cx, double csl, double *csu, double hsx, double hss, double mu, double sigma, int df, int Nx, int Ns, int nmax, int qm);
+int xse2fu_crit(double lx, double ls, double L0, double *cx, double *csl, double csu, double hsx, double hss, double mu, double sigma, int df, int Nx, int Ns, int nmax, int qm);
+int xse2_crit(double lx, double ls, double L0, double *cx, double *csl, double *csu, double hsx, double hss, double mu, double sigma, int df, int Nx, int Ns, int nmax, int qm);
+
+double xseU_sf(double lx, double ls, double cx, double cs, double hsx, double hss, double mu, double sigma, int df, int Nx, int Ns, int nmax, int qm, double *p0);
+double xseU_sf_deluxe(double lx, double ls, double cx, double cs, double hsx, double hss, double mu, double sigma, int df, int Nx, int Ns, int nmax, int qm, double *p0, int *nstop, double *rho);
+double xse2_sf(double lx, double ls, double cx, double csl, double csu, double hsx, double hss, double mu, double sigma, int df, int Nx, int Ns, int nmax, int qm, double *p0);
+double xse2_sf_deluxe(double lx, double ls, double cx, double csl, double csu, double hsx, double hss, double mu, double sigma, int df, int Nx, int Ns, int nmax, int qm, double *p0, int *nstop, double *rho);
+
+int xseU_q_crit(double lx, double ls, int L0, double alpha, double *cx, double *cs, double hsx, double hss, double mu, double sigma, int df, int Nx, int Ns, int qm, double c_error, double a_error);
+int xse2fu_q_crit(double lx, double ls, int L0, double alpha, double *cx, double *csl, double csu, double hsx, double hss, double mu, double sigma, int df, int Nx, int Ns, int qm, double c_error, double a_error);
+int xse2_q_crit(double lx, double ls, int L0, double alpha, double *cx, double *csl, double *csu, double hsx, double hss, double mu, double sigma, int df, int Nx, int Ns, int qm, double c_error, double a_error);
+
+double xseU_Wq(double lx, double ls, double cx, double cs, double p, double hsx, double hss, double mu, double sigma, int df, int Nx, int Ns, int nmax, int qm);
+double xse2_Wq(double lx, double ls, double cx, double csl, double csu, double p, double hsx, double hss, double mu, double sigma, int df, int Nx, int Ns, int nmax, int qm);
+
+
+/* EWMA p under sampling by variables */
+
+double WK_h(double mu, double sigma, double LSL, double USL);
+double wk_h_mu(double mu, double sigma, double LSL, double USL);
+double wk_h_sigma(double mu, double sigma, double LSL, double USL);
+double WK_h_invers_mu(double p, double sigma, double LSL, double USL);
+double WK_h_invers_sigma(double p, double mu, double LSL, double USL);
+
+double wk_alpha(double p, double sigma, int n, double LSL, double USL);
+
+double cdf_phat(double p, double mu, double sigma, int n, double LSL, double USL);
+double pdf_phat(double p, double mu, double sigma, int n, double LSL, double USL);
+double qf_phat(double p0, double mu, double sigma, int n, double LSL, double USL);
+
+double wk_cdf_i(double y, double p, double mu, double sigma, int n, double LSL, double USL);
+double wk_pdf_i(double y, double p, double mu, double sigma, int n, double LSL, double USL);
+
+double cdf_phat2(double p, double mu, double sigma, int n, double LSL, double USL, int nodes);
+double pdf_phat2(double p, double mu, double sigma, int n, double LSL, double USL, int nodes);
+double qf_phat2(double p0, double mu, double sigma, int n, double LSL, double USL, int nodes);
+
+double ewma_phat_arl (double lambda, double ucl, double mu, double sigma, int n, double z0, double LSL, double USL, int N, int qm);
+double ewma_phat_arl_be(double lambda, double ucl, double mu, double sigma, int n, double z0, double LSL, double USL, int N);
+double ewma_phat_crit(double lambda, double L0, double mu, double sigma, int n, double z0, double LSL, double USL, int N, int qm);
+double ewma_phat_lambda(double L0, double mu, double sigma, double max_l, double min_l, int n, double z0, double LSL, double USL, int qm);
+
+double ewma_phat_arl2 (double lambda, double ucl, double mu, double sigma, int n, double z0, double LSL, double USL, int N, int qm, int M);
+double ewma_phat_arl2_be(double lambda, double ucl, double mu, double sigma, int n, double z0, double LSL, double USL, int N);
+double ewma_phat_crit2(double lambda, double L0, double mu, double sigma, int n, double z0, double LSL, double USL, int N, int qm, int M);
+double ewma_phat_lambda2(double L0, double mu, double sigma, double max_l, double min_l, int n, double z0, double LSL, double USL, int qm, int M);
+
+
+/* attribute EWMA p (X follows binomial distribution) */
+
+double ewma_p_arl(double lambda, double ucl, int n, double p, double z0, int d_res, int round_mode, int mid_mode);
+
+
+/* tolerance intervals */
+
+double kww(int n, double q, double a);
+double tl_factor(int n, double q, double a, int m);
+
+
+/* internal functions etc. */
+
+int qm_for_l_and_c(double l, double c);
+int choose_N_for_seU(double lambda);
+int choose_N_for_se2(double lambda, double cl, double cu);
+
+void gausslegendre(int n, double x1, double x2, double *x, double *w);
+void radau(int n, double x1, double x2, double *x, double *w);
+
+int LU_decompose(double *a, int *ps, int n);
+void LU_solve(double *a, double *b, int n);
+void LU_solve2(double *a, double *b, int *ps, int n);
+
+void pmethod(int n, double *p, int *status, double *lambda, double x_[], int *noofit);
+
+int *ivector(long n);
+double *vector (long n);
+double *matrix(long m, long n);
+
+double phi(double x, double mu);
+double PHI(double x, double mu);
+double qPHI(double p);
+
+double chi(double s, int df);
+double CHI(double s, int df);
+double qCHI(double p, int df);
+double nchi(double s, int df, double ncp);
+double nCHI(double s, int df, double ncp);
+double nqCHI(double p, int df, double ncp);
+
+double pdf_t(double x, int df);
+double cdf_t(double x, int df);
+double qf_t(double x, int df);
+
+double pdf_tn(double x, int df, double ncp);
+double cdf_tn(double x, int df, double ncp);
+double qf_tn(double x, int df, double ncp);
+
+double cdf_binom(double q, int n, double p);
+double pdf_binom(double x, int n, double p);
+
+double Tn(double z, int n); /* Chebyshev polynomials */
+double iTn(double z, int n); /* indefinite integrals of Chebyshev polynomials */
+double dTn(double z, int n); /* derivatives of Chebyshev polynomials */
+
+double rho0;
+
+
+/* ------------------- functions and procedures ------------- */
+
+int *ivector(long n)
+{
+ return (int *) Calloc( n, int );
+}
+
+double *vector(long n)
+{
+ return (double *) Calloc( n, double );
+}
+
+double *matrix(long m, long n)
+{
+ return (double *) Calloc( m*n, double );
+}
+
+/* normal density (pdf) */
+
+double phi(double x, double mu)
+{
+ return dnorm(x,mu,1.,LOG);
+}
+
+/* normal cumulative distribution function (cdf) */
+
+double PHI(double x, double mu)
+{
+ return pnorm(x,mu,1.,TAIL,LOG);
+}
+
+/* qf of normal rv */
+
+double qPHI(double p)
+{
+ return qnorm(p,0.,1.,TAIL,LOG);
+}
+
+/* pdf of chisquare rv */
+
+double chi(double s, int df)
+{
+ return dchisq(s,(double)df,LOG);
+}
+
+
+/* pdf of non-central chisquare rv */
+
+double nchi(double s, int df, double ncp)
+{
+ return dnchisq(s,(double)df,ncp,LOG);
+}
+
+/* cdf of chisquare rv */
+
+double CHI(double s, int df)
+{
+ return pchisq(s,(double)df,TAIL,LOG);
+}
+
+/* cdf of non-central chisquare rv */
+
+double nCHI(double s, int df, double ncp)
+{
+ return pnchisq(s,(double)df,ncp,TAIL,LOG);
+}
+
+/* qf of chisquare rv */
+
+double qCHI(double p, int df)
+{
+ return qchisq(p,(double)df,TAIL,LOG);
+}
+
+/* qf of non-central chisquare rv */
+
+double nqCHI(double p, int df, double ncp)
+{
+ return qnchisq(p,(double)df,ncp,TAIL,LOG);
+}
+
+
+/* pdf of t distribution */
+
+double pdf_t(double x, int df)
+{
+ return dt(x,(double)df,LOG);
+}
+
+/* cdf of t distribution */
+
+double cdf_t(double x, int df)
+{
+ return pt(x,(double)df,TAIL,LOG);
+}
+
+/* quantile function of t distribution */
+
+double qf_t(double x, int df)
+{
+ return qt(x,(double)df,TAIL,LOG);
+}
+
+
+/* pdf of non-central t distribution */
+
+double pdf_tn(double x, int df, double ncp)
+{
+ return dnt(x,(double)df,ncp,LOG);
+}
+
+/* cdf of non-central t distribution */
+
+double cdf_tn(double x, int df, double ncp)
+{
+ return pnt(x,(double)df,ncp,TAIL,LOG);
+}
+
+/* quantile function of non-central t distribution */
+
+double qf_tn(double x, int df, double ncp)
+{
+ return qnt(x,(double)df,ncp,TAIL,LOG);
+}
+
+
+/* cdf of binomial rv */
+double cdf_binom(double q, int n, double p)
+{
+ return pbinom(q,(double)n,p,TAIL,LOG);
+}
+
+/* pdf of binomial rv */
+double pdf_binom(double x, int n, double p)
+{
+ return dbinom(x,(double)n,p,LOG);
+}
+
+/* expectation of log-gamma */
+double E_log_gamma(double ddf)
+{
+ return log(2./ddf) + digamma(ddf/2.);
+}
+
+/* variance of log-gamma */
+double V_log_gamma(double ddf)
+{
+ return trigamma(ddf/2.);
+}
+
+/* expectation of S (chi) */
+double c_four(double ddf)
+{
+ return sqrt( 2./ddf ) * gammafn( (ddf+1)/2. ) / gammafn( ddf/2. );
+}
+
+
+/* abscissae and weights of Gauss-Legendre quadrature */
+
+#define GLeps 3e-11
+
+void gausslegendre(int n, double x1, double x2, double *x, double *w)
+/*
+ The following algorithm is based on ideas of Knut Petras
+ (see http://www-public.tu-bs.de:8080/~petras/).
+
+ The nodes are derived by means of the Newton method.
+ Afterwards, the weights are obtained by utilizing
+ (regarding the connection between the Christoffel function
+ and the weight, which is also called Christoffel number)
+
+ w_i = w(x_i) = 2 / sum_j=0^n ( (2j+1) * (P_j(x_i))^2 )
+
+ which is more stable than to rely on the usual
+
+ w_i = 2 / (1-x_i^2)/(P_n^'(x_i))^2.
+
+ Note that the Newton method is stopped as soon as the distance
+ between two successive iterates is smaller than GLeps, plus
+ one extra step.
+
+ By comparing with results in Yakimiw (1996)
+ we may conclude that the code behaves very well and even better.
+*/
+{ double xw, xmid, z0, z1, diff, p0, p1, p2=0., a;
+ int i, j, m, stop, odd;
+
+ m = (n+1)/2;
+ odd = n%2 == 1;
+ xmid = .5*(x2+x1); /* interval centre */
+ xw = .5*(x2-x1); /* half interval length */
+
+ for (i=0;i<m;i++) {
+ if (odd && i==m-1)
+ z1 = 0.;
+ else {
+ z0 = -cos( PI*(i+.75)/(n+.5) ); /* initial guess */
+ stop = 0;
+ diff = 1;
+ while (stop<2) {
+ p0 = 1.;
+ p1 = z0;
+ for (j=1;j<n;j++) { /* iterate to get the nth Legendre polynomial at z0 */
+ p2 = ( (2.*j+1.)*z0*p1 - j*p0 )/(j+1.);
+ p0 = p1;
+ p1 = p2;
+ }
+ z1 = z0 + (1.-z0*z0)*p2/n/(z0*p2-p0); /* Newton method update, where */
+ diff = fabs(z1-z0); /* derivative is based on P_n(x) */
+ z0 = z1; /* and P_n-1(x) */
+ if (diff<GLeps) stop++; /* stop as soon diff is small enough */
+ } /* (for 2 times -> kind of overiterating) */
+ }
+
+ x[i] = xmid + xw*z1;
+ x[n-1-i] = xmid - xw*z1; /* nodes on interval (x1,x2) */
+
+ p0 = 1.;
+ p1 = z1;
+ a = 1. + 3.*z1*z1;
+ for (j=1;j<n;j++) {
+ p2 = ( (2.*j+1.)*z1*p1 - j*p0 )/(j+1.);
+ p0 = p1;
+ p1 = p2;
+ a += p1*p1*(2.*j+3.);
+ } /* Christoffel function based approach which is more stable */
+
+ w[i] = 2./a * xw;
+ w[n-1-i] = w[i]; /* weights for interval (x1,x2) */
+ }
+}
+
+#undef GLeps
+
+
+/* helper functions */
+
+
+double r8_epsilon ( )
+/*
+ Purpose: R8_EPSILON returns the R8 roundoff unit.
+
+ Discussion:
+
+ The roundoff unit is a number R which is a power of 2 with the property
+ that, to the precision of the computer's arithmetic,
+ 1 < 1 + R
+ but
+ 1 = ( 1 + R / 2 )
+
+ Licensing: This code is distributed under the GNU LGPL license.
+
+ Modified: 01 July 2004
+
+ Author: John Burkardt
+
+ Parameters: Output, double R8_EPSILON, the double precision round-off unit.
+*/
+{ double r;
+
+ r = 1.0;
+ while ( 1.0 < ( double ) ( 1.0 + r ) )
+ {
+ r = r / 2.0;
+ }
+ return ( 2.0 * r );
+}
+
+
+double r8_max ( double x, double y )
+/*
+ Purpose: R8_MAX returns the maximum of two R8's.
+
+ Licensing: This code is distributed under the GNU LGPL license.
+
+ Modified: 18 August 2004
+
+ Author: John Burkardt
+
+ Parameters: Input, double X, Y, the quantities to compare.
+ Output, double R8_MAX, the maximum of X and Y.
+*/
+{ double value;
+
+ if ( y < x )
+ {
+ value = x;
+ }
+ else
+ {
+ value = y;
+ }
+ return value;
+}
+
+
+double r8_abs ( double x )
+/*
+ Purpose: R8_ABS returns the absolute value of an R8.
+
+ Licensing: This code is distributed under the GNU LGPL license.
+
+ Modified: 14 November 2006
+
+ Author: John Burkardt
+
+ Parameters: Input, double X, the quantity whose absolute value is desired.
+ Output, double R8_ABS, the absolute value of X.
+*/
+{ double value;
+
+ if ( 0.0 <= x )
+ {
+ value = x;
+ }
+ else
+ {
+ value = -x;
+ }
+ return value;
+}
+
+
+void radau(int n, double x1, double x2, double *x, double *w)
+
+/******************************************************************************/
+/*
+ Purpose:
+
+ RADAU_COMPUTE computes a Radau quadrature rule.
+
+ Discussion:
+
+ The Radau rule is distinguished by the fact that the left endpoint
+ (-1) is always an abscissa.
+
+ The integral:
+
+ Integral ( -1 <= X <= 1 ) F(X) dX
+
+ The quadrature rule:
+
+ Sum ( 1 <= I <= NORDER ) WEIGHT(I) * F ( XTAB(I) )
+
+ The quadrature rule will integrate exactly all polynomials up to
+ X**(2*NORDER-2).
+
+ Licensing:
+
+ This code is distributed under the GNU LGPL license.
+
+ Modified:
+
+ 28 August 2007
+
+ Author:
+
+ Original MATLAB version by Greg von Winckel.
+ C version by John Burkardt.
+
+ Reference:
+
+ Milton Abramowitz, Irene Stegun,
+ Handbook of Mathematical Functions,
+ National Bureau of Standards, 1964,
+ ISBN: 0-486-61272-4,
+ LC: QA47.A34.
+
+ Claudio Canuto, Yousuff Hussaini, Alfio Quarteroni, Thomas Zang,
+ Spectral Methods in Fluid Dynamics,
+ Springer, 1993,
+ ISNB13: 978-3540522058,
+ LC: QA377.S676.
+
+ Francis Hildebrand,
+ Section 8.11,
+ Introduction to Numerical Analysis,
+ Dover, 1987,
+ ISBN13: 978-0486653631,
+ LC: QA300.H5.
+
+ Arthur Stroud, Don Secrest,
+ Gaussian Quadrature Formulas,
+ Prentice Hall, 1966,
+ LC: QA299.4G3S7.
+
+ Daniel Zwillinger, editor,
+ CRC Standard Mathematical Tables and Formulae,
+ 30th Edition,
+ CRC Press, 1996,
+ ISBN: 0-8493-2479-3,
+ LC: QA47.M315.
+
+ Parameters:
+
+ Input, int N, the order.
+ N must be at least 1.
+
+ Output, double X[N], the abscissas.
+
+ Output, double W[N], the weights.
+*/
+{
+ int i;
+ int iterate;
+ int iterate_max = 25;
+ int j;
+ double pi = 3.141592653589793;
+ double temp;
+ double test;
+ double tolerance;
+ double xw, xmid;
+
+ xmid = .5*(x2+x1); /* interval centre */
+ xw = .5*(x2-x1); /* half interval length */
+
+ tolerance = 100.0 * r8_epsilon ( );
+/*
+ Initial estimate for the abscissas is the Chebyshev-Gauss-Radau nodes.
+*/
+ for ( i = 0; i < n; i++ )
+ {
+ x[i] = - cos ( 2.0 * pi * ( double ) ( i )
+ / ( double ) ( 2 * n - 1 ) );
+ }
+ double xold[n];
+ double p[n*(n+1)];
+ iterate = 0;
+
+ do
+ {
+ for ( i = 0; i < n; i++ )
+ {
+ xold[i] = x[i];
+ }
+
+ temp = 1.0;
+ for ( j = 0; j < n + 1; j++ )
+ {
+ p[0+j*n] = temp;
+ temp = -temp;
+ }
+
+ for ( i = 1; i < n; i++ )
+ {
+ p[i+0*n] = 1.0;
+ }
+ for ( i = 1; i < n; i++ )
+ {
+ p[i+1*n] = x[i];
+ }
+
+ for ( j = 2; j <= n; j++ )
+ {
+ for ( i = 1; i < n; i++ )
+ {
+ p[i+j*n] = ( ( double ) ( 2 * j - 1 ) * x[i] * p[i+(j-1)*n]
+ + ( double ) ( - j + 1 ) * p[i+(j-2)*n] )
+ / ( double ) ( j );
+ }
+ }
+ for ( i = 1; i < n; i++ )
+ {
+ x[i] = xold[i] - ( ( 1.0 - xold[i] ) / ( double ) ( n ) )
+ * ( p[i+(n-1)*n] + p[i+n*n] ) / ( p[i+(n-1)*n] - p[i+n*n] );
+ }
+ test = 0.0;
+ for ( i = 0; i < n; i++ )
+ {
+ test = r8_max ( test, r8_abs ( x[i] - xold[i] ) );
+ }
+ iterate = iterate + 1;
+ } while ( tolerance < test && iterate < iterate_max );
+
+ w[0] = xw * 2.0 / ( double ) ( n * n );
+ x[0] = x1;
+ for ( i = 1; i < n; i++ ) {
+ w[i] = xw * ( 1.0 - x[i] ) / pow ( ( double ) ( n ) * p[i+(n-1)*n], 2 );
+ x[i] = xw*x[i] + xmid;
+ }
+
+ return;
+}
+/******************************************************************************/
+
+
+void matvec(int n, double *p, double *z, double y_[])
+{ int i, j;
+ for (i=0;i<n;i++) {
+ y_[i] = 0.;
+ for (j=0;j<n;j++)
+ y_[i] += p[i*n+j] * z[j];
+ }
+}
+
+
+/* power method */
+#define convgd 0
+#define limit 1
+#define epsilon 1e-12
+#define maxits 100000
+
+void pmethod(int n, double *p, int *status, double *lambda,
+ double x_[], int *noofit)
+{ int count, i, newi, oldi;
+ double newmu, oldmu, *z, *y_;
+ void matvec();
+
+ z = vector(n);
+ y_ = vector(n);
+
+ for (i=1;i<n;i++) z[i] = 0.; z[0] = 1.;
+
+ newmu = 0.; newi = 0;
+ count = 0; *status = limit;
+
+ while ( (count<maxits) && (*status==limit) ) {
+ count++;
+ matvec(n, p, z, y_);
+ oldmu = newmu; oldi = newi; newmu = 0.;
+
+ for (i=0;i<n;i++)
+ if ( fabs(y_[i])>fabs(newmu) ) { newmu = y_[i]; newi = i; }
+
+ for (i=0;i<n;i++) z[i] = y_[i] / newmu;
+
+ if ( fabs(newmu-oldmu)<=epsilon && newi==oldi ) *status = convgd;
+ }
+
+ for (i=0;i<n;i++) x_[i] = z[i];
+
+ if (*status == convgd) { *lambda = newmu; *noofit = count; }
+ else { *noofit = maxits; }
+}
+
+
+/* Brownian Motion ARL approximations for CUSUM */
+double BM_xc_arl(double k, double h, double mu)
+{ double Delta, b, arl, offset=1.166;
+/* offset examples
+ 0 -- Bagshaw/Johnson (1975)
+ 1.2 -- Reynolds (1975)
+ 1.166 -- Siegmund (1985)
+*/
+ Delta = mu - k;
+ b = h + offset;
+ if ( fabs(Delta) > 1e-10 ) arl = ( exp(-2.*Delta*b) + 2.*Delta*b - 1. )/2./Delta/Delta;
+ else arl = b*b;
+ return arl;
+}
+
+
+double BM_xc_crit(double k, double L0, double m0)
+{ double c1, c2, c3, L1=0., L2=0., L3=0., dc;
+
+ c2 = 0.;
+ do {
+ c2 += .1;
+ L2 = BM_xc_arl(k, c2, m0);
+ } while ( L2<L0 );
+
+ c1 = c2 - .1;
+ L1 = BM_xc_arl(k, c1, m0);
+
+ do {
+ if ( fabs(L2-L1) > 1e-10 ) {
+ c3 = c1 + (L0-L1)/(L2-L1) * (c2-c1);
+ L3 = BM_xc_arl(k, c3, m0);
+ dc = c3-c2; c1 = c2; L1 = L2; c2 = c3; L2 = L3;
+ } else {
+ dc = 1e-12;
+ c3 = c2;
+ }
+ } while ( (fabs(L0-L3)>1e-6) && (fabs(dc)>1e-9) );
+ return c3;
+}
+
+
+
+/* ************************************************************************* */
+/* zero-state and steady-state ARl and critical value routines */
+
+double xc_crit(int ctyp, double k, double L0, double hs, double m0, int N)
+{ double c1, c2, c3, L1=0., L2=0., L3=0., dc, k_bm;
+
+ if ( ctyp==cusumC || fabs(hs)>1e-9 ) {
+ c2 = 0.;
+ do {
+ c2 += .5;
+ if (ctyp==cusum1) L2 = xc1_iglarl ( k,c2,hs,m0,N );
+ if (ctyp==cusum2) L2 = xc2_iglarl ( k,c2,hs,m0,N );
+ if (ctyp==cusumC) L2 = xcC_iglarl ( k,c2,hs,m0,N );
+ } while (L2<L0);
+
+ c1 = c2 - .5;
+
+ if (ctyp==cusum1) L1 = xc1_iglarl ( k,c1,hs,m0,N );
+ if (ctyp==cusum2) L1 = xc2_iglarl ( k,c1,hs,m0,N );
+ if (ctyp==cusumC) L1 = xcC_iglarl ( k,c1,hs,m0,N );
+ } else {
+ k_bm = k;
+ /*if ( fabs(m0 - k) < 1e-3 ) k_bm = 1e-3;*/
+ if ( ctyp==cusum1 ) {
+ c2 = BM_xc_crit(k_bm, L0, m0);
+ } else {
+ c2 = BM_xc_crit(k_bm, 2.*L0, m0);
+ }
+ c1 = c2 - .2;
+ if ( ctyp==cusum1 ) {
+ L1 = xc1_iglarl ( k,c1,hs,m0,N );
+ L2 = xc1_iglarl ( k,c2,hs,m0,N );
+ } else {
+ L1 = xc2_iglarl ( k,c1,hs,m0,N );
+ L2 = xc2_iglarl ( k,c2,hs,m0,N );
+ }
+ }
+
+ do {
+ c3 = c1 + (L0-L1)/(L2-L1) * (c2-c1);
+ if (ctyp==cusum1) L3 = xc1_iglarl ( k,c3,hs,m0,N );
+ if (ctyp==cusum2) L3 = xc2_iglarl ( k,c3,hs,m0,N );
+ if (ctyp==cusumC) L3 = xcC_iglarl ( k,c3,hs,m0,N );
+ dc = c3-c2; c1 = c2; L1 = L2; c2 = c3; L2 = L3;
+ } while ( (fabs(L0-L3)>1e-6) && (fabs(dc)>1e-9) );
+ return c3;
+}
+
+
+double xsr1_crit(double k, double L0, double zr, double hs, double m0, int N, int MPT)
+{ double c1, c2, c3, L1, L2, L3, dc;
+
+ c2 = 0.;
+ do {
+ c2 += .5;
+ L2 = xsr1_iglarl(k, c2, zr, hs, m0, N, MPT);
+ } while ( L2<L0 );
+
+ c1 = c2 - .5;
+ L1 = xsr1_iglarl(k, c1, zr, hs, m0, N, MPT);
+
+ do {
+ c3 = c1 + (L0-L1)/(L2-L1) * (c2-c1);
+ L3 = xsr1_iglarl(k, c3, zr, hs, m0, N, MPT);
+ dc = c3-c2; c1 = c2; L1 = L2; c2 = c3; L2 = L3;
+ } while ( (fabs(L0-L3)>1e-6) && (fabs(dc)>1e-9) );
+ return c3;
+}
+
+
+double xe_crit(int ctyp, double l, double L0, double zr, double hs, double m0, int ltyp, int N, double c0)
+{ double c1, c2, c3, L1=0., L2=0., L3=0., dc, norm, L2old=0., c2old=0.;
+ int nmax=100000;
+
+ if ( (ctyp==ewma1 && c0 < zr) || (ctyp==ewma2 && c0 < 0.) ) c2 = 1.; else c2 = c0;
+
+ do {
+ if ( ctyp==ewma1 ) {
+ if ( ltyp==fix && hs>=0. ) L2 = xe1_iglarl ( l,c2,zr,hs,m0,N );
+ if ( ltyp==fix && hs<0. ) L2 = xe1_iglarl ( l,c2,zr,c2/2,m0,N );
+ if ( ltyp>fix ) L2 = xe1_arlm ( l,c2,zr,hs,1,m0,m0,ltyp,N,nmax );
+ }
+ if ( ctyp==ewma2 ) {
+ if ( ltyp==fix ) L2 = xe2_iglarl ( l,c2,hs,m0,N );
+ if ( ltyp>fix ) {
+ if ( hs<0. && ltyp==fir ) L2 = xe2_arlm ( l,c2,c2/2.,1,m0,m0,ltyp,N,nmax );
+ if ( hs<0. && ltyp==both ) L2 = xe2_arlm ( l,c2,c2/2.*sqrt(l*(2.-l)),1,m0,m0,ltyp,N,nmax );
+ if ( hs>=0. ) L2 = xe2_arlm ( l,c2,hs,1,m0,m0,ltyp,N,nmax );
+ }
+ }
+ if ( L2 < 1. ) c2 -= .1;
+ } while ( L2 < 1. && c2 > .00001 );
+
+ if ( L2 < 1. ) error("invalid ARL value");
+ if ( L2 > L0 ) { norm = -.1; } else { norm = .5; }
+ if ( L2 < 1. + 1e-12 ) { c2 = 0.; norm = .1; }
+ if ( (ctyp==ewma1 && c0 > zr) || (ctyp==ewma2 && c0 > 0.) ) norm /= 10.;
+
+ do {
+ L2old = L2;
+ c2old = c2;
+ c2 += norm;
+ do {
+ if ( ctyp==ewma1 ) {
+ if ( ltyp==fix && hs>=0. ) L2 = xe1_iglarl ( l,c2,zr,hs,m0,N );
+ if ( ltyp==fix && hs<0. ) L2 = xe1_iglarl ( l,c2,zr,c2/2,m0,N );
+ if ( ltyp>fix ) L2 = xe1_arlm ( l,c2,zr,hs,1,m0,m0,ltyp,N,nmax );
+ }
+ if ( ctyp==ewma2 ) {
+ if ( ltyp==fix ) L2 = xe2_iglarl ( l,c2,hs,m0,N );
+ if ( ltyp>fix ) {
+ if ( hs<0. && ltyp==fir ) L2 = xe2_arlm ( l,c2,c2/2.,1,m0,m0,ltyp,N,nmax );
+ if ( hs<0. && ltyp==both ) L2 = xe2_arlm ( l,c2,c2/2.*sqrt(l*(2.-l)),1,m0,m0,ltyp,N,nmax );
+ if ( hs>=0. ) L2 = xe2_arlm ( l,c2,hs,1,m0,m0,ltyp,N,nmax );
+ }
+ }
+ if ( L2 < 1. ) { norm /= 2.; c2 -= norm; }
+ if ( c2 <= 1e-9 && fabs(L2-L2old)>100. ) norm = -.001;
+ } while ( L2 < 1. );
+ } while ( ((L2 < L0 && norm>0.) || (L2 > L0 && norm<0.)) && (fabs(norm)>1e-8) );
+
+ c1 = c2old;
+ L1 = L2old;
+
+ do {
+ c3 = c1 + (L0-L1)/(L2-L1) * (c2-c1);
+ norm = .5;
+ do {
+ if ( ctyp==ewma1 ){
+ if ( ltyp==fix && hs>=0. ) L3 = xe1_iglarl ( l,c3,zr,hs,m0,N );
+ if ( ltyp==fix && hs<0. ) L3 = xe1_iglarl ( l,c3,zr,c3/2,m0,N );
+ if ( ltyp>fix ) L3 = xe1_arlm ( l,c3,zr,hs,1,m0,m0,ltyp,N,nmax );
+ }
+ if ( ctyp==ewma2 ) {
+ if ( ltyp==fix ) L3 = xe2_iglarl ( l,c3,hs,m0,N );
+ if ( ltyp>fix ) {
+ if ( hs<0. && ltyp==fir ) L3 = xe2_arlm ( l,c3,c3/2.,1,m0,m0,ltyp,N,nmax );
+ if ( hs<0. && ltyp==both ) L3 = xe2_arlm ( l,c3,c3/2.*sqrt(l*(2.-l)),1,m0,m0,ltyp,N,nmax );
+ if ( hs>=0. ) L3 = xe2_arlm ( l,c3,hs,1,m0,m0,ltyp,N,nmax );
+ }
+ }
+ if ( L3 < 1. ) {
+ c3 = c1 + norm*(L0-L1)/(L2-L1) * (c2-c1);
+ norm /= 2.;
+ }
+ } while ( (L3 < 1.) && (fabs(norm)>1e-8) );
+ dc = c3-c2; c1 = c2; L1 = L2; c2 = c3; L2 = L3;
+ if ( L3 < 1. ) error("invalid ARL value");
+ } while ( (fabs(L0-L3)>1e-6) && (fabs(dc)>1e-9) );
+ if ( fabs(L0-L3)>1e-6 ) warning("did not converge");
+ return c3;
+}
+
+
+double xe_q_crit(int ctyp, double l, int L0, double alpha, double zr, double hs, double m0, int ltyp, int N, double c_error, double a_error)
+{ double c1=0., c2=0., c3=0., p1=1., p2=1., p3=1., dc, *SF;
+ int result=1;
+
+ SF = vector(L0);
+
+ c2 = 0.; p2 = 1.;
+ do {
+ p1 = p2;
+ c2 += .5;
+ if ( ctyp==ewma1 && ltyp==fix ) result = xe1_sf(l, c2, zr, hs, m0, N, L0, SF);
+ if ( ctyp==ewma1 && ltyp>fix ) error("not implemented yet for one-sided EWMA and varying limits");
+ if ( ctyp==ewma2 && ltyp==fix ) result = xe2_sf(l, c2, hs, m0, N, L0, SF);
+ if ( ctyp==ewma2 && ltyp>fix ) result = xe2_sfm(l, c2, hs, 1, m0, m0, ltyp, N, L0, SF);
+ if ( result != 0 ) warning("trouble in xe_q_crit [package spc]");
+ p2 = 1. - SF[L0-1];
+ } while ( p2 > alpha );
+ c1 = c2 - .5;
+
+ do {
+ c3 = c1 + ( alpha - p1 )/( p2 - p1 ) * ( c2 - c1 );
+ if ( ctyp==ewma1 && ltyp==fix ) result = xe1_sf(l, c3, zr, hs, m0, N, L0, SF);
+ if ( ctyp==ewma1 && ltyp>fix ) error("not implemented yet for one-sided EWMA and varying limits");
+ if ( ctyp==ewma2 && ltyp==fix ) result = xe2_sf(l, c3, hs, m0, N, L0, SF);
+ if ( ctyp==ewma2 && ltyp>fix ) result = xe2_sfm(l, c3, hs, 1, m0, m0, ltyp, N, L0, SF);
+ if ( result != 0 ) warning("trouble in xe_q_crit [package spc]");
+ p3 = 1. - SF[L0-1];
+
+ dc = c3 - c2; c1 = c2; p1 = p2; c2 = c3; p2 = p3;
+ } while ( fabs(alpha - p3)>a_error && fabs(dc)>c_error );
+
+ Free(SF);
+
+ return c3;
+}
+
+
+double xc1_iglarl (double k, double h, double hs, double mu, int N)
+{ double *a, *g, *w, *z, arl;
+ int i, j, NN;
+
+ NN = N + 1;
+ a = matrix(NN,NN);
+ g = vector(NN);
+ w = vector(N);
+ z = vector(N);
+
+ gausslegendre(N,0.,h,z,w);
+
+ for (i=0;i<N;i++) {
+ for (j=0;j<N;j++) a[i*NN+j] = -w[j]*phi(z[j]+k-z[i],mu);
+ ++a[i*NN+i];
+ a[i*NN+N] = -PHI(k-z[i],mu);
+ }
+ for (j=0;j<N;j++)
+ a[N*NN+j] = -w[j]*phi(z[j]+k,mu);
+ a[N*NN+N] = 1. - PHI(k,mu);
+
+ for (j=0;j<NN;j++) g[j] = 1.;
+ LU_solve(a,g,NN);
+
+ arl = 1. + PHI(k-hs,mu)*g[N];
+ for (j=0;j<N;j++)
+ arl += w[j]*phi(z[j]+k-hs,mu) * g[j];
+
+ Free(a);
+ Free(g);
+ Free(w);
+ Free(z);
+
+ return arl;
+}
+
+
+double xtc1_iglarl(double k, double h, double hs, int df, double mu, int N, int subst)
+{ double *a, *g, *w, *z, arl, norm=1., arg=0., korr=1.;
+ int i, j, NN;
+
+ NN = N + 1;
+ a = matrix(NN,NN);
+ g = vector(NN);
+ w = vector(N);
+ z = vector(N);
+
+ switch ( subst ) {
+ case IDENTITY: gausslegendre(N, 0, h, z, w); norm = 1.; break;
+ case SIN: gausslegendre(N, 0., PI/2., z, w); norm = 1.; break;
+ case SINH: gausslegendre(N, 0., 1., z, w); norm = sinh(1.); break;
+ case TAN: gausslegendre(N, 0., PI/4., z, w); norm = 1.; break;
+ }
+
+ h /= norm;
+
+ for (i=0;i<N;i++) {
+ for (j=0;j<N;j++) {
+ switch ( subst ) {
+ case IDENTITY: arg = z[j] + k - z[i]; korr = 1.; break;
+ case SIN: arg = h*sin(z[j]) + k - h*sin(z[i]); korr = h*cos(z[j]); break;
+ case SINH: arg = h*sinh(z[j]) + k - h*sinh(z[i]); korr = h*cosh(z[j]); break;
+ case TAN: arg = h*tan(z[j]) + k - h*tan(z[i]); korr = h/( cos(z[j])*cos(z[j]) ); break;
+ }
+ a[i*NN+j] = -w[j] * pdf_t( arg - mu, df) * korr;
+ }
+ ++a[i*NN+i];
+ switch ( subst ) {
+ case IDENTITY: arg = k - z[i]; break;
+ case SIN: arg = k - h*sin(z[i]); break;
+ case SINH: arg = k - h*sinh(z[i]); break;
+ case TAN: arg = k - h*tan(z[i]); break;
+ }
+ a[i*NN+N] = - cdf_t(arg - mu, df);
+ }
+
+ for (j=0;j<N;j++) {
+ switch ( subst ) {
+ case IDENTITY: arg = z[j] + k; korr = 1.; break;
+ case SIN: arg = h*sin(z[j]) + k; korr = h*cos(z[j]); break;
+ case SINH: arg = h*sinh(z[j]) + k; korr = h*cosh(z[j]); break;
+ case TAN: arg = h*tan(z[j]) + k; korr = h/( cos(z[j])*cos(z[j]) ); break;
+ }
+ a[N*NN+j] = -w[j] * pdf_t( arg - mu, df) * korr;
+ }
+ a[N*NN+N] = 1. - cdf_t(k - mu, df);
+
+ for (j=0;j<NN;j++) g[j] = 1.;
+ LU_solve(a, g, NN);
+
+ switch ( subst ) {
+ case IDENTITY: arg = k - hs; korr = 1.; break;
+ case SIN: arg = k - h*sin(hs); korr = h*cos(z[j]); break;
+ case SINH: arg = k - h*sinh(hs); korr = h*cosh(z[j]); break;
+ case TAN: arg = k - h*tan(hs); korr = h/( cos(z[j])*cos(z[j]) ); break;
+ }
+ arl = 1. + cdf_t(k - hs - mu, df) * g[N];
+ for (j=0;j<N;j++) {
+ switch ( subst ) {
+ case IDENTITY: arg = z[j] + k - hs; korr = 1.; break;
+ case SIN: arg = h*sin(z[j]) + k - h*sin(hs); korr = h*cos(z[j]); break;
+ case SINH: arg = h*sinh(z[j]) + k - h*sinh(hs); korr = h*cosh(z[j]); break;
+ case TAN: arg = h*tan(z[j]) + k - h*tan(hs); korr = h/( cos(z[j])*cos(z[j]) ); break;
+ }
+ arl += w[j] * pdf_t( arg - mu, df) * korr * g[j];
+ }
+
+ Free(a);
+ Free(g);
+ Free(w);
+ Free(z);
+
+ return arl;
+}
+
+
+double xc1_Wq(double k, double h, double p, double hs, double mu, int N, int nmax)
+{ double *Pn, *w, *z, *p0, *atom, ratio, q_minus=0., q_plus=0., mn_minus=1., mn_plus=0., enumerator=0., Wq=0.;
+ int i, j, n;
+
+ w = vector(N);
+ z = vector(N);
+ Pn = matrix(nmax,N);
+ p0 = vector(nmax);
+ atom = vector(nmax);
+
+ gausslegendre(N,0,h,z,w);
+
+ for (n=1;n<=nmax;n++) {
+
+ if (n==1) {
+ for (i=0;i<N;i++)
+ Pn[i] = PHI( -z[i]+h+k, mu);
+ atom[0] = PHI( h+k, mu);
+ } else {
+ for (i=0;i<N;i++) {
+ Pn[(n-1)*N+i] = PHI( -z[i]+k, mu) * atom[n-2];
+ for (j=0;j<N;j++) Pn[(n-1)*N+i] += w[j] * phi( z[j]-z[i]+k, mu) * Pn[(n-2)*N+j];
+ }
+ atom[n-1] = PHI( k, mu) * atom[n-2];
+ for (j=0;j<N;j++) atom[n-1] += w[j] * phi( z[j]+k, mu) * Pn[(n-2)*N+j];
+ }
+
+ if (n==1)
+ p0[0] = PHI( h-hs+k, mu);
+ else {
+ p0[n-1] = PHI( -hs+k, mu) * atom[n-2];
+ for (j=0;j<N;j++) p0[n-1] += w[j] * phi( z[j]-hs+k, mu) * Pn[(n-2)*N+j];
+ }
+
+ if ( p0[n-1] < 1.-p ) {
+ Wq = (double)n;
+ n = nmax+1;
+ } else {
+ mn_minus = 1.; mn_plus = 0.;
+ if ( n>1 ) {
+ for (i=0; i<N; i++) {
+ if (Pn[(n-2)*N+i]==0)
+ if (Pn[(n-1)*N+i]==0) ratio = 0.;
+ else ratio = 1.;
+ else ratio = Pn[(n-1)*N+i]/Pn[(n-2)*N+i];
+ if ( ratio<mn_minus ) mn_minus = ratio;
+ if ( ratio>mn_plus ) mn_plus = ratio;
+ }
+ enumerator = log( (1.-p)/p0[n-1] );
+ q_minus = (double)n + enumerator/log(mn_minus);
+ q_plus = (double)n + enumerator/log(mn_plus);
+ if ( fabs( ceil(q_plus) - ceil(q_minus) ) < .5 ) {
+ Wq = ceil(q_plus);
+ n = nmax +1;
+ }
+ } /* n > 1 */
+ } /* p0[n-1] >= 1.-p */
+ } /* n=1; n<=nmax; n++ */
+
+ Free(p0);
+ Free(Pn);
+ Free(z);
+ Free(w);
+ Free(atom);
+
+ return Wq;
+}
+
+
+double xc1_sf(double k, double h, double hs, double mu, int N, int nmax, double *p0)
+{ double *Pn, *w, *z, *atom;
+ int i, j, n;
+
+ w = vector(N);
+ z = vector(N);
+ Pn = matrix(nmax,N);
+ atom = vector(nmax);
+
+ gausslegendre(N,0,h,z,w);
+
+ for (n=1;n<=nmax;n++) {
+ if (n==1) {
+ for (i=0;i<N;i++)
+ Pn[i] = PHI( -z[i]+h+k, mu);
+ atom[0] = PHI( h+k, mu);
+ } else {
+ for (i=0;i<N;i++) {
+ Pn[(n-1)*N+i] = PHI( -z[i]+k, mu) * atom[n-2];
+ for (j=0;j<N;j++) Pn[(n-1)*N+i] += w[j] * phi( z[j]-z[i]+k, mu) * Pn[(n-2)*N+j];
+ }
+ atom[n-1] = PHI( k, mu) * atom[n-2];
+ for (j=0;j<N;j++) atom[n-1] += w[j] * phi( z[j]+k, mu) * Pn[(n-2)*N+j];
+ }
+
+ if (n==1)
+ p0[0] = PHI( h-hs+k, mu);
+ else {
+ p0[n-1] = PHI( -hs+k, mu) * atom[n-2];
+ for (j=0;j<N;j++) p0[n-1] += w[j] * phi( z[j]-hs+k, mu) * Pn[(n-2)*N+j];
+ }
+ }
+
+ Free(Pn);
+ Free(z);
+ Free(w);
+ Free(atom);
+
+ return 0;
+}
+
+
+double xc1_arlm(double k, double h, double hs, int q, double mu0, double mu1, int N, int nmax)
+{ double *p0, *fn, *w, *z, arl0, rho, arl_minus=0., arl, arl_plus=0., mn_minus=0., mn_plus=0., ratio=0.;
+ int i, j, n, NN;
+
+ NN = N + 1;
+ w = vector(NN);
+ z = vector(NN);
+ fn = matrix(nmax, NN);
+ p0 = vector(nmax);
+
+ gausslegendre(N, 0., h, z, w);
+
+ /* in-control, i. e. n<=q-1 */
+ for (n=1;n<=q-1;n++) {
+ /* determine f_n, n=1,2,...,q-1 */
+ if (n==1) {
+ for (i=0;i<N;i++) fn[0*NN+i] = phi( z[i]+k-hs, mu0);
+ fn[0*NN+N] = PHI( k-hs, mu0);
+ } else {
+ for (i=0;i<N;i++) {
+ fn[(n-1)*NN+i] = fn[(n-2)*NN+N] * phi(z[i] + k, mu0);
+ for (j=0;j<N;j++) {
+ fn[(n-1)*NN+i] += w[j] * fn[(n-2)*NN+j] * phi(z[i] + k - z[j], mu0);
+ }
+ }
+ fn[(n-1)*NN+N] = fn[(n-2)*NN+N] * PHI(k, mu0);
+ for (j=0;j<N;j++) fn[(n-1)*NN+N] += w[j] * fn[(n-2)*NN+j] * PHI(k - z[j], mu0);
+ }
+
+ /* determine P(L>n), n=1,2,...,q-1 */
+ p0[n-1] = fn[(n-1)*NN+N];
+ for (i=0;i<N;i++) p0[n-1] += w[i] * fn[(n-1)*NN+i];
+ }
+
+ /* out-of-control, i.e. t>=q */
+ arl0 = 1.; rho = 0.;
+
+ for (n=q;n<=nmax;n++) {
+ /* determine f_n, n=q,q+1,... */
+
+ if (n==1) {
+ for (i=0;i<N;i++) fn[0*NN+i] = phi( z[i]+k-hs, mu1);
+ fn[0*NN+N] = PHI( k-hs, mu1);
+ } else {
+ for (i=0;i<N;i++) {
+ fn[(n-1)*NN+i] = fn[(n-2)*NN+N] * phi(z[i] + k, mu1);
+ for (j=0;j<N;j++) {
+ fn[(n-1)*NN+i] += w[j] * fn[(n-2)*NN+j] * phi(z[i] + k - z[j], mu1);
+ }
+ if (n==q && q>1) fn[(n-1)*NN+i] /= p0[q-2];
+ }
+ fn[(n-1)*NN+N] = fn[(n-2)*NN+N] * PHI(k, mu1);
+ for (j=0;j<N;j++) fn[(n-1)*NN+N] += w[j] * fn[(n-2)*NN+j] * PHI(k - z[j], mu1);
+ if (n==q && q>1) fn[(n-1)*NN+N] /= p0[q-2];
+ }
+
+ /* determine P(L>n), n=1,2,...,q-1 */
+ p0[n-1] = fn[(n-1)*NN+N];
+ for (i=0;i<N;i++) p0[n-1] += w[i] * fn[(n-1)*NN+i];
+
+ /* computation of m_n+1^- and m_n+1^+, n=m-1,m,... */
+ mn_minus = 1.; mn_plus = 0.;
+ if (n>q) {
+ for (i=0;i<NN;i++) {
+ if (fn[(n-2)*NN+i]==0)
+ if (fn[(n-1)*NN+i]==0) ratio = 0.; else ratio = 1.;
+ else ratio = fn[(n-1)*NN+i]/fn[(n-2)*NN+i];
+ if ( ratio<mn_minus ) mn_minus = ratio;
+ if ( ratio>mn_plus ) mn_plus = ratio;
+ }
+ }
+
+ if (n>q) rho = p0[n-1]/p0[n-2];
+
+ /* computation of ARL, ARL^-, and ARL^+ */
+ arl = arl0 + p0[n-1]/(1.-rho);
+ if (mn_minus<1.) arl_minus = arl0 + p0[n-1]/(1.-mn_minus);
+ else arl_minus = -1.;
+ if (mn_plus<1.) arl_plus = arl0 + p0[n-1]/(1.-mn_plus);
+ else arl_plus = -1.;
+ arl0 += p0[n-1];
+
+ if ( fabs((arl_plus-arl_minus)) < 1e-7 ) n = nmax+1;
+ }
+
+ arl = (arl_plus+arl_minus)/2.; rho0 = rho;
+
+ Free(w);
+ Free(z);
+ Free(fn);
+ Free(p0);
+
+ return arl;
+}
+
+
+double xc1_arlm_hom(double k, double h, double hs, int q, double mu0, double mu1, int N, double *ced)
+{ double *fn, *w, *z, *a, *arl, norm;
+ int i, j, n, NN;
+
+ NN = N + 1;
+ w = vector(NN);
+ z = vector(NN);
+ fn = matrix(q+1, NN);
+ a = matrix(NN,NN);
+ arl = vector(NN);
+
+ gausslegendre(N, 0., h, z, w);
+
+ /* ARL vector */
+ for (i=0; i<N; i++) {
+ for (j=0; j<N; j++) a[i*NN+j] = -w[j] * phi( z[j]+k-z[i], mu1);
+ ++a[i*NN+i];
+ a[i*NN+N] = - PHI(k-z[i], mu1);
+ }
+ for (j=0;j<N;j++) a[N*NN+j] = -w[j] * phi( z[j]+k, mu1);
+ a[N*NN+N] = 1. - PHI(k, mu1);
+
+ for (j=0;j<NN;j++) arl[j] = 1.;
+ LU_solve(a,arl,NN);
+
+ /* q == 1 */
+ ced[0] = 1. + PHI( k-hs, mu1) * arl[N];
+ for (j=0; j<N; j++) ced[0] += w[j] * phi( z[j]+k-hs, mu1) * arl[j];
+
+
+ /* density sequence for q > 1 */
+ for (n=1; n<=q-1; n++) {
+ if (n==1) {
+ for (i=0; i<N; i++) fn[0*NN+i] = phi( z[i]+k-hs, mu0);
+ fn[0*NN+N] = PHI( k-hs, mu0);
+ } else {
+ for (i=0; i<N; i++) {
+ fn[(n-1)*NN+i] = fn[(n-2)*NN+N] * phi( z[i] + k, mu0);
+ for (j=0; j<N; j++) fn[(n-1)*NN+i] += w[j] * fn[(n-2)*NN+j] * phi( z[i] + k - z[j], mu0);
+ }
+ fn[(n-1)*NN+N] = fn[(n-2)*NN+N] * PHI(k, mu0);
+ for (j=0;j<N;j++) fn[(n-1)*NN+N] += w[j] * fn[(n-2)*NN+j] * PHI(k - z[j], mu0);
+ }
+
+ ced[n] = fn[(n-1)*NN+N] * arl[N];
+ norm = fn[(n-1)*NN+N];
+ for (j=0; j<N; j++) {
+ ced[n] += w[j] * fn[(n-1)*NN+j] * arl[j];
+ norm += w[j] * fn[(n-1)*NN+j];
+ }
+ ced[n] /= norm;
+ }
+
+ Free(w);
+ Free(z);
+ Free(fn);
+ Free(a);
+ Free(arl);
+
+ return 0;
+}
+
+
+double xc1_iglarl_drift(double k, double h, double hs, double delta, int m, int N, int with0)
+{ double *a, *g, *w, *z, arl, *MUs, *ARLs;
+ int i, j, NN, m_;
+
+ NN = N + 1;
+ a = matrix(NN, NN);
+ g = vector(NN);
+ w = vector(NN);
+ z = vector(NN);
+ ARLs = vector(NN);
+ MUs = vector(m+1);
+
+ gausslegendre(N, 0., h, z, w);
+
+ if ( with0 ) {
+ for (i=0;i<=m;i++) MUs[i] = (double)i * delta;
+ } else {
+ for (i=0;i<=m;i++) MUs[i] = (double)(i+1.) * delta;
+ }
+
+ for (i=0;i<N;i++) {
+ for (j=0;j<N;j++) a[i*NN+j] = -w[j] * phi( z[j]+k-z[i], MUs[m]);
+ ++a[i*NN+i];
+ a[i*NN+N] = -PHI( k-z[i], MUs[m]);
+ }
+ for (j=0;j<N;j++)
+ a[N*NN+j] = -w[j] * phi( z[j]+k, MUs[m]);
+ a[N*NN+N] = 1. - PHI(k, MUs[m]);
+
+ for (j=0;j<NN;j++) g[j] = 1.;
+ LU_solve(a, g, NN);
+
+ for (m_=0;m_<m;m_++) {
+ for (i=0;i<=N;i++) {
+ ARLs[i] = 1. + PHI( k-z[i], MUs[m-m_]) * g[N];
+ for (j=0;j<N;j++) {
+ ARLs[i] += w[j] * phi( z[j]+k-z[i], MUs[m-m_]) * g[j];
+ }
+ }
+ for (j=0;j<=N;j++) g[j] = ARLs[j];
+ }
+
+ arl = 1. + PHI( k-hs, MUs[0]) * ARLs[N];
+ for (j=0;j<N;j++) arl += w[j] * phi( z[j]+k-hs, MUs[0]) * ARLs[j];
+
+ Free(a);
+ Free(g);
+ Free(w);
+ Free(z);
+ Free(ARLs);
+ Free(MUs);
+
+ return arl;
+}
+
+
+double xc1_iglarl_drift_wo_m(double k, double h, double hs, double delta, int *m, int N, int with0)
+{ int m_;
+ double arl1, arl2, eps=1e-6;
+ m_ = 4;
+ arl1 = xc1_iglarl_drift(k, h, hs, delta, m_, N, with0);
+ arl2 = arl1 + 2.*eps;
+ while ( fabs(arl2-arl1)>eps && (double)m_<1e4 ) {
+ m_ = (int)round(1.5 * m_);
+ arl1 = xc1_iglarl_drift(k, h, hs, delta, m_, N, with0);
+ arl2 = xc1_iglarl_drift(k, h, hs, delta, m_+1, N, with0);
+ }
+ *m = m_;
+ return arl1;
+}
+
+
+double xc1_iglarlm_drift(double k, double h, double hs, int q, double delta, int N, int nmax, int with0)
+{ double *p0, *fn, *w, *z, arl0, rho, MEAN=0.,
+ arl_minus=0., arl, arl_plus=0., mn_minus=0., mn_plus=0., nn, ratio=0.;
+ int i, j, n, NN;
+
+ NN = N + 1;
+ w = vector(NN);
+ z = vector(NN);
+ fn = matrix(nmax, NN);
+ p0 = vector(nmax);
+
+ gausslegendre(N, 0, h, z, w);
+
+ /* in-control, i. e. n<=q-1 */
+ MEAN = 0.;
+
+ for (n=1;n<=q-1;n++) {
+ nn = (double) n;
+
+ /* determine f_n, n=1,2,...,q-1 */
+ if (n==1) {
+ for (i=0;i<N;i++) fn[0*NN+i] = phi( z[i]+k-hs, MEAN);
+ fn[0*NN+N] = PHI( k-hs, MEAN);
+ } else {
+ for (i=0;i<N;i++) {
+ fn[(n-1)*NN+i] = fn[(n-2)*NN+N] * phi(z[i] + k, MEAN);
+ for (j=0;j<N;j++) {
+ fn[(n-1)*NN+i] += w[j] * fn[(n-2)*NN+j] * phi(z[i] + k - z[j], MEAN);
+ }
+ }
+ fn[(n-1)*NN+N] = fn[(n-2)*NN+N] * PHI(k, MEAN);
+ for (j=0;j<N;j++) fn[(n-1)*NN+N] += w[j] * fn[(n-2)*NN+j] * PHI(k - z[j], MEAN);
+ }
+
+ /* determine P(L>n), n=1,2,...,q-1 */
+ p0[n-1] = fn[(n-1)*NN+N];
+ for (i=0;i<N;i++) p0[n-1] += w[i] * fn[(n-1)*NN+i];
+ }
+
+ /* out-of-control, i.e. t>=q */
+ arl0 = 1.; rho = 0.;
+
+ for (n=q;n<=nmax;n++) {
+ nn = (double) n;
+
+ /* determine f_n, n=q,q+1,... */
+ if ( with0 ) {
+ MEAN = (nn-(double)q) * delta;
+ } else {
+ MEAN = (nn-(double)q+1.) * delta;
+ }
+
+ if (n==1) {
+ for (i=0;i<N;i++) fn[0*NN+i] = phi( z[i]+k-hs, MEAN);
+ fn[0*NN+N] = PHI( k-hs, MEAN);
+ } else {
+ for (i=0;i<N;i++) {
+ fn[(n-1)*NN+i] = fn[(n-2)*NN+N] * phi(z[i] + k, MEAN);
+ for (j=0;j<N;j++) {
+ fn[(n-1)*NN+i] += w[j] * fn[(n-2)*NN+j] * phi(z[i] + k - z[j], MEAN);
+ }
+ if (n==q && q>1) fn[(n-1)*NN+i] /= p0[q-2];
+ }
+ fn[(n-1)*NN+N] = fn[(n-2)*NN+N] * PHI(k, MEAN);
+ for (j=0;j<N;j++) fn[(n-1)*NN+N] += w[j] * fn[(n-2)*NN+j] * PHI(k - z[j], MEAN);
+ if (n==q && q>1) fn[(n-1)*NN+N] /= p0[q-2];
+ }
+
+ /* determine P(L>n), n=1,2,...,q-1 */
+ p0[n-1] = fn[(n-1)*NN+N];
+ for (i=0;i<N;i++) p0[n-1] += w[i] * fn[(n-1)*NN+i];
+
+ /* computation of m_n+1^- and m_n+1^+, n=m-1,m,... */
+ mn_minus = 1.; mn_plus = 0.;
+ if (n>q) {
+ for (i=0;i<NN;i++) {
+ if (fn[(n-2)*NN+i]==0)
+ if (fn[(n-1)*NN+i]==0) ratio = 0.; else ratio = 1.;
+ else ratio = fn[(n-1)*NN+i]/fn[(n-2)*NN+i];
+ if ( ratio<mn_minus ) mn_minus = ratio;
+ if ( ratio>mn_plus ) mn_plus = ratio;
+ }
+ }
+
+ if (n>q) rho = p0[n-1]/p0[n-2];
+
+ /* computation of ARL, ARL^-, and ARL^+ */
+ arl = arl0 + p0[n-1]/(1.-rho);
+ if (mn_minus<1.) arl_minus = arl0 + p0[n-1]/(1.-mn_minus);
+ else arl_minus = -1.;
+ if (mn_plus<1.) arl_plus = arl0 + p0[n-1]/(1.-mn_plus);
+ else arl_plus = -1.;
+ arl0 += p0[n-1];
+
+ if ( fabs((arl_plus-arl_minus)) < 1e-7 ) n = nmax+1;
+ }
+
+ arl = (arl_plus+arl_minus)/2.; rho0 = rho;
+
+ Free(w);
+ Free(z);
+ Free(fn);
+ Free(p0);
+
+ return arl;
+}
+
+
+double xc2_iglarl(double k, double h, double hs, double mu, int N)
+{ double arl1, arl2, arl3, arl4, arl;
+
+/* relation between 1- and 2-sided CUSUM schemes due to Lucas/Crosier 1982,
+ Technometrics 24, 199-205;
+ only for headstart hs smaller than h/2 + k !!
+*/
+
+ arl1 = xc1_iglarl(k,h,0.,mu,N);
+ arl2 = xc1_iglarl(k,h,hs,mu,N);
+ arl3 = xc1_iglarl(k,h,0.,-mu,N);
+ arl4 = xc1_iglarl(k,h,hs,-mu,N);
+ arl = ( arl2*arl3 + arl1*arl4 - arl1*arl3 ) / ( arl1 + arl3 );
+ return arl;
+}
+
+
+double xtc2_iglarl(double k, double h, double hs, int df, double mu, int N, int subst)
+{ double arl1, arl2, arl3, arl4, arl;
+
+/* relation between 1- and 2-sided CUSUM schemes due to Lucas/Crosier 1982,
+ Technometrics 24, 199-205;
+ only for headstart hs smaller than h/2 + k !!
+*/
+
+ arl1 = xtc1_iglarl(k, h, 0., df, mu, N, subst);
+ arl2 = xtc1_iglarl(k, h, hs, df, mu, N, subst);
+ arl3 = xtc1_iglarl(k, h, 0., df, -mu, N, subst);
+ arl4 = xtc1_iglarl(k, h, hs, df, -mu, N, subst);
+ arl = ( arl2*arl3 + arl1*arl4 - arl1*arl3 ) / ( arl1 + arl3 );
+ return arl;
+}
+
+
+double xc2_be_arl (double k, double h, double hs1, double hs2, double mu, int N)
+{ double *a, *g, arl, z1, z2, z11, z12, z21, z22, w;
+ int i1, i2, j1, j2, NN, N3;
+
+/* two-dimensional Markov chain approximation */
+
+ NN = N*N; N3 = NN*N;
+ a = matrix(NN,NN);
+ g = vector(NN);
+
+ w = 2.*h/(2.*N - 1.);
+
+ for (i1=0;i1<N;i1++)
+ for (j1=0;j1<N;j1++)
+ for (i2=0;i2<N;i2++)
+ for (j2=0;j2<N;j2++) {
+ z11 = (i2-i1)*w - w/2. + k; if (i2==0) z11 = -10000.;
+ z12 = (i2-i1)*w + w/2. + k;
+ z21 = -2.*k - (j2-j1)*w - w/2. + k;
+ z22 = -2.*k - (j2-j1)*w + w/2. + k; if (j2==0) z22 = 10000.;
+ if ( z11 < z21 ) z1 = z21; else z1 = z11;
+ if ( z12 < z22 ) z2 = z12; else z2 = z22;
+ if ( z1 > z2 ) a[i1*N3+j1*NN+i2*N+j2] = 0.;
+ else a[i1*N3+j1*NN+i2*N+j2] = -PHI(z2, mu) + PHI(z1, mu);
+ if ( i1==i2 && j1==j2 ) a[i1*N3+j1*NN+i2*N+j2]++;
+ }
+
+ for (j1=0;j1<NN;j1++) g[j1] = 1.;
+ LU_solve(a, g, NN);
+
+ i1 = (int) ceil(hs1/w - .5);
+ i2 = (int) ceil(hs2/w - .5);
+ arl = g[i1*N + i2];
+
+ Free(a);
+ Free(g);
+
+ return arl;
+}
+
+
+double xc2_iglarl_drift(double k, double h, double hs, double delta, int m, int N, int drift0)
+{ double arl1, arl2, arl3, arl4, arl;
+
+/* relation between 1- and 2-sided CUSUM schemes due to Lucas/Crosier 1982,
+ Technometrics 24, 199-205;
+ only for headstart hs smaller than h/2 + k !!
+*/
+
+ arl1 = xc1_iglarl_drift(k, h, 0., delta, m, N, drift0);
+ arl2 = xc1_iglarl_drift(k, h, hs, delta, m, N, drift0);
+ arl3 = xc1_iglarl_drift(k, h, 0., -delta, m, N, drift0);
+ arl4 = xc1_iglarl_drift(k, h, hs, -delta, m, N, drift0);
+ arl = ( arl2*arl3 + arl1*arl4 - arl1*arl3 ) / ( arl1 + arl3 );
+ return arl;
+}
+
+
+double xc2_iglarl_drift_wo_m(double k, double h, double hs, double delta, int *m, int N, int drift0)
+{ int m_;
+ double arl1, arl2, eps=1e-6;
+ m_ = 4;
+ arl1 = xc2_iglarl_drift(k, h, hs, delta, m_, N, drift0);
+ arl2 = arl1 + 2.*eps;
+ while ( fabs(arl2-arl1)>eps && (double)m_<1e4 ) {
+ m_ = (int)round(1.5 * m_);
+ arl1 = xc2_iglarl_drift(k, h, hs, delta, m_, N, drift0);
+ arl2 = xc2_iglarl_drift(k, h, hs, delta, m_+1, N, drift0);
+ }
+ *m = m_;
+ return arl1;
+}
+
+
+double xcC_iglarl (double k, double h, double hs, double mu, int N)
+{ double *a, *g, *w, *z, arl;
+ int i, j, NN;
+
+ NN = 2*N + 1;
+ a = matrix(NN,NN);
+ g = vector(NN);
+ w = vector(NN);
+ z = vector(NN);
+
+ gausslegendre(N,0.,h,z,w);
+
+ for (i=0;i<N;i++) { /* upper */
+ for (j=0;j<N;j++) a[i*NN+j] = -w[j] *phi( z[j] +k-z[i],mu);
+ for (j=N;j<NN-1;j++) a[i*NN+j] = -w[j-N]*phi(-z[j-N]-k-z[i],mu);
+ ++a[i*NN+i];
+ a[i*NN+NN-1] = - ( PHI(k-z[i],mu) - PHI(-k-z[i],mu) );
+ }
+
+ for (i=N;i<NN-1;i++) { /* lower */
+ for (j=0;j<N;j++) a[i*NN+j] = -w[j] *phi( z[j] +k+z[i-N],mu);
+ for (j=N;j<NN-1;j++) a[i*NN+j] = -w[j-N]*phi(-z[j-N]-k+z[i-N],mu);
+ ++a[i*NN+i];
+ a[i*NN+NN-1] = - ( PHI(k+z[i-N],mu) - PHI(-k+z[i-N],mu) );
+ }
+
+ /* "fat" zero */
+ for (j=0;j<N;j++)
+ a[(NN-1)*NN+j] = -w[j] *phi( z[j] +k,mu);
+ for (j=N;j<NN-1;j++)
+ a[(NN-1)*NN+j] = -w[j-N]*phi(-z[j-N]-k,mu);
+ a[(NN-1)*NN+NN-1] = 1. - ( PHI(k,mu) - PHI(-k,mu) );
+
+ for (j=0;j<NN;j++) g[j] = 1.;
+ LU_solve(a,g,NN);
+
+ arl = 1. + ( PHI(k-hs,mu) - PHI(-k-hs,mu) )*g[NN-1];
+ for (j=0;j<N;j++)
+ arl += w[j] *phi( z[j] +k-hs,mu) * g[j];
+ for (j=N;j<NN-1;j++)
+ arl += w[j-N]*phi(-z[j-N]-k+hs,mu) * g[j];
+
+ Free(a);
+ Free(g);
+ Free(w);
+ Free(z);
+
+ return arl;
+}
+
+
+/* variance CUSUM charts */
+/* double s2cusumU_arl_igl */
+double scU_iglarl_v1(double refk, double h, double hs, double sigma, int df, int N, int qm)
+{ double *a, *g, *w, *z, *b, arl, Hij, xl, xu, za, dN, ddf, s2, alpha, *zch;
+ int i, j, k, M, Ntilde, NN, ii, jj, ihs, qi, qj;
+
+ M = ceil( h/refk );
+ ihs = ceil( hs/refk );
+ if ( ihs<=0 ) ihs = 1;
+ Ntilde = ceil( (double)N/(double)M );
+ NN = M*Ntilde;
+ s2 = sigma*sigma;
+ ddf = (double)df;
+ dN = (double)Ntilde;
+ alpha = ddf/2./s2;
+
+ a = matrix(NN,NN);
+ g = vector(NN);
+ b = vector(M+1);
+ w = vector(qm);
+ z = vector(qm);
+ zch = matrix(M,Ntilde);
+
+ /* interval borders b_i */
+ b[0] = 0.;
+ for (i=1; i<M; i++) b[i] = (double)(i)*refk;
+ b[M] = h;
+
+ /* Chebyshev nodes on [b_1,b_2],[b_2,b_3],...,[b_M,hu] */
+ for (i=1; i<=M; i++)
+ for (j=1; j<=Ntilde; j++)
+ zch[(i-1)*Ntilde + j-1] = b[i-1] + (b[i]-b[i-1])/2.*(1.+cos(PI*(2.*(Ntilde-j+1.)-1.)/2./dN));
+
+ for (i=1; i<=M; i++)
+ for (j=1; j<=Ntilde ;j++) {
+ qi = (i-1)*Ntilde + j-1;
+ za = zch[(i-1)*Ntilde + j-1] - refk;
+
+ for (ii=1; ii<=M; ii++) {
+ if ( za>b[ii-1] ) xl = za; else xl = b[ii-1];
+ xu = b[ii];
+ if ( df!=2 && b[ii]>za ) { xl = sqrt(xl-za); xu = sqrt(xu-za); }
+
+ for (jj=1; jj<=Ntilde; jj++) {
+ qj = (ii-1)*Ntilde + jj-1;
+ if ( b[ii]<za ) a[qi*NN + qj] = 0.;
+ else {
+ gausslegendre(qm, xl, xu, z, w);
+ Hij = 0.;
+ for (k=0; k<qm; k++)
+ if ( df==2 )
+ Hij += w[k]*Tn((2.*z[k]-b[ii]-b[ii-1])/(b[ii]-b[ii-1]),jj-1)*exp(-z[k]/s2);
+ else
+ Hij += w[k]*Tn((2.*(za+z[k]*z[k])-b[ii]-b[ii-1])/(b[ii]-b[ii-1]),jj-1)
+ * 2. * pow(z[k], ddf-1.) * exp(-alpha*z[k]*z[k]);
+ if ( df==2 ) Hij *= exp(za/s2)/s2;
+ else Hij *= pow(alpha,ddf/2.)/gammafn(ddf/2.);
+ a[qi*NN + qj] = -Hij;
+ }
+ }
+ }
+
+ for (jj=1; jj<=Ntilde; jj++)
+ a[qi*NN + jj-1] -= CHI(-ddf/s2*za, df) * Tn(-1.,jj-1);
+
+ for (jj=1; jj<=Ntilde; jj++)
+ a[qi*NN + (i-1)*Ntilde + jj-1] += Tn((2.*zch[(i-1)*Ntilde + j-1]-b[i]-b[i-1])/(b[i]-b[i-1]),jj-1);
+ }
+
+ for (j=0;j<NN;j++) g[j] = 1.;
+
+ LU_solve(a, g, NN);
+
+ arl = 0.;
+ for (j=1; j<=Ntilde; j++)
+ arl += g[(ihs-1)*Ntilde + j-1] * Tn((2.*hs-b[ihs]-b[ihs-1])/(b[ihs]-b[ihs-1]),j-1);
+
+ Free(zch);
+ Free(z);
+ Free(w);
+ Free(b);
+ Free(g);
+ Free(a);
+
+ return arl;
+}
+
+
+/* double Cs2arlGCRpw */
+double scU_iglarl_v2(double refk, double h, double hs, double sigma, int df, int N, int qm)
+{ double *a, *g, *w, *z, arl, Hij, xl, za, dN, ddf, s2, *t, t0, t1, th, x0, x1, dummy;
+ int i, j, k, M, Ntilde, NN, ii, jj, it, qi, qj;
+
+ M = ceil( h/refk );
+ Ntilde = ceil( (double)N/(double)M );
+ NN = M*Ntilde;
+ s2 = sigma*sigma;
+ ddf = (double)df;
+ dN = (double)Ntilde;
+
+ a = matrix(NN,NN);
+ g = vector(NN);
+ w = vector(qm);
+ z = vector(qm);
+ t = vector(NN);
+
+ /* Chebyshev Gauss-Lobatto nodes */
+ for(i=1; i<=M; i++) {
+ t0 = (double)(i-1.)*refk;
+ t1 = t0 + refk;
+ if ( t1>h ) t1 = h;
+ for (j=1; j<Ntilde; j++) {
+ th = cos( PI/(dN-1.) * (dN-j-1.) );
+ t[(i-1)*(Ntilde-1)+j] = t0 + (th+1.)/2.*(t1-t0);
+ }
+ }
+ t[0] = 0.;
+
+ for (i=1; i<=M; i++)
+ for (j=1; j<=Ntilde ;j++) {
+ qi = (i-1)*Ntilde + j-1; it = (i-1)*(Ntilde-1) + j-1;
+
+ za = t[it] - refk;
+ if ( za<0. ) xl = 0.; else xl = za;
+
+ for (ii=1; ii<i-1; ii++)
+ for (jj=1; jj<=Ntilde; jj++) {
+ qj = (ii-1)*Ntilde + jj-1;
+ a[qi*NN + qj] = 0.;
+ } /* ii = 1 .. i-2, jj = 1 .. Ntilde */
+
+ if ( i>1 ) {
+ ii = i-1;
+ t0 = (double)(ii-1.)*refk;
+ t1 = t0 + refk;
+ if ( t1>h ) t1 = h;
+ if ( t0<xl ) x0 = xl; else x0 = t0;
+ if ( df!=2 ) {
+ if ( x0-za>1e-10 ) x0 = sqrt(x0-za); else x0 = 0.;
+ if ( t1-za>1e-10 ) x1 = sqrt(t1-za); else x1 = 0.; }
+ else x1 = t1;
+
+ for (jj=1; jj<=Ntilde; jj++) {
+ qj = (ii-1)*Ntilde + jj-1;
+
+ if ( j==1 ) a[qi*NN + qj] = - Tn((2.*t[it]-t0-t1)/(t1-t0),jj-1);
+ else {
+ if ( fabs(x1-x0)>1e-12 ) {
+ gausslegendre(qm, x0, x1, z, w);
+ Hij = 0.;
+ for (k=0; k<qm; k++) {
+ if ( df==2 )
+ Hij += w[k] * Tn((2.*z[k]-t0-t1)/(t1-t0),jj-1) * ddf/s2*chi(ddf/s2*(z[k]-za),df);
+ else
+ Hij += w[k] * Tn((2.*(z[k]*z[k]+za)-t0-t1)/(t1-t0),jj-1)*2.*pow(z[k],ddf-1.)*exp(-ddf*z[k]*z[k]/2./s2);
+ } /* k = 0 .. qm-1 */
+ if ( df!=2 ) Hij /= gammafn(ddf/2.) * pow(2.*s2/ddf,ddf/2.);
+ a[qi*NN + qj] = - Hij;
+ }
+ else a[qi*NN + qj] = 0.;
+ } /* j != 1*/
+ } /* jj = 1 .. Ntilde */
+ } /* i > 1 */
+
+ for (ii=i; ii<=M; ii++) {
+ t0 = (double)(ii-1.)*refk;
+ t1 = t0 + refk;
+ if ( t1>h ) t1 = h;
+ if ( t0<xl ) x0 = xl; else x0 = t0;
+ if ( df!=2 ) {
+ if ( x0-za>1e-10 ) x0 = sqrt(x0-za); else x0 = 0.;
+ if ( t1-za>1e-10 ) x1 = sqrt(t1-za); else x1 = 0.; }
+ else x1 = t1;
+
+ if ( i>1 && j==1 && ii==i ) {
+ for (jj=1; jj<=Ntilde; jj++) {
+ qj = (ii-1)*Ntilde + jj-1;
+ a[qi*NN + qj] = Tn((2.*t[it]-t0-t1)/(t1-t0),jj-1);
+ } /* jj = 1 .. Ntilde */
+ } /* i>1 && j==1 && ii==i */
+
+ if ( i>1 && j==1 && ii>i ) {
+ for (jj=1; jj<=Ntilde; jj++) {
+ qj = (ii-1)*Ntilde + jj-1;
+ a[qi*NN + qj] = 0.;
+ } /* jj = 1 .. Ntilde */
+ } /* i>1 && j==1 && ii>i */
+
+ if ( i==1 || j>1 ) {
+ for (jj=1; jj<=Ntilde; jj++) {
+ qj = (ii-1)*Ntilde + jj-1;
+ gausslegendre(qm, x0, x1, z, w);
+ Hij = 0.;
+ for (k=0; k<qm; k++)
+ if ( df==2 )
+ Hij += w[k] * Tn((2.*z[k]-t0-t1)/(t1-t0),jj-1) * ddf/s2*chi(ddf/s2*(z[k]-za),df);
+ else
+ Hij += w[k] * Tn((2.*(z[k]*z[k]+za)-t0-t1)/(t1-t0),jj-1)*2.*pow(z[k],ddf-1.)*exp(-ddf*z[k]*z[k]/2./s2);
+ if ( df!=2 ) Hij /= gammafn(ddf/2.) * pow(2.*s2/ddf,ddf/2.);
+ if ( ii==i ) a[qi*NN + qj] = Tn((2.*t[it]-t0-t1)/(t1-t0),jj-1) - Hij;
+ else a[qi*NN + qj] = -Hij;
+ } /* jj = 1 .. Ntilde */
+ } /* i==1 || j>1 */
+ } /* ii = i .. M */
+
+ if ( i==1 ) {
+ t0 = 0.;
+ t1 = refk;
+ if ( t1>h ) t1 = h;
+ for (jj=1; jj<=Ntilde; jj++) {
+ dummy = -za/s2;
+ if ( dummy>0. ) {
+ if ( df==1 ) dummy = 2.*PHI( sqrt(dummy), 0. ) - 1.;
+ if ( df==2 ) dummy = 1. - exp( -dummy );
+ if ( df>2 ) dummy = CHI( ddf*dummy, df);
+ }
+ else dummy = 0.;
+ a[qi*NN + jj-1] -= dummy * Tn(-1.,jj-1);
+ } /* jj = 1 .. Ntilde */
+ } /* i==1 */
+
+ } /* i = 1 .. M, j = 1 .. Ntilde */
+
+ for (j=0; j<NN; j++) g[j] = 1.;
+ for (j=1; j<M; j++) g[Ntilde*j] = 0.;
+
+ LU_solve(a, g, NN);
+
+ arl = 0.;
+ for (i=1; i<=M; i++) {
+ t0 = (double)(i-1.)*refk;
+ t1 = t0 + refk;
+ if ( t1>h ) t1 = h;
+ if ( t0<=hs && hs<t1 )
+ for (j=1; j<=Ntilde; j++) {
+ ii = (i-1)*Ntilde + j-1;
+ arl += g[ii] * Tn((2.*hs-t0-t1)/(t1-t0),j-1);
+ } /* j = 1 .. Ntilde */
+ } /* i = 1 .. M */
+
+ Free(t);
+ Free(z);
+ Free(w);
+ Free(g);
+ Free(a);
+
+ return arl;
+}
+
+
+/* double lCs2arlGCRpw */
+double scL_iglarl_v2(double refk, double h, double hs, double sigma, int df, int N, int qm)
+{ double *a, *g, *w, *z, arl, Hij, xu, za, dN, ddf, s2, *t, t0, t1, th, x0, x1, dummy;
+ int i, j, k, M, Ntilde, NN, ii, jj, it, qi, qj, imax;
+
+ M = ceil( h/refk );
+ Ntilde = ceil( (double)N/(double)M );
+ NN = M*Ntilde;
+ s2 = sigma*sigma;
+ ddf = (double)df;
+ dN = (double)Ntilde;
+
+ a = matrix(NN,NN);
+ g = vector(NN);
+ w = vector(qm);
+ z = vector(qm);
+ t = vector(NN);
+
+ /* Chebyshev Gauss-Lobatto nodes */
+ for(i=1; i<=M; i++) {
+ t0 = h - (double)(M-i+1.)*refk;
+ t1 = t0 + refk;
+ if ( t0<0. ) t0 = 0.;
+ for (j=1; j<Ntilde; j++) {
+ th = cos( PI/(dN-1.) * (dN-j-1.) );
+ t[(i-1)*(Ntilde-1)+j] = t0 + (th+1.)/2.*(t1-t0);
+ }
+ }
+ t[0] = 0.;
+
+ for (i=1; i<=M; i++)
+ for (j=1; j<=Ntilde ;j++) {
+ qi = (i-1)*Ntilde + j-1; it = (i-1)*(Ntilde-1) + j-1;
+
+ za = t[it] + refk;
+ if ( za<h ) xu = za; else xu = h;
+
+ imax = i+1; if ( imax>M ) imax = M;
+ for (ii=1; ii<=imax; ii++) {
+ t0 = h - (double)(M-ii+1.)*refk;
+ t1 = t0 + refk;
+ if ( t0<0. ) t0 = 0.;
+ if ( t1<xu ) x1 = t1; else x1 = xu;
+
+ if ( df!=2 ) {
+ if ( za-x1>1e-10 ) x0 = sqrt(za-x1); else x0 = 0.;
+ if ( za-t0>1e-10 ) x1 = sqrt(za-t0); else x1 = 0.;
+ }
+ else x0 = t0;
+
+ for (jj=1; jj<=Ntilde; jj++) {
+ qj = (ii-1)*Ntilde + jj-1;
+
+ if ( i>1 && j==1 ) { /* continuity condition */
+ if ( ii==i-1 ) a[qi*NN + qj] = - Tn((2.*t[it]-t0-t1)/(t1-t0),jj-1);
+ if ( ii==i ) a[qi*NN + qj] = Tn((2.*t[it]-t0-t1)/(t1-t0),jj-1);
+ if ( ii<i-1 || ii>i) a[qi*NN + qj] = 0.;
+ } else {
+ gausslegendre(qm, x0, x1, z, w);
+ Hij = 0.;
+ for (k=0; k<qm; k++)
+ if (df==2)
+ Hij += w[k] * Tn((2.*z[k]-t0-t1)/(t1-t0),jj-1) * ddf/s2*chi(ddf/s2*(za-z[k]),df);
+ else
+ Hij += w[k] * Tn((2.*(za-z[k]*z[k])-t0-t1)/(t1-t0),jj-1) *2.*pow(z[k],ddf-1.)*exp(-ddf*z[k]*z[k]/2./s2);
+ if ( df!=2 ) Hij /= gammafn(ddf/2.) * pow(2.*s2/ddf,ddf/2.);
+ if ( ii==i ) a[qi*NN + qj] = Tn((2.*t[it]-t0-t1)/(t1-t0),jj-1) - Hij;
+ else a[qi*NN + qj] = -Hij;
+ } /* (! i>1 && j==1) */
+ } /* jj = 1 .. Ntilde */
+ } /* ii = 1 .. imax <= M */
+
+ for (ii=i+2; ii<=M; ii++)
+ for (jj=1; jj<=Ntilde; jj++) {
+ qj = (ii-1)*N + jj-1;
+ a[qi*NN + qj] = 0.;
+ }
+
+ if ( i==1 || j>1 ) {
+ for ( jj=1; jj<=Ntilde; jj++) { /* ii = 1 -- atom */
+ dummy = za/s2;
+ if ( df==1 ) dummy = 2.*( 1. - PHI( sqrt(dummy), 0. ) );
+ if ( df==2 ) dummy = exp( -dummy );
+ if ( df>2 ) dummy = 1. - CHI( ddf*dummy, df);
+ a[qi*NN + jj-1] -= dummy * Tn(-1.,jj-1);
+ } /* jj = 1 .. Ntilde */
+ } /* i==1 || j>1 */
+ } /* i = 1 .. M, j = 1 .. Ntilde */
+
+ for (j=0; j<NN; j++) g[j] = 1.;
+ for (j=1; j<M; j++) g[Ntilde*j] = 0.;
+
+ LU_solve(a, g, NN);
+
+ arl = 0.;
+ for (i=1; i<=M; i++) {
+ t0 = h - (double)(M-i+1.)*refk;
+ t1 = t0 + refk;
+ if ( t0<0. ) t0 = 0.;
+ if ( t0<=hs && hs<t1 )
+ for (j=1; j<=Ntilde; j++) {
+ ii = (i-1)*Ntilde + j-1;
+ arl += g[ii] * Tn((2.*hs-t0-t1)/(t1-t0),j-1);
+ } /* j = 1 .. Ntilde */
+ } /* i = 1 .. M */
+
+ Free(t);
+ Free(z);
+ Free(w);
+ Free(g);
+ Free(a);
+
+ return arl;
+}
+
+
+double sc2_iglarl_v2(double refkl, double refku, double hl, double hu, double hsl, double hsu, double sigma, int df, int N, int qm)
+{ double arl1, arl2, arl3, arl4, arl;
+
+/* relation between 1- and 2-sided CUSUM schemes due to Lucas/Crosier 1982,
+ Technometrics 24, 199-205;
+ only for headstart hs smaller than h/2 + k !!
+ Chang/Gan 1995 claim that it is valid also for 2-sided S^2 CUSUM
+ (JQT 27(2), 109-119
+*/
+
+ arl1 = scU_iglarl_v2(refku, hu, 0., sigma, df, N, qm);
+ arl2 = scU_iglarl_v2(refku, hu, hsu, sigma, df, N, qm);
+ arl3 = scL_iglarl_v2(refkl, hl, 0., sigma, df, N, qm);
+ arl4 = scL_iglarl_v2(refkl, hl, hsl, sigma, df, N, qm);
+ arl = ( arl2*arl3 + arl1*arl4 - arl1*arl3 ) / ( arl1 + arl3 );
+ return arl;
+}
+
+
+double scU_crit(double refk, double L0, double hs, double sigma, int df, int N, int qm)
+{ double c1, c2, c3, L1=0., L2=0., L3=0., dc;
+
+ c2 = 0.;
+ L2 = 1.;
+ do {
+ c1 = c2;
+ L1 = L2;
+ c2 += 1.;
+ L2 = scU_iglarl_v2(refk, c2, hs, sigma, df, N, qm);
+ } while ( L2<L0 );
+
+ do {
+ c3 = c1 + (L0-L1)/(L2-L1) * (c2-c1);
+ L3 = scU_iglarl_v2(refk, c3, hs, sigma, df, N, qm);
+ dc = c3-c2; c1 = c2; L1 = L2; c2 = c3; L2 = L3;
+ } while ( (fabs(L0-L3)>1e-6) && (fabs(dc)>1e-9) );
+ return c3;
+}
+
+
+double scL_crit(double refk, double L0, double hs, double sigma, int df, int N, int qm)
+{ double c1, c2, c3, L1=0., L2=0., L3=0., dc;
+
+ c2 = 0.;
+ L2 = 1.;
+ do {
+ c1 = c2;
+ L1 = L2;
+ c2 += 1;
+ L2 = scL_iglarl_v2(refk, c2, hs, sigma, df, N, qm);
+ } while ( L2<L0 );
+
+ do {
+ c3 = c1 + (L0-L1)/(L2-L1) * (c2-c1);
+ L3 = scL_iglarl_v2(refk, c3, hs, sigma, df, N, qm);
+ dc = c3-c2; c1 = c2; L1 = L2; c2 = c3; L2 = L3;
+ } while ( (fabs(L0-L3)>1e-6) && (fabs(dc)>1e-9) );
+ return c3;
+}
+
+
+double scL_fu_crit(double refkl, double refku, double hu, double L0, double hsl, double hsu, double sigma, int df, int N, int qm)
+{ double c1, c2, c3, L1=0., L2=0., L3=0., dc;
+
+ c2 = 0.;
+ L2 = 1.;
+ do {
+ c1 = c2;
+ L1 = L2;
+ c2 += 1;
+ L2 = sc2_iglarl_v2(refkl, refku, c2, hu, hsl, hsu, sigma, df, N, qm);
+ } while ( L2<L0 );
+
+ do {
+ c3 = c1 + (L0-L1)/(L2-L1) * (c2-c1);
+ L3 = sc2_iglarl_v2(refkl, refku, c3, hu, hsl, hsu, sigma, df, N, qm);
+ dc = c3-c2; c1 = c2; L1 = L2; c2 = c3; L2 = L3;
+ } while ( (fabs(L0-L3)>1e-6) && (fabs(dc)>1e-9) );
+ return c3;
+}
+
+
+double scU_fl_crit(double refkl, double refku, double hl, double L0, double hsl, double hsu, double sigma, int df, int N, int qm)
+{ double c1, c2, c3, L1=0., L2=0., L3=0., dc;
+
+ c2 = 0.;
+ L2 = 1.;
+ do {
+ c1 = c2;
+ L1 = L2;
+ c2 += 1;
+ L2 = sc2_iglarl_v2(refkl, refku, hl, c2, hsl, hsu, sigma, df, N, qm);
+ } while ( L2<L0 );
+
+ do {
+ c3 = c1 + (L0-L1)/(L2-L1) * (c2-c1);
+ L3 = sc2_iglarl_v2(refkl, refku, hl, c3, hsl, hsu, sigma, df, N, qm);
+ dc = c3-c2; c1 = c2; L1 = L2; c2 = c3; L2 = L3;
+ } while ( (fabs(L0-L3)>1e-6) && (fabs(dc)>1e-9) );
+ return c3;
+}
+
+
+int sc2_crit_unbiased(double refkl, double refku, double L0, double *hl, double *hu, double hsl, double hsu, double sigma, int df, int N, int qm)
+{ double h1, h2, h3, dh, lh, sl1, sl2, sl3, Lm, Lp, step;
+
+ step = .2/sqrt(df);
+
+ h1 = scU_crit(refku, 2.*L0, hsu, sigma, df, N, qm);
+ lh = scL_crit(refkl, 2.*L0, hsl, sigma, df, N, qm);
+ Lm = sc2_iglarl_v2(refkl, refku, lh, h1, hsl, hsu, sigma-lmEPS, df, N, qm);
+ Lp = sc2_iglarl_v2(refkl, refku, lh, h1, hsl, hsu, sigma+lmEPS, df, N, qm);
+ sl1 = (Lp-Lm)/(2.*lmEPS);
+
+ h2 = h1;
+ sl2 = sl1;
+ do {
+ h1 = h2;
+ sl1 = sl2;
+ h2 = h1 + step;
+ lh = scL_fu_crit(refkl, refku, h2, L0, hsl, hsu, sigma, df, N, qm);
+ Lm = sc2_iglarl_v2(refkl, refku, lh, h2, hsl, hsu, sigma-lmEPS, df, N, qm);
+ Lp = sc2_iglarl_v2(refkl, refku, lh, h2, hsl, hsu, sigma+lmEPS, df, N, qm);
+ sl2 = (Lp-Lm)/(2.*lmEPS);
+ } while ( sl2 < 0. );
+
+ do {
+ h3 = h1 - sl1/(sl2-sl1) * (h2-h1);
+ lh = scL_fu_crit(refkl, refku, h3, L0, hsl, hsu, sigma, df, N, qm);
+ Lm = sc2_iglarl_v2(refkl, refku, lh, h3, hsl, hsu, sigma-lmEPS, df, N, qm);
+ Lp = sc2_iglarl_v2(refkl, refku, lh, h3, hsl, hsu, sigma+lmEPS, df, N, qm);
+ sl3 = (Lp-Lm)/(2.*lmEPS);
+ dh = h3-h2; h1 = h2; sl1 = sl2; h2 = h3; sl2 = sl3;
+ } while ( fabs(sl3)>1e-7 && fabs(dh)>1e-9 );
+
+ *hl = lh; *hu = h3;
+
+ return 0;
+}
+
+
+/* MPT = Moustakides/Polunchenko/Tartakovsky */
+double xsr1_iglarl(double k, double h, double zr, double hs, double mu, int N, int MPT)
+{ double *a, *g, *w, *z, arl, adjust=1.;
+ int i, j, NN;
+
+ adjust = 1.;
+ if ( MPT ) adjust = 2.*k;
+
+ NN = N + 1;
+ a = matrix(NN,NN);
+ g = vector(NN);
+ w = vector(NN);
+ z = vector(NN);
+
+ gausslegendre(N, zr, h, z, w);
+
+ for (i=0;i<N;i++) {
+ for (j=0;j<N;j++)
+ a[i*NN+j] = -w[j] * phi( (z[j]-log(1.+exp(z[i])))/adjust + k, mu)/adjust;
+ ++a[i*NN+i];
+ a[i*NN+N] = - PHI( (zr-log(1.+exp(z[i])))/adjust + k, mu);
+ }
+ for (j=0;j<N;j++)
+ a[N*NN+j] = -w[j] * phi( (z[j]-log(1.+exp(zr)))/adjust + k, mu)/adjust;
+ a[N*NN+N] = 1. - PHI( (zr-log(1.+exp(zr)))/adjust + k, mu);
+
+ for (j=0;j<NN;j++) g[j] = 1.;
+ LU_solve(a,g,NN);
+
+ if (hs > h) {
+ arl = 1. + PHI( zr/adjust + k, mu) * g[N];
+ for (j=0;j<N;j++)
+ arl += w[j] * phi( z[j]/adjust + k, mu)/adjust * g[j];
+ } else {
+ arl = 1. + PHI( (zr-log(1.+exp(hs)))/adjust + k, mu) * g[N];
+ for (j=0;j<N;j++)
+ arl += w[j] * phi( (z[j]-log(1.+exp(hs)))/adjust + k, mu)/adjust * g[j];
+ }
+
+ Free(a);
+ Free(g);
+ Free(w);
+ Free(z);
+
+ return arl;
+}
+
+
+double xsr1_arlm(double k, double h, double zr, double hs, int q, double mu0, double mu1, int N, int nmax, int MPT)
+{ double *p0, *fn, *w, *z, arl0, rho, arl_minus=0., arl, arl_plus=0., mn_minus=0., mn_plus=0., ratio=0., adjust=1.;
+ int i, j, n, NN;
+
+ adjust = 1.;
+ if ( MPT ) adjust = 2.*k;
+
+ NN = N + 1;
+ w = vector(NN);
+ z = vector(NN);
+ fn = matrix(nmax, NN);
+ p0 = vector(nmax);
+
+ gausslegendre(N, zr, h, z, w);
+
+ /* in-control, i. e. n<=q-1 */
+ for (n=1; n<=q-1; n++) {
+ /* determine f_n, n=1,2,...,q-1 */
+ if (n==1) {
+ if ( hs > h ) {
+ for (i=0; i<N; i++) fn[0*NN+i] = phi( z[i]/adjust + k, mu0)/adjust;
+ fn[0*NN+N] = PHI( zr/adjust + k, mu0);
+ } else {
+ for (i=0; i<N; i++) fn[0*NN+i] = phi( (z[i]-log(1.+exp(hs)))/adjust + k, mu0)/adjust;
+ fn[0*NN+N] = PHI( (zr-log(1.+exp(hs)))/adjust + k, mu0);
+ }
+ } else {
+ for (i=0; i<N; i++) {
+ fn[(n-1)*NN+i] = fn[(n-2)*NN+N] * phi( (z[i]-log(1.+exp(zr)))/adjust + k, mu0)/adjust;
+ for (j=0; j<N; j++) {
+ fn[(n-1)*NN+i] += w[j] * fn[(n-2)*NN+j] * phi( (z[i]-log(1.+exp(z[j])))/adjust + k, mu0)/adjust;
+ }
+ }
+ fn[(n-1)*NN+N] = fn[(n-2)*NN+N] * PHI( (zr-log(1.+exp(zr)))/adjust + k, mu0);
+ for (j=0; j<N; j++) fn[(n-1)*NN+N] += w[j] * fn[(n-2)*NN+j] * PHI( (zr-log(1.+exp(z[j])))/adjust + k, mu0);
+ }
+
+ /* determine P(L>n), n=1,2,...,q-1 */
+ p0[n-1] = fn[(n-1)*NN+N];
+ for (i=0; i<N; i++) p0[n-1] += w[i] * fn[(n-1)*NN+i];
+ }
+
+ /* out-of-control, i.e. t>=q */
+ arl0 = 1.; rho = 0.;
+
+ for (n=q; n<=nmax; n++) {
+ if ( n==1 ) {
+ if ( hs > h ) {
+ for (i=0; i<N; i++) fn[0*NN+i] = phi( z[i]/adjust + k, mu1)/adjust;
+ fn[0*NN+N] = PHI( zr/adjust + k, mu1);
+ } else {
+ for (i=0; i<N; i++) fn[0*NN+i] = phi( (z[i]-log(1.+exp(hs)))/adjust + k, mu1)/adjust;
+ fn[0*NN+N] = PHI( (zr-log(1.+exp(hs)))/adjust + k, mu1);
+ }
+ } else {
+ for (i=0; i<N; i++) {
+ fn[(n-1)*NN+i] = fn[(n-2)*NN+N] * phi( (z[i]-log(1.+exp(zr)))/adjust + k, mu1)/adjust;
+ for (j=0; j<N; j++) {
+ fn[(n-1)*NN+i] += w[j] * fn[(n-2)*NN+j] * phi( (z[i]-log(1.+exp(z[j])))/adjust + k, mu1)/adjust;
+ }
+ if ( n==q && q>1 ) fn[(n-1)*NN+i] /= p0[q-2];
+ }
+ fn[(n-1)*NN+N] = fn[(n-2)*NN+N] * PHI( (zr-log(1.+exp(zr)))/adjust + k, mu1);
+ for (j=0; j<N; j++) fn[(n-1)*NN+N] += w[j] * fn[(n-2)*NN+j] * PHI( (zr-log(1.+exp(z[j])))/adjust + k, mu1);
+ if ( n==q && q>1 ) fn[(n-1)*NN+N] /= p0[q-2];
+ }
+
+ /* determine P(L>n), n=1,2,...,q-1 */
+ p0[n-1] = fn[(n-1)*NN+N];
+ for (i=0;i<N;i++) p0[n-1] += w[i] * fn[(n-1)*NN+i];
+
+ /* computation of m_n+1^- and m_n+1^+, n=m-1,m,... */
+ mn_minus = 1.; mn_plus = 0.;
+ if ( n > q ) {
+ for (i=0; i<NN; i++) {
+ if (fn[(n-2)*NN+i]==0)
+ if (fn[(n-1)*NN+i]==0) ratio = 0.; else ratio = 1.;
+ else ratio = fn[(n-1)*NN+i]/fn[(n-2)*NN+i];
+ if ( ratio<mn_minus ) mn_minus = ratio;
+ if ( ratio>mn_plus ) mn_plus = ratio;
+ }
+ rho = p0[n-1]/p0[n-2];
+ }
+
+ /* computation of ARL, ARL^-, and ARL^+ */
+ arl = arl0 + p0[n-1]/(1.-rho);
+ if (mn_minus<1.) arl_minus = arl0 + p0[n-1]/(1.-mn_minus);
+ else arl_minus = -1.;
+ if (mn_plus<1.) arl_plus = arl0 + p0[n-1]/(1.-mn_plus);
+ else arl_plus = -1.;
+ arl0 += p0[n-1];
+
+ if ( fabs((arl_plus-arl_minus)) < 1e-7 ) n = nmax+1;
+ }
+
+ arl = (arl_plus+arl_minus)/2.; rho0 = rho;
+
+ Free(w);
+ Free(z);
+ Free(fn);
+ Free(p0);
+
+ return arl;
+}
+
+
+double xsr1_arlm_hom(double k, double h, double zr, double hs, int q, double mu0, double mu1, int N, int MPT, double *ced)
+{ double *fn, *w, *z, *a, *arl, adjust=1., norm;
+ int i, j, n, NN;
+
+ adjust = 1.;
+ if ( MPT ) adjust = 2.*k;
+
+ NN = N + 1;
+ w = vector(NN);
+ z = vector(NN);
+ fn = matrix(q+1, NN);
+ a = matrix(NN,NN);
+ arl = vector(NN);
+
+ gausslegendre(N, zr, h, z, w);
+
+ /* ARL vector */
+ for (i=0; i<N; i++) {
+ for (j=0; j<N; j++) a[i*NN+j] = -w[j] * phi( (z[j]-log(1.+exp(z[i])))/adjust + k, mu1)/adjust;
+ ++a[i*NN+i];
+ a[i*NN+N] = - PHI( (zr-log(1.+exp(z[i])))/adjust + k, mu1);
+ }
+ for (j=0; j<N; j++)
+ a[N*NN+j] = -w[j] * phi( (z[j]-log(1.+exp(zr)))/adjust + k, mu1)/adjust;
+ a[N*NN+N] = 1. - PHI( (zr-log(1.+exp(zr)))/adjust + k, mu1);
+
+ for (j=0; j<NN; j++) arl[j] = 1.;
+ LU_solve(a, arl, NN);
+
+ /* q == 1 */
+ if ( hs > h ) {
+ ced[0] = 1. + PHI( zr/adjust + k, mu1) * arl[N];
+ for (j=0; j<N; j++)
+ ced[0] += w[j] * phi( z[j]/adjust + k, mu1)/adjust * arl[j];
+ } else {
+ ced[0] = 1. + PHI( (zr-log(1.+exp(hs)))/adjust + k, mu1) * arl[N];
+ for (j=0; j<N; j++)
+ ced[0] += w[j] * phi( (z[j]-log(1.+exp(hs)))/adjust + k, mu1)/adjust * arl[j];
+ }
+
+ /* density sequence for q > 1 */
+ for (n=1; n<=q-1; n++) {
+ if ( n == 1 ) {
+ if ( hs > h ) {
+ for (i=0; i<N; i++) fn[0*NN+i] = phi( z[i]/adjust + k, mu0)/adjust;
+ fn[0*NN+N] = PHI( zr/adjust + k, mu0);
+ } else {
+ for (i=0; i<N; i++) fn[0*NN+i] = phi( (z[i]-log(1.+exp(hs)))/adjust + k, mu0)/adjust;
+ fn[0*NN+N] = PHI( (zr-log(1.+exp(hs)))/adjust + k, mu0);
+ }
+ } else {
+ for (i=0; i<N; i++) {
+ fn[(n-1)*NN+i] = fn[(n-2)*NN+N] * phi( (z[i]-log(1.+exp(zr)))/adjust + k, mu0)/adjust;
+ for (j=0; j<N; j++) {
+ fn[(n-1)*NN+i] += w[j] * fn[(n-2)*NN+j] * phi( (z[i]-log(1.+exp(z[j])))/adjust + k, mu0)/adjust;
+ }
+ }
+ fn[(n-1)*NN+N] = fn[(n-2)*NN+N] * PHI( (zr-log(1.+exp(zr)))/adjust + k, mu0);
+ for (j=0; j<N; j++) fn[(n-1)*NN+N] += w[j] * fn[(n-2)*NN+j] * PHI( (zr-log(1.+exp(z[j])))/adjust + k, mu0);
+ }
+
+ ced[n] = fn[(n-1)*NN+N] * arl[N];
+ norm = fn[(n-1)*NN+N];
+ for (j=0; j<N; j++) {
+ ced[n] += w[j] * fn[(n-1)*NN+j] * arl[j];
+ norm += w[j] * fn[(n-1)*NN+j];
+ }
+ ced[n] /= norm;
+ }
+
+ Free(w);
+ Free(z);
+ Free(fn);
+ Free(a);
+ Free(arl);
+
+ return 0;
+}
+
+
+double xsr1_iglarl_drift(double k, double h, double zr, double hs, double delta, int m, int N, int with0)
+{ double *a, *g, *w, *z, arl, *MUs, *ARLs;
+ int i, j, NN, m_;
+
+ NN = N + 1;
+ a = matrix(NN, NN);
+ g = vector(NN);
+ w = vector(NN);
+ z = vector(NN);
+ ARLs = vector(NN);
+ MUs = vector(m+1);
+
+ gausslegendre(N, zr, h, z, w);
+
+ if ( with0 ) {
+ for (i=0;i<=m;i++) MUs[i] = (double)i * delta;
+ } else {
+ for (i=0;i<=m;i++) MUs[i] = (double)(i+1.) * delta;
+ }
+
+ for (i=0;i<N;i++) {
+ for (j=0;j<N;j++) a[i*NN+j] = -w[j] * phi( z[j]-log(1.+exp(z[i]))+k, MUs[m]);
+ ++a[i*NN+i];
+ a[i*NN+N] = - PHI( zr-log(1.+exp(z[i]))+k, MUs[m]);
+ }
+ for (j=0;j<N;j++)
+ a[N*NN+j] = -w[j] * phi( z[j]-log(1.+exp(zr))+k, MUs[m]);
+ a[N*NN+N] = 1. - PHI( zr-log(1.+exp(zr))+k, MUs[m]);
+
+ for (j=0;j<NN;j++) g[j] = 1.;
+ LU_solve(a, g, NN);
+
+ for (m_=0;m_<m;m_++) {
+ for (i=0;i<=N;i++) {
+ ARLs[i] = 1. + PHI( zr-log(1.+exp(z[i]))+k, MUs[m-m_]) * g[N];
+ for (j=0;j<N;j++) {
+ ARLs[i] += w[j] * phi( z[j]-log(1.+exp(z[i]))+k, MUs[m-m_]) * g[j];
+ }
+ }
+ for (j=0;j<=N;j++) g[j] = ARLs[j];
+ }
+
+ if (hs > h) {
+ arl = 1. + PHI( zr+k, MUs[0]) * ARLs[N];
+ for (j=0;j<N;j++) arl += w[j] * phi( z[j]+k, MUs[0]) * ARLs[j];
+ } else {
+ arl = 1. + PHI( zr-log(1.+exp(hs))+k, MUs[0]) * ARLs[N];
+ for (j=0;j<N;j++) arl += w[j] * phi( z[j]-log(1.+exp(hs))+k, MUs[0]) * ARLs[j];
+ }
+
+ Free(a);
+ Free(g);
+ Free(w);
+ Free(z);
+ Free(ARLs);
+ Free(MUs);
+
+ return arl;
+}
+
+
+double xsr1_iglarl_drift_wo_m(double k, double h, double zr, double hs, double delta, int *m, int N, int with0)
+{ int m_;
+ double arl1, arl2, eps=1e-6;
+ m_ = 4;
+ arl1 = xsr1_iglarl_drift(k, h, zr, hs, delta, m_, N, with0);
+ arl2 = arl1 + 2.*eps;
+ while ( fabs(arl2-arl1)>eps && (double)m_<1e4 ) {
+ m_ = (int)round(1.5 * m_);
+ arl1 = xsr1_iglarl_drift(k, h, zr, hs, delta, m_, N, with0);
+ arl2 = xsr1_iglarl_drift(k, h, zr, hs, delta, m_+1, N, with0);
+ }
+ *m = m_;
+ return arl1;
+}
+
+
+double xsr1_iglarlm_drift(double k, double h, double zr, double hs, int q, double delta, int N, int nmax, int with0)
+{ double *p0, *fn, *w, *z, arl0, rho, MEAN=0.,
+ arl_minus=0., arl, arl_plus=0., mn_minus=0., mn_plus=0., nn, ratio=0.;
+ int i, j, n, NN;
+
+ NN = N + 1;
+ w = vector(NN);
+ z = vector(NN);
+ fn = matrix(nmax, NN);
+ p0 = vector(nmax);
+
+ gausslegendre(N, zr, h, z, w);
+
+ /* in-control, i. e. n<=q-1 */
+ MEAN = 0.;
+
+ for (n=1;n<=q-1;n++) {
+ nn = (double) n;
+
+ /* determine f_n, n=1,2,...,q-1 */
+ if (n==1) {
+ for (i=0;i<N;i++) fn[0*NN+i] = phi( z[i]-log(1.+exp(hs))+k, MEAN);
+ fn[0*NN+N] = PHI( zr-log(1.+exp(hs))+k, MEAN);
+ } else {
+ for (i=0;i<N;i++) {
+ fn[(n-1)*NN+i] = fn[(n-2)*NN+N] * phi( z[i]-log(1.+exp(zr))+k, MEAN);
+ for (j=0;j<N;j++) {
+ fn[(n-1)*NN+i] += w[j] * fn[(n-2)*NN+j] * phi( z[i]-log(1.+exp(z[j]))+k, MEAN);
+ }
+ }
+ fn[(n-1)*NN+N] = fn[(n-2)*NN+N] * PHI( zr-log(1.+exp(zr))+k, MEAN);
+ for (j=0;j<N;j++) fn[(n-1)*NN+N] += w[j] * fn[(n-2)*NN+j] * PHI( zr-log(1.+exp(z[j]))+k, MEAN);
+ }
+
+ /* determine P(L>n), n=1,2,...,q-1 */
+ p0[n-1] = fn[(n-1)*NN+N];
+ for (i=0;i<N;i++) p0[n-1] += w[i] * fn[(n-1)*NN+i];
+ }
+
+ /* out-of-control, i.e. t>=q */
+ arl0 = 1.; rho = 0.;
+
+ for (n=q;n<=nmax;n++) {
+ nn = (double) n;
+
+ /* determine f_n, n=q,q+1,... */
+ if ( with0 ) {
+ MEAN = (nn-(double)q) * delta;
+ } else {
+ MEAN = (nn-(double)q+1.) * delta;
+ }
+
+ if (n==1) {
+ for (i=0;i<N;i++) fn[0*NN+i] = phi( z[i]-log(1.+exp(hs))+k, MEAN);
+ fn[0*NN+N] = PHI( zr-log(1.+exp(hs))+k, MEAN);
+ } else {
+ for (i=0;i<N;i++) {
+ fn[(n-1)*NN+i] = fn[(n-2)*NN+N] * phi( z[i]-log(1.+exp(zr))+k, MEAN);
+ for (j=0;j<N;j++) {
+ fn[(n-1)*NN+i] += w[j] * fn[(n-2)*NN+j] * phi( z[i]-log(1.+exp(z[j]))+k, MEAN);
+ }
+ if (n==q && q>1) fn[(n-1)*NN+i] /= p0[q-2];
+ }
+ fn[(n-1)*NN+N] = fn[(n-2)*NN+N] * PHI( zr-log(1.+exp(zr))+k, MEAN);
+ for (j=0;j<N;j++) fn[(n-1)*NN+N] += w[j] * fn[(n-2)*NN+j] * PHI( zr-log(1.+exp(z[j]))+k, MEAN);
+ if (n==q && q>1) fn[(n-1)*NN+N] /= p0[q-2];
+ }
+
+ /* determine P(L>n), n=1,2,...,q-1 */
+ p0[n-1] = fn[(n-1)*NN+N];
+ for (i=0;i<N;i++) p0[n-1] += w[i] * fn[(n-1)*NN+i];
+
+ /* computation of m_n+1^- and m_n+1^+, n=m-1,m,... */
+ mn_minus = 1.; mn_plus = 0.;
+ if (n>q) {
+ for (i=0;i<NN;i++) {
+ if (fn[(n-2)*NN+i]==0)
+ if (fn[(n-1)*NN+i]==0) ratio = 0.; else ratio = 1.;
+ else ratio = fn[(n-1)*NN+i]/fn[(n-2)*NN+i];
+ if ( ratio<mn_minus ) mn_minus = ratio;
+ if ( ratio>mn_plus ) mn_plus = ratio;
+ }
+ }
+
+ if (n>q) rho = p0[n-1]/p0[n-2];
+
+ /* computation of ARL, ARL^-, and ARL^+ */
+ arl = arl0 + p0[n-1]/(1.-rho);
+ if (mn_minus<1.) arl_minus = arl0 + p0[n-1]/(1.-mn_minus);
+ else arl_minus = -1.;
+ if (mn_plus<1.) arl_plus = arl0 + p0[n-1]/(1.-mn_plus);
+ else arl_plus = -1.;
+ arl0 += p0[n-1];
+
+ if ( fabs((arl_plus-arl_minus)) < 1e-7 ) n = nmax+1;
+ }
+
+ arl = (arl_plus+arl_minus)/2.; rho0 = rho;
+
+ Free(w);
+ Free(z);
+ Free(fn);
+ Free(p0);
+
+ return arl;
+}
+
+
+double xsr1_iglad(double k, double h, double zr, double mu0, double mu1, int N, int MPT)
+{ double *a, *w, *z, *arl, *psi, rho, ad, norm, adjust=1.;
+ int i, j, status, noofit, NN;
+
+ adjust = 1.;
+ if ( MPT ) adjust = 2.*k;
+
+ NN = N + 1;
+ a = matrix(NN,NN);
+ arl = vector(NN);
+ psi = vector(NN);
+ w = vector(NN);
+ z = vector(NN);
+
+ gausslegendre(N, zr, h, z, w);
+
+ for (i=0; i<N; i++) {
+ for (j=0; j<N; j++) a[i*NN+j] = -w[j] * phi( (z[j]-log(1.+exp(z[i])))/adjust + k, mu1)/adjust;
+ ++a[i*NN+i];
+ a[i*NN+N] = - PHI( (zr-log(1.+exp(z[i])))/adjust + k, mu1);
+ }
+ for (j=0; j<N; j++)
+ a[N*NN+j] = -w[j] * phi( (z[j]-log(1.+exp(zr)))/adjust + k, mu1)/adjust;
+ a[N*NN+N] = 1. - PHI( (zr-log(1.+exp(zr)))/adjust + k, mu1);
+
+ for (j=0; j<NN; j++) arl[j] = 1.;
+ LU_solve(a,arl,NN);
+
+ for (i=0; i<N; i++) {
+ for (j=0; j<N; j++) a[i*NN+j] = w[j] * phi( (z[i]-log(1.+exp(z[j])))/adjust + k, mu0)/adjust;
+ a[i*NN+N] = phi( (z[i]-log(1.+exp(zr)))/adjust + k, mu0)/adjust;
+ }
+ for (j=0; j<N; j++)
+ a[N*NN+j] = w[j] * PHI( (zr-log(1.+exp(z[j])))/adjust + k, mu0);
+ a[N*NN+N] = PHI( (zr-log(1.+exp(zr)))/adjust + k, mu0);
+
+ pmethod(NN, a, &status, &rho, psi, &noofit);
+
+ ad = psi[N]*arl[N];
+ norm = psi[N];
+ for (j=0; j<N; j++) {
+ ad += w[j] * arl[j] * psi[j];
+ norm += w[j] * psi[j];
+ }
+ ad /= norm;
+ rho0 = rho;
+
+ Free(a);
+ Free(arl);
+ Free(psi);
+ Free(w);
+ Free(z);
+
+ return ad;
+}
+
+
+/* functions based on Srivastava & Wu (1997)
+ Evaluation of optimum weights and average run lengths in EWMA control schemes,
+ Commun. Stat., Theory Methods 26, 1253-1267.
+ DOI: 10.1080/03610929708831980
+*/
+
+
+double xe2_SrWu_crit(double l, double L0)
+{ double a, c;
+ a = 2. * log( l * L0 * sqrt(2/PI) );
+ c = sqrt( a - log(a-1.) ) + (1.-l)/2.;
+ return c;
+}
+
+
+double xe2_SrWu_arl(double l, double c, double mu)
+{ double g, w, arl=-1.;
+ g = c * sqrt( l/2./mu/mu );
+ w = c + 1.166*sqrt( mu * l ) - sqrt( 2.*mu*mu/l );
+ if ( g < 1. ) arl = -log( 1.- g) /l - g/4./(1.-g)/mu/mu + .75;
+ if ( g > 1. && fabs(mu) > 1. ) arl = PHI(w,0.)/phi(w,0.)/l/w;
+ return arl;
+}
+
+
+double xe2_SrWu_arl_full(double l, double c, double mu)
+{ double eta, Lmu, alpha1, alpha2, h1, h2, f1, f2, arl=-1., *w, *z;
+ int i, qm=50;
+
+ mu = fabs(mu);
+
+ w = vector(qm);
+ z = vector(qm);
+
+ Lmu = c + 1.16*sqrt(l*mu);
+
+ eta = mu * sqrt(2./l);
+
+ gausslegendre(qm, 0, Lmu, z, w);
+
+ alpha1 = 0.; alpha2 = 0.;
+ for (i=0; i<qm; i++) {
+ alpha1 += w[i] / phi(z[i]+eta, 0.);
+ alpha2 += w[i] / phi(z[i]-eta, 0.);
+ }
+
+ h1 = alpha1 / (alpha1 + alpha2);
+ h2 = alpha2 / (alpha1 + alpha2);
+
+ f1 = 0.; f2 = 0.;
+ for (i=0; i<qm; i++) {
+ f1 += w[i] * ( PHI(z[i]+eta, 0.) - PHI( eta, 0.) ) / phi(z[i]+eta, 0.);
+ f2 += w[i] * ( PHI(z[i]-eta, 0.) - PHI(-eta, 0.) ) / phi(z[i]-eta, 0.);
+ }
+
+ arl = ( h1*f2 + h2*f1 )/l;
+
+ Free(w);
+ Free(z);
+
+ return arl;
+}
+
+
+double xe2_SrWu_lambda(double delta, double L0)
+{ double dstar, b, l;
+ dstar = 0.5117;
+ b = 2.*log( 2.*sqrt(2./PI)*dstar*delta*delta*L0 );
+ l = 2*dstar*delta*delta/( b - log(b) );
+ return l;
+}
+
+
+
+double xe1_iglarl(double l, double c, double zr, double hs, double mu, int N)
+{ double *a, *g, *w, *z, arl;
+ int i, j, NN;
+
+ NN = N + 1;
+ a = matrix(NN,NN);
+ g = vector(NN);
+ w = vector(NN);
+ z = vector(NN);
+
+ c *= sqrt( l/(2.-l) );
+ zr *= sqrt( l/(2.-l) );
+ hs *= sqrt( l/(2.-l) );
+
+ gausslegendre(N,zr,c,z,w);
+
+ for (i=0;i<N;i++) {
+ for (j=0;j<N;j++) a[i*NN+j] = -w[j]/l * phi((z[j]-(1.-l)*z[i])/l,mu);
+ ++a[i*NN+i];
+ a[i*NN+N] = - PHI((zr-(1.-l)*z[i])/l,mu);
+ }
+ for (j=0;j<N;j++)
+ a[N*NN+j] = -w[j]/l * phi((z[j]-(1.-l)*zr)/l,mu);
+ a[N*NN+N] = 1. - PHI(zr,mu);
+
+ for (j=0;j<NN;j++) g[j] = 1.;
+ LU_solve(a,g,NN);
+
+ arl = 1. + PHI((zr-(1.-l)*hs)/l,mu) * g[N];
+ for (j=0;j<N;j++)
+ arl += w[j]/l * phi((z[j]-(1.-l)*hs)/l,mu) * g[j];
+
+ Free(a);
+ Free(g);
+ Free(w);
+ Free(z);
+
+ return arl;
+}
+
+
+double xe2_iglarl(double l, double c, double hs, double mu, int N)
+{ double *a, *g, *w, *z, arl;
+ int i, j;
+
+ a = matrix(N,N);
+ g = vector(N);
+ w = vector(N);
+ z = vector(N);
+
+ c *= sqrt( l/(2.-l) );
+ hs *= sqrt( l/(2.-l) );
+
+ gausslegendre(N,-c,c,z,w);
+
+ for (i=0;i<N;i++) {
+ for (j=0;j<N;j++) a[i*N+j] = -w[j]/l * phi( (z[j]-(1.-l)*z[i])/l,mu);
+ ++a[i*N+i];
+ }
+
+ for (j=0;j<N;j++) g[j] = 1.;
+ LU_solve(a,g,N);
+
+ arl = 1.;
+ for (j=0;j<N;j++)
+ arl += w[j]/l * phi( (z[j]-(1.-l)*hs)/l,mu) * g[j];
+
+ Free(a);
+ Free(g);
+ Free(w);
+ Free(z);
+
+ return arl;
+}
+
+
+double xte2_iglarl(double l, double c, double hs, int df, double mu, int N, int subst)
+{ double *a, *g, *w, *z, arl, norm=1., arg=0., korr=1.;
+ int i, j;
+
+ a = matrix(N,N);
+ g = vector(N);
+ w = vector(N);
+ z = vector(N);
+
+ c *= sqrt( l/(2.-l) );
+ hs *= sqrt( l/(2.-l) );
+
+ switch ( subst ) {
+ case IDENTITY: gausslegendre(N, -c, c, z, w); norm = 1.; break;
+ case SIN: gausslegendre(N, -PI/2., PI/2., z, w); norm = 1.; break;
+ case SINH: gausslegendre(N, -1., 1., z, w); norm = sinh(1.); break;
+ case TAN: gausslegendre(N, -PI/4., PI/4., z, w); norm = 1.; break;
+ }
+
+ c /= norm;
+
+ for (i=0;i<N;i++) {
+ for (j=0;j<N;j++) {
+ switch ( subst ) {
+ case IDENTITY: arg = z[j] - (1.-l)*z[i]; korr = 1.; break;
+ case SIN: arg = c*sin(z[j]) - (1.-l)*c*sin(z[i]); korr = c*cos(z[j]); break;
+ case SINH: arg = c*sinh(z[j]) - (1.-l)*c*sinh(z[i]); korr = c*cosh(z[j]); break;
+ case TAN: arg = c*tan(z[j]) - (1.-l)*c*tan(z[i]); korr = c/( cos(z[j])*cos(z[j]) ); break;
+ }
+ a[i*N+j] = -w[j]/l * pdf_t( arg/l - mu, df) * korr;
+ }
+ ++a[i*N+i];
+ }
+
+ for (j=0;j<N;j++) g[j] = 1.;
+ LU_solve(a,g,N);
+
+ arl = 1.;
+ for (j=0;j<N;j++) {
+ switch ( subst ) {
+ case IDENTITY: arg = z[j] - (1.-l)*hs; korr = 1.; break;
+ case SIN: arg = c*sin(z[j]) - (1.-l)*hs; korr = c*cos(z[j]); break;
+ case SINH: arg = c*sinh(z[j]) - (1.-l)*hs; korr = c*cosh(z[j]); break;
+ case TAN: arg = c*tan(z[j]) - (1.-l)*hs; korr = c/( cos(z[j])*cos(z[j]) ); break;
+ }
+ arl += w[j]/l * pdf_t( arg/l - mu, df) * g[j] * korr;
+ }
+
+ Free(a);
+ Free(g);
+ Free(w);
+ Free(z);
+
+ return arl;
+}
+
+
+double xe1_iglarl_drift(double l, double c, double zr, double hs, double delta, int m, int N, int with0)
+{ double *a, *g, *w, *z, arl, *MUs, *ARLs;
+ int i, j, NN, m_;
+
+ NN = N + 1;
+ a = matrix(NN, NN);
+ g = vector(NN);
+ w = vector(NN);
+ z = vector(NN);
+ ARLs = vector(NN);
+ MUs = vector(m+1);
+
+ c *= sqrt( l/(2.-l) );
+ zr *= sqrt( l/(2.-l) );
+ hs *= sqrt( l/(2.-l) );
+
+ gausslegendre(N, zr, c, z, w);
+
+ if ( with0 ) {
+ for (i=0;i<=m;i++) MUs[i] = (double)i * delta;
+ } else {
+ for (i=0;i<=m;i++) MUs[i] = (double)(i+1.) * delta;
+ }
+
+ for (i=0;i<N;i++) {
+ for (j=0;j<N;j++) a[i*NN+j] = -w[j]/l * phi( (z[j]-(1.-l)*z[i])/l, MUs[m]);
+ ++a[i*NN+i];
+ a[i*NN+N] = - PHI( (zr-(1.-l)*z[i])/l, MUs[m]);
+ }
+ for (j=0;j<N;j++)
+ a[N*NN+j] = -w[j]/l * phi( (z[j]-(1.-l)*zr)/l, MUs[m]);
+ a[N*NN+N] = 1. - PHI(zr, MUs[m]);
+
+ for (j=0;j<NN;j++) g[j] = 1.;
+ LU_solve(a, g, N);
+
+ for (m_=0;m_<m;m_++) {
+ for (i=0;i<N;i++) {
+ ARLs[i] = 1. + PHI(zr, MUs[m-m_]) * g[N];
+ for (j=0;j<=N;j++) {
+ ARLs[i] += w[j]/l * phi( (z[j]-(1.-l)*z[i])/l, MUs[m-m_]) * g[j];
+ }
+ }
+ for (j=0;j<=N;j++) g[j] = ARLs[j];
+ }
+
+ arl = 1. + PHI( (zr-(1.-l)*hs)/l, MUs[0]) * ARLs[N];
+ for (j=0;j<N;j++) arl += w[j]/l * phi( (z[j]-(1.-l)*hs)/l, MUs[0]) * ARLs[j];
+
+ Free(a);
+ Free(g);
+ Free(w);
+ Free(z);
+ Free(ARLs);
+ Free(MUs);
+
+ return arl;
+}
+
+
+double xe1_iglarl_drift_wo_m(double l, double c, double zr, double hs, double delta, int *m, int N, int with0)
+{ int m_;
+ double arl1, arl2, eps=1e-6;
+ m_ = 4;
+ arl1 = xe1_iglarl_drift(l, c, zr, hs, delta, m_, N, with0);
+ arl2 = arl1 + 2.*eps;
+ while ( fabs(arl2-arl1)>eps && (double)m_<1e4 ) {
+ m_ = (int)round(1.5 * m_);
+ arl1 = xe1_iglarl_drift(l, c, zr, hs, delta, m_, N, with0);
+ arl2 = xe1_iglarl_drift(l, c, zr, hs, delta, m_+1, N, with0);
+ }
+ *m = m_;
+ return arl1;
+}
+
+
+double xe1_iglarlm_drift(double l, double c, double zr, double hs, int q, double delta, int N, int nmax, int with0)
+{ double *p0, *fn, *w, *z, arl0, rho, MEAN=0.,
+ arl_minus=0., arl, arl_plus=0., mn_minus=0., mn_plus=0., nn, ratio=0.;
+ int i, j, n, NN;
+
+ NN = N + 1;
+ w = vector(NN);
+ z = vector(NN);
+ fn = matrix(nmax, NN);
+ p0 = vector(nmax);
+
+ c *= sqrt( l/(2.-l) );
+ zr *= sqrt( l/(2.-l) );
+ hs *= sqrt( l/(2.-l) );
+
+ gausslegendre(N, zr, c, z, w);
+
+ /* in-control, i. e. n<=q-1 */
+ MEAN = 0.;
+
+ for (n=1;n<=q-1;n++) {
+ nn = (double) n;
+
+ /* determine f_n, n=1,2,...,q-1 */
+ if (n==1) {
+ for (i=0;i<N;i++) fn[0*NN+i] = phi( (z[i]-(1.-l)*hs)/l, MEAN)/l;
+ fn[0*NN+N] = PHI( (zr-(1.-l)*hs)/l, MEAN);
+ } else {
+ for (i=0;i<N;i++) {
+ fn[(n-1)*NN+i] = fn[(n-2)*NN+N] * phi( (z[i]-(1.-l)*zr)/l, MEAN)/l;
+ for (j=0;j<N;j++) {
+ fn[(n-1)*NN+i] += w[j] * fn[(n-2)*NN+j] * phi( (z[i]-(1.-l)*z[j])/l, MEAN)/l;
+ }
+ }
+ fn[(n-1)*NN+N] = fn[(n-2)*NN+N] * PHI( zr, MEAN);
+ for (j=0;j<N;j++) fn[(n-1)*NN+N] += w[j] * fn[(n-2)*NN+j] * PHI( (zr-(1.-l)*z[j])/l, MEAN);
+ }
+
+ /* determine P(L>n), n=1,2,...,q-1 */
+ p0[n-1] = fn[(n-1)*NN+N];
+ for (i=0;i<N;i++) p0[n-1] += w[i] * fn[(n-1)*NN+i];
+ }
+
+ /* out-of-control, i.e. t>=q */
+ arl0 = 1.; rho = 0.;
+
+ for (n=q;n<=nmax;n++) {
+ nn = (double) n;
+
+ /* determine f_n, n=q,q+1,... */
+ if ( with0 ) {
+ MEAN = (nn-(double)q) * delta;
+ } else {
+ MEAN = (nn-(double)q+1.) * delta;
+ }
+
+ if (n==1) {
+ for (i=0;i<N;i++) fn[0*NN+i] = phi( (z[i]-(1.-l)*hs)/l, MEAN)/l;
+ fn[0*NN+N] = PHI( (zr-(1.-l)*hs)/l, MEAN);
+ } else {
+ for (i=0;i<N;i++) {
+ fn[(n-1)*NN+i] = fn[(n-2)*NN+N] * phi( (z[i]-(1.-l)*zr)/l, MEAN)/l;
+ for (j=0;j<N;j++) {
+ fn[(n-1)*NN+i] += w[j] * fn[(n-2)*NN+j] * phi( (z[i]-(1.-l)*z[j])/l, MEAN)/l;
+ }
+ if (n==q && q>1) fn[(n-1)*NN+i] /= p0[q-2];
+ }
+ fn[(n-1)*NN+N] = fn[(n-2)*NN+N] * PHI( zr, MEAN);
+ for (j=0;j<N;j++) fn[(n-1)*NN+N] += w[j] * fn[(n-2)*NN+j] * PHI( (zr-(1.-l)*z[j])/l, MEAN);
+ if (n==q && q>1) fn[(n-1)*NN+N] /= p0[q-2];
+ }
+
+ /* determine P(L>n), n=1,2,...,q-1 */
+ p0[n-1] = fn[(n-1)*NN+N];
+ for (i=0;i<N;i++) p0[n-1] += w[i] * fn[(n-1)*NN+i];
+
+ /* computation of m_n+1^- and m_n+1^+, n=m-1,m,... */
+ mn_minus = 1.; mn_plus = 0.;
+ if (n>q) {
+ for (i=0;i<NN;i++) {
+ if (fn[(n-2)*NN+i]==0)
+ if (fn[(n-1)*NN+i]==0) ratio = 0.; else ratio = 1.;
+ else ratio = fn[(n-1)*NN+i]/fn[(n-2)*NN+i];
+ if ( ratio<mn_minus ) mn_minus = ratio;
+ if ( ratio>mn_plus ) mn_plus = ratio;
+ }
+ }
+
+ if (n>q) rho = p0[n-1]/p0[n-2];
+
+ /* computation of ARL, ARL^-, and ARL^+ */
+ arl = arl0 + p0[n-1]/(1.-rho);
+ if (mn_minus<1.) arl_minus = arl0 + p0[n-1]/(1.-mn_minus);
+ else arl_minus = -1.;
+ if (mn_plus<1.) arl_plus = arl0 + p0[n-1]/(1.-mn_plus);
+ else arl_plus = -1.;
+ arl0 += p0[n-1];
+
+ if ( fabs((arl_plus-arl_minus)) < 1e-7 ) n = nmax+1;
+ }
+
+ arl = (arl_plus+arl_minus)/2.; rho0 = rho;
+
+ Free(w);
+ Free(z);
+ Free(fn);
+ Free(p0);
+
+ return arl;
+}
+
+
+double xe2_iglarl_drift(double l, double c, double hs, double delta, int m, int N, int with0)
+{ double *a, *g, *w, *z, arl, *MUs, *ARLs;
+ int i, j, m_;
+
+ a = matrix(N,N);
+ g = vector(N);
+ w = vector(N);
+ z = vector(N);
+ ARLs = vector(N);
+ MUs = vector(m+1);
+
+ c *= sqrt( l/(2.-l) );
+ hs *= sqrt( l/(2.-l) );
+
+ gausslegendre(N, -c, c, z, w);
+
+ if ( with0 ) {
+ for (i=0;i<=m;i++) MUs[i] = (double)i * delta;
+ } else {
+ for (i=0;i<=m;i++) MUs[i] = (double)(i+1.) * delta;
+ }
+
+ for (i=0;i<N;i++) {
+ for (j=0;j<N;j++) a[i*N+j] = -w[j]/l * phi( (z[j]-(1.-l)*z[i])/l, MUs[m]);
+ ++a[i*N+i];
+ }
+ for (j=0;j<N;j++) g[j] = 1.;
+ LU_solve(a, g, N);
+
+ for (m_=0;m_<m;m_++) {
+ for (i=0;i<N;i++) {
+ ARLs[i] = 1.;
+ for (j=0;j<N;j++) {
+ ARLs[i] += w[j]/l * phi( (z[j]-(1.-l)*z[i])/l, MUs[m-m_]) * g[j];
+ }
+ }
+ for (j=0;j<N;j++) g[j] = ARLs[j];
+ }
+
+ arl = 1.;
+ for (j=0;j<N;j++) arl += w[j]/l * phi( (z[j]-(1.-l)*hs)/l, MUs[0]) * ARLs[j];
+
+ Free(a);
+ Free(g);
+ Free(w);
+ Free(z);
+ Free(ARLs);
+ Free(MUs);
+
+ return arl;
+}
+
+
+double xe2_iglarl_drift_wo_m(double l, double c, double hs, double delta, int *m, int N, int with0)
+{ int m_;
+ double arl1, arl2, eps=1e-6;
+ m_ = 4;
+ arl1 = xe2_iglarl_drift(l, c, hs, delta, m_, N, with0);
+ arl2 = arl1 + 2.*eps;
+ while ( fabs(arl2-arl1)>eps && (double)m_<1e4 ) {
+ m_ = (int)round(1.5 * m_);
+ arl1 = xe2_iglarl_drift(l, c, hs, delta, m_, N, with0);
+ arl2 = xe2_iglarl_drift(l, c, hs, delta, m_+1, N, with0);
+ }
+ *m = m_;
+ return arl1;
+}
+
+
+double xe2_iglarlm_drift(double l, double c, double hs, int q, double delta, int N, int nmax, int with0)
+{ double *p0, *fn, *w, *z, arl0, rho, MEAN=0.,
+ arl_minus=0., arl, arl_plus=0., mn_minus=0., mn_plus=0., nn, ratio=0.;
+ int i, j, n;
+
+ w = vector(N);
+ z = vector(N);
+ fn = matrix(nmax, N);
+ p0 = vector(nmax);
+
+ c *= sqrt( l/(2.-l) );
+ hs *= sqrt( l/(2.-l) );
+
+ gausslegendre(N, -c, c, z, w);
+
+ /* in-control, i. e. n<=q-1 */
+ MEAN = 0.;
+
+ for (n=1;n<=q-1;n++) {
+ nn = (double) n;
+
+ /* determine f_n, n=1,2,...,q-1 */
+ if (n==1) {
+ for (i=0;i<N;i++) fn[0*N+i] = phi( (z[i]-(1.-l)*hs)/l, MEAN)/l;
+ } else {
+ for (i=0;i<N;i++) {
+ fn[(n-1)*N+i] = 0.;
+ for (j=0;j<N;j++) {
+ fn[(n-1)*N+i] += w[j] * fn[(n-2)*N+j] * phi( (z[i]-(1.-l)*z[j])/l, MEAN)/l;
+ }
+ }
+ }
+
+ /* determine P(L>n), n=1,2,...,q-1 */
+ p0[n-1] = 0.;
+ for (i=0;i<N;i++) p0[n-1] += w[i] * fn[(n-1)*N+i];
+ }
+
+ /* out-of-control, i.e. t>=q */
+ arl0 = 1.; rho = 0.;
+ for (n=q;n<=nmax;n++) {
+ nn = (double) n;
+
+ /* determine f_n, n=q,q+1,... */
+ if ( with0 ) {
+ MEAN = (nn-(double)q) * delta;
+ } else {
+ MEAN = (nn-(double)q+1.) * delta;
+ }
+
+ if (n==1) {
+ for (i=0;i<N;i++) fn[0*N+i] = phi( (z[i]-(1.-l)*hs)/l, MEAN)/l;
+ } else {
+ for (i=0;i<N;i++) {
+ fn[(n-1)*N+i] = 0.;
+ for (j=0;j<N;j++) {
+ fn[(n-1)*N+i] += w[j] * fn[(n-2)*N+j] * phi( (z[i]-(1.-l)*z[j])/l, MEAN)/l;
+ }
+ if (n==q && q>1) fn[(n-1)*N+i] /= p0[q-2];
+ }
+ }
+
+ /* determine P(L>n), n=1,2,...,q-1 */
+ p0[n-1] = 0.;
+ for (i=0;i<N;i++) p0[n-1] += w[i] * fn[(n-1)*N+i];
+
+ /* computation of m_n+1^- and m_n+1^+, n=m-1,m,... */
+ mn_minus = 1.; mn_plus = 0.;
+ if (n>q) {
+ for (i=0;i<N;i++) {
+ if (fn[(n-2)*N+i]==0)
+ if (fn[(n-1)*N+i]==0) ratio = 0.; else ratio = 1.;
+ else ratio = fn[(n-1)*N+i]/fn[(n-2)*N+i];
+ if ( ratio<mn_minus ) mn_minus = ratio;
+ if ( ratio>mn_plus ) mn_plus = ratio;
+ }
+ }
+
+ if (n>q) rho = p0[n-1]/p0[n-2];
+
+ /* computation of ARL, ARL^-, and ARL^+ */
+ arl = arl0 + p0[n-1]/(1.-rho);
+ if (mn_minus<1.) arl_minus = arl0 + p0[n-1]/(1.-mn_minus);
+ else arl_minus = -2.;
+ if (mn_plus<1.) arl_plus = arl0 + p0[n-1]/(1.-mn_plus);
+ else arl_plus = -1.;
+ arl0 += p0[n-1];
+
+ if ( fabs((arl_plus-arl_minus)) < 1e-7 ) n = nmax+1;
+ }
+
+ arl = (arl_plus+arl_minus)/2.; rho0 = rho;
+
+ Free(w);
+ Free(z);
+ Free(fn);
+ Free(p0);
+
+ return arl;
+}
+
+
+double xe2_Warl_drift(double l, double c, double hs, double delta, int N, int nmax, int with0)
+{ double *Pn, *w, *z, *p0, MEAN, nn, ratio, arl_minus=0., arl0=1., arl_plus=0., mn_minus=1., mn_plus=0.;
+ int i, j, n;
+
+ c *= sqrt( l/(2.-l) );
+ hs *= sqrt( l/(2.-l) );
+
+ w = vector(N);
+ z = vector(N);
+ Pn = matrix(nmax,N);
+ p0 = vector(nmax);
+
+ gausslegendre(N,-c,c,z,w);
+
+ arl0 = 1.;
+
+ for (n=1;n<=nmax;n++) {
+ nn = (double)n;
+ if ( with0 ) {
+ MEAN = (nn-1.) * delta;
+ } else {
+ MEAN = nn * delta;
+ }
+
+ if (n==1)
+ for (i=0;i<N;i++)
+ Pn[i] = PHI( (c-(1.-l)*z[i])/l, MEAN) - PHI( (-c-(1.-l)*z[i])/l, MEAN);
+ else
+ for (i=0;i<N;i++) {
+ Pn[(n-1)*N+i] = 0.;
+ for (j=0;j<N;j++)
+ Pn[(n-1)*N+i] += w[j]/l*phi( (z[j]-(1.-l)*z[i])/l, MEAN)*Pn[(n-2)*N+j];
+ }
+
+ if (n==1)
+ p0[0] = PHI( (c-(1.-l)*hs)/l, MEAN) - PHI( (-c-(1.-l)*hs)/l, MEAN);
+ else {
+ p0[n-1] = 0.;
+ for (j=0;j<N;j++) p0[n-1] += w[j]/l * phi( (z[j]-(1.-l)*hs)/l, MEAN) * Pn[(n-2)*N+j];
+ }
+
+ mn_minus = 1.; mn_plus = 0.;
+ if (n>1) {
+ for (i=0;i<N;i++) {
+ if (Pn[(n-2)*N+i]==0)
+ if (Pn[(n-1)*N+i]==0) ratio = 0.;
+ else ratio = 1.;
+ else ratio = Pn[(n-1)*N+i]/Pn[(n-2)*N+i];
+ if ( ratio<mn_minus ) mn_minus = ratio;
+ if ( ratio>mn_plus ) mn_plus = ratio;
+ }
+ }
+
+ if (0.<mn_minus && mn_minus<1.) arl_minus = arl0 + p0[n-1]/(1.-mn_minus);
+ else arl_minus = -2.;
+ if (0.<mn_plus && mn_plus<1.) arl_plus = arl0 + p0[n-1]/(1.-mn_plus);
+ else arl_plus = -1.;
+ arl0 += p0[n-1];
+
+ if ( fabs( (arl_plus-arl_minus)/arl_minus )<FINALeps ) n = nmax+1;
+ }
+
+ Free(p0);
+ Free(Pn);
+ Free(z);
+ Free(w);
+
+ return (arl_plus+arl_minus)/2.;
+}
+
+
+double xe2_Warl(double l, double c, double hs, double mu, int N, int nmax)
+{ double *Sm, *Pn, *w, *z, *p0, ratio, arl_minus=0., arl=1., arl_plus=0., mn_minus=1., mn_plus=0.;
+ int i, j, n;
+
+ c *= sqrt( l/(2.-l) );
+ hs *= sqrt( l/(2.-l) );
+
+ Sm = matrix(N,N);
+ w = vector(N);
+ z = vector(N);
+ Pn = matrix(nmax,N);
+ p0 = vector(nmax);
+
+ gausslegendre(N,-c,c,z,w);
+
+ for (i=0;i<N;i++)
+ for (j=0;j<N;j++)
+ Sm[i*N+j] = w[j]/l * phi( (z[j]-(1.-l)*z[i])/l, mu);
+
+ arl = 1.;
+
+ for (n=1;n<=nmax;n++) {
+
+ if (n==1)
+ for (i=0;i<N;i++)
+ Pn[i] = PHI( (c-(1.-l)*z[i])/l, mu) - PHI( (-c-(1.-l)*z[i])/l, mu);
+ else
+ for (i=0;i<N;i++) {
+ Pn[(n-1)*N+i] = 0.;
+ for (j=0;j<N;j++)
+ Pn[(n-1)*N+i] += Sm[i*N+j] * Pn[(n-2)*N+j];
+ }
+
+ if (n==1)
+ p0[0] = PHI( (c-(1.-l)*hs)/l, mu) - PHI( (-c-(1.-l)*hs)/l, mu);
+ else {
+ p0[n-1] = 0.;
+ for (j=0;j<N;j++) p0[n-1] += w[j]/l * phi( (z[j]-(1.-l)*hs)/l, mu) * Pn[(n-2)*N+j];
+ }
+
+ mn_minus = 1.; mn_plus = 0.;
+ if (n>1) {
+ for (i=0;i<N;i++) {
+ if (Pn[(n-2)*N+i]==0)
+ if (Pn[(n-1)*N+i]==0) ratio = 0.;
+ else ratio = 1.;
+ else ratio = Pn[(n-1)*N+i]/Pn[(n-2)*N+i];
+ if ( ratio<mn_minus ) mn_minus = ratio;
+ if ( ratio>mn_plus ) mn_plus = ratio;
+ }
+
+ arl_minus = arl + p0[n-1]/(1.-mn_minus);
+ arl_plus = arl + p0[n-1]/(1.-mn_plus);
+ }
+ arl += p0[n-1];
+
+ if ( fabs( (arl_plus-arl_minus)/arl_minus )<FINALeps ) n = nmax+1;
+ }
+
+ Free(p0);
+ Free(Pn);
+ Free(z);
+ Free(w);
+ Free(Sm);
+
+ return (arl_plus+arl_minus)/2.;
+}
+
+
+double xe2_Wq(double l, double c, double p, double hs, double mu, int N, int nmax)
+{ double *Sm, *Pn, *w, *z, *p0, ratio, q_minus=0., q_plus=0., mn_minus=1., mn_plus=0., enumerator=0., Wq=0.;
+ int i, j, n;
+
+ c *= sqrt( l/(2.-l) );
+ hs *= sqrt( l/(2.-l) );
+
+ Sm = matrix(N, N);
+ w = vector(N);
+ z = vector(N);
+ Pn = matrix(nmax, N);
+ p0 = vector(nmax);
+ gausslegendre(N, -c, c, z, w);
+
+ for (i=0; i<N; i++)
+ for (j=0; j<N; j++) Sm[i*N+j] = w[j]/l * phi( (z[j]-(1.-l)*z[i])/l, mu);
+
+ for (n=1; n<=nmax; n++) {
+
+ if ( n==1 )
+ for (i=0; i<N; i++) Pn[i] = PHI( (c-(1.-l)*z[i])/l, mu) - PHI( (-c-(1.-l)*z[i])/l, mu);
+ else
+ for (i=0; i<N; i++) {
+ Pn[(n-1)*N+i] = 0.;
+ for (j=0; j<N; j++) Pn[(n-1)*N+i] += Sm[i*N+j] * Pn[(n-2)*N+j];
+ }
+
+ if ( n==1 )
+ p0[0] = PHI( (c-(1.-l)*hs)/l, mu) - PHI( (-c-(1.-l)*hs)/l, mu);
+ else {
+ p0[n-1] = 0.;
+ for (j=0; j<N; j++) p0[n-1] += w[j]/l * phi( (z[j]-(1.-l)*hs)/l, mu) * Pn[(n-2)*N+j];
+ }
+
+ if ( p0[n-1] < 1.-p ) {
+ Wq = (double)n;
+ n = nmax+1;
+ } else {
+ mn_minus = 1.; mn_plus = 0.;
+ if ( n>1 ) {
+ for (i=0; i<N; i++) {
+ if (Pn[(n-2)*N+i]==0)
+ if (Pn[(n-1)*N+i]==0) ratio = 0.;
+ else ratio = 1.;
+ else ratio = Pn[(n-1)*N+i]/Pn[(n-2)*N+i];
+ if ( ratio<mn_minus ) mn_minus = ratio;
+ if ( ratio>mn_plus ) mn_plus = ratio;
+ }
+ enumerator = log( (1.-p)/p0[n-1] );
+ q_minus = (double)n + enumerator/log(mn_minus);
+ q_plus = (double)n + enumerator/log(mn_plus);
+ if ( fabs( ceil(q_plus) - ceil(q_minus) ) < .5 ) {
+ Wq = ceil(q_plus);
+ n = nmax +1;
+ }
+ } /* n > 1 */
+ } /* p0[n-1] >= 1.-p */
+ } /* n=1; n<=nmax; n++ */
+
+ Free(p0);
+ Free(Pn);
+ Free(z);
+ Free(w);
+ Free(Sm);
+
+ return Wq;
+}
+
+
+double xte2_Wq(double l, double c, double p, double hs, int df, double mu, int N, int nmax, int subst)
+{ double *Sm, *Pn, *w, *z, *p0, ratio, q_minus=0., q_plus=0., mn_minus=1., mn_plus=0., enumerator=0., Wq=0., norm=1., arg=0., korr=1.;
+ int i, j, n;
+
+ c *= sqrt( l/(2.-l) );
+ hs *= sqrt( l/(2.-l) );
+
+ Sm = matrix(N, N);
+ w = vector(N);
+ z = vector(N);
+ Pn = matrix(nmax, N);
+ p0 = vector(nmax);
+
+ switch ( subst ) {
+ case IDENTITY: gausslegendre(N, -c, c, z, w); norm = 1.; break;
+ case SIN: gausslegendre(N, -PI/2., PI/2., z, w); norm = 1.; break;
+ case SINH: gausslegendre(N, -1., 1., z, w); norm = sinh(1.); break;
+ case TAN: gausslegendre(N, -PI/4., PI/4., z, w); norm = 1.; break;
+ }
+
+ c /= norm;
+
+ for (i=0; i<N; i++)
+ for (j=0; j<N; j++) {
+ switch ( subst ) {
+ case IDENTITY: arg = z[j] - (1.-l)*z[i]; korr = 1.; break;
+ case SIN: arg = c*sin(z[j]) - (1.-l)*c*sin(z[i]); korr = c*cos(z[j]); break;
+ case SINH: arg = c*sinh(z[j]) - (1.-l)*c*sinh(z[i]); korr = c*cosh(z[j]); break;
+ case TAN: arg = c*tan(z[j]) - (1.-l)*c*tan(z[i]); korr = c/( cos(z[j])*cos(z[j]) ); break;
+ }
+ Sm[i*N+j] = w[j]/l * pdf_t( arg/l - mu, df) * korr;
+ }
+
+/* for (n=1; n<=nmax; n++) {*/
+ for (n=1; n<=100; n++) {
+
+ if ( n==1 )
+ for (i=0; i<N; i++) {
+ switch ( subst ) {
+ case IDENTITY: arg = z[i]; break;
+ case SIN: arg = c*sin(z[i]); break;
+ case SINH: arg = c*sinh(z[i]); break;
+ case TAN: arg = c*tan(z[i]); break;
+ }
+ Pn[i] = cdf_t( ( c*norm - (1.-l)*arg )/l - mu, df) - cdf_t( ( -c*norm - (1.-l)*arg )/l - mu, df);
+ }
+ else
+ for (i=0; i<N; i++) {
+ Pn[(n-1)*N+i] = 0.;
+ for (j=0; j<N; j++) Pn[(n-1)*N+i] += Sm[i*N+j] * Pn[(n-2)*N+j];
+ }
+
+ if ( n==1 )
+ p0[0] = cdf_t( ( c*norm - (1.-l)*hs )/l - mu, df) - cdf_t( ( -c*norm - (1.-l)*hs )/l - mu, df);
+ else {
+ p0[n-1] = 0.;
+ for (j=0; j<N; j++) {
+ switch ( subst ) {
+ case IDENTITY: arg = z[j]; korr = 1.; break;
+ case SIN: arg = c*sin(z[j]); korr = c*cos(z[j]); break;
+ case SINH: arg = c*sinh(z[j]); korr = c*cosh(z[j]); break;
+ case TAN: arg = c*tan(z[j]); korr = c/( cos(z[j])*cos(z[j]) ); break;
+ }
+ p0[n-1] += w[j]/l * pdf_t( ( arg - (1.-l)*hs )/l - mu, df) * Pn[(n-2)*N+j] * korr;
+ }
+ }
+
+ /*printf("%4d\t\t%.6f\n", n, p0[n-1]);*/
+
+ if ( p0[n-1] < 1.-p ) {
+ Wq = (double)n;
+ n = nmax+1;
+ } else {
+ mn_minus = 1.; mn_plus = 0.;
+ if ( n>1 ) {
+ for (i=0; i<N; i++) {
+ if (Pn[(n-2)*N+i]==0)
+ if (Pn[(n-1)*N+i]==0) ratio = 0.;
+ else ratio = 1.;
+ else ratio = Pn[(n-1)*N+i]/Pn[(n-2)*N+i];
+ if ( ratio<mn_minus ) mn_minus = ratio;
+ if ( ratio>mn_plus ) mn_plus = ratio;
+ }
+ enumerator = log( (1.-p)/p0[n-1] );
+ q_minus = (double)n + enumerator/log(mn_minus);
+ q_plus = (double)n + enumerator/log(mn_plus);
+ if ( fabs( ceil(q_plus) - ceil(q_minus) ) < .5 ) {
+ Wq = ceil(q_plus);
+ n = nmax +1;
+ }
+ } /* n > 1 */
+ } /* p0[n-1] >= 1.-p */
+ } /* n=1; n<=nmax; n++ */
+
+ Free(p0);
+ Free(Pn);
+ Free(z);
+ Free(w);
+ Free(Sm);
+
+ return Wq;
+}
+
+
+double xe2_Wqm(double l, double c, double p, double hs, int q, double mu0, double mu1, int mode, int N, int nmax)
+{ double *Smatrix, *p0, *fn, *w, *z, dn, rn, cn, rn0, cn0, delta=0.,
+ q_minus=2., q_plus=3., mn_minus, mn_plus, nn, fSt, aSt, ratio, enumerator=0., nq, Wq=0.;
+ int i, j, n;
+
+ fSt = 0.5;
+ aSt = ( -2./log10(1.-fSt) - 1.)/19.;
+
+ c *= sqrt( l/(2.-l) );
+ hs *= sqrt( l/(2.-l) );
+ if ( mode==fir || mode==both ) delta = 2.*hs;
+
+ Smatrix = matrix(N, N);
+ w = vector(N);
+ z = vector(N);
+ fn = matrix(nmax, N);
+ p0 = vector(nmax);
+
+ gausslegendre(N, -c, c, z, w);
+
+ rn = 1.; cn = 0.; rn0 = 1., cn0 = 0.;
+
+ /* in-control, i. e. n<=q-1 */
+ for (n=1; n<=q-1; n++) {
+ nn = (double) n;
+
+ /* determine c_n and r_n, n=1,2,...,q-1 */
+ switch ( mode ) {
+ case vacl: rn = sqrt( 1. - pow(1.-l,2.*nn) );
+ break;
+ case fir: dn = delta*pow(1.-l,nn);
+ rn = 1. - dn/(2.*c);
+ cn = dn/2.;
+ break;
+ case both: dn = delta*pow(1.-l,nn);
+ rn = sqrt( 1. - pow(1.-l,2.*nn) ) - dn/(2.*c);
+ cn = dn/2.;
+ break;
+ case steiner: rn = sqrt(1.-pow(1.-l,2.*nn))*(1.-pow(1.-fSt,1.+aSt*(nn-1.)));
+ break;
+ }
+
+ /* determine f_n, n=1,2,...,q-1 */
+ if ( n==1 ) {
+ for (i=0; i<N; i++)
+ if ( mode==stat )
+ fn[0*N+i] = 1./sqrt(l/(2.-l))*phi( (cn+rn*z[i])/sqrt(l/(2.-l)),mu0);
+ else
+ fn[0*N+i] = rn/l * phi( (cn+rn*z[i]-(1.-l)*hs)/l,mu0);
+ }
+ else {
+ for (i=0; i<N; i++) {
+ fn[(n-1)*N+i] = 0.;
+ for (j=0; j<N; j++) {
+ fn[(n-1)*N+i] += w[j]*fn[(n-2)*N+j]*rn/l*phi((cn+rn*z[i]-(1.-l)*(cn0+rn0*z[j]))/l,mu0);
+ }
+ }
+ }
+
+ /* determine P(L>n), n=1,2,...,q-1 */
+ p0[n-1] = 0.;
+ for (i=0; i<N; i++) p0[n-1] += w[i] * fn[(n-1)*N+i];
+
+ /* weights and nodes w.r.t. O_n become w. a. n. w.r.t. O_n-1 */
+ cn0 = cn; rn0 = rn;
+ }
+
+ /* out-of-control, i.e. t>=q */
+ for (n=q; n<=nmax; n++) {
+ nn = (double) n;
+
+ /* determine c_n and r_n, n=q,q+1,... */
+ switch ( mode ) {
+ case vacl: rn = sqrt( 1. - pow(1.-l,2.*nn) );
+ break;
+ case fir: dn = delta*pow(1.-l,nn);
+ rn = 1. - dn/(2.*c);
+ cn = dn/2.;
+ break;
+ case both: dn = delta*pow(1.-l,nn);
+ rn = sqrt( 1. - pow(1.-l,2.*nn) ) - dn/(2.*c);
+ cn = dn/2.;
+ break;
+ case steiner: rn = sqrt(1.-pow(1.-l,2.*nn))*(1.-pow(1.-fSt,1.+aSt*(nn-1.)));
+ break;
+ }
+
+ /* determine f_n, n=q,q+1,... */
+ if ( n==1 ) {
+ for (i=0; i<N; i++)
+ if ( mode==stat )
+ fn[0*N+i] = 1./sqrt(l/(2.-l))*phi( (cn+rn*z[i])/sqrt(l/(2.-l)),mu1);
+ else
+ fn[0*N+i] = rn/l * phi( (cn+rn*z[i]-(1.-l)*hs)/l,mu1);
+ }
+ else {
+ for (i=0; i<N; i++) {
+ fn[(n-1)*N+i] = 0.;
+ for (j=0; j<N; j++)
+ fn[(n-1)*N+i] += w[j]*fn[(n-2)*N+j]*rn/l*phi( (cn+rn*z[i]-(1.-l)*(cn0+rn0*z[j]))/l,mu1);
+ if ( n==q && q>1 ) fn[(n-1)*N+i] /= p0[q-2];
+ }
+ }
+
+ /* determine P(L>n), n=1,2,...,q-1 */
+ p0[n-1] = 0.;
+ for (i=0; i<N; i++) p0[n-1] += w[i] * fn[(n-1)*N+i];
+ nq = (double)(n-q+1);
+
+ /* weights and nodes w.r.t. O_n become w. a. n. w.r.t. O_n-1 */
+ cn0 = cn; rn0 = rn;
+
+ if ( p0[n-1] < 1.-p ) {
+ Wq = nq;
+ n = nmax+1;
+ } else {
+ /* computation of m_n+1^- and m_n+1^+, n=m-1,m,... */
+ mn_minus = 1.; mn_plus = 0.;
+ if ( n > q ) {
+ for (i=0; i<N; i++) {
+ if (fn[(n-2)*N+i]==0)
+ if (fn[(n-1)*N+i]==0) ratio = 0.; else ratio = 1.;
+ else ratio = fn[(n-1)*N+i]/fn[(n-2)*N+i];
+ if ( ratio<mn_minus ) mn_minus = ratio;
+ if ( ratio>mn_plus ) mn_plus = ratio;
+ }
+ enumerator = log( (1.-p)/p0[n-1] );
+ q_minus = nq + enumerator/log(mn_minus);
+ q_plus = nq + enumerator/log(mn_plus);
+ if ( fabs( ceil(q_plus) - ceil(q_minus) ) < .5 ) {
+ Wq = ceil(q_plus);
+ n = nmax +1;
+ }
+ } /* n > q */
+ } /* p0[n-1] >= 1.-p */
+ } /* n=q; n<=nmax; n++ */
+
+ Free(Smatrix);
+ Free(w);
+ Free(z);
+ Free(fn);
+ Free(p0);
+
+ return Wq;
+}
+
+
+double xte2_Wqm(double l, double c, double p, double hs, int df, int q, double mu0, double mu1, int mode, int N, int nmax, int subst)
+{ double *Smatrix, *p0, *fn, *w, *z, dn, rn, cn, rn0, cn0, delta=0.,
+ q_minus=2., q_plus=3., mn_minus, mn_plus, nn, fSt, aSt, ratio, enumerator=0., nq, Wq=0., norm=1., arg=0., korr=1.;
+ int i, j, n;
+
+ fSt = 0.5;
+ aSt = ( -2./log10(1.-fSt) - 1.)/19.;
+
+ c *= sqrt( l/(2.-l) );
+ hs *= sqrt( l/(2.-l) );
+ if ( mode==fir || mode==both ) delta = 2.*hs;
+
+ Smatrix = matrix(N, N);
+ w = vector(N);
+ z = vector(N);
+ fn = matrix(nmax, N);
+ p0 = vector(nmax);
+
+ switch ( subst ) {
+ case IDENTITY: gausslegendre(N, -c, c, z, w); norm = 1.; break;
+ case SIN: gausslegendre(N, -PI/2., PI/2., z, w); norm = 1.; break;
+ case SINH: gausslegendre(N, -1., 1., z, w); norm = sinh(1.); break;
+ case TAN: gausslegendre(N, -PI/4., PI/4., z, w); norm = 1.; break;
+ }
+
+ c /= norm;
+
+ rn = 1.; cn = 0.; rn0 = 1., cn0 = 0.;
+
+ /* in-control, i. e. n<=q-1 */
+ for (n=1; n<=q-1; n++) {
+ nn = (double) n;
+
+ /* determine c_n and r_n, n=1,2,...,q-1 */
+ switch ( mode ) {
+ case vacl: rn = sqrt( 1. - pow(1.-l,2.*nn) );
+ break;
+ case fir: dn = delta*pow(1.-l,nn);
+ rn = 1. - dn/(2.*c*norm);
+ cn = dn/2.;
+ break;
+ case both: dn = delta*pow(1.-l,nn);
+ rn = sqrt( 1. - pow(1.-l,2.*nn) ) - dn/(2.*c*norm);
+ cn = dn/2.;
+ break;
+ case steiner: rn = sqrt(1.-pow(1.-l,2.*nn))*(1.-pow(1.-fSt,1.+aSt*(nn-1.)));
+ break;
+ }
+
+ /* determine f_n, n=1,2,...,q-1 */
+ if ( n==1 ) {
+ for (i=0; i<N; i++) {
+ switch ( subst ) {
+ case IDENTITY: arg = z[i]; break;
+ case SIN: arg = c*sin(z[i]); break;
+ case SINH: arg = c*sinh(z[i]); break;
+ case TAN: arg = c*tan(z[i]); break;
+ }
+ if ( mode==stat )
+ fn[0*N+i] = 1./sqrt(l/(2.-l)) * pdf_t( ( cn+rn*arg )/sqrt(l/(2.-l)) - mu0, df);
+ else
+ fn[0*N+i] = rn/l * pdf_t( ( cn+rn*arg - (1.-l)*hs )/l - mu0, df);
+ }
+ }
+ else {
+ for (i=0; i<N; i++) {
+ fn[(n-1)*N+i] = 0.;
+ for (j=0; j<N; j++) {
+ switch ( subst ) {
+ case IDENTITY: arg = cn+rn*z[i] - (1.-l)*(cn0+rn0*z[j]); korr = 1.; break;
+ case SIN: arg = cn+rn*c*sin(z[i]) - (1.-l)*(cn0+rn0*c*sin(z[j])); korr = c*cos(z[j]); break;
+ case SINH: arg = cn+rn*c*sinh(z[i]) - (1.-l)*(cn0+rn0*c*sinh(z[j])); korr = c*cosh(z[j]); break;
+ case TAN: arg = cn+rn*c*tan(z[i]) - (1.-l)*(cn0+rn0*c*tan(z[j])); korr = c/( cos(z[j])*cos(z[j]) ); break;
+ }
+ fn[(n-1)*N+i] += w[j]*fn[(n-2)*N+j]*rn/l * pdf_t( arg/l - mu0, df) * korr;
+ }
+ }
+ }
+
+ /* determine P(L>n), n=1,2,...,q-1 */
+ p0[n-1] = 0.;
+ for (i=0; i<N; i++) {
+ switch ( subst ) {
+ case IDENTITY: korr = 1.; break;
+ case SIN: korr = c*cos(z[i]); break;
+ case SINH: korr = c*cosh(z[i]); break;
+ case TAN: korr = c/( cos(z[i])*cos(z[i]) ); break;
+ }
+ p0[n-1] += w[i] * fn[(n-1)*N+i] * korr;
+ }
+
+ /* weights and nodes w.r.t. O_n become w. a. n. w.r.t. O_n-1 */
+ cn0 = cn; rn0 = rn;
+ }
+
+ /* out-of-control, i.e. t>=q */
+ for (n=q; n<=nmax; n++) {
+ nn = (double) n;
+
+ /* determine c_n and r_n, n=q,q+1,... */
+ switch ( mode ) {
+ case vacl: rn = sqrt( 1. - pow(1.-l,2.*nn) );
+ break;
+ case fir: dn = delta*pow(1.-l,nn);
+ rn = 1. - dn/(2.*c*norm);
+ cn = dn/2.;
+ break;
+ case both: dn = delta*pow(1.-l,nn);
+ rn = sqrt( 1. - pow(1.-l,2.*nn) ) - dn/(2.*c*norm);
+ cn = dn/2.;
+ break;
+ case steiner: rn = sqrt(1.-pow(1.-l,2.*nn))*(1.-pow(1.-fSt,1.+aSt*(nn-1.)));
+ break;
+ }
+
+ /* determine f_n, n=q,q+1,... */
+ if ( n==1 ) {
+ for (i=0; i<N; i++) {
+ switch ( subst ) {
+ case IDENTITY: arg = z[i]; break;
+ case SIN: arg = c*sin(z[i]); break;
+ case SINH: arg = c*sinh(z[i]); break;
+ case TAN: arg = c*tan(z[i]); break;
+ }
+ if ( mode==stat )
+ fn[0*N+i] = 1./sqrt(l/(2.-l)) * pdf_t( ( cn+rn*arg )/sqrt(l/(2.-l)) - mu1, df);
+ else
+ fn[0*N+i] = rn/l * pdf_t( ( cn+rn*arg - (1.-l)*hs )/l - mu1, df);
+ }
+ }
+ else {
+ for (i=0; i<N; i++) {
+ fn[(n-1)*N+i] = 0.;
+ for (j=0; j<N; j++) {
+ switch ( subst ) {
+ case IDENTITY: arg = cn+rn*z[i] - (1.-l)*(cn0+rn0*z[j]); korr = 1.; break;
+ case SIN: arg = cn+rn*c*sin(z[i]) - (1.-l)*(cn0+rn0*c*sin(z[j])); korr = c*cos(z[j]); break;
+ case SINH: arg = cn+rn*c*sinh(z[i]) - (1.-l)*(cn0+rn0*c*sinh(z[j])); korr = c*cosh(z[j]); break;
+ case TAN: arg = cn+rn*c*tan(z[i]) - (1.-l)*(cn0+rn0*c*tan(z[j])); korr = c/( cos(z[j])*cos(z[j]) ); break;
+ }
+ fn[(n-1)*N+i] += w[j]*fn[(n-2)*N+j]*rn/l * pdf_t( arg/l - mu1, df) * korr;
+ }
+ if ( n==q && q>1 ) fn[(n-1)*N+i] /= p0[q-2];
+ }
+ }
+
+ /* determine P(L>n), n=1,2,...,q-1 */
+ p0[n-1] = 0.;
+ for (i=0;i<N;i++) {
+ switch ( subst ) {
+ case IDENTITY: korr = 1.; break;
+ case SIN: korr = c*cos(z[i]); break;
+ case SINH: korr = c*cosh(z[i]); break;
+ case TAN: korr = c/( cos(z[i])*cos(z[i]) ); break;
+ }
+ p0[n-1] += w[i] * fn[(n-1)*N+i] * korr;
+ }
+ nq = (double)(n-q+1.);
+
+ /* weights and nodes w.r.t. O_n become w. a. n. w.r.t. O_n-1 */
+ cn0 = cn; rn0 = rn;
+
+ if ( p0[n-1] < 1.-p ) {
+ Wq = nq;
+ n = nmax+1;
+ } else {
+ /* computation of m_n+1^- and m_n+1^+, n=m-1,m,... */
+ mn_minus = 1.; mn_plus = 0.;
+ if ( n > q ) {
+ for (i=0; i<N; i++) {
+ if (fn[(n-2)*N+i]==0)
+ if (fn[(n-1)*N+i]==0) ratio = 0.; else ratio = 1.;
+ else ratio = fn[(n-1)*N+i]/fn[(n-2)*N+i];
+ if ( ratio<mn_minus ) mn_minus = ratio;
+ if ( ratio>mn_plus ) mn_plus = ratio;
+ }
+ enumerator = log( (1.-p)/p0[n-1] );
+ q_minus = nq + enumerator/log(mn_minus);
+ q_plus = nq + enumerator/log(mn_plus);
+ if ( fabs( ceil(q_plus) - ceil(q_minus) ) < .5 ) {
+ Wq = ceil(q_plus);
+ n = nmax +1;
+ }
+ } /* n > q */
+ } /* p0[n-1] >= 1.-p */
+ } /* n=q; n<=nmax; n++ */
+
+ Free(Smatrix);
+ Free(w);
+ Free(z);
+ Free(fn);
+ Free(p0);
+
+ return Wq;
+}
+
+
+double xe1_Warl(double l, double c, double zr, double hs,
+double mu, int N, int nmax)
+{ double *Pn, *w, *z, *p0, *atom, ratio, arl_minus=0., arl=1., arl_plus=0., mn_minus=1., mn_plus=0.;
+ int i, j, n;
+
+ c *= sqrt( l/(2.-l) );
+ hs *= sqrt( l/(2.-l) );
+ zr *= sqrt( l/(2.-l) );
+
+ w = vector(N);
+ z = vector(N);
+ Pn = matrix(nmax,N);
+ p0 = vector(nmax);
+ atom = vector(nmax);
+
+ gausslegendre(N,zr,c,z,w);
+
+ for (n=1;n<=nmax;n++) {
+
+ if (n==1) {
+ for (i=0;i<N;i++)
+ Pn[i] = PHI( (c-(1.-l)*z[i])/l, mu);
+ atom[0] = PHI( (c-(1.-l)*zr)/l, mu);
+ } else {
+ for (i=0;i<N;i++) {
+ Pn[(n-1)*N+i] = PHI( (zr-(1.-l)*z[i])/l, mu) * atom[n-2];
+ for (j=0;j<N;j++)
+ Pn[(n-1)*N+i] += w[j]/l * phi( (z[j]-(1.-l)*z[i])/l, mu) * Pn[(n-2)*N+j];
+ }
+ atom[n-1] = PHI( zr, mu) * atom[n-2];
+ for (j=0;j<N;j++)
+ atom[n-1] += w[j]/l * phi( (z[j]-(1.-l)*zr)/l, mu) * Pn[(n-2)*N+j];
+ }
+
+ if (n==1)
+ p0[0] = PHI( (c-(1.-l)*hs)/l, mu);
+ else {
+ p0[n-1] = PHI( (zr-(1.-l)*hs)/l, mu) * atom[n-2];
+ for (j=0;j<N;j++)
+ p0[n-1] += w[j]/l * phi( (z[j]-(1.-l)*hs)/l, mu) * Pn[(n-2)*N+j];
+ }
+
+ mn_minus = 1.; mn_plus = 0.;
+ if (n>1) {
+ mn_minus = atom[n-1]/atom[n-2];
+ mn_plus = atom[n-1]/atom[n-2];
+ for (i=0;i<N;i++) {
+ if (Pn[(n-2)*N+i]==0)
+ if (Pn[(n-1)*N+i]==0) ratio = 0.;
+ else ratio = 1.;
+ else ratio = Pn[(n-1)*N+i]/Pn[(n-2)*N+i];
+ if ( ratio<mn_minus ) mn_minus = ratio;
+ if ( ratio>mn_plus ) mn_plus = ratio;
+ }
+
+ arl_minus = arl + p0[n-1]/(1.-mn_minus);
+ arl_plus = arl + p0[n-1]/(1.-mn_plus);
+ }
+ arl += p0[n-1];
+
+ if ( fabs( (arl_plus-arl_minus)/arl_minus )<FINALeps ) n = nmax+1;
+ }
+
+ Free(p0);
+ Free(Pn);
+ Free(z);
+ Free(w);
+ Free(atom);
+
+ return (arl_plus+arl_minus)/2.;
+}
+
+
+double xe1_Wq(double l, double c, double p, double zr, double hs, double mu, int N, int nmax)
+{ double *Pn, *w, *z, *p0, *atom, ratio, q_minus=0., q_plus=0., mn_minus=1., mn_plus=0., enumerator=0., Wq=0.;
+ int i, j, n;
+
+ c *= sqrt( l/(2.-l) );
+ hs *= sqrt( l/(2.-l) );
+ zr *= sqrt( l/(2.-l) );
+
+ w = vector(N);
+ z = vector(N);
+ Pn = matrix(nmax,N);
+ p0 = vector(nmax);
+ atom = vector(nmax);
+
+ gausslegendre(N,zr,c,z,w);
+
+ for (n=1;n<=nmax;n++) {
+
+ if (n==1) {
+ for (i=0;i<N;i++)
+ Pn[i] = PHI( (c-(1.-l)*z[i])/l, mu);
+ atom[0] = PHI( (c-(1.-l)*zr)/l, mu);
+ } else {
+ for (i=0;i<N;i++) {
+ Pn[(n-1)*N+i] = PHI( (zr-(1.-l)*z[i])/l, mu) * atom[n-2];
+ for (j=0;j<N;j++) Pn[(n-1)*N+i] += w[j]/l * phi( (z[j]-(1.-l)*z[i])/l, mu) * Pn[(n-2)*N+j];
+ }
+ atom[n-1] = PHI( zr, mu) * atom[n-2];
+ for (j=0;j<N;j++) atom[n-1] += w[j]/l * phi( (z[j]-(1.-l)*zr)/l, mu) * Pn[(n-2)*N+j];
+ }
+
+ if (n==1)
+ p0[0] = PHI( (c-(1.-l)*hs)/l, mu);
+ else {
+ p0[n-1] = PHI( (zr-(1.-l)*hs)/l, mu) * atom[n-2];
+ for (j=0;j<N;j++) p0[n-1] += w[j]/l * phi( (z[j]-(1.-l)*hs)/l, mu) * Pn[(n-2)*N+j];
+ }
+
+ if ( p0[n-1] < 1.-p ) {
+ Wq = (double)n;
+ n = nmax+1;
+ } else {
+ mn_minus = 1.; mn_plus = 0.;
+ if ( n>1 ) {
+ mn_minus = atom[n-1]/atom[n-2];
+ mn_plus = atom[n-1]/atom[n-2];
+ for (i=0;i<N;i++) {
+ if (Pn[(n-2)*N+i]==0)
+ if (Pn[(n-1)*N+i]==0) ratio = 0.;
+ else ratio = 1.;
+ else ratio = Pn[(n-1)*N+i]/Pn[(n-2)*N+i];
+ if ( ratio<mn_minus ) mn_minus = ratio;
+ if ( ratio>mn_plus ) mn_plus = ratio;
+ }
+ enumerator = log( (1.-p)/p0[n-1] );
+ q_minus = (double)n + enumerator/log(mn_minus);
+ q_plus = (double)n + enumerator/log(mn_plus);
+ if ( fabs( ceil(q_plus) - ceil(q_minus) ) < .5 ) {
+ Wq = ceil(q_plus);
+ n = nmax +1;
+ }
+ } /* n > 1 */
+ } /* p0[n-1] >= 1.-p */
+ } /* n=1; n<=nmax; n++ */
+
+ Free(p0);
+ Free(Pn);
+ Free(z);
+ Free(w);
+ Free(atom);
+
+ return Wq;
+}
+
+
+double xe1_Wqm(double l, double c, double p, double zr, double hs, int q, double mu0, double mu1, int mode, int N, int nmax)
+{ double *Smatrix, *p0, *fn, *w, *z, rn, cn, rn0, cn0, q_minus=2., q_plus=3., mn_minus, mn_plus, nn, ratio, enumerator=0., nq, Wq=0.;
+ int i, j, n, NN;
+
+ c *= sqrt( l/(2.-l) );
+ zr *= sqrt( l/(2.-l) );
+ hs *= sqrt( l/(2.-l) );
+
+ NN = N + 1;
+ Smatrix = matrix(NN, NN);
+ w = vector(NN);
+ z = vector(NN);
+ fn = matrix(nmax, NN);
+ p0 = vector(nmax);
+
+ gausslegendre(N, zr, c, z, w);
+
+ rn = 1.; cn = 0.; rn0 = 1., cn0 = 0.;
+
+ /* in-control, i. e. n<=q-1 */
+ for (n=1;n<=q-1;n++) {
+ nn = (double) n;
+
+ /* determine r_n, n=1,2,...,q-1 */
+ if ( mode==vacl ) {
+ rn = sqrt( 1. - pow(1.-l, 2.*nn) );
+ }
+
+ /* determine f_n, n=1,2,...,q-1 */
+ if (n==1) {
+ for (i=0;i<N;i++) {
+ if ( mode==stat ) {
+ fn[0*NN+i] = 1./sqrt(l/(2.-l))*phi( (cn+rn*z[i])/sqrt(l/(2.-l)), mu0);
+ }
+ else {
+ fn[0*NN+i] = rn/l * phi( (cn+rn*z[i]-(1.-l)*hs)/l, mu0);
+ }
+ }
+ if ( mode==stat ) {
+ fn[0*NN+N] = PHI( (cn+rn*zr)/sqrt(l/(2.-l)), mu0);
+ }
+ else {
+ fn[0*NN+N] = PHI( (cn+rn*zr-(1.-l)*hs)/l, mu0);
+ }
+ }
+ else {
+ for (i=0;i<N;i++) {
+ fn[(n-1)*NN+i] = fn[(n-2)*NN+N] * rn/l * phi((cn+rn*z[i]-(1.-l)*(cn0+rn0*zr))/l, mu0);
+ for (j=0;j<N;j++) {
+ fn[(n-1)*NN+i] += w[j]*fn[(n-2)*NN+j] * rn/l
+ *phi((cn+rn*z[i]-(1.-l)*(cn0+rn0*z[j]))/l, mu0);
+ }
+ }
+ fn[(n-1)*NN+N] = fn[(n-2)*NN+N] * PHI( (cn+rn*zr-(1.-l)*(cn0+rn0*zr))/l, mu0);
+ for (j=0;j<N;j++)
+ fn[(n-1)*NN+N] += w[j] * fn[(n-2)*NN+j] * PHI( (cn+rn*zr-(1.-l)*(cn0+rn0*z[j]))/l, mu0);
+ }
+
+ /* determine P(L>n), n=1,2,...,q-1 */
+ p0[n-1] = fn[(n-1)*NN+N];
+ for (i=0;i<N;i++) p0[n-1] += w[i] * fn[(n-1)*NN+i];
+
+ /* weights and nodes w.r.t. O_n become w. a. n. w.r.t. O_n-1 */
+ cn0 = cn; rn0 = rn;
+ }
+
+ /* out-of-control, i.e. t>=q */
+ for (n=q;n<=nmax;n++) {
+ nn = (double) n;
+
+ /* determine r_n, n=1,2,...,q-1 */
+ if ( mode==vacl ) {
+ rn = sqrt( 1. - pow(1.-l, 2.*nn) );
+ }
+
+ /* determine f_n, n=q,q+1,... */
+ if (n==1) {
+ for (i=0;i<N;i++) {
+ if ( mode==stat ) {
+ fn[0*NN+i] = 1./sqrt(l/(2.-l))*phi( (cn+rn*z[i])/sqrt(l/(2.-l)), mu1);
+ }
+ else {
+ fn[0*NN+i] = rn/l * phi( (cn+rn*z[i]-(1.-l)*hs)/l, mu1);
+ }
+ }
+ if ( mode==stat ) {
+ fn[0*NN+N] = PHI( (cn+rn*zr)/sqrt(l/(2.-l)), mu1);
+ }
+ else {
+ fn[0*NN+N] = PHI( (cn+rn*zr-(1.-l)*hs)/l, mu1);
+ }
+ }
+ else {
+ for (i=0;i<N;i++) {
+ fn[(n-1)*NN+i] = fn[(n-2)*NN+N] * rn/l * phi((cn+rn*z[i]-(1.-l)*(cn0+rn0*zr))/l, mu1);
+ for (j=0;j<N;j++) {
+ fn[(n-1)*NN+i] += w[j]*fn[(n-2)*NN+j] * rn/l * phi((cn+rn*z[i]-(1.-l)*(cn0+rn0*z[j]))/l, mu1);
+ }
+ if ( n==q && q>1 ) fn[(n-1)*NN+i] /= p0[q-2];
+ }
+ fn[(n-1)*NN+N] = fn[(n-2)*NN+N] * PHI( (cn+rn*zr-(1.-l)*(cn0+rn0*zr))/l, mu1);
+ for (j=0;j<N;j++)
+ fn[(n-1)*NN+N] += w[j] * fn[(n-2)*NN+j] * PHI( (cn+rn*zr-(1.-l)*(cn0+rn0*z[j]))/l, mu1);
+ if (n==q && q>1) fn[(n-1)*NN+N] /= p0[q-2];
+ }
+
+ /* determine P(L>n), n=1,2,...,q-1 */
+ p0[n-1] = fn[(n-1)*NN+N];
+ for (i=0;i<N;i++) p0[n-1] += w[i] * fn[(n-1)*NN+i];
+ nq = (double)(n-q+1);
+
+ /* weights and nodes w.r.t. O_n become w. a. n. w.r.t. O_n-1 */
+ cn0 = cn; rn0 = rn;
+
+ if ( p0[n-1] < 1.-p ) {
+ Wq = nq;
+ n = nmax+1;
+ } else {
+ /* computation of m_n+1^- and m_n+1^+, n=m-1,m,... */
+ mn_minus = 1.; mn_plus = 0.;
+ if ( n > q ) {
+ for (i=0;i<NN;i++) {
+ if (fn[(n-2)*NN+i]==0)
+ if (fn[(n-1)*NN+i]==0) ratio = 0.; else ratio = 1.;
+ else ratio = fn[(n-1)*NN+i]/fn[(n-2)*NN+i];
+ if ( ratio<mn_minus ) mn_minus = ratio;
+ if ( ratio>mn_plus ) mn_plus = ratio;
+ }
+ enumerator = log( (1.-p)/p0[n-1] );
+ q_minus = nq + enumerator/log(mn_minus);
+ q_plus = nq + enumerator/log(mn_plus);
+ if ( fabs( ceil(q_plus) - ceil(q_minus) ) < .5 ) {
+ Wq = ceil(q_plus);
+ n = nmax +1;
+ }
+ } /* n > q */
+ } /* p0[n-1] >= 1.-p */
+ } /* n=q; n<=nmax; n++ */
+
+ Free(Smatrix);
+ Free(w);
+ Free(z);
+ Free(fn);
+ Free(p0);
+
+ return Wq;
+}
+
+
+double xe2_Carl(double l, double c, double hs, double mu, int N, int qm)
+{ double *a, *g, *w, *z, arl, Hij, zi, lzi, dN;
+ int i, j, k;
+
+ c *= sqrt( l/(2.-l) );
+ hs *= sqrt( l/(2.-l) );
+
+ dN = (double)N;
+
+ a = matrix(N,N);
+ g = vector(N);
+ w = vector(qm);
+ z = vector(qm);
+
+ gausslegendre(qm,-c,c,z,w);
+
+ for (i=0;i<N;i++) {
+ zi = c * cos( (2.*(i+1.)-1.)*PI/2./dN );
+ lzi = (1.-l)*zi;
+
+ a[i*N] = 1 - ( PHI( (c-lzi)/l, mu) - PHI( (-c-lzi)/l, mu) );
+
+ for (j=1;j<N;j++) {
+ Hij = 0.;
+ for (k=0;k<qm;k++)
+ Hij += w[k]/l * Tn( z[k]/c, j) * phi( (z[k]-lzi)/l, mu);
+ a[i*N+j] = Tn( zi/c, j) - Hij;
+ }
+ }
+
+ for (j=0;j<N;j++) g[j] = 1.;
+ LU_solve(a,g,N);
+
+ arl = g[0];
+ for (j=1;j<N;j++) arl += g[j] * Tn( hs/c, j);
+
+ Free(z);
+ Free(w);
+ Free(g);
+ Free(a);
+
+ return arl;
+}
+
+
+/* Manuel's PMS stuff */
+
+
+double xe2_iglarl_RES
+(double l, double c, double hs, double mu, int N, double alpha, int df)
+{ double *a, *g, *w, *z, arl, ddf;
+ int i, j;
+
+/* residual preliminaries */
+ ddf = (double)df;
+ mu *= ( 1. + ddf*sqrt( (1.-alpha)/(1.+alpha) ) )/(ddf+1.);
+
+ a = matrix(N,N);
+ g = vector(N);
+ w = vector(N);
+ z = vector(N);
+
+ c *= sqrt( l/(2.-l) );
+ hs *= sqrt( l/(2.-l) );
+
+ gausslegendre(N,-c,c,z,w);
+
+ for (i=0;i<N;i++) {
+ for (j=0;j<N;j++) a[i*N+j] = -w[j]/l * phi( (z[j]-(1.-l)*z[i])/l,mu);
+ ++a[i*N+i];
+ }
+
+ for (j=0;j<N;j++) g[j] = 1.;
+ LU_solve(a,g,N);
+
+ arl = 1.;
+ for (j=0;j<N;j++)
+ arl += w[j]/l * phi( (z[j]-(1.-l)*hs)/l,mu) * g[j];
+
+ Free(a);
+ Free(g);
+ Free(w);
+ Free(z);
+
+ return arl;
+}
+
+
+double seU_iglarl_RES
+ (double l, double cu, double hs, double sigma, int df, int N, int qm, double alpha, double mu)
+{ double *a, *g, *w, *z, arl, Hij, xi, xl, za, xu, dN, ddf, s2, v, ncp;
+ int i, j, k;
+
+ s2 = sigma*sigma;
+ ddf = (double)df;
+ dN = (double)N;
+
+ /* residual preliminaries */
+ mu *= ( 1. + ddf*sqrt( (1.-alpha)/(1.+alpha) ) )/(ddf+1.);
+ ncp = ddf/(ddf+1.)*mu*mu/s2*pow( 1.-sqrt((1.-alpha)/(1.+alpha)), 2.);
+
+ a = matrix(N,N);
+ g = vector(N);
+ w = vector(qm);
+ z = vector(qm);
+
+ for (i=0;i<N;i++) {
+ xi = cu/2.*(1.+cos(PI*(2.*(i+1.)-1.)/2./dN));
+
+ za = (1.-l)*xi;
+ xl = 0.;
+ xu = sqrt(cu-za);
+
+ gausslegendre(qm,xl,xu,z,w);
+
+ v = (cu - za)/l;
+ a[i*N] = 1. - nCHI( ddf/s2*v, df, ncp);
+
+ for (j=1;j<N;j++) {
+ Hij = 0.;
+ for (k=0;k<qm;k++) {
+ v = (z[k] - za) / l;
+ Hij += w[k] * Tn( (2.*(z[k]*z[k]+za)-cu)/cu ,j)
+ * 2. * z[k]/l * ddf/s2 * nchi( ddf/s2*z[k]*z[k]/l, df, ncp);
+ }
+ a[i*N+j] = Tn( (2.*xi-cu)/cu ,j) - Hij;
+ }
+ }
+
+ for (j=0;j<N;j++) g[j] = 1.;
+ LU_solve(a,g,N);
+
+ arl = g[0];
+ for (j=1;j<N;j++)
+ arl += g[j] * Tn( (2.*hs-cu)/cu ,j);
+
+ Free(z);
+ Free(w);
+ Free(g);
+ Free(a);
+
+ return arl;
+}
+
+
+double xseU_arl_RES
+ (double lx, double ls, double cx, double cs, double hsx, double hss, double mu, double sigma, int df, int Nx, int Ns, int nmax, int qm, double alpha)
+{ double *Sx, *Pnx, *wx, *zx, *p0x, *p0,
+ *S1s, *S2s, *Pns, *ws, *zs, *p0s, q, *zch, *rside,
+ za=0., s2,
+ arl_minus=0., arl, arl_plus=0., mn_minus=1., mn_plus=0.,
+ mn_minusx, mn_minuss, mn_plusx, mn_pluss, ddf, xl, xu,
+ oben, unten, ncp;
+ int i, j, k, n, *ps;
+
+ cx *= sqrt( lx/(2.-lx) );
+ hsx *= sqrt( lx/(2.-lx) );
+
+ s2 = sigma*sigma;
+ ddf = (double)df;
+
+ /* residual preliminaries */
+ ncp = ddf/(ddf+1.)/(ddf+1.)*mu*mu/s2*pow( 1.-sqrt((1.-alpha)/(1.+alpha)), 2.);
+ mu *= ( 1. + ddf*sqrt( (1.-alpha)/(1.+alpha) ) )/(ddf+1.);
+
+ Sx = matrix(Nx,Nx);
+ wx = vector(Nx);
+ zx = vector(Nx);
+ Pnx = matrix(nmax,Nx);
+ p0x = vector(nmax);
+
+ S1s = matrix(Ns,Ns);
+ S2s = matrix(Ns,Ns);
+ ps = ivector(Ns);
+ zch = vector(Ns);
+ rside = vector(Ns);
+ ws = vector(qm);
+ zs = vector(qm);
+ Pns = matrix(nmax,Ns);
+ p0s = vector(nmax);
+
+ p0 = vector(nmax);
+
+ gausslegendre(Nx,-cx,cx,zx,wx);
+
+ for (i=0;i<Nx;i++) {
+ za = (1.-lx)*zx[i];
+ for (j=0;j<Nx;j++)
+ Sx[i*Nx+j] = wx[j]/lx*phi( ((zx[j]-za)/lx-mu)/sigma, 0.)/sigma;
+ }
+
+/* Chebyshev nodes on [0,cs] */
+ for (i=0;i<Ns;i++)
+ zch[i] = cs/2.*(1.+cos(PI*(2.*(i+1.)-1.)/2./(double)Ns) );
+
+/* P(L>1)(zch[i]) */
+ for (i=0;i<Ns;i++)
+ rside[i] = nCHI( ddf/s2*(cs-(1.-ls)*zch[i])/ls, df, ncp);
+
+ for (i=0;i<Ns;i++) {
+ za = (1.-ls)*zch[i];
+ xl = 0.; xu = sqrt(cs-za);
+ gausslegendre(qm,xl,xu,zs,ws);
+ for (j=0;j<Ns;j++) {
+ S1s[i*Ns+j] = 0.;
+ for (k=0;k<qm;k++)
+ S1s[i*Ns+j] += ws[k]*Tn((2.*(zs[k]*zs[k]+za)-cs)/cs, j)
+ * 2.*zs[k]/ls * ddf/s2 * nchi( ddf/s2 * zs[k]*zs[k]/ls, df, ncp);
+ }
+ }
+
+ for (i=0;i<Ns;i++)
+ for (j=0;j<Ns;j++) S2s[i*Ns+j] = Tn( (2.*zch[i]-cs)/cs, j);
+
+ LU_decompose(S2s,ps,Ns);
+
+ arl = 1.;
+ for (n=1;n<=nmax;n++) {
+
+ if (n==1)
+ for (i=0;i<Nx;i++)
+ Pnx[i] = PHI( (( cx-(1.-lx)*zx[i])/lx-mu)/sigma, 0.) -
+ PHI( ((-cx-(1.-lx)*zx[i])/lx-mu)/sigma, 0.);
+ else
+ for (i=0;i<Nx;i++) {
+ Pnx[(n-1)*Nx+i] = 0.;
+ for (j=0;j<Nx;j++)
+ Pnx[(n-1)*Nx+i] += Sx[i*Nx+j] * Pnx[(n-2)*Nx+j];
+ }
+
+ p0x[n-1] = 0.;
+ if (n==1)
+ p0x[0] = PHI( (( cx-(1.-lx)*hsx)/lx-mu)/sigma, 0.) -
+ PHI( ((-cx-(1.-lx)*hsx)/lx-mu)/sigma, 0.);
+ else
+ for (j=0;j<Nx;j++)
+ p0x[n-1] += wx[j]/lx * phi( ((zx[j]-(1.-lx)*hsx)/lx-mu)/sigma, 0.)/sigma * Pnx[(n-2)*Nx+j];
+
+
+ if (n==1)
+ for (i=0;i<Ns;i++) {
+ Pns[i] = 0.;
+ for (j=0;j<Ns;j++)
+ Pns[i] += 2./Ns * Tn( (2.*zch[j]-cs)/cs, i) * rside[j];
+ if (i==0) Pns[i] /= 2.;
+ }
+ else {
+ for (i=0;i<Ns;i++) {
+ rside[i] = 0.;
+ for (j=0;j<Ns;j++) rside[i] += S1s[i*Ns+j] * Pns[(n-2)*Ns+j];
+ }
+ LU_solve2(S2s,rside,ps,Ns);
+ for (i=0;i<Ns;i++) Pns[(n-1)*Ns+i] = rside[i];
+ }
+
+ p0s[n-1] = 0.;
+ if (n==1)
+ p0s[0] = nCHI(ddf/s2*(cs-(1.-ls)*hss)/ls, df, ncp);
+ else
+ for (j=0;j<Ns;j++)
+ p0s[n-1] += Pns[(n-1)*Ns+j] * Tn( (2.*hss-cs)/cs, j);
+
+ p0[n-1] = p0x[n-1] * p0s[n-1];
+
+ mn_minusx = 1.; mn_plusx = 0.;
+ mn_minuss = 1.; mn_pluss = 0.;
+ if (n>1) {
+ for (i=0;i<Nx;i++) {
+ if (Pnx[(n-1)*Nx+i]==0)
+ if (Pnx[(n-1)*Nx+i]==0) q = 0.;
+ else q = 1.;
+ else q = Pnx[(n-1)*Nx+i]/Pnx[(n-2)*Nx+i];
+ if ( q<mn_minusx ) mn_minusx = q;
+ if ( q>mn_plusx ) mn_plusx = q;
+ }
+
+ for (i=0;i<Ns;i++) {
+ oben = 0.; unten = 0.;
+ for (j=0;j<Ns;j++) {
+ oben += Pns[(n-1)*Ns+j] * Tn( (2.*zch[i]-cs)/cs, j);
+ unten+= Pns[(n-2)*Ns+j] * Tn( (2.*zch[i]-cs)/cs, j);
+ }
+ if (fabs(unten)<1e-16)
+ if (fabs(oben)<1e-16) q = 0.;
+ else q = 1.;
+ else q = oben/unten;
+ if ( q<mn_minuss ) mn_minuss = q;
+ if ( q>mn_pluss ) mn_pluss = q;
+ }
+
+ mn_minus = mn_minusx * mn_minuss;
+ mn_plus = mn_plusx * mn_pluss;
+
+ arl_minus = arl + p0[n-1]/(1.-mn_minus);
+ arl_plus = arl + p0[n-1]/(1.-mn_plus);
+ }
+ arl += p0[n-1];
+
+ if ( fabs( (arl_plus-arl_minus)/arl_minus )<FINALeps ) n = nmax+1;
+ }
+
+ Free(p0);
+
+ Free(p0s);
+ Free(Pns);
+ Free(zs);
+ Free(ws);
+ Free(rside);
+ Free(zch);
+ Free(ps);
+ Free(S2s);
+ Free(S1s);
+
+ Free(p0x);
+ Free(Pnx);
+ Free(zx);
+ Free(wx);
+ Free(Sx);
+
+ return (arl_plus+arl_minus)/2.;
+}
+
+
+double xseU_mu_before_sigma_RES
+ (double lx, double ls, double cx, double cs, double hsx, double hss, double mu, double sigma, int df, int Nx, int Ns, int nmax, int qm, double alpha, int vice_versa)
+{ double *Sx, *Pnx, *wx, *zx, *p0x,
+ *S1s, *S2s, *Pns, *ws, *zs, *p0s, *zch, *rside,
+ za=0., s2, mu_before_sigma=0., ddf, xl, xu, ncp;
+ int i, j, k, n, *ps;
+
+ cx *= sqrt( lx/(2.-lx) );
+ hsx *= sqrt( lx/(2.-lx) );
+
+ s2 = sigma*sigma;
+ ddf = (double)df;
+
+ /* residual preliminaries */
+ ncp = ddf/(ddf+1.)/(ddf+1.)*mu*mu/s2*pow( 1.-sqrt((1.-alpha)/(1.+alpha)), 2.);
+ mu *= ( 1. + ddf*sqrt( (1.-alpha)/(1.+alpha) ) )/(ddf+1.);
+
+ Sx = matrix(Nx,Nx);
+ wx = vector(Nx);
+ zx = vector(Nx);
+ Pnx = matrix(nmax,Nx);
+ p0x = vector(nmax);
+
+ S1s = matrix(Ns,Ns);
+ S2s = matrix(Ns,Ns);
+ ps = ivector(Ns);
+ zch = vector(Ns);
+ rside = vector(Ns);
+ ws = vector(qm);
+ zs = vector(qm);
+ Pns = matrix(nmax,Ns);
+ p0s = vector(nmax);
+
+ gausslegendre(Nx,-cx,cx,zx,wx);
+
+ for (i=0;i<Nx;i++) {
+ za = (1.-lx)*zx[i];
+ for (j=0;j<Nx;j++)
+ Sx[i*Nx+j] = wx[j]/lx*phi( ((zx[j]-za)/lx-mu)/sigma, 0.)/sigma;
+ }
+
+/* Chebyshev nodes on [0,cs] */
+ for (i=0;i<Ns;i++)
+ zch[i] = cs/2.*(1.+cos(PI*(2.*(i+1.)-1.)/2./(double)Ns) );
+
+/* P(L>1)(zch[i]) */
+ for (i=0;i<Ns;i++)
+ rside[i] = nCHI( ddf/s2*(cs-(1.-ls)*zch[i])/ls, df, ncp);
+
+ for (i=0;i<Ns;i++) {
+ za = (1.-ls)*zch[i];
+ xl = 0.; xu = sqrt(cs-za);
+ gausslegendre(qm,xl,xu,zs,ws);
+ for (j=0;j<Ns;j++) {
+ S1s[i*Ns+j] = 0.;
+ for (k=0;k<qm;k++)
+ S1s[i*Ns+j] += ws[k]*Tn((2.*(zs[k]*zs[k]+za)-cs)/cs, j)
+ * 2.*zs[k]/ls * ddf/s2 * nchi( ddf/s2 * zs[k]*zs[k]/ls, df, ncp);
+ }
+ }
+
+ for (i=0;i<Ns;i++)
+ for (j=0;j<Ns;j++) S2s[i*Ns+j] = Tn( (2.*zch[i]-cs)/cs, j);
+
+ LU_decompose(S2s,ps,Ns);
+
+ mu_before_sigma = 0.;
+ for (n=1;n<=nmax;n++) {
+
+ if (n==1)
+ for (i=0;i<Nx;i++)
+ Pnx[i] = PHI( (( cx-(1.-lx)*zx[i])/lx-mu)/sigma, 0.) -
+ PHI( ((-cx-(1.-lx)*zx[i])/lx-mu)/sigma, 0.);
+ else
+ for (i=0;i<Nx;i++) {
+ Pnx[(n-1)*Nx+i] = 0.;
+ for (j=0;j<Nx;j++)
+ Pnx[(n-1)*Nx+i] += Sx[i*Nx+j] * Pnx[(n-2)*Nx+j];
+ }
+
+ p0x[n-1] = 0.;
+ if (n==1)
+ p0x[0] = PHI( (( cx-(1.-lx)*hsx)/lx-mu)/sigma, 0.) -
+ PHI( ((-cx-(1.-lx)*hsx)/lx-mu)/sigma, 0.);
+ else
+ for (j=0;j<Nx;j++)
+ p0x[n-1] += wx[j]/lx * phi( ((zx[j]-(1.-lx)*hsx)/lx-mu)/sigma, 0.)/sigma * Pnx[(n-2)*Nx+j];
+
+
+ if (n==1)
+ for (i=0;i<Ns;i++) {
+ Pns[i] = 0.;
+ for (j=0;j<Ns;j++)
+ Pns[i] += 2./Ns * Tn( (2.*zch[j]-cs)/cs, i) * rside[j];
+ if (i==0) Pns[i] /= 2.;
+ }
+ else {
+ for (i=0;i<Ns;i++) {
+ rside[i] = 0.;
+ for (j=0;j<Ns;j++) rside[i] += S1s[i*Ns+j] * Pns[(n-2)*Ns+j];
+ }
+ LU_solve2(S2s,rside,ps,Ns);
+ for (i=0;i<Ns;i++) Pns[(n-1)*Ns+i] = rside[i];
+ }
+
+ p0s[n-1] = 0.;
+ if (n==1)
+ p0s[0] = nCHI(ddf/s2*(cs-(1.-ls)*hss)/ls, df, ncp);
+ else
+ for (j=0;j<Ns;j++)
+ p0s[n-1] += Pns[(n-1)*Ns+j] * Tn( (2.*hss-cs)/cs, j);
+
+ if ( vice_versa ) { /* S chart before X chart -- PMS IV */
+ if (n>1)
+ mu_before_sigma += ( p0s[n-2] - p0s[n-1] ) * p0x[n-1];
+ else
+ mu_before_sigma = ( 1. - p0s[n-1] ) * p0x[n-1];
+ if ( p0s[n-1]<FINALeps ) n = nmax+1;
+ } else { /* X chart before S chart -- PMS III */
+ if (n>1)
+ mu_before_sigma += ( p0x[n-2]-p0x[n-1] ) * p0s[n-1];
+ else
+ mu_before_sigma = ( 1.-p0x[n-1] ) * p0s[n-1];
+ if ( p0x[n-1]<FINALeps ) n = nmax+1;
+ }
+ }
+
+ Free(p0s);
+ Free(Pns);
+ Free(zs);
+ Free(ws);
+ Free(rside);
+ Free(zch);
+ Free(ps);
+ Free(S2s);
+ Free(S1s);
+
+ Free(p0x);
+ Free(Pnx);
+ Free(zx);
+ Free(wx);
+ Free(Sx);
+
+ return mu_before_sigma;
+}
+
+
+/* end of Manuel's stuff */
+
+
+/* For Christian */
+
+/* Shewhart charts for dependent data */
+double x_shewhart_ar1_arl(double alpha, double cS, double delta, int N1, int N2)
+{ double *a, *g, *w1, *z1, *w2, *z2, arl, arl1, mdelta, l, korr;
+ int i, j;
+
+ a = matrix(N1,N1);
+ g = vector(N1);
+ w1 = vector(N1);
+ z1 = vector(N1);
+ w2 = vector(N2);
+ z2 = vector(N2);
+
+ l = 1. - alpha;
+ korr = sqrt( (1. - alpha) / (1. + alpha) );
+ mdelta = korr * delta;
+ gausslegendre(N1, -cS*korr, cS*korr, z1, w1);
+
+ for (i=0; i<N1; i++) {
+ for (j=0; j<N1; j++) a[i*N1+j] = -w1[j]/l * phi( ( z1[j] - (1.-l)*z1[i] )/l, mdelta);
+ ++a[i*N1 + i];
+ }
+
+ for (j=0; j<N1; j++) g[j] = 1.;
+ LU_solve(a, g, N1);
+
+ gausslegendre(N2, -cS, cS, z2, w2);
+
+ arl = 1.;
+ for (i=0; i<N2; i++) {
+ arl1 = 1.;
+ for (j=0; j<N1; j++) arl1 += w1[j]/l * phi( ( z1[j] - (1.-l)*z2[i]*korr )/l, mdelta) * g[j];
+ arl += w2[i] * phi(z2[i], delta) * arl1;
+ }
+
+ Free(a);
+ Free(g);
+ Free(w1);
+ Free(z1);
+ Free(w2);
+ Free(z2);
+
+ return arl;
+}
+
+
+/* end of Christian's stuff */
+
+
+double xc1_iglad (double k, double h, double mu0, double mu1, int N)
+{ double *a, *w, *z, *arl, *psi, rho, ad, norm;
+ int i, j, status, noofit, NN;
+
+ NN = N + 1;
+ a = matrix(NN,NN);
+ arl = vector(NN);
+ psi = vector(NN);
+ w = vector(NN);
+ z = vector(NN);
+
+ gausslegendre(N,0.,h,z,w);
+
+ for (i=0;i<N;i++) {
+ for (j=0;j<N;j++) a[i*NN+j] = -w[j]*phi(z[j]+k-z[i],mu1);
+ ++a[i*NN+i];
+ a[i*NN+N] = - PHI(k-z[i],mu1);
+ }
+ for (j=0;j<N;j++)
+ a[N*NN+j] = -w[j]*phi( z[j]+k,mu1);
+ a[N*NN+N] = 1. - PHI(k,mu1);
+
+ for (j=0;j<NN;j++) arl[j] = 1.;
+ LU_solve(a,arl,NN);
+
+ for (i=0;i<N;i++) {
+ for (j=0;j<N;j++) a[i*NN+j] = w[j]*phi(z[i]+k-z[j],mu0);
+ a[i*NN+N] = phi(z[i]+k,mu0);
+ }
+ for (j=0;j<N;j++)
+ a[N*NN+j] = w[j] * PHI(k-z[j],mu0);
+ a[N*NN+N] = PHI(k,mu0);
+
+ pmethod(NN,a,&status,&rho,psi,&noofit);
+
+ ad = psi[N]*arl[N];
+ norm = psi[N];
+ for (j=0;j<N;j++) {
+ ad += w[j] * arl[j] * psi[j];
+ norm += w[j] * psi[j];
+ }
+ ad /= norm;
+ rho0 = rho;
+
+ Free(a);
+ Free(arl);
+ Free(psi);
+ Free(w);
+ Free(z);
+
+ return ad;
+}
+
+
+double xcC_iglad (double k, double h, double mu0, double mu1, int N)
+{ double *a, *w, *z, *arl, *psi, rho, ad, norm;
+ int i, j, status, noofit, NN;
+
+ NN = 2*N + 1;
+ a = matrix(NN,NN);
+ arl = vector(NN);
+ psi = vector(NN);
+ w = vector(NN);
+ z = vector(NN);
+
+ gausslegendre(N,0.,h,z,w);
+
+ for (i=0;i<N;i++) { /* upper */
+ for (j=0;j<N;j++) a[i*NN+j] = -w[j] *phi( z[j] +k-z[i],mu1);
+ for (j=N;j<NN-1;j++) a[i*NN+j] = -w[j-N]*phi(-z[j-N]-k-z[i],mu1);
+ ++a[i*NN+i];
+ a[i*NN+NN-1] = - ( PHI(k-z[i],mu1) - PHI(-k-z[i],mu1) );
+ }
+
+ for (i=N;i<NN-1;i++) { /* lower */
+ for (j=0;j<N;j++) a[i*NN+j] = -w[j] *phi( z[j] +k+z[i-N],mu1);
+ for (j=N;j<NN-1;j++) a[i*NN+j] = -w[j-N]*phi(-z[j-N]-k+z[i-N],mu1);
+ ++a[i*NN+i];
+ a[i*NN+NN-1] = - ( PHI(k+z[i-N],mu1) - PHI(-k+z[i-N],mu1) );
+ }
+
+ /* "fat" zero */
+ for (j=0;j<N;j++)
+ a[(NN-1)*NN+j] = -w[j] * phi( z[j] +k,mu1);
+ for (j=N;j<NN-1;j++)
+ a[(NN-1)*NN+j] = -w[j-N]*phi(-z[j-N]-k,mu1);
+ a[(NN-1)*NN+NN-1] = 1. - ( PHI(k,mu1) - PHI(-k,mu1) );
+
+ for (j=0;j<NN;j++) arl[j] = 1.;
+ LU_solve(a,arl,NN);
+
+ for (i=0;i<N;i++) { /* upper */
+ for (j=0;j<N;j++) a[i*NN+j] = w[j] *phi( z[i]+k-z[j] ,mu0);
+ for (j=N;j<NN-1;j++) a[i*NN+j] = w[j-N]*phi( z[i]+k+z[j-N],mu0);
+ a[i*NN+NN-1] = phi(z[i]+k,mu0);
+ }
+
+ for (i=N;i<NN-1;i++) { /* lower */
+ for (j=0;j<N;j++) a[i*NN+j] = w[j] *phi( -z[i-N]-k-z[j] ,mu0);
+ for (j=N;j<NN-1;j++) a[i*NN+j] = w[j-N]*phi( -z[i-N]-k+z[j-N],mu0);
+ a[i*NN+NN-1] = phi(-z[i-N]-k,mu0);
+ }
+
+ /* "fat" zero */
+ for (j=0;j<N;j++)
+ a[(NN-1)*NN+j] = w[j] * ( PHI(k-z[j] ,mu0) - PHI(-k-z[j] ,mu0) );
+ for (j=N;j<NN-1;j++)
+ a[(NN-1)*NN+j] = w[j-N]* ( PHI(k+z[j-N],mu0) - PHI(-k+z[j-N],mu0) );
+ a[(NN-1)*NN+NN-1] = PHI(k,mu0) - PHI(-k,mu0);
+
+ pmethod(NN,a,&status,&rho,psi,&noofit);
+
+ ad = psi[NN-1]*arl[NN-1];
+ norm = psi[NN-1];
+ for (j=0;j<N;j++) {
+ ad += w[j] * arl[j] * psi[j];
+ norm += w[j] * psi[j];
+ }
+ for (j=N;j<NN-1;j++) {
+ ad += w[j-N] * arl[j] * psi[j];
+ norm += w[j-N] * psi[j];
+ }
+ ad /= norm;
+ rho0 = rho;
+
+ Free(a);
+ Free(arl);
+ Free(psi);
+ Free(w);
+ Free(z);
+
+ return ad;
+}
+
+
+double xe1_iglad (double l, double c, double zr, double mu0, double mu1, int N)
+{ double *a, *w, *z, *arl, *psi, rho, ad, norm;
+ int i, j, status, noofit, NN;
+
+ NN = N + 1;
+ a = matrix(NN,NN);
+ arl = vector(NN);
+ psi = vector(NN);
+ w = vector(NN);
+ z = vector(NN);
+
+ c *= sqrt( l/(2.-l) );
+ zr *= sqrt( l/(2.-l) );
+
+ gausslegendre(N,zr,c,z,w);
+
+ for (i=0;i<N;i++) {
+ for (j=0;j<N;j++) a[i*NN+j] = -w[j]/l * phi( (z[j]-(1.-l)*z[i])/l,mu1);
+ ++a[i*NN+i];
+ a[i*NN+N] = - PHI((zr-(1.-l)*z[i])/l,mu1);
+ }
+ for (j=0;j<N;j++)
+ a[N*NN+j] = -w[j]/l * phi( (z[j]-(1.-l)*zr)/l,mu1);
+ a[N*NN+N] = 1. - PHI(zr,mu1);
+
+ for (j=0;j<NN;j++) arl[j] = 1.;
+ LU_solve(a,arl,NN);
+
+ for (i=0;i<N;i++) {
+ for (j=0;j<N;j++) a[i*NN+j] = w[j]/l * phi((z[i]-(1.-l)*z[j])/l,mu0);
+ a[i*NN+N] = 1./l * phi((z[i]-(1.-l)*zr)/l,mu0);
+ }
+ for (j=0;j<N;j++)
+ a[N*NN+j] = w[j] * PHI((zr-(1.-l)*z[j])/l,mu0);
+ a[N*NN+N] = PHI(zr,mu0);
+
+ pmethod(NN,a,&status,&rho,psi,&noofit);
+
+ ad = psi[N]*arl[N];
+ norm = psi[N];
+ for (j=0;j<N;j++) {
+ ad += w[j] * arl[j] * psi[j];
+ norm += w[j] * psi[j];
+ }
+ ad /= norm;
+ rho0 = rho;
+
+ Free(a);
+ Free(arl);
+ Free(psi);
+ Free(w);
+ Free(z);
+
+ return ad;
+}
+
+
+double xe2_iglad (double l, double c, double mu0, double mu1, int N)
+{ double *a, *w, *z, *arl, *psi, rho, ad, norm;
+ int i, j, status, noofit;
+
+ a = matrix(N,N);
+ arl = vector(N);
+ psi = vector(N);
+ w = vector(N);
+ z = vector(N);
+
+ c *= sqrt( l/(2.-l) );
+
+ gausslegendre(N,-c,c,z,w);
+
+ for (i=0;i<N;i++) {
+ for (j=0;j<N;j++) a[i*N+j] = -w[j]/l * phi((z[j]-(1.-l)*z[i])/l,mu1);
+ ++a[i*N+i];
+ }
+
+ for (j=0;j<N;j++) arl[j] = 1.;
+ LU_solve(a,arl,N);
+
+ for (i=0;i<N;i++)
+ for (j=0;j<N;j++) a[i*N+j] = w[j]/l * phi((z[i]-(1.-l)*z[j])/l,mu0);
+
+ pmethod(N,a,&status,&rho,psi,&noofit);
+
+ ad = 0.; norm = 0.;
+ for (j=0;j<N;j++) {
+ ad += w[j] * arl[j] * psi[j];
+ norm += w[j] * psi[j];
+ }
+ ad /= norm;
+ rho0 = rho;
+
+ Free(a);
+ Free(arl);
+ Free(psi);
+ Free(w);
+ Free(z);
+
+ return ad;
+}
+
+
+double xte2_iglad (double l, double c, int df, double mu0, double mu1, int N, int subst)
+{ double *a, *w, *z, *arl, *psi, rho, ad, nenner, norm=1., arg=0., korr=1.;
+ int i, j, status, noofit;
+
+ a = matrix(N,N);
+ arl = vector(N);
+ psi = vector(N);
+ w = vector(N);
+ z = vector(N);
+
+ c *= sqrt( l/(2.-l) );
+
+ switch ( subst ) {
+ case IDENTITY: gausslegendre(N, -c, c, z, w); norm = 1.; break;
+ case SIN: gausslegendre(N, -PI/2., PI/2., z, w); norm = 1.; break;
+ case SINH: gausslegendre(N, -1., 1., z, w); norm = sinh(1.); break;
+ case TAN: gausslegendre(N, -PI/4., PI/4., z, w); norm = 1.; break;
+ }
+
+ c /= norm;
+
+ for (i=0; i<N; i++) {
+ for (j=0; j<N; j++) {
+ switch ( subst ) {
+ case IDENTITY: arg = z[j] - (1.-l)*z[i]; korr = 1.; break;
+ case SIN: arg = c*sin(z[j]) - (1.-l)*c*sin(z[i]); korr = c*cos(z[j]); break;
+ case SINH: arg = c*sinh(z[j]) - (1.-l)*c*sinh(z[i]); korr = c*cosh(z[j]); break;
+ case TAN: arg = c*tan(z[j]) - (1.-l)*c*tan(z[i]); korr = c/( cos(z[j])*cos(z[j]) ); break;
+ }
+ a[i*N+j] = -w[j]/l * pdf_t( arg/l - mu1, df) * korr;
+ }
+ ++a[i*N+i];
+ }
+
+ for (j=0;j<N;j++) arl[j] = 1.;
+ LU_solve(a, arl, N);
+
+ for (i=0; i<N; i++)
+ for (j=0; j<N; j++) {
+ switch ( subst ) {
+ case IDENTITY: arg = z[i] - (1.-l)*z[j]; korr = 1.; break;
+ case SIN: arg = c*sin(z[i]) - (1.-l)*c*sin(z[j]); korr = c*cos(z[j]); break;
+ case SINH: arg = c*sinh(z[i]) - (1.-l)*c*sinh(z[j]); korr = c*cosh(z[j]); break;
+ case TAN: arg = c*tan(z[i]) - (1.-l)*c*tan(z[j]); korr = c/( cos(z[j])*cos(z[j]) ); break;
+ }
+ a[i*N+j] = w[j]/l * pdf_t( arg/l - mu0, df) * korr;
+ }
+
+ pmethod(N, a, &status, &rho, psi, &noofit);
+
+ ad = 0.; nenner = 0.;
+ for (j=0; j<N; j++) {
+ switch ( subst ) {
+ case IDENTITY: korr = 1.; break;
+ case SIN: korr = c*cos(z[j]); break;
+ case SINH: korr = c*cosh(z[j]); break;
+ case TAN: korr = c/( cos(z[j])*cos(z[j]) ); break;
+ }
+ ad += w[j] * arl[j] * psi[j] * korr;
+ nenner += w[j] * psi[j] * korr;
+ }
+ ad /= nenner;
+ rho0 = rho;
+
+ Free(a);
+ Free(arl);
+ Free(psi);
+ Free(w);
+ Free(z);
+
+ return ad;
+}
+
+
+double xe2_igladc(double l, double c, double mu0, double mu1, double z0, int N)
+{ double *a, *w, *z, *arl, *psi, rho, ad, norm, L0;
+ int i, j, status, noofit, NN;
+
+ NN = N + 1;
+ a = matrix(NN,NN);
+ arl = vector(N);
+ psi = vector(NN);
+ w = vector(N);
+ z = vector(N);
+
+ c *= sqrt( l/(2.-l) );
+ z0 *= sqrt( l/(2.-l) );
+
+ gausslegendre(N, -c, c, z, w);
+
+ /* ooc vector */
+ for (i=0; i<N; i++) {
+ for (j=0; j<N; j++) a[i*N+j] = -w[j]/l * phi((z[j]-(1.-l)*z[i])/l, mu1);
+ ++a[i*N+i];
+ }
+
+ for (j=0; j<N; j++) arl[j] = 1.;
+ LU_solve(a, arl, N);
+
+ /* ooc ARL at restart point */
+ L0 = 1.;
+ for (j=0; j<N; j++) L0 += w[j]/l * phi( (z[j]-(1.-l)*z0)/l, mu1) * arl[j];
+
+
+ /* left eigenvector psi */
+ for (i=0; i<N; i++) {
+ for (j=0; j<N; j++) a[i*NN+j] = w[j]/l * phi( (z[i]-(1.-l)*z[j])/l, mu0);
+ a[i*NN+N] = 1./l * phi( (z[i]-(1.-l)*z0)/l, mu0);
+ }
+ for (j=0;j<N;j++) a[N*NN+j] = w[j] * ( 1 - PHI( (c-(1.-l)*z[j])/l, mu0) + PHI( (-c-(1.-l)*z[j])/l, mu0) );
+ a[N*NN+N] = 1 - PHI( (c-(1.-l)*z0)/l, mu0) + PHI( (-c-(1.-l)*z0)/l, mu0);
+
+ pmethod(NN, a, &status, &rho, psi, &noofit);
+
+ ad = L0 * psi[N];
+ norm = psi[N];
+ for (j=0; j<N; j++) {
+ ad += w[j] * arl[j] * psi[j];
+ norm += w[j] * psi[j];
+ }
+ ad /= norm;
+ rho0 = rho;
+
+ Free(a);
+ Free(arl);
+ Free(psi);
+ Free(w);
+ Free(z);
+
+ return ad;
+}
+
+
+double xte2_igladc(double l, double c, int df, double mu0, double mu1, double z0, int N, int subst)
+{ double *a, *w, *z, *arl, *psi, rho, ad, nenner, L0, norm=1., arg=0., korr=1.;
+ int i, j, status, noofit, NN;
+
+ NN = N + 1;
+ a = matrix(NN,NN);
+ arl = vector(N);
+ psi = vector(NN);
+ w = vector(N);
+ z = vector(N);
+
+ c *= sqrt( l/(2.-l) );
+ z0 *= sqrt( l/(2.-l) );
+
+ switch ( subst ) {
+ case IDENTITY: gausslegendre(N, -c, c, z, w); norm = 1.; break;
+ case SIN: gausslegendre(N, -PI/2., PI/2., z, w); norm = 1.; break;
+ case SINH: gausslegendre(N, -1., 1., z, w); norm = sinh(1.); break;
+ case TAN: gausslegendre(N, -PI/4., PI/4., z, w); norm = 1.; break;
+ }
+
+ c /= norm;
+
+ /* ooc vector */
+ for (i=0; i<N; i++) {
+ for (j=0; j<N; j++) {
+ switch ( subst ) {
+ case IDENTITY: arg = z[j] - (1.-l)*z[i]; korr = 1.; break;
+ case SIN: arg = c*sin(z[j]) - (1.-l)*c*sin(z[i]); korr = c*cos(z[j]); break;
+ case SINH: arg = c*sinh(z[j]) - (1.-l)*c*sinh(z[i]); korr = c*cosh(z[j]); break;
+ case TAN: arg = c*tan(z[j]) - (1.-l)*c*tan(z[i]); korr = c/( cos(z[j])*cos(z[j]) ); break;
+ }
+ a[i*N+j] = -w[j]/l * pdf_t( arg/l - mu1, df) * korr;
+ }
+ ++a[i*N+i];
+ }
+
+ for (j=0; j<N; j++) arl[j] = 1.;
+ LU_solve(a, arl, N);
+
+
+ /* ooc ARL at restart point */
+ L0 = 1.;
+ for (j=0; j<N; j++) {
+ switch ( subst ) {
+ case IDENTITY: arg = z[j]; korr = 1.; break;
+ case SIN: arg = c*sin(z[j]); korr = c*cos(z[j]); break;
+ case SINH: arg = c*sinh(z[j]); korr = c*cosh(z[j]); break;
+ case TAN: arg = c*tan(z[j]); korr = c/( cos(z[j])*cos(z[j]) ); break;
+ }
+ L0 += w[j]/l * pdf_t( ( arg - (1.-l)*z0 )/l - mu1, df) * korr * arl[j];
+ }
+
+ /* left eigenvector psi */
+ for (i=0; i<N; i++) {
+ for (j=0; j<N; j++) {
+ switch ( subst ) {
+ case IDENTITY: arg = z[i] - (1.-l)*z[j]; korr = 1.; break;
+ case SIN: arg = c*sin(z[i]) - (1.-l)*c*sin(z[j]); korr = c*cos(z[j]); break;
+ case SINH: arg = c*sinh(z[i]) - (1.-l)*c*sinh(z[j]); korr = c*cosh(z[j]); break;
+ case TAN: arg = c*tan(z[i]) - (1.-l)*c*tan(z[j]); korr = c/( cos(z[j])*cos(z[j]) ); break;
+ }
+ a[i*NN+j] = w[j]/l * pdf_t( arg/l - mu0, df) * korr;
+ }
+ switch ( subst ) {
+ case IDENTITY: arg = z[i]; break;
+ case SIN: arg = c*sin(z[i]); break;
+ case SINH: arg = c*sinh(z[i]); break;
+ case TAN: arg = c*tan(z[i]); break;
+ }
+ a[i*NN+N] = 1./l * pdf_t( ( arg - (1.-l)*z0 )/l - mu0, df);
+ }
+ for (j=0;j<N;j++) {
+ switch ( subst ) {
+ case IDENTITY: arg = z[j]; korr = 1.; break;
+ case SIN: arg = c*sin(z[j]); korr = c*cos(z[j]); break;
+ case SINH: arg = c*sinh(z[j]); korr = c*cosh(z[j]); break;
+ case TAN: arg = c*tan(z[j]); korr = c/( cos(z[j])*cos(z[j]) ); break;
+ }
+ a[N*NN+j] = w[j] * ( 1. - cdf_t( ( c*norm - (1.-l)*arg )/l - mu0, df) + cdf_t( ( -c*norm - (1.-l)*arg )/l - mu0, df) ) * korr;
+ }
+ a[N*NN+N] = 1. - cdf_t( ( c*norm - (1.-l)*z0 )/l - mu0, df) + cdf_t( ( -c*norm - (1.-l)*z0 )/l - mu0, df);
+
+ pmethod(NN, a, &status, &rho, psi, &noofit);
+
+ ad = L0 * psi[N];
+ nenner = psi[N];
+ for (j=0; j<N; j++) {
+ switch ( subst ) {
+ case IDENTITY: korr = 1.; break;
+ case SIN: korr = c*cos(z[j]); break;
+ case SINH: korr = c*cosh(z[j]); break;
+ case TAN: korr = c/( cos(z[j])*cos(z[j]) ); break;
+ }
+ ad += w[j] * arl[j] * psi[j] * korr;
+ nenner += w[j] * psi[j] * korr;
+ }
+ ad /= nenner;
+ rho0 = rho;
+
+ Free(a);
+ Free(arl);
+ Free(psi);
+ Free(w);
+ Free(z);
+
+ return ad;
+}
+
+
+double xe1_sf(double l, double c, double zr, double hs, double mu, int N, int nmax, double *p0)
+{ double *Pn, *w, *z, *atom;
+ int i, j, n;
+
+ c *= sqrt( l/(2.-l) );
+ hs *= sqrt( l/(2.-l) );
+ zr *= sqrt( l/(2.-l) );
+
+ w = vector(N);
+ z = vector(N);
+ Pn = matrix(nmax,N);
+ atom = vector(nmax);
+
+ gausslegendre(N,zr,c,z,w);
+
+ for (n=1;n<=nmax;n++) {
+ if (n==1) {
+ for (i=0;i<N;i++)
+ Pn[i] = PHI( (c-(1.-l)*z[i])/l, mu);
+ atom[0] = PHI( (c-(1.-l)*zr)/l, mu);
+ } else {
+ for (i=0;i<N;i++) {
+ Pn[(n-1)*N+i] = PHI( (zr-(1.-l)*z[i])/l, mu) * atom[n-2];
+ for (j=0;j<N;j++) Pn[(n-1)*N+i] += w[j]/l * phi( (z[j]-(1.-l)*z[i])/l, mu) * Pn[(n-2)*N+j];
+ }
+ atom[n-1] = PHI( zr, mu) * atom[n-2];
+ for (j=0;j<N;j++) atom[n-1] += w[j]/l * phi( (z[j]-(1.-l)*zr)/l, mu) * Pn[(n-2)*N+j];
+ }
+
+ if (n==1)
+ p0[0] = PHI( (c-(1.-l)*hs)/l, mu);
+ else {
+ p0[n-1] = PHI( (zr-(1.-l)*hs)/l, mu) * atom[n-2];
+ for (j=0;j<N;j++) p0[n-1] += w[j]/l * phi( (z[j]-(1.-l)*hs)/l, mu) * Pn[(n-2)*N+j];
+ }
+ }
+
+ Free(Pn);
+ Free(z);
+ Free(w);
+ Free(atom);
+
+ return 0;
+}
+
+
+double xe1_sfm(double l, double c, double zr, double hs, int q, double mu0, double mu1, int mode, int N, int nmax, double *p0)
+{ double *Smatrix, *fn, *w, *z, rn, cn, rn0, cn0, nn;
+ int i, j, n, NN;
+
+ c *= sqrt( l/(2.-l) );
+ zr *= sqrt( l/(2.-l) );
+ hs *= sqrt( l/(2.-l) );
+
+ NN = N + 1;
+ Smatrix = matrix(NN, NN);
+ w = vector(NN);
+ z = vector(NN);
+ fn = matrix(nmax, NN);
+
+ gausslegendre(N, zr, c, z, w);
+
+ rn = 1.; cn = 0.; rn0 = 1., cn0 = 0.;
+
+ /* in-control, i. e. n<=q-1 */
+ for (n=1;n<=q-1;n++) {
+ nn = (double) n;
+
+ /* determine r_n, n=1,2,...,q-1 */
+ if ( mode==vacl ) {
+ rn = sqrt( 1. - pow(1.-l, 2.*nn) );
+ }
+
+ /* determine f_n, n=1,2,...,q-1 */
+ if (n==1) {
+ for (i=0;i<N;i++) {
+ if (mode==stat) {
+ fn[0*NN+i] = 1./sqrt(l/(2.-l))*phi( (cn+rn*z[i])/sqrt(l/(2.-l)), mu0);
+ } else {
+ fn[0*NN+i] = rn/l * phi( (cn+rn*z[i]-(1.-l)*hs)/l, mu0);
+ }
+ }
+ if (mode==stat) {
+ fn[0*NN+N] = PHI( (cn+rn*zr)/sqrt(l/(2.-l)), mu0);
+ } else {
+ fn[0*NN+N] = PHI( (cn+rn*zr-(1.-l)*hs)/l, mu0);
+ }
+ } else {
+ for (i=0;i<N;i++) {
+ fn[(n-1)*NN+i] = fn[(n-2)*NN+N] * rn/l * phi((cn+rn*z[i]-(1.-l)*(cn0+rn0*zr))/l, mu0);
+ for (j=0;j<N;j++) {
+ fn[(n-1)*NN+i] += w[j]*fn[(n-2)*NN+j] * rn/l
+ *phi((cn+rn*z[i]-(1.-l)*(cn0+rn0*z[j]))/l, mu0);
+ }
+ }
+ fn[(n-1)*NN+N] = fn[(n-2)*NN+N] * PHI( (cn+rn*zr-(1.-l)*(cn0+rn0*zr))/l, mu0);
+ for (j=0;j<N;j++)
+ fn[(n-1)*NN+N] += w[j] * fn[(n-2)*NN+j] * PHI( (cn+rn*zr-(1.-l)*(cn0+rn0*z[j]))/l, mu0);
+ }
+
+ /* determine P(L>n), n=1,2,...,q-1 */
+ p0[n-1] = fn[(n-1)*NN+N];
+ for (i=0;i<N;i++) p0[n-1] += w[i] * fn[(n-1)*NN+i];
+
+ /* weights and nodes w.r.t. O_n become w. a. n. w.r.t. O_n-1 */
+ cn0 = cn; rn0 = rn;
+ }
+
+ /* out-of-control, i.e. t>=q */
+
+ for (n=q;n<=nmax;n++) {
+ nn = (double) n;
+
+ /* determine r_n, n=1,2,...,q-1 */
+ if ( mode==vacl ) {
+ rn = sqrt( 1. - pow(1.-l, 2.*nn) );
+ }
+
+ /* determine f_n, n=q,q+1,... */
+ if ( n==1 ) {
+ for (i=0;i<N;i++) {
+ if (mode==stat) {
+ fn[0*NN+i] = 1./sqrt(l/(2.-l))*phi( (cn+rn*z[i])/sqrt(l/(2.-l)), mu1);
+ } else {
+ fn[0*NN+i] = rn/l * phi( (cn+rn*z[i]-(1.-l)*hs)/l, mu1);
+ }
+ }
+ if ( mode==stat ) {
+ fn[0*NN+N] = PHI( (cn+rn*zr)/sqrt(l/(2.-l)), mu1);
+ } else {
+ fn[0*NN+N] = PHI( (cn+rn*zr-(1.-l)*hs)/l, mu1);
+ }
+ } else {
+ for (i=0;i<N;i++) {
+ fn[(n-1)*NN+i] = fn[(n-2)*NN+N] * rn/l * phi((cn+rn*z[i]-(1.-l)*(cn0+rn0*zr))/l, mu1);
+ for (j=0;j<N;j++) {
+ fn[(n-1)*NN+i] += w[j]*fn[(n-2)*NN+j] * rn/l * phi((cn+rn*z[i]-(1.-l)*(cn0+rn0*z[j]))/l, mu1);
+ }
+ if ( n==q && q>1 ) fn[(n-1)*NN+i] /= p0[q-2];
+ }
+ fn[(n-1)*NN+N] = fn[(n-2)*NN+N] * PHI( (cn+rn*zr-(1.-l)*(cn0+rn0*zr))/l, mu1);
+ for (j=0;j<N;j++)
+ fn[(n-1)*NN+N] += w[j] * fn[(n-2)*NN+j] * PHI( (cn+rn*zr-(1.-l)*(cn0+rn0*z[j]))/l, mu1);
+ if ( n==q && q>1 ) fn[(n-1)*NN+N] /= p0[q-2];
+ }
+
+ /* determine P(L>n), n=1,2,...,q-1 */
+ p0[n-1] = fn[(n-1)*NN+N];
+ for (i=0;i<N;i++) p0[n-1] += w[i] * fn[(n-1)*NN+i];
+
+ /* weights and nodes w.r.t. O_n become w. a. n. w.r.t. O_n-1 */
+ cn0 = cn; rn0 = rn;
+ }
+
+ Free(Smatrix);
+ Free(w);
+ Free(z);
+ Free(fn);
+
+ return 0;
+}
+
+
+double xe2_sf(double l, double c, double hs, double mu, int N, int nmax, double *p0)
+{ double *Sm, *Pn, *w, *z;
+ int i, j, n;
+
+ c *= sqrt( l/(2.-l) );
+ hs *= sqrt( l/(2.-l) );
+
+ Sm = matrix(N, N);
+ w = vector(N);
+ z = vector(N);
+ Pn = matrix(nmax, N);
+
+ gausslegendre(N, -c, c, z, w);
+
+ for (i=0; i<N; i++)
+ for (j=0; j<N; j++) Sm[i*N+j] = w[j]/l * phi( (z[j]-(1.-l)*z[i])/l, mu);
+
+ for (n=1; n<=nmax; n++) {
+ if ( n==1 )
+ for (i=0; i<N; i++) Pn[i] = PHI( (c-(1.-l)*z[i])/l, mu) - PHI( (-c-(1.-l)*z[i])/l, mu);
+ else
+ for (i=0; i<N; i++) {
+ Pn[(n-1)*N+i] = 0.;
+ for (j=0; j<N; j++) Pn[(n-1)*N+i] += Sm[i*N+j] * Pn[(n-2)*N+j];
+ }
+
+ if ( n==1 )
+ p0[0] = PHI( (c-(1.-l)*hs)/l, mu) - PHI( (-c-(1.-l)*hs)/l, mu);
+ else {
+ p0[n-1] = 0.;
+ for (j=0; j<N; j++) p0[n-1] += w[j]/l * phi( (z[j]-(1.-l)*hs)/l, mu) * Pn[(n-2)*N+j];
+ }
+ }
+
+ Free(Pn);
+ Free(z);
+ Free(w);
+ Free(Sm);
+
+ return 0;
+}
+
+
+double xte2_sf(double l, double c, double hs, int df, double mu, int N, int nmax, double *p0, int subst)
+{ double *Sm, *Pn, *w, *z, norm=1., arg=0., korr=1.;
+ int i, j, n;
+
+ c *= sqrt( l/(2.-l) );
+ hs *= sqrt( l/(2.-l) );
+
+ Sm = matrix(N, N);
+ w = vector(N);
+ z = vector(N);
+ Pn = matrix(nmax, N);
+
+ switch ( subst ) {
+ case IDENTITY: gausslegendre(N, -c, c, z, w); norm = 1.; break;
+ case SIN: gausslegendre(N, -PI/2., PI/2., z, w); norm = 1.; break;
+ case SINH: gausslegendre(N, -1., 1., z, w); norm = sinh(1.); break;
+ case TAN: gausslegendre(N, -PI/4., PI/4., z, w); norm = 1.; break;
+ }
+
+ c /= norm;
+
+ for (i=0; i<N; i++)
+ for (j=0; j<N; j++) {
+ switch ( subst ) {
+ case IDENTITY: arg = z[j] - (1.-l)*z[i]; korr = 1.; break;
+ case SIN: arg = c*sin(z[j]) - (1.-l)*c*sin(z[i]); korr = c*cos(z[j]); break;
+ case SINH: arg = c*sinh(z[j]) - (1.-l)*c*sinh(z[i]); korr = c*cosh(z[j]); break;
+ case TAN: arg = c*tan(z[j]) - (1.-l)*c*tan(z[i]); korr = c/( cos(z[j])*cos(z[j]) ); break;
+ }
+ Sm[i*N+j] = w[j]/l * pdf_t( arg/l - mu, df) * korr;
+ }
+
+ for (n=1; n<=nmax; n++) {
+ if ( n==1 )
+ for (i=0; i<N; i++) {
+ switch ( subst ) {
+ case IDENTITY: arg = z[i]; break;
+ case SIN: arg = c*sin(z[i]); break;
+ case SINH: arg = c*sinh(z[i]); break;
+ case TAN: arg = c*tan(z[i]); break;
+ }
+ Pn[i] = cdf_t( ( c*norm - (1.-l)*arg )/l - mu, df) - cdf_t( ( -c*norm - (1.-l)*arg )/l - mu, df);
+ }
+ else
+ for (i=0; i<N; i++) {
+ Pn[(n-1)*N+i] = 0.;
+ for (j=0; j<N; j++) Pn[(n-1)*N+i] += Sm[i*N+j] * Pn[(n-2)*N+j];
+ }
+
+ if ( n==1 )
+ p0[0] = cdf_t( ( c*norm - (1.-l)*hs )/l - mu, df) - cdf_t( ( -c*norm - (1.-l)*hs )/l - mu, df);
+ else {
+ p0[n-1] = 0.;
+ for (j=0; j<N; j++) {
+ switch ( subst ) {
+ case IDENTITY: arg = z[j]; korr = 1.; break;
+ case SIN: arg = c*sin(z[j]); korr = c*cos(z[j]); break;
+ case SINH: arg = c*sinh(z[j]); korr = c*cosh(z[j]); break;
+ case TAN: arg = c*tan(z[j]); korr = c/( cos(z[j])*cos(z[j]) ); break;
+ }
+ p0[n-1] += w[j]/l * pdf_t( ( arg - (1.-l)*hs )/l - mu, df) * Pn[(n-2)*N+j] * korr;
+ }
+ }
+ }
+
+ Free(Pn);
+ Free(z);
+ Free(w);
+ Free(Sm);
+
+ return 0;
+}
+
+
+double xe2_sfm(double l, double c, double hs, int q, double mu0, double mu1, int mode, int N, int nmax, double *p0)
+{ double *Smatrix, *fn, *w, *z, dn, rn, cn, rn0, cn0, delta=0., nn, fSt, aSt;
+ int i, j, n;
+
+ fSt = 0.5;
+ aSt = ( -2./log10(1.-fSt) - 1.)/19.;
+
+ c *= sqrt( l/(2.-l) );
+ hs *= sqrt( l/(2.-l) );
+ if ( mode==fir || mode==both ) delta = 2.*hs;
+
+ Smatrix = matrix(N, N);
+ w = vector(N);
+ z = vector(N);
+ fn = matrix(nmax, N);
+
+ gausslegendre(N, -c, c, z, w);
+
+ rn = 1.; cn = 0.; rn0 = 1., cn0 = 0.;
+
+ /* in-control, i. e. n<=q-1 */
+
+ for (n=1; n<=q-1; n++) {
+ nn = (double) n;
+
+ /* determine c_n and r_n, n=1,2,...,q-1 */
+ switch ( mode ) {
+ case vacl: rn = sqrt( 1. - pow(1.-l,2.*nn) );
+ break;
+ case fir: dn = delta*pow(1.-l,nn);
+ rn = 1. - dn/(2.*c);
+ cn = dn/2.;
+ break;
+ case both: dn = delta*pow(1.-l,nn);
+ rn = sqrt( 1. - pow(1.-l,2.*nn) ) - dn/(2.*c);
+ cn = dn/2.;
+ break;
+ case steiner: rn = sqrt(1.-pow(1.-l,2.*nn))*(1.-pow(1.-fSt,1.+aSt*(nn-1.)));
+ break;
+ }
+
+ /* determine f_n, n=1,2,...,q-1 */
+ if ( n==1 ) {
+ for (i=0; i<N; i++)
+ if ( mode==stat )
+ fn[0*N+i] = 1./sqrt(l/(2.-l))*phi( (cn+rn*z[i])/sqrt(l/(2.-l)),mu0);
+ else
+ fn[0*N+i] = rn/l * phi( (cn+rn*z[i]-(1.-l)*hs)/l,mu0);
+ }
+ else {
+ for (i=0; i<N; i++) {
+ fn[(n-1)*N+i] = 0.;
+ for (j=0; j<N; j++) {
+ fn[(n-1)*N+i] += w[j]*fn[(n-2)*N+j]*rn/l*phi((cn+rn*z[i]-(1.-l)*(cn0+rn0*z[j]))/l,mu0);
+ }
+ }
+ }
+
+ /* determine P(L>n), n=1,2,...,q-1 */
+ p0[n-1] = 0.;
+ for (i=0; i<N; i++) p0[n-1] += w[i] * fn[(n-1)*N+i];
+
+ /* weights and nodes w.r.t. O_n become w. a. n. w.r.t. O_n-1 */
+ cn0 = cn; rn0 = rn;
+ }
+
+ /* out-of-control, i.e. t>=q */
+
+ for (n=q; n<=nmax; n++) {
+ nn = (double) n;
+
+ /* determine c_n and r_n, n=q,q+1,... */
+ switch ( mode ) {
+ case vacl: rn = sqrt( 1. - pow(1.-l,2.*nn) );
+ break;
+ case fir: dn = delta*pow(1.-l,nn);
+ rn = 1. - dn/(2.*c);
+ cn = dn/2.;
+ break;
+ case both: dn = delta*pow(1.-l,nn);
+ rn = sqrt( 1. - pow(1.-l,2.*nn) ) - dn/(2.*c);
+ cn = dn/2.;
+ break;
+ case steiner: rn = sqrt(1.-pow(1.-l,2.*nn))*(1.-pow(1.-fSt,1.+aSt*(nn-1.)));
+ break;
+ }
+
+ /* determine f_n, n=q,q+1,... */
+ if ( n==1 ) {
+ for (i=0; i<N; i++)
+ if ( mode==stat )
+ fn[0*N+i] = 1./sqrt(l/(2.-l))*phi( (cn+rn*z[i])/sqrt(l/(2.-l)),mu1);
+ else
+ fn[0*N+i] = rn/l * phi( (cn+rn*z[i]-(1.-l)*hs)/l,mu1);
+ }
+ else {
+ for (i=0; i<N; i++) {
+ fn[(n-1)*N+i] = 0.;
+ for (j=0; j<N; j++)
+ fn[(n-1)*N+i] += w[j]*fn[(n-2)*N+j]*rn/l*phi( (cn+rn*z[i]-(1.-l)*(cn0+rn0*z[j]))/l,mu1);
+ if ( n==q && q>1 ) fn[(n-1)*N+i] /= p0[q-2];
+ }
+ }
+
+ /* determine P(L>n), n=1,2,...,q-1 */
+ p0[n-1] = 0.;
+ for (i=0; i<N; i++) p0[n-1] += w[i] * fn[(n-1)*N+i];
+
+ /* weights and nodes w.r.t. O_n become w. a. n. w.r.t. O_n-1 */
+ cn0 = cn; rn0 = rn;
+ }
+
+ Free(Smatrix);
+ Free(w);
+ Free(z);
+ Free(fn);
+
+ return 0;
+}
+
+
+double xte2_sfm(double l, double c, double hs, int df, int q, double mu0, double mu1, int mode, int N, int nmax, double *p0, int subst)
+{ double *Smatrix, *fn, *w, *z, dn, rn, cn, rn0, cn0, delta=0., nn, fSt, aSt, norm=1., arg=0., korr=1.;
+ int i, j, n;
+
+ fSt = 0.5;
+ aSt = ( -2./log10(1.-fSt) - 1.)/19.;
+
+ c *= sqrt( l/(2.-l) );
+ hs *= sqrt( l/(2.-l) );
+ if ( mode==fir || mode==both ) delta = 2.*hs;
+
+ Smatrix = matrix(N, N);
+ w = vector(N);
+ z = vector(N);
+ fn = matrix(nmax, N);
+
+ switch ( subst ) {
+ case IDENTITY: gausslegendre(N, -c, c, z, w); norm = 1.; break;
+ case SIN: gausslegendre(N, -PI/2., PI/2., z, w); norm = 1.; break;
+ case SINH: gausslegendre(N, -1., 1., z, w); norm = sinh(1.); break;
+ case TAN: gausslegendre(N, -PI/4., PI/4., z, w); norm = 1.; break;
+ }
+
+ c /= norm;
+
+ rn = 1.; cn = 0.; rn0 = 1., cn0 = 0.;
+
+ /* in-control, i. e. n<=q-1 */
+
+ for (n=1; n<=q-1; n++) {
+ nn = (double) n;
+
+ /* determine c_n and r_n, n=1,2,...,q-1 */
+ switch ( mode ) {
+ case vacl: rn = sqrt( 1. - pow(1.-l,2.*nn) );
+ break;
+ case fir: dn = delta*pow(1.-l,nn);
+ rn = 1. - dn/(2.*c*norm);
+ cn = dn/2.;
+ break;
+ case both: dn = delta*pow(1.-l,nn);
+ rn = sqrt( 1. - pow(1.-l,2.*nn) ) - dn/(2.*c*norm);
+ cn = dn/2.;
+ break;
+ case steiner: rn = sqrt(1.-pow(1.-l,2.*nn))*(1.-pow(1.-fSt,1.+aSt*(nn-1.)));
+ break;
+ }
+
+ /* determine f_n, n=1,2,...,q-1 */
+ if ( n==1 ) {
+ for (i=0; i<N; i++) {
+ switch ( subst ) {
+ case IDENTITY: arg = z[i]; break;
+ case SIN: arg = c*sin(z[i]); break;
+ case SINH: arg = c*sinh(z[i]); break;
+ case TAN: arg = c*tan(z[i]); break;
+ }
+ if ( mode==stat )
+ fn[0*N+i] = 1./sqrt(l/(2.-l)) * pdf_t( ( cn+rn*arg )/sqrt(l/(2.-l)) - mu0, df);
+ else
+ fn[0*N+i] = rn/l * pdf_t( ( cn+rn*arg - (1.-l)*hs )/l - mu0, df);
+ }
+ }
+ else {
+ for (i=0; i<N; i++) {
+ fn[(n-1)*N+i] = 0.;
+ for (j=0; j<N; j++) {
+ switch ( subst ) {
+ case IDENTITY: arg = cn+rn*z[i] - (1.-l)*(cn0+rn0*z[j]); korr = 1.; break;
+ case SIN: arg = cn+rn*c*sin(z[i]) - (1.-l)*(cn0+rn0*c*sin(z[j])); korr = c*cos(z[j]); break;
+ case SINH: arg = cn+rn*c*sinh(z[i]) - (1.-l)*(cn0+rn0*c*sinh(z[j])); korr = c*cosh(z[j]); break;
+ case TAN: arg = cn+rn*c*tan(z[i]) - (1.-l)*(cn0+rn0*c*tan(z[j])); korr = c/( cos(z[j])*cos(z[j]) ); break;
+ }
+ fn[(n-1)*N+i] += w[j]*fn[(n-2)*N+j]*rn/l * pdf_t( arg/l - mu0, df) * korr;
+ }
+ }
+ }
+
+ /* determine P(L>n), n=1,2,...,q-1 */
+ p0[n-1] = 0.;
+ for (i=0; i<N; i++) {
+ switch ( subst ) {
+ case IDENTITY: korr = 1.; break;
+ case SIN: korr = c*cos(z[i]); break;
+ case SINH: korr = c*cosh(z[i]); break;
+ case TAN: korr = c/( cos(z[i])*cos(z[i]) ); break;
+ }
+ p0[n-1] += w[i] * fn[(n-1)*N+i] * korr;
+ }
+
+ /* weights and nodes w.r.t. O_n become w. a. n. w.r.t. O_n-1 */
+ cn0 = cn; rn0 = rn;
+ }
+
+ /* out-of-control, i.e. t>=q */
+
+ for (n=q; n<=nmax; n++) {
+ nn = (double) n;
+
+ /* determine c_n and r_n, n=q,q+1,... */
+ switch ( mode ) {
+ case vacl: rn = sqrt( 1. - pow(1.-l,2.*nn) );
+ break;
+ case fir: dn = delta*pow(1.-l,nn);
+ rn = 1. - dn/(2.*c*norm);
+ cn = dn/2.;
+ break;
+ case both: dn = delta*pow(1.-l,nn);
+ rn = sqrt( 1. - pow(1.-l,2.*nn) ) - dn/(2.*c*norm);
+ cn = dn/2.;
+ break;
+ case steiner: rn = sqrt(1.-pow(1.-l,2.*nn))*(1.-pow(1.-fSt,1.+aSt*(nn-1.)));
+ break;
+ }
+
+ /* determine f_n, n=q,q+1,... */
+ if ( n==1 ) {
+ for (i=0; i<N; i++) {
+ switch ( subst ) {
+ case IDENTITY: arg = z[i]; break;
+ case SIN: arg = c*sin(z[i]); break;
+ case SINH: arg = c*sinh(z[i]); break;
+ case TAN: arg = c*tan(z[i]); break;
+ }
+ if ( mode==stat )
+ fn[0*N+i] = 1./sqrt(l/(2.-l)) * pdf_t( ( cn+rn*arg )/sqrt(l/(2.-l)) - mu1, df);
+ else
+ fn[0*N+i] = rn/l * pdf_t( ( cn+rn*arg - (1.-l)*hs )/l - mu1, df);
+ }
+ }
+ else {
+ for (i=0; i<N; i++) {
+ fn[(n-1)*N+i] = 0.;
+ for (j=0; j<N; j++) {
+ switch ( subst ) {
+ case IDENTITY: arg = cn+rn*z[i] - (1.-l)*(cn0+rn0*z[j]); korr = 1.; break;
+ case SIN: arg = cn+rn*c*sin(z[i]) - (1.-l)*(cn0+rn0*c*sin(z[j])); korr = c*cos(z[j]); break;
+ case SINH: arg = cn+rn*c*sinh(z[i]) - (1.-l)*(cn0+rn0*c*sinh(z[j])); korr = c*cosh(z[j]); break;
+ case TAN: arg = cn+rn*c*tan(z[i]) - (1.-l)*(cn0+rn0*c*tan(z[j])); korr = c/( cos(z[j])*cos(z[j]) ); break;
+ }
+ fn[(n-1)*N+i] += w[j]*fn[(n-2)*N+j]*rn/l * pdf_t( arg/l - mu1, df) * korr;
+ }
+ if ( n==q && q>1 ) fn[(n-1)*N+i] /= p0[q-2];
+ }
+ }
+
+ /* determine P(L>n), n=1,2,...,q-1 */
+ p0[n-1] = 0.;
+ for (i=0;i<N;i++) {
+ switch ( subst ) {
+ case IDENTITY: korr = 1.; break;
+ case SIN: korr = c*cos(z[i]); break;
+ case SINH: korr = c*cosh(z[i]); break;
+ case TAN: korr = c/( cos(z[i])*cos(z[i]) ); break;
+ }
+ p0[n-1] += w[i] * fn[(n-1)*N+i] * korr;
+ }
+
+ /* weights and nodes w.r.t. O_n become w. a. n. w.r.t. O_n-1 */
+ cn0 = cn; rn0 = rn;
+ }
+
+ Free(Smatrix);
+ Free(w);
+ Free(z);
+ Free(fn);
+
+ return 0;
+}
+
+
+double xe1_arlm(double l, double c, double zr, double hs, int q, double mu0, double mu1,
+ int mode, int N, int nmax)
+{ double *Smatrix, *p0, *fn, *w, *z, arl0, rho, rn, cn, rn0, cn0,
+ arl_minus=0, arl, arl_plus=0, mn_minus, mn_plus, nn, ratio;
+ int i=0, j=0, n, NN;
+
+ c *= sqrt( l/(2.-l) );
+ zr *= sqrt( l/(2.-l) );
+ hs *= sqrt( l/(2.-l) );
+
+ NN = N + 1;
+ Smatrix = matrix(NN, NN);
+ w = vector(NN);
+ z = vector(NN);
+ fn = matrix(nmax, NN);
+ p0 = vector(nmax);
+
+ gausslegendre(N, zr, c, z, w);
+
+ rn = 1.; cn = 0.; rn0 = 1., cn0 = 0.;
+
+ /* in-control, i. e. n<=q-1 */
+ for (n=1;n<=q-1;n++) {
+ nn = (double) n;
+
+ /* determine r_n, n=1,2,...,q-1 */
+ if ( mode==vacl ) {
+ rn = sqrt( 1. - pow(1.-l, 2.*nn) );
+ }
+
+ /* determine f_n, n=1,2,...,q-1 */
+ if (n==1) {
+ for (i=0;i<N;i++) {
+ if (mode==stat) {
+ fn[0*NN+i] = 1./sqrt(l/(2.-l))*phi( (cn+rn*z[i])/sqrt(l/(2.-l)), mu0);
+ }
+ else {
+ fn[0*NN+i] = rn/l * phi( (cn+rn*z[i]-(1.-l)*hs)/l, mu0);
+ }
+ }
+ if (mode==stat) {
+ fn[0*NN+N] = PHI( (cn+rn*zr)/sqrt(l/(2.-l)), mu0);
+ }
+ else {
+ fn[0*NN+N] = PHI( (cn+rn*zr-(1.-l)*hs)/l, mu0);
+ }
+ }
+ else {
+ for (i=0;i<N;i++) {
+ fn[(n-1)*NN+i] = fn[(n-2)*NN+N] * rn/l * phi((cn+rn*z[i]-(1.-l)*(cn0+rn0*zr))/l, mu0);
+ for (j=0;j<N;j++) {
+ fn[(n-1)*NN+i] += w[j]*fn[(n-2)*NN+j] * rn/l
+ *phi((cn+rn*z[i]-(1.-l)*(cn0+rn0*z[j]))/l, mu0);
+ }
+ }
+ fn[(n-1)*NN+N] = fn[(n-2)*NN+N] * PHI( (cn+rn*zr-(1.-l)*(cn0+rn0*zr))/l, mu0);
+ for (j=0;j<N;j++)
+ fn[(n-1)*NN+N] += w[j] * fn[(n-2)*NN+j] * PHI( (cn+rn*zr-(1.-l)*(cn0+rn0*z[j]))/l, mu0);
+ }
+
+ /* determine P(L>n), n=1,2,...,q-1 */
+ p0[n-1] = fn[(n-1)*NN+N];
+ for (i=0;i<N;i++) p0[n-1] += w[i] * fn[(n-1)*NN+i];
+
+ /* weights and nodes w.r.t. O_n become w. a. n. w.r.t. O_n-1 */
+ cn0 = cn; rn0 = rn;
+ }
+
+ /* out-of-control, i.e. t>=q */
+ arl0 = 1.; rho = 0.;
+
+ for (n=q;n<=nmax;n++) {
+ nn = (double) n;
+
+ /* determine r_n, n=1,2,...,q-1 */
+ if ( mode==vacl ) {
+ rn = sqrt( 1. - pow(1.-l, 2.*nn) );
+ }
+
+ /* determine f_n, n=q,q+1,... */
+ if (n==1) {
+ for (i=0;i<N;i++) {
+ if (mode==stat) {
+ fn[0*NN+i] = 1./sqrt(l/(2.-l))*phi( (cn+rn*z[i])/sqrt(l/(2.-l)), mu1);
+ }
+ else {
+ fn[0*NN+i] = rn/l * phi( (cn+rn*z[i]-(1.-l)*hs)/l, mu1);
+ }
+ }
+ if (mode==stat) {
+ fn[0*NN+N] = PHI( (cn+rn*zr)/sqrt(l/(2.-l)), mu1);
+ }
+ else {
+ fn[0*NN+N] = PHI( (cn+rn*zr-(1.-l)*hs)/l, mu1);
+ }
+ }
+ else {
+ for (i=0;i<N;i++) {
+ fn[(n-1)*NN+i] = fn[(n-2)*NN+N] * rn/l * phi((cn+rn*z[i]-(1.-l)*(cn0+rn0*zr))/l, mu1);
+ for (j=0;j<N;j++) {
+ fn[(n-1)*NN+i] += w[j]*fn[(n-2)*NN+j] * rn/l * phi((cn+rn*z[i]-(1.-l)*(cn0+rn0*z[j]))/l, mu1);
+ }
+ if (n==q && q>1) fn[(n-1)*NN+i] /= p0[q-2];
+ }
+ fn[(n-1)*NN+N] = fn[(n-2)*NN+N] * PHI( (cn+rn*zr-(1.-l)*(cn0+rn0*zr))/l, mu1);
+ for (j=0;j<N;j++)
+ fn[(n-1)*NN+N] += w[j] * fn[(n-2)*NN+j] * PHI( (cn+rn*zr-(1.-l)*(cn0+rn0*z[j]))/l, mu1);
+ if (n==q && q>1) fn[(n-1)*NN+N] /= p0[q-2];
+ }
+
+ /* determine P(L>n), n=1,2,...,q-1 */
+ p0[n-1] = fn[(n-1)*NN+N];
+ for (i=0;i<N;i++) p0[n-1] += w[i] * fn[(n-1)*NN+i];
+
+ /* weights and nodes w.r.t. O_n become w. a. n. w.r.t. O_n-1 */
+ cn0 = cn; rn0 = rn;
+
+ /* computation of m_n+1^- and m_n+1^+, n=m-1,m,... */
+ mn_minus = 1.; mn_plus = 0.;
+ if (n>q) {
+ for (i=0;i<NN;i++) {
+ if (fn[(n-2)*NN+i]==0)
+ if (fn[(n-1)*NN+i]==0) ratio = 0.; else ratio = 1.;
+ else ratio = fn[(n-1)*NN+i]/fn[(n-2)*NN+i];
+ if ( ratio<mn_minus ) mn_minus = ratio;
+ if ( ratio>mn_plus ) mn_plus = ratio;
+ }
+ }
+
+ if (n>q) rho = p0[n-1]/p0[n-2];
+
+ /* computation of ARL, ARL^-, and ARL^+ */
+ arl = arl0 + p0[n-1]/(1.-rho);
+ if (mn_minus<1.) arl_minus = arl0 + p0[n-1]/(1.-mn_minus);
+ else arl_minus = -1.;
+ if (mn_plus<1.) arl_plus = arl0 + p0[n-1]/(1.-mn_plus);
+ else arl_plus = -1.;
+ arl0 += p0[n-1];
+
+ if ( fabs((arl_plus-arl_minus)) < 1e-7 ) n = nmax+1;
+ }
+
+ arl = (arl_plus+arl_minus)/2; rho0 = rho;
+
+ Free(Smatrix);
+ Free(w);
+ Free(z);
+ Free(fn);
+ Free(p0);
+
+ return arl;
+}
+
+
+double xe1_arlm_hom(double l, double c, double zr, double hs, int q, double mu0, double mu1, int N, double *ced)
+{ double *fn, *w, *z, *a, *arl, norm;
+ int i, j, n, NN;
+
+ NN = N + 1;
+ w = vector(NN);
+ z = vector(NN);
+ fn = matrix(q+1, NN);
+ a = matrix(NN,NN);
+ arl = vector(NN);
+
+ c *= sqrt( l/(2.-l) );
+ zr *= sqrt( l/(2.-l) );
+ hs *= sqrt( l/(2.-l) );
+
+ gausslegendre(N, zr, c, z, w);
+
+ /* ARL vector */
+ for (i=0; i<N; i++) {
+ for (j=0; j<N; j++) a[i*NN+j] = -w[j]/l * phi( (z[j]-(1.-l)*z[i])/l, mu1);
+ ++a[i*NN+i];
+ a[i*NN+N] = - PHI( (zr-(1.-l)*z[i])/l, mu1);
+ }
+ for (j=0; j<N; j++) a[N*NN+j] = -w[j]/l * phi( (z[j]-(1.-l)*zr)/l, mu1);
+ a[N*NN+N] = 1. - PHI( zr, mu1);
+
+ for (j=0; j<NN; j++) arl[j] = 1.;
+ LU_solve(a, arl, NN);
+
+ /* q == 1 */
+ ced[0] = 1. + PHI( (zr-(1.-l)*hs)/l, mu1) * arl[N];
+ for (j=0; j<N; j++) ced[0] += w[j]/l * phi( (z[j]-(1.-l)*hs)/l, mu1) * arl[j];
+
+/* density sequence for q > 1 */
+ for (n=1; n<=q-1; n++) {
+ if (n==1) {
+ for (i=0;i<N;i++) fn[0*NN+i] = phi( (z[i]-(1.-l)*hs)/l, mu0)/l;
+ fn[0*NN+N] = PHI( (zr-(1.-l)*hs)/l, mu0);
+ } else {
+ for (i=0; i<N; i++) {
+ fn[(n-1)*NN+i] = fn[(n-2)*NN+N] * phi( (z[i]-(1.-l)*zr)/l, mu0)/l;
+ for (j=0; j<N; j++) fn[(n-1)*NN+i] += w[j] * fn[(n-2)*NN+j] * phi( (z[i]-(1.-l)*z[j])/l, mu0)/l;
+ }
+ fn[(n-1)*NN+N] = fn[(n-2)*NN+N] * PHI( zr, mu0);
+ for (j=0; j<N; j++) fn[(n-1)*NN+N] += w[j] * fn[(n-2)*NN+j] * PHI( (zr-(1.-l)*z[j])/l, mu0);
+ }
+
+ ced[n] = fn[(n-1)*NN+N] * arl[N];
+ norm = fn[(n-1)*NN+N];
+ for (j=0; j<N; j++) {
+ ced[n] += w[j] * fn[(n-1)*NN+j] * arl[j];
+ norm += w[j] * fn[(n-1)*NN+j];
+ }
+ ced[n] /= norm;
+ }
+
+ Free(w);
+ Free(z);
+ Free(fn);
+ Free(a);
+ Free(arl);
+
+ return 0;
+}
+
+
+double xlimit1_arlm(double c, double zr, int q, double mu0, double mu1, int N, int nmax)
+{ double *Smatrix, *p0, *fn, *w, *z, l1, l2, arl0, rho,
+ arl_minus=0, arl, arl_plus=0, mn_minus, mn_plus, nn, ratio;
+ int i=0, j=0, n, NN;
+
+ NN = N + 1;
+ Smatrix = matrix(NN, NN);
+ w = vector(NN);
+ z = vector(NN);
+ fn = matrix(nmax, NN);
+ p0 = vector(nmax);
+
+ gausslegendre(N, zr, c, z, w);
+
+ /* in-control, i. e. n<=q-1 */
+ for (n=1;n<=q-1;n++) {
+ nn = (double) n;
+ /* determine f_n, n=1,2,...,q-1 */
+ if (n==1) {
+ for (i=0;i<N;i++) fn[0*NN+i] = phi( z[i], mu0);
+ fn[0*NN+N] = PHI( zr, mu0);
+ }
+ else {
+ l1 = sqrt( (nn-1.)/nn );
+ l2 = sqrt( 1./nn );
+ for (i=0;i<N;i++) {
+ fn[(n-1)*NN+i] = fn[(n-2)*NN+N] * phi( (z[i]-l1*zr)/l2, mu0)/l2;
+ for (j=0;j<N;j++) {
+ fn[(n-1)*NN+i] += w[j]*fn[(n-2)*NN+j] * phi( (z[i]-l1*z[j])/l2, mu0)/l2;
+ }
+ }
+ fn[(n-1)*NN+N] = fn[(n-2)*NN+N] * PHI( (zr-l1*zr)/l2, mu0);
+ for (j=0;j<N;j++)
+ fn[(n-1)*NN+N] += w[j] * fn[(n-2)*NN+j] * PHI( (zr-l1*z[j])/l2, mu0);
+ }
+
+ /* determine P(L>n), n=1,2,...,q-1 */
+ p0[n-1] = fn[(n-1)*NN+N];
+ for (i=0;i<N;i++) p0[n-1] += w[i] * fn[(n-1)*NN+i];
+ }
+
+ /* out-of-control, i.e. t>=q */
+ arl0 = 1.; rho = 0.;
+
+ for (n=q;n<=nmax;n++) {
+ nn = (double) n;
+
+ /* determine f_n, n=q,q+1,... */
+ if (n==1) {
+ for (i=0;i<N;i++) fn[0*NN+i] = phi( z[i], mu1);
+ fn[0*NN+N] = PHI( zr, mu1);
+ }
+ else {
+ l1 = sqrt( (nn-1.)/nn );
+ l2 = sqrt( 1./nn );
+ for (i=0;i<N;i++) {
+ fn[(n-1)*NN+i] = fn[(n-2)*NN+N] * phi( (z[i]-l1*zr)/l2, mu1)/l2;
+ for (j=0;j<N;j++) {
+ fn[(n-1)*NN+i] += w[j] * fn[(n-2)*NN+j] * phi( (z[i]-l1*z[j])/l2, mu1)/l2;
+ }
+ if (n==q && q>1) fn[(n-1)*NN+i] /= p0[q-2];
+ }
+ fn[(n-1)*NN+N] = fn[(n-2)*NN+N] * PHI( (zr-l1*zr)/l2, mu1);
+ for (j=0;j<N;j++)
+ fn[(n-1)*NN+N] += w[j] * fn[(n-2)*NN+j] * PHI( (zr-l1*z[j])/l2, mu1);
+ if (n==q && q>1) fn[(n-1)*NN+N] /= p0[q-2];
+ }
+
+ /* determine P(L>n), n=1,2,...,q-1 */
+ p0[n-1] = fn[(n-1)*NN+N];
+ for (i=0;i<N;i++) p0[n-1] += w[i] * fn[(n-1)*NN+i];
+
+ /* computation of m_n+1^- and m_n+1^+, n=m-1,m,... */
+ mn_minus = 1.; mn_plus = 0.;
+ if (n>q) {
+ for (i=0;i<NN;i++) {
+ if (fn[(n-2)*NN+i]==0)
+ if (fn[(n-1)*NN+i]==0) ratio = 0.; else ratio = 1.;
+ else ratio = fn[(n-1)*NN+i]/fn[(n-2)*NN+i];
+ if ( ratio<mn_minus ) mn_minus = ratio;
+ if ( ratio>mn_plus ) mn_plus = ratio;
+ }
+ }
+
+ if (n>q) rho = p0[n-1]/p0[n-2];
+
+ /* computation of ARL, ARL^-, and ARL^+ */
+ arl = arl0 + p0[n-1]/(1.-rho);
+ if (mn_minus<1.) arl_minus = arl0 + p0[n-1]/(1.-mn_minus);
+ else arl_minus = -1.;
+ if (mn_plus<1.) arl_plus = arl0 + p0[n-1]/(1.-mn_plus);
+ else arl_plus = -1.;
+ arl0 += p0[n-1];
+
+ if ( (p0[n-1]>p0[n-2] || rho>1.) && n>10 ) error("invalid ARL value");
+ if ( fabs((arl_plus-arl_minus)) < 1e-5 ) n = nmax+1;
+ }
+
+ arl = (arl_plus+arl_minus)/2; rho0 = rho;
+
+ Free(Smatrix);
+ Free(w);
+ Free(z);
+ Free(fn);
+ Free(p0);
+
+ return arl;
+}
+
+
+double xe2_arlm(double l, double c, double hs, int q, double mu0, double mu1, int mode, int N, int nmax)
+{ double *Smatrix, *p0, *fn, *w, *z,
+ arl0, rho, dn, rn, cn, rn0, cn0, delta=0.,
+ arl_minus=0, arl, arl_plus=0, mn_minus, mn_plus, nn,
+ fSt, aSt, ratio;
+ int i, j, n;
+
+ fSt = 0.5;
+ aSt = ( -2./log10(1.-fSt) - 1.)/19.;
+
+ c *= sqrt( l/(2.-l) );
+ hs *= sqrt( l/(2.-l) );
+ if (mode==fir || mode==both) delta = 2.*hs;
+
+ Smatrix = matrix(N,N);
+ w = vector(N);
+ z = vector(N);
+ fn = matrix(nmax,N);
+ p0 = vector(nmax);
+
+ gausslegendre(N,-c,c,z,w);
+
+ rn = 1.; cn = 0.; rn0 = 1., cn0 = 0.;
+
+ /* in-control, i. e. n<=q-1 */
+ for (n=1;n<=q-1;n++) {
+ nn = (double) n;
+
+ /* determine c_n and r_n, n=1,2,...,q-1 */
+ switch (mode) {
+ case vacl: rn = sqrt( 1. - pow(1.-l, 2.*nn) );
+ break;
+ case fir: dn = delta*pow(1.-l,nn);
+ rn = 1. - dn/(2.*c);
+ cn = dn/2.;
+ break;
+ case both: dn = delta*pow(1.-l,nn);
+ rn = sqrt( 1. - pow(1.-l,2.*nn) ) - dn/(2.*c);
+ cn = dn/2.;
+ break;
+ case steiner: rn = sqrt(1.-pow(1.-l,2.*nn))*(1.-pow(1.-fSt,1.+aSt*(nn-1.)));
+ break;
+ }
+
+ /* determine f_n, n=1,2,...,q-1 */
+ if (n==1) {
+ for (i=0;i<N;i++)
+ if (mode==stat)
+ fn[0*N+i] = 1./sqrt(l/(2.-l))*phi( (cn+rn*z[i])/sqrt(l/(2.-l)),mu0);
+ else
+ fn[0*N+i] = rn/l * phi( (cn+rn*z[i]-(1.-l)*hs)/l,mu0);
+ }
+ else {
+ for (i=0;i<N;i++) {
+ fn[(n-1)*N+i] = 0.;
+ for (j=0;j<N;j++) {
+ fn[(n-1)*N+i] += w[j]*fn[(n-2)*N+j]*rn/l
+ *phi((cn+rn*z[i]-(1.-l)*(cn0+rn0*z[j]))/l,mu0);
+ }
+ }
+ }
+
+ /* determine P(L>n), n=1,2,...,q-1 */
+ p0[n-1] = 0.;
+ for (i=0;i<N;i++) p0[n-1] += w[i] * fn[(n-1)*N+i];
+
+ /* weights and nodes w.r.t. O_n become w. a. n. w.r.t. O_n-1 */
+ cn0 = cn; rn0 = rn;
+ }
+
+ /* out-of-control, i.e. t>=q */
+ arl0 = 1.; rho = 0.;
+
+ for (n=q;n<=nmax;n++) {
+ nn = (double) n;
+
+ /* determine c_n and r_n, n=q,q+1,... */
+ switch (mode) {
+ case vacl: rn = sqrt( 1. - pow(1.-l,2.*nn) );
+ break;
+ case fir: dn = delta*pow(1.-l,nn);
+ rn = 1. - dn/(2.*c);
+ cn = dn/2.;
+ break;
+ case both: dn = delta*pow(1.-l,nn);
+ rn = sqrt( 1. - pow(1.-l,2.*nn) ) - dn/(2.*c);
+ cn = dn/2.;
+ break;
+ case steiner: rn = sqrt(1.-pow(1.-l,2.*nn))*(1.-pow(1.-fSt,1.+aSt*(nn-1.)));
+ break;
+ }
+
+ /* determine f_n, n=q,q+1,... */
+ if (n==1) {
+ for (i=0;i<N;i++)
+ if (mode==stat)
+ fn[0*N+i] = 1./sqrt(l/(2.-l))*phi( (cn+rn*z[i])/sqrt(l/(2.-l)),mu1);
+ else
+ fn[0*N+i] = rn/l * phi( (cn+rn*z[i]-(1.-l)*hs)/l,mu1);
+ }
+ else {
+ for (i=0;i<N;i++) {
+ fn[(n-1)*N+i] = 0.;
+ for (j=0;j<N;j++)
+ fn[(n-1)*N+i] += w[j]*fn[(n-2)*N+j]*rn/l
+ *phi( (cn+rn*z[i]-(1.-l)*(cn0+rn0*z[j]))/l,mu1);
+ if (n==q && q>1) fn[(n-1)*N+i] /= p0[q-2];
+ }
+ }
+
+ /* determine P(L>n), n=1,2,...,q-1 */
+ p0[n-1] = 0.;
+ for (i=0;i<N;i++) p0[n-1] += w[i] * fn[(n-1)*N+i];
+
+ /* weights and nodes w.r.t. O_n become w. a. n. w.r.t. O_n-1 */
+ cn0 = cn; rn0 = rn;
+
+ /* computation of m_n+1^- and m_n+1^+, n=m-1,m,... */
+ mn_minus = 1.; mn_plus = 0.;
+ if (n>q) {
+ for (i=0;i<N;i++) {
+ if (fn[(n-2)*N+i]==0)
+ if (fn[(n-1)*N+i]==0) ratio = 0.; else ratio = 1.;
+ else ratio = fn[(n-1)*N+i]/fn[(n-2)*N+i];
+ if ( ratio<mn_minus ) mn_minus = ratio;
+ if ( ratio>mn_plus ) mn_plus = ratio;
+ }
+ }
+
+ if (n>q) rho = p0[n-1]/p0[n-2];
+
+ /* computation of ARL, ARL^-, and ARL^+ */
+ arl = arl0 + p0[n-1]/(1.-rho);
+ if (mn_minus<1.) arl_minus = arl0 + p0[n-1]/(1.-mn_minus);
+ else arl_minus = -1.;
+ if (mn_plus<1.) arl_plus = arl0 + p0[n-1]/(1.-mn_plus);
+ else arl_plus = -1.;
+ arl0 += p0[n-1];
+
+ if ( fabs((arl_plus-arl_minus)) < 1e-7 ) n = nmax+1;
+ }
+
+ arl = (arl_plus+arl_minus)/2; rho0 = rho;
+
+ Free(Smatrix);
+ Free(w);
+ Free(z);
+ Free(fn);
+ Free(p0);
+
+ return arl;
+}
+
+
+int xe2_arlm_special(double l, double c, double hs, int q, double mu0, double mu1, int mode, int N, int nmax, double *pair)
+{ double *Smatrix, *p0, *fn, *w, *z,
+ arl0, rho, dn, rn, cn, rn0, cn0, delta=0.,
+ arl_minus=0, arl, arl_plus=0, mn_minus, mn_plus, nn,
+ fSt, aSt, ratio;
+ int i, j, n;
+
+ fSt = 0.5;
+ aSt = ( -2./log10(1.-fSt) - 1.)/19.;
+
+ c *= sqrt( l/(2.-l) );
+ hs *= sqrt( l/(2.-l) );
+ if (mode==fir || mode==both) delta = 2.*hs;
+
+ Smatrix = matrix(N,N);
+ w = vector(N);
+ z = vector(N);
+ fn = matrix(nmax,N);
+ p0 = vector(nmax);
+
+ gausslegendre(N,-c,c,z,w);
+
+ rn = 1.; cn = 0.; rn0 = 1., cn0 = 0.;
+
+ /* in-control, i. e. n<=q-1 */
+ for (n=1;n<=q-1;n++) {
+ nn = (double) n;
+
+ /* determine c_n and r_n, n=1,2,...,q-1 */
+ switch (mode) {
+ case vacl: rn = sqrt( 1. - pow(1.-l, 2.*nn) );
+ break;
+ case fir: dn = delta*pow(1.-l,nn);
+ rn = 1. - dn/(2.*c);
+ cn = dn/2.;
+ break;
+ case both: dn = delta*pow(1.-l,nn);
+ rn = sqrt( 1. - pow(1.-l,2.*nn) ) - dn/(2.*c);
+ cn = dn/2.;
+ break;
+ case steiner: rn = sqrt(1.-pow(1.-l,2.*nn))*(1.-pow(1.-fSt,1.+aSt*(nn-1.)));
+ break;
+ }
+
+ /* determine f_n, n=1,2,...,q-1 */
+ if (n==1) {
+ for (i=0;i<N;i++)
+ if (mode==stat)
+ fn[0*N+i] = 1./sqrt(l/(2.-l))*phi( (cn+rn*z[i])/sqrt(l/(2.-l)),mu0);
+ else
+ fn[0*N+i] = rn/l * phi( (cn+rn*z[i]-(1.-l)*hs)/l,mu0);
+ }
+ else {
+ for (i=0;i<N;i++) {
+ fn[(n-1)*N+i] = 0.;
+ for (j=0;j<N;j++) {
+ fn[(n-1)*N+i] += w[j]*fn[(n-2)*N+j]*rn/l
+ *phi((cn+rn*z[i]-(1.-l)*(cn0+rn0*z[j]))/l,mu0);
+ }
+ }
+ }
+
+ /* determine P(L>n), n=1,2,...,q-1 */
+ p0[n-1] = 0.;
+ for (i=0;i<N;i++) p0[n-1] += w[i] * fn[(n-1)*N+i];
+
+ /* weights and nodes w.r.t. O_n become w. a. n. w.r.t. O_n-1 */
+ cn0 = cn; rn0 = rn;
+ }
+
+ /* out-of-control, i.e. t>=q */
+ arl0 = 1.; rho = 0.;
+
+ for (n=q;n<=nmax;n++) {
+ nn = (double) n;
+
+ /* determine c_n and r_n, n=q,q+1,... */
+ switch (mode) {
+ case vacl: rn = sqrt( 1. - pow(1.-l,2.*nn) );
+ break;
+ case fir: dn = delta*pow(1.-l,nn);
+ rn = 1. - dn/(2.*c);
+ cn = dn/2.;
+ break;
+ case both: dn = delta*pow(1.-l,nn);
+ rn = sqrt( 1. - pow(1.-l,2.*nn) ) - dn/(2.*c);
+ cn = dn/2.;
+ break;
+ case steiner: rn = sqrt(1.-pow(1.-l,2.*nn))*(1.-pow(1.-fSt,1.+aSt*(nn-1.)));
+ break;
+ }
+
+ /* determine f_n, n=q,q+1,... */
+ if (n==1) {
+ for (i=0;i<N;i++)
+ if (mode==stat)
+ fn[0*N+i] = 1./sqrt(l/(2.-l))*phi( (cn+rn*z[i])/sqrt(l/(2.-l)),mu1);
+ else
+ fn[0*N+i] = rn/l * phi( (cn+rn*z[i]-(1.-l)*hs)/l,mu1);
+ }
+ else {
+ for (i=0;i<N;i++) {
+ fn[(n-1)*N+i] = 0.;
+ for (j=0;j<N;j++)
+ fn[(n-1)*N+i] += w[j]*fn[(n-2)*N+j]*rn/l
+ *phi( (cn+rn*z[i]-(1.-l)*(cn0+rn0*z[j]))/l,mu1);
+ }
+ }
+
+ /* determine P(L>n), n=1,2,...,q-1 */
+ p0[n-1] = 0.;
+ for (i=0;i<N;i++) p0[n-1] += w[i] * fn[(n-1)*N+i];
+
+ /* weights and nodes w.r.t. O_n become w. a. n. w.r.t. O_n-1 */
+ cn0 = cn; rn0 = rn;
+
+ /* computation of m_n+1^- and m_n+1^+, n=m-1,m,... */
+ mn_minus = 1.; mn_plus = 0.;
+ if (n>q) {
+ for (i=0;i<N;i++) {
+ if (fn[(n-2)*N+i]==0)
+ if (fn[(n-1)*N+i]==0) ratio = 0.; else ratio = 1.;
+ else ratio = fn[(n-1)*N+i]/fn[(n-2)*N+i];
+ if ( ratio<mn_minus ) mn_minus = ratio;
+ if ( ratio>mn_plus ) mn_plus = ratio;
+ }
+ }
+
+ if ( n > q ) rho = p0[n-1]/p0[n-2];
+
+ /* computation of ARL, ARL^-, and ARL^+ */
+ arl = arl0 + p0[n-1]/(1.-rho);
+ if (mn_minus<1.) arl_minus = arl0 + p0[n-1]/(1.-mn_minus);
+ else arl_minus = -1.;
+ if (mn_plus<1.) arl_plus = arl0 + p0[n-1]/(1.-mn_plus);
+ else arl_plus = -1.;
+ arl0 += p0[n-1];
+
+ if ( fabs((arl_plus-arl_minus)) < 1e-7 ) n = nmax+1;
+ }
+
+ arl = ( arl_plus + arl_minus )/2;
+
+ pair[0] = 1.;
+ if ( q > 1 ) pair[0] = p0[q-2];
+ pair[1] = arl;
+
+ Free(Smatrix);
+ Free(w);
+ Free(z);
+ Free(fn);
+ Free(p0);
+
+ return 0;
+}
+
+
+double xte2_arlm(double l, double c, double hs, int df, int q, double mu0, double mu1, int mode, int N, int nmax, int subst)
+{ double *Smatrix, *p0, *fn, *w, *z,
+ arl0, rho, dn, rn, cn, rn0, cn0, delta=0.,
+ arl_minus=0, arl, arl_plus=0, mn_minus, mn_plus, nn,
+ fSt, aSt, ratio, norm=1., arg=0., korr=1.;
+ int i, j, n;
+
+ fSt = 0.5;
+ aSt = ( -2./log10(1.-fSt) - 1.)/19.;
+
+ c *= sqrt( l/(2.-l) );
+ hs *= sqrt( l/(2.-l) );
+ if (mode==fir || mode==both) delta = 2.*hs;
+
+ Smatrix = matrix(N,N);
+ w = vector(N);
+ z = vector(N);
+ fn = matrix(nmax,N);
+ p0 = vector(nmax);
+
+ switch ( subst ) {
+ case IDENTITY: gausslegendre(N, -c, c, z, w); norm = 1.; break;
+ case SIN: gausslegendre(N, -PI/2., PI/2., z, w); norm = 1.; break;
+ case SINH: gausslegendre(N, -1., 1., z, w); norm = sinh(1.); break;
+ case TAN: gausslegendre(N, -PI/4., PI/4., z, w); norm = 1.; break;
+ }
+
+ c /= norm;
+
+ rn = 1.; cn = 0.; rn0 = 1., cn0 = 0.;
+
+ /* in-control, i. e. n<=q-1 */
+ for (n=1; n<=q-1; n++) {
+ nn = (double) n;
+
+ /* determine c_n and r_n, n=1,2,...,q-1 */
+ switch ( mode ) {
+ case vacl: rn = sqrt( 1. - pow(1.-l, 2.*nn) );
+ break;
+ case fir: dn = delta*pow(1.-l,nn);
+ rn = 1. - dn/(2.*c*norm);
+ cn = dn/2.;
+ break;
+ case both: dn = delta*pow(1.-l,nn);
+ rn = sqrt( 1. - pow(1.-l,2.*nn) ) - dn/(2.*c*norm);
+ cn = dn/2.;
+ break;
+ case steiner: rn = sqrt(1.-pow(1.-l,2.*nn))*(1.-pow(1.-fSt,1.+aSt*(nn-1.)));
+ break;
+ }
+
+ /* determine f_n, n=1,2,...,q-1 */
+ if ( n==1 ) {
+ for (i=0; i<N; i++) {
+ switch ( subst ) {
+ case IDENTITY: arg = z[i]; break;
+ case SIN: arg = c*sin(z[i]); break;
+ case SINH: arg = c*sinh(z[i]); break;
+ case TAN: arg = c*tan(z[i]); break;
+ }
+ if ( mode==stat )
+ fn[0*N+i] = 1./sqrt(l/(2.-l)) * pdf_t( ( cn+rn*arg )/sqrt(l/(2.-l)) - mu0, df);
+ else
+ fn[0*N+i] = rn/l * pdf_t( ( cn+rn*arg - (1.-l)*hs )/l - mu0, df);
+ }
+ }
+ else {
+ for (i=0;i<N;i++) {
+ fn[(n-1)*N+i] = 0.;
+ for (j=0;j<N;j++) {
+ switch ( subst ) {
+ case IDENTITY: arg = cn+rn*z[i] - (1.-l)*(cn0+rn0*z[j]); korr = 1.; break;
+ case SIN: arg = cn+rn*c*sin(z[i]) - (1.-l)*(cn0+rn0*c*sin(z[j])); korr = c*cos(z[j]); break;
+ case SINH: arg = cn+rn*c*sinh(z[i]) - (1.-l)*(cn0+rn0*c*sinh(z[j])); korr = c*cosh(z[j]); break;
+ case TAN: arg = cn+rn*c*tan(z[i]) - (1.-l)*(cn0+rn0*c*tan(z[j])); korr = c/( cos(z[j])*cos(z[j]) ); break;
+ }
+ fn[(n-1)*N+i] += w[j]*fn[(n-2)*N+j]*rn/l * pdf_t( arg/l - mu0, df) * korr;
+ }
+ }
+ }
+
+ /* determine P(L>n), n=1,2,...,q-1 */
+ p0[n-1] = 0.;
+ for (i=0; i<N; i++) {
+ switch ( subst ) {
+ case IDENTITY: korr = 1.; break;
+ case SIN: korr = c*cos(z[i]); break;
+ case SINH: korr = c*cosh(z[i]); break;
+ case TAN: korr = c/( cos(z[i])*cos(z[i]) ); break;
+ }
+ p0[n-1] += w[i] * fn[(n-1)*N+i] * korr;
+ }
+
+ /* weights and nodes w.r.t. O_n become w. a. n. w.r.t. O_n-1 */
+ cn0 = cn; rn0 = rn;
+ }
+
+ /* out-of-control, i.e. t>=q */
+ arl0 = 1.; rho = 0.;
+
+ for (n=q; n<=nmax; n++) {
+ nn = (double) n;
+
+ /* determine c_n and r_n, n=q,q+1,... */
+ switch ( mode ) {
+ case vacl: rn = sqrt( 1. - pow(1.-l,2.*nn) );
+ break;
+ case fir: dn = delta*pow(1.-l,nn);
+ rn = 1. - dn/(2.*c*norm);
+ cn = dn/2.;
+ break;
+ case both: dn = delta*pow(1.-l,nn);
+ rn = sqrt( 1. - pow(1.-l,2.*nn) ) - dn/(2.*c*norm);
+ cn = dn/2.;
+ break;
+ case steiner: rn = sqrt(1.-pow(1.-l,2.*nn))*(1.-pow(1.-fSt,1.+aSt*(nn-1.)));
+ break;
+ }
+
+ /* determine f_n, n=q,q+1,... */
+ if ( n==1 ) {
+ for (i=0; i<N; i++) {
+ switch ( subst ) {
+ case IDENTITY: arg = z[i]; break;
+ case SIN: arg = c*sin(z[i]); break;
+ case SINH: arg = c*sinh(z[i]); break;
+ case TAN: arg = c*tan(z[i]); break;
+ }
+ if ( mode==stat )
+ fn[0*N+i] = 1./sqrt(l/(2.-l)) * pdf_t( ( cn+rn*arg )/sqrt(l/(2.-l)) - mu1, df);
+ else
+ fn[0*N+i] = rn/l * pdf_t( ( cn+rn*arg - (1.-l)*hs )/l - mu1, df);
+ }
+ }
+ else {
+ for (i=0; i<N; i++) {
+ fn[(n-1)*N+i] = 0.;
+ for (j=0; j<N; j++) {
+ switch ( subst ) {
+ case IDENTITY: arg = cn+rn*z[i] - (1.-l)*(cn0+rn0*z[j]); korr = 1.; break;
+ case SIN: arg = cn+rn*c*sin(z[i]) - (1.-l)*(cn0+rn0*c*sin(z[j])); korr = c*cos(z[j]); break;
+ case SINH: arg = cn+rn*c*sinh(z[i]) - (1.-l)*(cn0+rn0*c*sinh(z[j])); korr = c*cosh(z[j]); break;
+ case TAN: arg = cn+rn*c*tan(z[i]) - (1.-l)*(cn0+rn0*c*tan(z[j])); korr = c/( cos(z[j])*cos(z[j]) ); break;
+ }
+ fn[(n-1)*N+i] += w[j]*fn[(n-2)*N+j]*rn/l * pdf_t( arg/l - mu1, df) * korr;
+ }
+ if ( n==q && q>1 ) fn[(n-1)*N+i] /= p0[q-2];
+ }
+ }
+
+ /* determine P(L>n), n=1,2,...,q-1 */
+ p0[n-1] = 0.;
+ for (i=0;i<N;i++) {
+ switch ( subst ) {
+ case IDENTITY: korr = 1.; break;
+ case SIN: korr = c*cos(z[i]); break;
+ case SINH: korr = c*cosh(z[i]); break;
+ case TAN: korr = c/( cos(z[i])*cos(z[i]) ); break;
+ }
+ p0[n-1] += w[i] * fn[(n-1)*N+i] * korr;
+ }
+
+ /* weights and nodes w.r.t. O_n become w. a. n. w.r.t. O_n-1 */
+ cn0 = cn; rn0 = rn;
+
+ /* computation of m_n+1^- and m_n+1^+, n=m-1,m,... */
+ mn_minus = 1.; mn_plus = 0.;
+ if ( n>q ) {
+ for (i=0; i<N; i++) {
+ if (fn[(n-2)*N+i]==0)
+ if (fn[(n-1)*N+i]==0) ratio = 0.; else ratio = 1.;
+ else ratio = fn[(n-1)*N+i]/fn[(n-2)*N+i];
+ if ( ratio<mn_minus ) mn_minus = ratio;
+ if ( ratio>mn_plus ) mn_plus = ratio;
+ }
+ }
+
+ if ( n>q ) rho = p0[n-1]/p0[n-2];
+
+ /* computation of ARL, ARL^-, and ARL^+ */
+ arl = arl0 + p0[n-1]/(1.-rho);
+ if ( mn_minus<1. ) arl_minus = arl0 + p0[n-1]/(1.-mn_minus);
+ else arl_minus = -1.;
+ if ( mn_plus<1. ) arl_plus = arl0 + p0[n-1]/(1.-mn_plus);
+ else arl_plus = -1.;
+ arl0 += p0[n-1];
+
+ if ( fabs((arl_plus-arl_minus)) < 1e-7 ) n = nmax+1;
+ }
+
+ arl = (arl_plus+arl_minus)/2; rho0 = rho;
+
+ Free(Smatrix);
+ Free(w);
+ Free(z);
+ Free(fn);
+ Free(p0);
+
+ return arl;
+}
+
+
+double xe2_arlm_hom(double l, double c, double hs, int q, double mu0, double mu1, int N, double *ced)
+{ double *fn, *w, *z, *a, *arl, norm;
+ int i, j, n;
+
+ w = vector(N);
+ z = vector(N);
+ fn = matrix(q+1, N);
+ a = matrix(N,N);
+ arl = vector(N);
+
+ c *= sqrt( l/(2.-l) );
+ hs *= sqrt( l/(2.-l) );
+
+ gausslegendre(N, -c, c, z, w);
+
+ for (i=0; i<N; i++) {
+ for (j=0;j<N;j++) a[i*N+j] = -w[j]/l * phi( (z[j]-(1.-l)*z[i])/l, mu1);
+ ++a[i*N+i];
+ }
+
+ for (j=0; j<N; j++) arl[j] = 1.;
+ LU_solve(a, arl, N);
+
+ /* q == 1 */
+ ced[0] = 1.;
+ for (j=0; j<N; j++) ced[0] += w[j]/l * phi( (z[j]-(1.-l)*hs)/l, mu1) * arl[j];
+
+ /* density sequence for q > 1 */
+ for (n=1; n<=q-1; n++) {
+ if ( n==1 ) {
+ for (i=0; i<N; i++) fn[0*N+i] = phi( (z[i]-(1.-l)*hs)/l, mu0)/l;
+ } else {
+ for (i=0; i<N; i++) {
+ fn[(n-1)*N+i] = 0.;
+ for (j=0; j<N; j++) fn[(n-1)*N+i] += w[j] * fn[(n-2)*N+j] * phi((z[i]-(1.-l)*z[j])/l, mu0)/l;
+ }
+ }
+
+ ced[n] = 0.;
+ norm = 0.;
+ for (j=0; j<N; j++) {
+ ced[n] += w[j] * fn[(n-1)*N+j] * arl[j];
+ norm += w[j] * fn[(n-1)*N+j];
+ }
+ ced[n] /= norm;
+ }
+
+ Free(w);
+ Free(z);
+ Free(fn);
+ Free(a);
+ Free(arl);
+
+ return 0;
+}
+
+
+double xte2_arlm_hom(double l, double c, double hs, int df, int q, double mu0, double mu1, int N, double *ced, int subst)
+{ double *fn, *w, *z, *a, *arl, nenner=1., norm=1., arg=0., korr=1.;
+ int i, j, n;
+
+ w = vector(N);
+ z = vector(N);
+ fn = matrix(q+1, N);
+ a = matrix(N,N);
+ arl = vector(N);
+
+ c *= sqrt( l/(2.-l) );
+ hs *= sqrt( l/(2.-l) );
+
+ switch ( subst ) {
+ case IDENTITY: gausslegendre(N, -c, c, z, w); norm = 1.; break;
+ case SIN: gausslegendre(N, -PI/2., PI/2., z, w); norm = 1.; break;
+ case SINH: gausslegendre(N, -1., 1., z, w); norm = sinh(1.); break;
+ case TAN: gausslegendre(N, -PI/4., PI/4., z, w); norm = 1.; break;
+ }
+
+ c /= norm;
+
+ for (i=0;i<N;i++) {
+ for (j=0;j<N;j++) {
+ switch ( subst ) {
+ case IDENTITY: arg = z[j] - (1.-l)*z[i]; korr = 1.; break;
+ case SIN: arg = c*sin(z[j]) - (1.-l)*c*sin(z[i]); korr = c*cos(z[j]); break;
+ case SINH: arg = c*sinh(z[j]) - (1.-l)*c*sinh(z[i]); korr = c*cosh(z[j]); break;
+ case TAN: arg = c*tan(z[j]) - (1.-l)*c*tan(z[i]); korr = c/( cos(z[j])*cos(z[j]) ); break;
+ }
+ a[i*N+j] = -w[j]/l * pdf_t( arg/l - mu1, df) * korr;
+ }
+ ++a[i*N+i];
+ }
+
+ for (j=0;j<N;j++) arl[j] = 1.;
+ LU_solve(a,arl,N);
+
+ /* q == 1 */
+ ced[0] = 1.;
+ for (j=0; j<N; j++) {
+ switch ( subst ) {
+ case IDENTITY: arg = z[j] - (1.-l)*hs; korr = 1.; break;
+ case SIN: arg = c*sin(z[j]) - (1.-l)*hs; korr = c*cos(z[j]); break;
+ case SINH: arg = c*sinh(z[j]) - (1.-l)*hs; korr = c*cosh(z[j]); break;
+ case TAN: arg = c*tan(z[j]) - (1.-l)*hs; korr = c/( cos(z[j])*cos(z[j]) ); break;
+ }
+ ced[0] += w[j]/l * pdf_t( arg/l - mu1, df) * arl[j] * korr;
+ }
+
+ /* density sequence for q > 1 */
+ for (n=1; n<=q-1; n++) {
+ if ( n==1 ) {
+ for (i=0; i<N; i++) {
+ switch ( subst ) {
+ case IDENTITY: arg = z[i]; break;
+ case SIN: arg = c*sin(z[i]); break;
+ case SINH: arg = c*sinh(z[i]); break;
+ case TAN: arg = c*tan(z[i]); break;
+ }
+ fn[0*N+i] = pdf_t( ( arg - (1.-l)*hs )/l - mu0, df)/l;
+ }
+ } else {
+ for (i=0; i<N; i++) {
+ fn[(n-1)*N+i] = 0.;
+ for (j=0; j<N; j++) {
+ switch ( subst ) {
+ case IDENTITY: arg = z[i] - (1.-l)*z[j]; korr = 1.; break;
+ case SIN: arg = c*sin(z[i]) - (1.-l)*c*sin(z[j]); korr = c*cos(z[j]); break;
+ case SINH: arg = c*sinh(z[i]) - (1.-l)*c*sinh(z[j]); korr = c*cosh(z[j]); break;
+ case TAN: arg = c*tan(z[i]) - (1.-l)*c*tan(z[j]); korr = c/( cos(z[j])*cos(z[j]) ); break;
+ }
+ fn[(n-1)*N+i] += w[j] * fn[(n-2)*N+j] * pdf_t( arg/l - mu0, df)/l * korr;
+ }
+ }
+ }
+
+ ced[n] = 0.;
+ nenner = 0.;
+ for (j=0; j<N; j++) {
+ switch ( subst ) {
+ case IDENTITY: korr = 1.; break;
+ case SIN: korr = c*cos(z[j]); break;
+ case SINH: korr = c*cosh(z[j]); break;
+ case TAN: korr = c/( cos(z[j])*cos(z[j]) ); break;
+ }
+ ced[n] += w[j] * fn[(n-1)*N+j] * arl[j] * korr;
+ nenner += w[j] * fn[(n-1)*N+j] * korr;
+ }
+ ced[n] /= nenner;
+ }
+
+ Free(w);
+ Free(z);
+ Free(fn);
+ Free(a);
+ Free(arl);
+
+ return 0;
+}
+
+
+int qm_for_l_and_c(double l, double c) {
+ int qm=20;
+ qm = (int)ceil( 3.141 * c / sqrt(l) );
+ if ( qm < 20 ) qm = 20;
+ /*if ( qm > 1000 ) qm = 1000;*/
+ return qm;
+}
+
+
+/* routines for prerun impact on average ARL, QRL performance */
+
+/* 1. ARL (fixed limits) */
+
+double xe2_iglarl_prerun_MU(double l, double c, double hs, double mu, int pn, int qm, double truncate)
+{ double *w, *z, b, result, dn, sdn;
+ int i, Nlocal;
+
+ w = vector(qm);
+ z = vector(qm);
+ dn = (double)pn;
+ sdn = sqrt(dn);
+ b = -qPHI(truncate/2.)/sdn;
+ gausslegendre(qm, -b, b, z, w);
+ Nlocal = qm_for_l_and_c(l, c);
+ result = 0.;
+ for (i=0; i<qm; i++) result += w[i] * sdn*phi( z[i]*sdn, 0. ) * xe2_iglarl(l, c, hs, z[i]+mu, Nlocal);
+ Free(w);
+ Free(z);
+ return result;
+}
+
+
+double xe2_iglarl_prerun_SIGMA(double l, double c, double hs, double mu, int pn, int qm, double truncate)
+{ double *w, *z, b1, b2, result, ddf;
+ int i, Nlocal;
+
+ w = vector(qm);
+ z = vector(qm);
+ ddf = (double)(pn-1);
+ b1 = sqrt(qCHI( truncate/2., pn-1)/ddf);
+ b2 = sqrt(qCHI(1. - truncate/2., pn-1)/ddf);
+ gausslegendre(qm, b1, b2, z, w);
+ result = 0.;
+ for (i=0; i<qm; i++) {
+ Nlocal = qm_for_l_and_c(l, z[i]*c);
+ result += w[i] * 2.*ddf*z[i]*chi( ddf*z[i]*z[i], pn-1) * xe2_iglarl(l, z[i]*c, hs, mu, Nlocal);
+ }
+ Free(w);
+ Free(z);
+ return result;
+}
+
+
+double xe2_iglarl_prerun_BOTH(double l, double c, double hs, double mu, int pn, int df, int qm1, int qm2, double truncate)
+{ double *w1, *z1, *w2, *z2, b, b1, b2, result, dn, sdn, ddf;
+ int i, j, Nlocal;
+
+ w1 = vector(qm1);
+ z1 = vector(qm1);
+ w2 = vector(qm2);
+ z2 = vector(qm2);
+ dn = (double)pn;
+ sdn = sqrt(dn);
+ b = -qPHI(truncate/2.)/sdn;
+ gausslegendre(qm1, -b, b, z1, w1);
+ ddf = (double)(df);
+ b1 = sqrt(qCHI( truncate/2., df)/ddf);
+ b2 = sqrt(qCHI(1. - truncate/2., df)/ddf);
+ w2 = vector(qm2);
+ z2 = vector(qm2);
+ gausslegendre(qm2, b1, b2, z2, w2);
+ result = 0.;
+ for (j=0; j<qm2; j++) {
+ Nlocal = qm_for_l_and_c(l, z2[j]*c);
+ for (i=0; i<qm1; i++)
+ result += w1[i]*sdn*phi( z1[i]*sdn, 0.) * w2[j]*2.*ddf*z2[j]*chi( ddf*z2[j]*z2[j], df) * xe2_iglarl(l, z2[j]*c, hs, z1[i]+mu, Nlocal);
+ }
+ Free(w1);
+ Free(z1);
+ Free(w2);
+ Free(z2);
+ return result;
+}
+
+
+/* 2. ARL (varying limits and conditional) */
+
+double xe2_arlm_prerun_MU(double l, double c, double hs, int q, double mu0, double mu1, int pn, int mode, int nmax, int qm, double truncate)
+{ double *w, *z, b, result1, result0, dn, sdn, *pair;
+ int i, Nlocal, fahne;
+
+ w = vector(qm);
+ z = vector(qm);
+ pair = vector(2);
+ dn = (double)pn;
+ sdn = sqrt(dn);
+ b = -qPHI(truncate/2.)/sdn;
+ gausslegendre(qm, -b, b, z, w);
+ Nlocal = qm_for_l_and_c(l, c);
+ result1 = 0.;
+ result0 = 0.;
+ for (i=0; i<qm; i++) {
+ fahne = xe2_arlm_special(l, c, hs, q, z[i]+mu0, z[i]+mu1, mode, Nlocal, nmax, pair);
+ if ( fahne!= 0 ) warning("something happened with xe2_arlm_special");
+ result1 += w[i] * sdn*phi( z[i]*sdn, 0.) * pair[1];
+ result0 += w[i] * sdn*phi( z[i]*sdn, 0.) * pair[0];
+ }
+ result1 /= result0;
+ Free(pair);
+ Free(w);
+ Free(z);
+ return result1;
+}
+
+
+double xe2_arlm_prerun_SIGMA(double l, double c, double hs, int q, double mu0, double mu1, int pn, int mode, int nmax, int qm, double truncate)
+{ double *w, *z, b1, b2, result1, result0, ddf, *pair;
+ int i, Nlocal, fahne;
+
+ w = vector(qm);
+ z = vector(qm);
+ pair = vector(2);
+ ddf = (double)(pn-1);
+ b1 = sqrt(qCHI( truncate/2., pn-1)/ddf);
+ b2 = sqrt(qCHI(1. - truncate/2., pn-1)/ddf);
+ gausslegendre(qm, b1, b2, z, w);
+ result1 = 0.;
+ result0 = 0.;
+ for (i=0; i<qm; i++) {
+ Nlocal = qm_for_l_and_c(l, z[i]*c);
+ fahne = xe2_arlm_special(l, z[i]*c, hs, q, mu0, mu1, mode, Nlocal, nmax, pair);
+ if ( fahne!= 0 ) warning("something happened with xe2_arlm_special");
+ result1 += w[i] * 2.*ddf*z[i]*chi( ddf*z[i]*z[i], pn-1) * pair[1];
+ result0 += w[i] * 2.*ddf*z[i]*chi( ddf*z[i]*z[i], pn-1) * pair[0];
+ }
+ result1 /= result0;
+ Free(pair);
+ Free(w);
+ Free(z);
+ return result1;
+}
+
+
+double xe2_arlm_prerun_BOTH(double l, double c, double hs, int q, double mu0, double mu1, int pn, int df, int mode, int nmax, int qm1, int qm2, double truncate)
+{ double *w1, *z1, *w2, *z2, b, b1, b2, result1, result0, dn, sdn, ddf, *pair;
+ int i, j, Nlocal, fahne;
+
+ w1 = vector(qm1);
+ z1 = vector(qm1);
+ w2 = vector(qm2);
+ z2 = vector(qm2);
+ pair = vector(2);
+ dn = (double)pn;
+ sdn = sqrt(dn);
+ b = -qPHI(truncate/2.)/sdn;
+ gausslegendre(qm1, -b, b, z1, w1);
+ ddf = (double)(df);
+ b1 = sqrt(qCHI( truncate/2., df)/ddf);
+ b2 = sqrt(qCHI(1. - truncate/2., df)/ddf);
+ w2 = vector(qm2);
+ z2 = vector(qm2);
+ gausslegendre(qm2, b1, b2, z2, w2);
+ result1 = 0.;
+ result0 = 0.;
+ for (j=0; j<qm2; j++) {
+ Nlocal = qm_for_l_and_c(l, z2[j]*c);
+ for (i=0; i<qm1; i++) {
+ fahne = xe2_arlm_special(l, z2[j]*c, hs, q, z1[i]+mu0, z1[i]+mu1, mode, Nlocal, nmax, pair);
+ if ( fahne!= 0 ) warning("something happened with xe2_arlm_special");
+ result1 += w1[i]*sdn*phi( z1[i]*sdn, 0.) * w2[j]*2.*ddf*z2[j]*chi( ddf*z2[j]*z2[j], df) * pair[1];
+ result0 += w1[i]*sdn*phi( z1[i]*sdn, 0.) * w2[j]*2.*ddf*z2[j]*chi( ddf*z2[j]*z2[j], df) * pair[0];
+ }
+ }
+ result1 /= result0;
+ Free(pair);
+ Free(w1);
+ Free(z1);
+ Free(w2);
+ Free(z2);
+ return result1;
+}
+
+
+
+/* some helper functions */
+
+
+double xe2_sf_deluxe(double l, double c, double hs, double mu, int N, int nmax, double BOUND, double *p0, int *nstop, double *rho)
+{ double *Sm, *Pn, *w, *z, mn_minus=1., mn_plus=0., ratio;
+ int i, j, n;
+
+ c *= sqrt( l/(2.-l) );
+ hs *= sqrt( l/(2.-l) );
+ Sm = matrix(N, N);
+ w = vector(N);
+ z = vector(N);
+ Pn = matrix(nmax, N);
+ gausslegendre(N, -c, c, z, w);
+
+ *nstop = 0;
+
+ for (i=0; i<N; i++)
+ for (j=0; j<N; j++)
+ Sm[i*N+j] = w[j]/l * phi( (z[j]-(1.-l)*z[i])/l, mu);
+
+ for (n=1; n<=nmax; n++) {
+ if ( n==1 )
+ for (i=0; i<N; i++)
+ Pn[i] = PHI( (c-(1.-l)*z[i])/l, mu) - PHI( (-c-(1.-l)*z[i])/l, mu);
+ else
+ for (i=0; i<N; i++) {
+ Pn[(n-1)*N+i] = 0.;
+ for (j=0; j<N; j++)
+ Pn[(n-1)*N+i] += Sm[i*N+j] * Pn[(n-2)*N+j];
+ }
+
+ if ( n==1 )
+ p0[0] = PHI( (c-(1.-l)*hs)/l, mu) - PHI( (-c-(1.-l)*hs)/l, mu);
+ else {
+ p0[n-1] = 0.;
+ for (j=0; j<N; j++)
+ p0[n-1] += w[j]/l * phi( (z[j]-(1.-l)*hs)/l, mu) * Pn[(n-2)*N+j];
+ }
+
+ mn_minus = 1.; mn_plus = 0.;
+ if ( n>1 ) {
+ for (i=0;i<N;i++) {
+ if (Pn[(n-2)*N+i]==0)
+ if (Pn[(n-1)*N+i]==0) ratio = 0.;
+ else ratio = 1.;
+ else ratio = Pn[(n-1)*N+i]/Pn[(n-2)*N+i];
+ if ( ratio<mn_minus ) mn_minus = ratio;
+ if ( ratio>mn_plus ) mn_plus = ratio;
+ }
+ *rho = (mn_minus + mn_plus)/2.;
+ if ( fabs(mn_plus - mn_minus) < BOUND ) {
+ *nstop = n;
+ n = nmax + 1;
+ }
+ }
+ }
+
+ Free(Pn);
+ Free(z);
+ Free(w);
+ Free(Sm);
+
+ return 0;
+}
+
+
+double xe2_sfm_simple(double l, double c, double hs, int q, double mu0, double mu1, int mode, int N, int nmax, double *p0)
+{ double *Smatrix, *fn, *w, *z, dn, rn, cn, rn0, cn0, delta=0., nn, fSt, aSt;
+ int i, j, n;
+
+ fSt = 0.5;
+ aSt = ( -2./log10(1.-fSt) - 1.)/19.;
+
+ c *= sqrt( l/(2.-l) );
+ hs *= sqrt( l/(2.-l) );
+ if ( mode==fir || mode==both ) delta = 2.*hs;
+
+ Smatrix = matrix(N, N);
+ w = vector(N);
+ z = vector(N);
+ fn = matrix(nmax, N);
+
+ gausslegendre(N, -c, c, z, w);
+
+ rn = 1.; cn = 0.; rn0 = 1., cn0 = 0.;
+
+ /* in-control, i. e. n<=q-1 */
+
+ for (n=1; n<=q-1; n++) {
+ nn = (double) n;
+
+ /* determine c_n and r_n, n=1,2,...,q-1 */
+ switch ( mode ) {
+ case vacl: rn = sqrt( 1. - pow(1.-l,2.*nn) );
+ break;
+ case fir: dn = delta*pow(1.-l,nn);
+ rn = 1. - dn/(2.*c);
+ cn = dn/2.;
+ break;
+ case both: dn = delta*pow(1.-l,nn);
+ rn = sqrt( 1. - pow(1.-l,2.*nn) ) - dn/(2.*c);
+ cn = dn/2.;
+ break;
+ case steiner: rn = sqrt(1.-pow(1.-l,2.*nn))*(1.-pow(1.-fSt,1.+aSt*(nn-1.)));
+ break;
+ }
+
+ /* determine f_n, n=1,2,...,q-1 */
+ if ( n==1 ) {
+ for (i=0; i<N; i++)
+ if ( mode==stat )
+ fn[0*N+i] = 1./sqrt(l/(2.-l))*phi( (cn+rn*z[i])/sqrt(l/(2.-l)),mu0);
+ else
+ fn[0*N+i] = rn/l * phi( (cn+rn*z[i]-(1.-l)*hs)/l,mu0);
+ }
+ else {
+ for (i=0; i<N; i++) {
+ fn[(n-1)*N+i] = 0.;
+ for (j=0; j<N; j++) {
+ fn[(n-1)*N+i] += w[j]*fn[(n-2)*N+j]*rn/l*phi((cn+rn*z[i]-(1.-l)*(cn0+rn0*z[j]))/l,mu0);
+ }
+ }
+ }
+
+ /* determine P(L>n), n=1,2,...,q-1 */
+ p0[n-1] = 0.;
+ for (i=0; i<N; i++) p0[n-1] += w[i] * fn[(n-1)*N+i];
+
+ /* weights and nodes w.r.t. O_n become w. a. n. w.r.t. O_n-1 */
+ cn0 = cn; rn0 = rn;
+ }
+
+ /* out-of-control, i.e. t>=q */
+
+ for (n=q; n<=nmax; n++) {
+ nn = (double) n;
+
+ /* determine c_n and r_n, n=q,q+1,... */
+ switch ( mode ) {
+ case vacl: rn = sqrt( 1. - pow(1.-l,2.*nn) );
+ break;
+ case fir: dn = delta*pow(1.-l,nn);
+ rn = 1. - dn/(2.*c);
+ cn = dn/2.;
+ break;
+ case both: dn = delta*pow(1.-l,nn);
+ rn = sqrt( 1. - pow(1.-l,2.*nn) ) - dn/(2.*c);
+ cn = dn/2.;
+ break;
+ case steiner: rn = sqrt(1.-pow(1.-l,2.*nn))*(1.-pow(1.-fSt,1.+aSt*(nn-1.)));
+ break;
+ }
+
+ /* determine f_n, n=q,q+1,... */
+ if ( n==1 ) {
+ for (i=0; i<N; i++)
+ if ( mode==stat )
+ fn[0*N+i] = 1./sqrt(l/(2.-l))*phi( (cn+rn*z[i])/sqrt(l/(2.-l)),mu1);
+ else
+ fn[0*N+i] = rn/l * phi( (cn+rn*z[i]-(1.-l)*hs)/l,mu1);
+ }
+ else {
+ for (i=0; i<N; i++) {
+ fn[(n-1)*N+i] = 0.;
+ for (j=0; j<N; j++)
+ fn[(n-1)*N+i] += w[j]*fn[(n-2)*N+j]*rn/l*phi( (cn+rn*z[i]-(1.-l)*(cn0+rn0*z[j]))/l,mu1);
+ }
+ }
+
+ /* determine P(L>n), n=1,2,...,q-1 */
+ p0[n-1] = 0.;
+ for (i=0; i<N; i++) p0[n-1] += w[i] * fn[(n-1)*N+i];
+
+ /* weights and nodes w.r.t. O_n become w. a. n. w.r.t. O_n-1 */
+ cn0 = cn; rn0 = rn;
+ }
+
+ Free(Smatrix);
+ Free(w);
+ Free(z);
+ Free(fn);
+
+ return 0;
+}
+
+
+double xe2_sfm_deluxe(double l, double c, double hs, int q, double mu0, double mu1, int mode, int N, int nmax, double BOUND, double *p0, int *nstop, double *rho)
+{ double *Smatrix, *fn, *w, *z, dn, rn, cn, rn0, cn0, delta=0., nn, fSt, aSt, mn_minus, mn_plus, ratio;
+ int i, j, n;
+
+ fSt = 0.5;
+ aSt = ( -2./log10(1.-fSt) - 1.)/19.;
+ c *= sqrt( l/(2.-l) );
+ hs *= sqrt( l/(2.-l) );
+ if ( mode==fir || mode==both ) delta = 2.*hs;
+ Smatrix = matrix(N, N);
+ w = vector(N);
+ z = vector(N);
+ fn = matrix(nmax, N);
+ gausslegendre(N, -c, c, z, w);
+ *nstop = 0;
+
+ rn = 1.; cn = 0.; rn0 = 1., cn0 = 0.;
+
+ /* in-control, i. e. n<=q-1 */
+
+ for (n=1; n<=q-1; n++) {
+ nn = (double) n;
+
+ /* determine c_n and r_n, n=1,2,...,q-1 */
+ switch ( mode ) {
+ case vacl: rn = sqrt( 1. - pow(1.-l,2.*nn) );
+ break;
+ case fir: dn = delta*pow(1.-l,nn);
+ rn = 1. - dn/(2.*c);
+ cn = dn/2.;
+ break;
+ case both: dn = delta*pow(1.-l,nn);
+ rn = sqrt( 1. - pow(1.-l,2.*nn) ) - dn/(2.*c);
+ cn = dn/2.;
+ break;
+ case steiner: rn = sqrt(1.-pow(1.-l,2.*nn))*(1.-pow(1.-fSt,1.+aSt*(nn-1.)));
+ break;
+ }
+
+ /* determine f_n, n=1,2,...,q-1 */
+ if ( n==1 ) {
+ for (i=0; i<N; i++)
+ if ( mode==stat )
+ fn[0*N+i] = 1./sqrt(l/(2.-l))*phi( (cn+rn*z[i])/sqrt(l/(2.-l)), mu0);
+ else
+ fn[0*N+i] = rn/l * phi( (cn+rn*z[i]-(1.-l)*hs)/l, mu0);
+ }
+ else {
+ for (i=0; i<N; i++) {
+ fn[(n-1)*N+i] = 0.;
+ for (j=0; j<N; j++) {
+ fn[(n-1)*N+i] += w[j]*fn[(n-2)*N+j]*rn/l*phi((cn+rn*z[i]-(1.-l)*(cn0+rn0*z[j]))/l, mu0);
+ }
+ }
+ }
+
+ /* determine P(L>n), n=1,2,...,q-1 */
+ p0[n-1] = 0.;
+ for (i=0; i<N; i++) p0[n-1] += w[i] * fn[(n-1)*N+i];
+
+ /* weights and nodes w.r.t. O_n become w. a. n. w.r.t. O_n-1 */
+ cn0 = cn; rn0 = rn;
+ }
+
+ /* out-of-control, i.e. t>=q */
+
+ for (n=q; n<=nmax; n++) {
+ nn = (double) n;
+
+ /* determine c_n and r_n, n=q,q+1,... */
+ switch ( mode ) {
+ case vacl: rn = sqrt( 1. - pow(1.-l,2.*nn) );
+ break;
+ case fir: dn = delta*pow(1.-l,nn);
+ rn = 1. - dn/(2.*c);
+ cn = dn/2.;
+ break;
+ case both: dn = delta*pow(1.-l,nn);
+ rn = sqrt( 1. - pow(1.-l,2.*nn) ) - dn/(2.*c);
+ cn = dn/2.;
+ break;
+ case steiner: rn = sqrt(1.-pow(1.-l,2.*nn))*(1.-pow(1.-fSt,1.+aSt*(nn-1.)));
+ break;
+ }
+
+ /* determine f_n, n=q,q+1,... */
+ if ( n==1 ) {
+ for (i=0; i<N; i++)
+ if ( mode==stat )
+ fn[0*N+i] = 1./sqrt(l/(2.-l))*phi( (cn+rn*z[i])/sqrt(l/(2.-l)), mu1);
+ else
+ fn[0*N+i] = rn/l * phi( (cn+rn*z[i]-(1.-l)*hs)/l, mu1);
+ }
+ else {
+ for (i=0; i<N; i++) {
+ fn[(n-1)*N+i] = 0.;
+ for (j=0; j<N; j++)
+ fn[(n-1)*N+i] += w[j]*fn[(n-2)*N+j]*rn/l*phi( (cn+rn*z[i]-(1.-l)*(cn0+rn0*z[j]))/l, mu1);
+ }
+ }
+
+ /* determine P(L>n), n=1,2,...,q-1 */
+ p0[n-1] = 0.;
+ for (i=0; i<N; i++) p0[n-1] += w[i] * fn[(n-1)*N+i];
+
+ /* weights and nodes w.r.t. O_n become w. a. n. w.r.t. O_n-1 */
+ cn0 = cn; rn0 = rn;
+
+ mn_minus = 1.; mn_plus = 0.;
+ if ( n>q ) {
+ for (i=0;i<N;i++) {
+ if (fn[(n-2)*N+i]==0)
+ if (fn[(n-1)*N+i]==0) ratio = 0.; else ratio = 1.;
+ else ratio = fn[(n-1)*N+i]/fn[(n-2)*N+i];
+ if ( ratio<mn_minus ) mn_minus = ratio;
+ if ( ratio>mn_plus ) mn_plus = ratio;
+ }
+ *rho = (mn_minus + mn_plus)/2.;
+ if ( fabs(mn_plus - mn_minus) < BOUND ) {
+ *nstop = n;
+ n = nmax + 1;
+ }
+ }
+ }
+
+ Free(Smatrix);
+ Free(w);
+ Free(z);
+ Free(fn);
+
+ return 0;
+}
+
+
+
+/* Survival function P(L>n) */
+
+
+double xe2_sf_prerun_MU_deluxe(double l, double c, double hs, double mu, int pn, int nmax, int qm, double truncate, double BOUND, double *p0)
+{ double *ww, *zz, b, dn, sdn, *SF, rho;
+ int i, m, n, nstop, Nlocal;
+
+ SF = vector(nmax);
+ ww = vector(qm);
+ zz = vector(qm);
+
+ dn = (double)pn;
+ sdn = sqrt(dn);
+ b = -qPHI(truncate/2.)/sdn;
+ gausslegendre(qm, -b, b, zz, ww);
+ for (i=0; i<qm; i++) ww[i] *= sdn*phi( zz[i]*sdn, 0. );
+
+ for (n=0; n<nmax; n++) p0[n] = 0.;
+
+ Nlocal = qm_for_l_and_c(l, c);
+ for (i=0; i<qm; i++) {
+ m = xe2_sf_deluxe(l, c, hs, zz[i]+mu, Nlocal, nmax, BOUND, SF, &nstop, &rho);
+ if ( m != 0 ) warning("trouble with internal [package spc] function xe2_sf_deluxe");
+ if ( nstop > 0 ) {
+ for (n=0; n<nstop; n++) p0[n] += ww[i] * SF[n];
+ for (n=nstop; n<nmax; n++) p0[n] += ww[i] * SF[nstop-1] * pow(rho, n-nstop+1);
+ } else {
+ for (n=0; n<nmax; n++) p0[n] += ww[i] * SF[n];
+ }
+ }
+
+ Free(ww);
+ Free(zz);
+ Free(SF);
+
+ return 0;
+}
+
+
+double xe2_sf_prerun_MU(double l, double c, double hs, double mu, int pn, int nmax, int qm, double truncate, double *p0)
+{ double *ww, *zz, b, dn, sdn, *SF;
+ int i, m, n, Nlocal;
+
+ SF = vector(nmax);
+ ww = vector(qm);
+ zz = vector(qm);
+
+ dn = (double)pn;
+ sdn = sqrt(dn);
+ b = -qPHI(truncate/2.)/sdn;
+ gausslegendre(qm, -b, b, zz, ww);
+ for (i=0; i<qm; i++) ww[i] *= sdn*phi( zz[i]*sdn, 0. );
+
+ for (n=0; n<nmax; n++) p0[n] = 0.;
+
+ Nlocal = qm_for_l_and_c(l, c);
+ for (i=0; i<qm; i++) {
+ m = xe2_sf(l, c, hs, zz[i]+mu, Nlocal, nmax, SF);
+ if ( m != 0 ) warning("trouble with internal [package spc] function xe2_sf");
+ for (n=0; n<nmax; n++) p0[n] += ww[i] * SF[n];
+ }
+
+ Free(ww);
+ Free(zz);
+ Free(SF);
+
+ return 0;
+}
+
+
+double xe2_sfm_prerun_MU_deluxe(double l, double c, double hs, int q, double mu0, double mu1, int pn, int mode, int nmax, int qm, double truncate, double BOUND, double *p0)
+{ double *ww, *zz, b, dn, sdn, *SF, rho;
+ int i, m, n, nstop, Nlocal;
+
+ SF = vector(nmax);
+ ww = vector(qm);
+ zz = vector(qm);
+
+ dn = (double)pn;
+ sdn = sqrt(dn);
+ b = -qPHI(truncate/2.)/sdn;
+ gausslegendre(qm, -b, b, zz, ww);
+ for (i=0; i<qm; i++) ww[i] *= sdn*phi( zz[i]*sdn, 0. );
+
+ for (n=0; n<nmax; n++) p0[n] = 0.;
+
+ Nlocal = qm_for_l_and_c(l, c);
+ for (i=0; i<qm; i++) {
+ m = xe2_sfm_deluxe(l, c, hs, q, zz[i]+mu0, zz[i]+mu1, mode, Nlocal, nmax, BOUND, SF, &nstop, &rho);
+ if ( m != 0 ) warning("trouble with internal [package spc] function xe2_sf_deluxe");
+ if ( nstop > 0 ) {
+ for (n=0; n<nstop; n++) p0[n] += ww[i] * SF[n];
+ for (n=nstop; n<nmax; n++) p0[n] += ww[i] * SF[nstop-1] * pow(rho, n-nstop+1);
+ } else {
+ for (n=0; n<nmax; n++) p0[n] += ww[i] * SF[n];
+ }
+ }
+
+ if ( q > 1 ) for (n=q-1; n<nmax; n++) p0[n] /= p0[q-2];
+
+ Free(ww);
+ Free(zz);
+ Free(SF);
+
+ return 0;
+}
+
+
+double xe2_sfm_prerun_MU(double l, double c, double hs, int q, double mu0, double mu1, int pn, int mode, int nmax, int qm, double truncate, double *p0)
+{ double *ww, *zz, b, dn, sdn, *SF;
+ int i, m, n, Nlocal;
+
+ SF = vector(nmax);
+ ww = vector(qm);
+ zz = vector(qm);
+
+ dn = (double)pn;
+ sdn = sqrt(dn);
+ b = -qPHI(truncate/2.)/sdn;
+ gausslegendre(qm, -b, b, zz, ww);
+ for (i=0; i<qm; i++) ww[i] *= sdn*phi( zz[i]*sdn, 0. );
+
+ for (n=0; n<nmax; n++) p0[n] = 0.;
+
+ Nlocal = qm_for_l_and_c(l, c);
+ for (i=0; i<qm; i++) {
+ m = xe2_sfm_simple(l, c, hs, q, zz[i]+mu0, zz[i]+mu1, mode, Nlocal, nmax, SF);
+ if ( m != 0 ) warning("trouble with internal [package spc] function xe2_sfm");
+ for (n=0; n<nmax; n++) p0[n] += ww[i] * SF[n];
+ }
+
+ if ( q > 1 ) for (n=q-1; n<nmax; n++) p0[n] /= p0[q-2];
+
+ Free(ww);
+ Free(zz);
+ Free(SF);
+
+ return 0;
+}
+
+
+double xe2_sf_prerun_SIGMA_deluxe(double l, double c, double hs, double mu, int pn, int nmax, int qm, double truncate, double BOUND, double *p0)
+{ double *ww, *zz, b1, b2, ddf, *SF, rho;
+ int i, m, n, nstop, Nlocal;
+
+ SF = vector(nmax);
+ ww = vector(qm);
+ zz = vector(qm);
+
+ ddf = (double)(pn-1);
+ b1 = sqrt(qCHI( truncate/2., pn-1)/ddf);
+ b2 = sqrt(qCHI(1. - truncate/2., pn-1)/ddf);
+ gausslegendre(qm, b1, b2, zz, ww);
+ for (i=0; i<qm; i++) ww[i] *= 2.*ddf*zz[i] * chi( ddf*zz[i]*zz[i], pn-1);
+
+ for (n=0; n<nmax; n++) p0[n] = 0.;
+
+ for (i=0; i<qm; i++) {
+ Nlocal = qm_for_l_and_c(l, zz[i]*c);
+ m = xe2_sf_deluxe(l, zz[i]*c, hs, mu, Nlocal, nmax, BOUND, SF, &nstop, &rho);
+ if ( m != 0 ) warning("trouble with internal [package spc] function xe2_sf_deluxe");
+ if ( nstop > 0 ) {
+ for (n=0; n<nstop; n++) p0[n] += ww[i] * SF[n];
+ for (n=nstop; n<nmax; n++) p0[n] += ww[i] * SF[nstop-1] * pow(rho, n-nstop+1);
+ } else {
+ for (n=0; n<nmax; n++) p0[n] += ww[i] * SF[n];
+ }
+ }
+
+ Free(ww);
+ Free(zz);
+ Free(SF);
+
+ return 0;
+}
+
+
+double xe2_sf_prerun_SIGMA(double l, double c, double hs, double mu, int pn, int nmax, int qm, double truncate, double *p0)
+{ double *ww, *zz, b1, b2, ddf, *SF;
+ int i, m, n, Nlocal;
+
+ SF = vector(nmax);
+ ww = vector(qm);
+ zz = vector(qm);
+
+ ddf = (double)(pn-1);
+ b1 = sqrt(qCHI( truncate/2., pn-1)/ddf);
+ b2 = sqrt(qCHI(1. - truncate/2., pn-1)/ddf);
+ gausslegendre(qm, b1, b2, zz, ww);
+ for (i=0; i<qm; i++) ww[i] *= 2.*ddf*zz[i] * chi( ddf*zz[i]*zz[i], pn-1);
+
+ for (n=0; n<nmax; n++) p0[n] = 0.;
+
+ for (i=0; i<qm; i++) {
+ Nlocal = qm_for_l_and_c(l, zz[i]*c);
+ m = xe2_sf(l, zz[i]*c, hs, mu, Nlocal, nmax, SF);
+ if ( m != 0 ) warning("trouble with internal [package spc] function xe2_sf");
+ for (n=0; n<nmax; n++) p0[n] += ww[i] * SF[n];
+ }
+
+ Free(ww);
+ Free(zz);
+ Free(SF);
+
+ return 0;
+}
+
+
+double xe2_sfm_prerun_SIGMA_deluxe(double l, double c, double hs, int q, double mu0, double mu1, int pn, int mode, int nmax, int qm, double truncate, double BOUND, double *p0)
+{ double *ww, *zz, b1, b2, ddf, *SF, rho;
+ int i, m, n, nstop, Nlocal;
+
+ SF = vector(nmax);
+ ww = vector(qm);
+ zz = vector(qm);
+
+ ddf = (double)(pn-1);
+ b1 = sqrt(qCHI( truncate/2., pn-1)/ddf);
+ b2 = sqrt(qCHI(1. - truncate/2., pn-1)/ddf);
+ gausslegendre(qm, b1, b2, zz, ww);
+ for (i=0; i<qm; i++) ww[i] *= 2.*ddf*zz[i] * chi( ddf*zz[i]*zz[i], pn-1);
+
+ for (n=0; n<nmax; n++) p0[n] = 0.;
+
+ for (i=0; i<qm; i++) {
+ Nlocal = qm_for_l_and_c(l, zz[i]*c);
+ m = xe2_sfm_deluxe(l, zz[i]*c, hs, q, mu0, mu1, mode, Nlocal, nmax, BOUND, SF, &nstop, &rho);
+ if ( m != 0 ) warning("trouble with internal [package spc] function xe2_sfm_deluxe");
+ if ( nstop > 0 ) {
+ for (n=0; n<nstop; n++) p0[n] += ww[i] * SF[n];
+ for (n=nstop; n<nmax; n++) p0[n] += ww[i] * SF[nstop-1] * pow(rho, n-nstop+1);
+ } else {
+ for (n=0; n<nmax; n++) p0[n] += ww[i] * SF[n];
+ }
+ }
+
+ if ( q > 1 ) for (n=q-1; n<nmax; n++) p0[n] /= p0[q-2];
+
+ Free(ww);
+ Free(zz);
+ Free(SF);
+
+ return 0;
+}
+
+
+double xe2_sfm_prerun_SIGMA(double l, double c, double hs, int q, double mu0, double mu1, int pn, int mode, int nmax, int qm, double truncate, double *p0)
+{ double *ww, *zz, b1, b2, ddf, *SF;
+ int i, m, n, Nlocal;
+
+ SF = vector(nmax);
+ ww = vector(qm);
+ zz = vector(qm);
+
+ ddf = (double)(pn-1);
+ b1 = sqrt(qCHI( truncate/2., pn-1)/ddf);
+ b2 = sqrt(qCHI(1. - truncate/2., pn-1)/ddf);
+ gausslegendre(qm, b1, b2, zz, ww);
+ for (i=0; i<qm; i++) ww[i] *= 2.*ddf*zz[i] * chi( ddf*zz[i]*zz[i], pn-1);
+
+ for (n=0; n<nmax; n++) p0[n] = 0.;
+
+ for (i=0; i<qm; i++) {
+ Nlocal = qm_for_l_and_c(l, zz[i]*c);
+ m = xe2_sfm_simple(l, zz[i]*c, hs, q, mu0, mu1, mode, Nlocal, nmax, SF);
+ if ( m != 0 ) warning("trouble with internal [package spc] function xe2_sfm");
+ for (n=0; n<nmax; n++) p0[n] += ww[i] * SF[n];
+ }
+
+ if ( q > 1 ) for (n=q-1; n<nmax; n++) p0[n] /= p0[q-2];
+
+ Free(ww);
+ Free(zz);
+ Free(SF);
+
+ return 0;
+}
+
+
+double xe2_sf_prerun_BOTH_deluxe(double l, double c, double hs, double mu, int pn, int df, int nmax, int qm1, int qm2, double truncate, double BOUND, double *p0)
+{ double *ww1, *zz1, *ww2, *zz2, b, b1, b2, dn, sdn, ddf, *SF, rho;
+ int i, j, m, n, nstop, Nlocal;
+
+ SF = vector(nmax);
+ ww1 = vector(qm1);
+ zz1 = vector(qm1);
+ ww2 = vector(qm2);
+ zz2 = vector(qm2);
+
+ dn = (double)pn;
+ sdn = sqrt(dn);
+ b = -qPHI(truncate/2.)/sdn;
+ gausslegendre(qm1, -b, b, zz1, ww1);
+ for (i=0; i<qm1; i++) ww1[i] *= sdn * phi( zz1[i]*sdn, 0.);
+
+ ddf = (double)(df);
+ b1 = sqrt(qCHI( truncate/2., df)/ddf);
+ b2 = sqrt(qCHI(1. - truncate/2., df)/ddf);
+ gausslegendre(qm2, b1, b2, zz2, ww2);
+ for (j=0; j<qm2; j++) ww2[j] *= 2.*ddf*zz2[j] * chi( ddf*zz2[j]*zz2[j], df);
+
+ for (n=0; n<nmax; n++) p0[n] = 0.;
+
+ for (i=0; i<qm1; i++) {
+ for (j=0; j<qm2; j++) {
+ Nlocal = qm_for_l_and_c(l, zz2[j]*c);
+ m = xe2_sf_deluxe(l, zz2[j]*c, hs, zz1[i]+mu, Nlocal, nmax, BOUND, SF, &nstop, &rho);
+ if ( m != 0 ) warning("trouble with internal [package spc] function xe2_sf_deluxe");
+ if ( nstop > 0 ) {
+ for (n=0; n<nstop; n++) p0[n] += ww1[i] * ww2[j] * SF[n];
+ for (n=nstop; n<nmax; n++) p0[n] += ww1[i] * ww2[j] * SF[nstop-1] * pow(rho, n-nstop+1);
+ } else {
+ for (n=0; n<nmax; n++) p0[n] += ww1[i] * ww2[j] * SF[n];
+ }
+ }
+ }
+
+ Free(ww1);
+ Free(zz1);
+ Free(ww2);
+ Free(zz2);
+ Free(SF);
+
+ return 0;
+}
+
+
+double xe2_sf_prerun_BOTH(double l, double c, double hs, double mu, int pn, int df, int nmax, int qm1, int qm2, double truncate, double *p0)
+{ double *ww1, *zz1, *ww2, *zz2, b, b1, b2, dn, sdn, ddf, *SF;
+ int i, j, m, n, Nlocal;
+
+ SF = vector(nmax);
+ ww1 = vector(qm1);
+ zz1 = vector(qm1);
+ ww2 = vector(qm2);
+ zz2 = vector(qm2);
+
+ dn = (double)pn;
+ sdn = sqrt(dn);
+ b = -qPHI(truncate/2.)/sdn;
+ gausslegendre(qm1, -b, b, zz1, ww1);
+ for (i=0; i<qm1; i++) ww1[i] *= sdn * phi( zz1[i]*sdn, 0.);
+
+ ddf = (double)(df);
+ b1 = sqrt(qCHI( truncate/2., df)/ddf);
+ b2 = sqrt(qCHI(1. - truncate/2., df)/ddf);
+ gausslegendre(qm2, b1, b2, zz2, ww2);
+ for (j=0; j<qm2; j++) ww2[j] *= 2.*ddf*zz2[j] * chi( ddf*zz2[j]*zz2[j], df);
+
+ for (n=0; n<nmax; n++) p0[n] = 0.;
+
+ for (i=0; i<qm1; i++) {
+ for (j=0; j<qm2; j++) {
+ Nlocal = qm_for_l_and_c(l, zz2[j]*c);
+ m = xe2_sf(l, zz2[j]*c, hs, zz1[i]+mu, Nlocal, nmax, SF);
+ if ( m != 0 ) warning("trouble with internal [package spc] function xe2_sf");
+ for (n=0; n<nmax; n++) p0[n] += ww1[i] * ww2[j] * SF[n];
+ }
+ }
+
+ Free(ww1);
+ Free(zz1);
+ Free(ww2);
+ Free(zz2);
+ Free(SF);
+
+ return 0;
+}
+
+
+
+double xe2_sfm_prerun_BOTH_deluxe(double l, double c, double hs, int q, double mu0, double mu1, int pn, int df, int mode, int nmax, int qm1, int qm2, double truncate, double BOUND, double *p0)
+{ double *ww1, *zz1, *ww2, *zz2, b, b1, b2, dn, sdn, ddf, *SF, rho;
+ int i, j, m, n, nstop, Nlocal;
+
+ SF = vector(nmax);
+ ww1 = vector(qm1);
+ zz1 = vector(qm1);
+ ww2 = vector(qm2);
+ zz2 = vector(qm2);
+
+ dn = (double)pn;
+ sdn = sqrt(dn);
+ b = -qPHI(truncate/2.)/sdn;
+ gausslegendre(qm1, -b, b, zz1, ww1);
+ for (i=0; i<qm1; i++) ww1[i] *= sdn * phi( zz1[i]*sdn, 0.);
+
+ ddf = (double)(df);
+ b1 = sqrt(qCHI( truncate/2., df)/ddf);
+ b2 = sqrt(qCHI(1. - truncate/2., df)/ddf);
+ gausslegendre(qm2, b1, b2, zz2, ww2);
+ for (j=0; j<qm2; j++) ww2[j] *= 2.*ddf*zz2[j] * chi( ddf*zz2[j]*zz2[j], df);
+
+ for (n=0; n<nmax; n++) p0[n] = 0.;
+
+ for (i=0; i<qm1; i++) {
+ for (j=0; j<qm2; j++) {
+ Nlocal = qm_for_l_and_c(l, zz2[j]*c);
+ m = xe2_sfm_deluxe(l, zz2[j]*c, hs, q, zz1[i]+mu0, zz1[i]+mu1, mode, Nlocal, nmax, BOUND, SF, &nstop, &rho);
+ if ( m != 0 ) warning("trouble with internal [package spc] function xe2_sfm_deluxe");
+ if ( nstop > 0 ) {
+ for (n=0; n<nstop; n++) p0[n] += ww1[i] * ww2[j] * SF[n];
+ for (n=nstop; n<nmax; n++) p0[n] += ww1[i] * ww2[j] * SF[nstop-1] * pow(rho, n-nstop+1);
+ } else {
+ for (n=0; n<nmax; n++) p0[n] += ww1[i] * ww2[j] * SF[n];
+ }
+ }
+ }
+
+ if ( q > 1 ) for (n=q-1; n<nmax; n++) p0[n] /= p0[q-2];
+
+ Free(ww1);
+ Free(zz1);
+ Free(ww2);
+ Free(zz2);
+ Free(SF);
+
+ return 0;
+}
+
+
+double xe2_sfm_prerun_BOTH(double l, double c, double hs, int q, double mu0, double mu1, int pn, int df, int mode, int nmax, int qm1, int qm2, double truncate, double *p0)
+{ double *ww1, *zz1, *ww2, *zz2, b, b1, b2, dn, sdn, ddf, *SF;
+ int i, j, m, n, Nlocal;
+
+ SF = vector(nmax);
+ ww1 = vector(qm1);
+ zz1 = vector(qm1);
+ ww2 = vector(qm2);
+ zz2 = vector(qm2);
+
+ dn = (double)pn;
+ sdn = sqrt(dn);
+ b = -qPHI(truncate/2.)/sdn;
+ gausslegendre(qm1, -b, b, zz1, ww1);
+ for (i=0; i<qm1; i++) ww1[i] *= sdn * phi( zz1[i]*sdn, 0.);
+
+ ddf = (double)(df);
+ b1 = sqrt(qCHI( truncate/2., df)/ddf);
+ b2 = sqrt(qCHI(1. - truncate/2., df)/ddf);
+ gausslegendre(qm2, b1, b2, zz2, ww2);
+ for (j=0; j<qm2; j++) ww2[j] *= 2.*ddf*zz2[j] * chi( ddf*zz2[j]*zz2[j], df);
+
+ for (n=0; n<nmax; n++) p0[n] = 0.;
+
+ for (i=0; i<qm1; i++) {
+ for (j=0; j<qm2; j++) {
+ Nlocal = qm_for_l_and_c(l, zz2[j]*c);
+ m = xe2_sfm_simple(l, zz2[j]*c, hs, q, zz1[i]+mu0, zz1[i]+mu1, mode, Nlocal, nmax, SF);
+ if ( m != 0 ) warning("trouble with internal [package spc] function xe2_sfm");
+ for (n=0; n<nmax; n++) p0[n] += ww1[i] * ww2[j] * SF[n];
+ }
+ }
+
+ if ( q > 1 ) for (n=q-1; n<nmax; n++) p0[n] /= p0[q-2];
+
+ Free(ww1);
+ Free(zz1);
+ Free(ww2);
+ Free(zz2);
+ Free(SF);
+
+ return 0;
+}
+
+
+/* quantile function */
+
+
+double xe2_Wq_prerun_MU_deluxe(double l, double c, double p, double hs, double mu, int pn, int nmax, int qm, double truncate, double BOUND)
+{ double *ww, *zz, b, dn, sdn, *SF, *p0, rho, *rhomany, *SFlast, Lp=-1., sf_level_adj;
+ int i, j, n, nstop, nstop_, nn, nsm, qnspecial=0, Nlocal;
+
+ p0 = vector(nmax);
+ SF = vector(nmax);
+
+ rhomany = vector(qm);
+ SFlast = vector(qm);
+ ww = vector(qm);
+ zz = vector(qm);
+
+ dn = (double)pn;
+ sdn = sqrt(dn);
+ b = -qPHI(truncate/2.)/sdn;
+ gausslegendre(qm, -b, b, zz, ww);
+ for (i=0; i<qm; i++) ww[i] *= sdn*phi( zz[i]*sdn, 0. );
+
+ Nlocal = qm_for_l_and_c(l, c);
+
+ qnspecial = (qm+1) / 2;
+
+ j = xe2_sf_deluxe(l, c, hs, zz[qnspecial]+mu, Nlocal, nmax, BOUND, SF, &nsm, &rho);
+ if ( j != 0 ) warning("trouble with internal [package spc] function xe2_sf_deluxe");
+ n = nsm;
+
+ if ( nsm < 1 ) { /* did not converge yet -- should be the rare case */
+ nn = nmax;
+ warning("The geometric tail approximation might not work.");
+ } else {
+ nstop = nsm;
+
+ j = xe2_sf_deluxe(l, c, hs, zz[qnspecial+1]+mu, Nlocal, nmax, BOUND, SF, &nstop_, &rho);
+ if ( j != 0 ) warning("trouble with internal [package spc] function xe2_sf_deluxe");
+ if ( nstop_ > nsm ) nsm = nstop_;
+ if ( nstop_ < 1) nsm = nmax;
+ if ( nstop_ >= nstop && nsm<nmax ) {
+ i = 1;
+ while ( nstop_ >= nstop && nsm<nmax ) {
+ nstop = nstop_;
+ i++;
+ j = xe2_sf_deluxe(l, c, hs, zz[qnspecial+i]+mu, Nlocal, nmax, BOUND, SF, &nstop_, &rho);
+ if ( j != 0 ) warning("trouble with internal [package spc] function xe2_sf_deluxe");
+ if ( nstop_ > nsm ) nsm = nstop_;
+ if ( nstop_ < 1) nsm = nmax;
+ }
+ }
+
+ nstop = n;
+ j = xe2_sf_deluxe(l, c, hs, zz[qnspecial-1]+mu, Nlocal, nmax, BOUND, SF, &nstop_, &rho);
+ if ( j != 0 ) warning("trouble with internal [package spc] function xe2_sf_deluxe");
+ if ( nstop_ > nsm ) nsm = nstop_;
+ if ( nstop_ < 1) nsm = nmax;
+ if ( nstop_ >= nstop && nsm<nmax ) {
+ i = 1;
+ while ( nstop_ >= nstop && nsm<nmax ) {
+ nstop = nstop_;
+ i++;
+ j = xe2_sf_deluxe(l, c, hs, zz[qnspecial-i]+mu, Nlocal, nmax, BOUND, SF, &nstop_, &rho);
+ if ( j != 0 ) warning("trouble with internal [package spc] function xe2_sf_deluxe");
+ if ( nstop_ > nsm ) nsm = nstop_;
+ if ( nstop_ < 1) nsm = nmax;
+ }
+ }
+ nn = nsm;
+ }
+
+ for (n=0; n<nmax; n++) p0[n] = 0.;
+
+ for (i=0; i<qm; i++) {
+ j = xe2_sf_deluxe(l, c, hs, zz[i]+mu, Nlocal, nn, BOUND, SF, &nstop, &rho);
+ if ( j != 0 ) warning("trouble with internal [package spc] function xe2_sf_deluxe");
+ if ( nstop < 1 ) {
+ nstop = nn;
+ warning("The geometric tail approximation might not work.");
+ }
+ rhomany[i] = rho;
+ for (n=0; n<nstop; n++) p0[n] += ww[i] * SF[n];
+ if ( nstop < nn) {
+ for (n=nstop; n<nn; n++) p0[n] += ww[i] * SF[nstop-1] * pow(rho, n-nstop+1);
+ }
+ SFlast[i] = SF[nstop-1] * pow(rho, nn-nstop);
+ }
+
+ sf_level_adj = 1. - p;
+ if ( p0[nn-1] <= sf_level_adj ) {
+ n = nn-1;
+ while ( p0[n] <= sf_level_adj && n > 0 ) n--;
+ if ( p0[n] > 1.-p ) Lp = (double)( n + 2 ); else Lp = 1.;
+ } else {
+ for (n=nn; n<nmax; n++) {
+ p0[n] = 0.;
+ for (i=0; i<qm; i++) p0[n] += ww[i] * SFlast[i] * pow(rhomany[i], n-nn+1);
+ if ( p0[n] <= sf_level_adj ) {
+ Lp = (double)( n + 1 );
+ n = nmax+1;
+ }
+ }
+ }
+
+ Free(p0);
+ Free(ww);
+ Free(zz);
+ Free(SF);
+ Free(SFlast);
+ Free(rhomany);
+
+ return Lp;
+}
+
+
+double xe2_Wqm_prerun_MU_deluxe(double l, double c, double p, double hs, int q, double mu0, double mu1, int pn, int mode, int nmax, int qm, double truncate, double BOUND)
+{ double *ww, *zz, b, dn, sdn, *SF, *p0, rho, *rhomany, *SFlast, Lp=-1., sf_level_adj;
+ int i, j, n, nstop, nstop_, nn, nsm, qnspecial=0, Nlocal;
+
+ p0 = vector(nmax);
+ SF = vector(nmax);
+
+ rhomany = vector(qm);
+ SFlast = vector(qm);
+ ww = vector(qm);
+ zz = vector(qm);
+
+ dn = (double)pn;
+ sdn = sqrt(dn);
+ b = -qPHI(truncate/2.)/sdn;
+ gausslegendre(qm, -b, b, zz, ww);
+ for (i=0; i<qm; i++) ww[i] *= sdn*phi( zz[i]*sdn, 0. );
+
+ Nlocal = qm_for_l_and_c(l, c);
+
+ qnspecial = (qm+1) / 2;
+
+ j = xe2_sfm_deluxe(l, c, hs, q, zz[qnspecial]+mu0, zz[qnspecial]+mu1, mode, Nlocal, nmax, BOUND, SF, &nsm, &rho);
+ if ( j != 0 ) warning("trouble with internal [package spc] function xe2_sfm_deluxe");
+ n = nsm;
+
+ if ( nsm < 1 ) { /* did not converge yet -- should be the rare case */
+ nn = nmax;
+ warning("The geometric tail approximation might not work.");
+ } else {
+ nstop = nsm;
+
+ j = xe2_sfm_deluxe(l, c, hs, q, zz[qnspecial+1]+mu0, zz[qnspecial+1]+mu1, mode, Nlocal, nmax, BOUND, SF, &nstop_, &rho);
+ if ( j != 0 ) warning("trouble with internal [package spc] function xe2_sfm_deluxe");
+ if ( nstop_ > nsm ) nsm = nstop_;
+ if ( nstop_ < 1) nsm = nmax;
+ if ( nstop_ >= nstop && nsm<nmax ) {
+ i = 1;
+ while ( nstop_ >= nstop && nsm<nmax) {
+ nstop = nstop_;
+ i++;
+ j = xe2_sfm_deluxe(l, c, hs, q, zz[qnspecial+i]+mu0, zz[qnspecial+i]+mu1, mode, Nlocal, nmax, BOUND, SF, &nstop_, &rho);
+ if ( j != 0 ) warning("trouble with internal [package spc] function xe2_sfm_deluxe");
+ if ( nstop_ > nsm ) nsm = nstop_;
+ if ( nstop_ < 1) nsm = nmax;
+ }
+ }
+
+ nstop = n;
+ j = xe2_sfm_deluxe(l, c, hs, q, zz[qnspecial-1]+mu0, zz[qnspecial-1]+mu1, mode, Nlocal, nmax, BOUND, SF, &nstop_, &rho);
+ if ( j != 0 ) warning("trouble with internal [package spc] function xe2_sfm_deluxe");
+ if ( nstop_ > nsm ) nsm = nstop_;
+ if ( nstop_ < 1) nsm = nmax;
+ if ( nstop_ >= nstop && nsm<nmax ) {
+ i = 1;
+ while ( nstop_ >= nstop && nsm<nmax ) {
+ nstop = nstop_;
+ i++;
+ j = xe2_sfm_deluxe(l, c, hs, q, zz[qnspecial-i]+mu0, zz[qnspecial-i]+mu1, mode, Nlocal, nmax, BOUND, SF, &nstop_, &rho);
+ if ( j != 0 ) warning("trouble with internal [package spc] function xe2_sfm_deluxe");
+ if ( nstop_ > nsm ) nsm = nstop_;
+ if ( nstop_ < 1) nsm = nmax;
+ }
+ }
+ nn = nsm;
+ }
+
+ for (n=0; n<nmax; n++) p0[n] = 0.;
+
+ for (i=0; i<qm; i++) {
+ j = xe2_sfm_deluxe(l, c, hs, q, zz[i]+mu0, zz[i]+mu1, mode, Nlocal, nn, BOUND, SF, &nstop, &rho);
+ if ( j != 0 ) warning("trouble with internal [package spc] function xe2_sfm_deluxe");
+ if ( nstop < 1 ) {
+ nstop = nn;
+ warning("The geometric tail approximation might not work.");
+ }
+ rhomany[i] = rho;
+ for (n=0; n<nstop; n++) p0[n] += ww[i] * SF[n];
+ if ( nstop < nn) {
+ for (n=nstop; n<nn; n++) p0[n] += ww[i] * SF[nstop-1] * pow(rho, n-nstop+1);
+ }
+ SFlast[i] = SF[nstop-1] * pow(rho, nn-nstop);
+ }
+
+ sf_level_adj = 1. - p;
+ if ( q > 1 ) sf_level_adj *= p0[q-2];
+ if ( p0[nn-1] <= sf_level_adj ) {
+ n = nn-1;
+ while ( p0[n] <= sf_level_adj && n > 0 ) n--;
+ if ( p0[n] > sf_level_adj ) Lp = (double)( n + 2 - q + 1 ); else Lp = 1.;
+ } else {
+ for (n=nn; n<nmax; n++) {
+ p0[n] = 0.;
+ for (i=0; i<qm; i++) p0[n] += ww[i] * SFlast[i] * pow(rhomany[i], n-nn+1);
+ if ( p0[n] <= sf_level_adj ) {
+ Lp = (double)( n + 1 - q + 1 );
+ n = nmax+1;
+ }
+ }
+ }
+
+ Free(p0);
+ Free(ww);
+ Free(zz);
+ Free(SF);
+ Free(SFlast);
+ Free(rhomany);
+
+ return Lp;
+}
+
+
+double xe2_Wq_prerun_SIGMA_deluxe(double l, double c, double p, double hs, double mu, int pn, int nmax, int qm, double truncate, double BOUND)
+{ double *ww, *zz, b1, b2, ddf, *SF, *p0, rho, *rhomany, *SFlast, Lp=-1., sf_level_adj;
+ int i, j, n, nstop, nstop_, nsm, nn, qnspecial=0, Nlocal;
+
+ p0 = vector(nmax);
+ SF = vector(nmax);
+
+ rhomany = vector(qm);
+ SFlast = vector(qm);
+ ww = vector(qm);
+ zz = vector(qm);
+
+ ddf = (double)(pn-1);
+ b1 = sqrt(qCHI( truncate/2., pn-1)/ddf);
+ b2 = sqrt(qCHI(1. - truncate/2., pn-1)/ddf);
+ gausslegendre(qm, b1, b2, zz, ww);
+ for (i=0; i<qm; i++) ww[i] *= 2.*ddf*zz[i] * chi( ddf*zz[i]*zz[i], pn-1);
+
+ /*qnspecial = qm-1;*/
+ qnspecial = (qm+1) / 2;
+
+ Nlocal = qm_for_l_and_c(l, zz[qnspecial]*c);
+ j = xe2_sf_deluxe(l, zz[qnspecial]*c, hs, mu, Nlocal, nmax, BOUND, SF, &nsm, &rho);
+ if ( j != 0 ) warning("trouble with internal [package spc] function xe2_sf_deluxe");
+ n = nsm;
+
+ if ( nsm < 1 ) { /* did not converge yet -- should be the rare case */
+ nn = nmax;
+ warning("The geometric tail approximation might not work.");
+ } else {
+ nstop = nsm;
+
+ Nlocal = qm_for_l_and_c(l, zz[qnspecial+1]*c);
+ j = xe2_sf_deluxe(l, zz[qnspecial+1]*c, hs, mu, Nlocal, nmax, BOUND, SF, &nstop_, &rho);
+ if ( j != 0 ) warning("trouble with internal [package spc] function xe2_sf_deluxe");
+ if ( nstop_ > nsm ) nsm = nstop_;
+ if ( nstop_ < 1) nsm = nmax;
+ if ( nstop_ >= nstop && nsm<nmax ) {
+ i = 1;
+ while ( nstop_ >= nstop && nsm<nmax ) {
+ nstop = nstop_;
+ i++;
+ Nlocal = qm_for_l_and_c(l, zz[qnspecial+i]*c);
+ j = xe2_sf_deluxe(l, zz[qnspecial+i]*c, hs, mu, Nlocal, nmax, BOUND, SF, &nstop_, &rho);
+ if ( j != 0 ) warning("trouble with internal [package spc] function xe2_sf_deluxe");
+ if ( nstop_ > nsm ) nsm = nstop_;
+ if ( nstop_ < 1) nsm = nmax;
+ }
+ }
+
+ nstop = n;
+ Nlocal = qm_for_l_and_c(l, zz[qnspecial-1]*c);
+ j = xe2_sf_deluxe(l, zz[qnspecial-1]*c, hs, mu, Nlocal, nmax, BOUND, SF, &nstop_, &rho);
+ if ( j != 0 ) warning("trouble with internal [package spc] function xe2_sf_deluxe");
+ if ( nstop_ > nsm ) nsm = nstop_;
+ if ( nstop_ < 1) nsm = nmax;
+ if ( nstop_ >= nstop && nsm<nmax ) {
+ i = 1;
+ while ( nstop_ >= nstop && nsm<nmax ) {
+ nstop = nstop_;
+ i++;
+ Nlocal = qm_for_l_and_c(l, zz[qnspecial-i]*c);
+ j = xe2_sf_deluxe(l, zz[qnspecial-i]*c, hs, mu, Nlocal, nmax, BOUND, SF, &nstop_, &rho);
+ if ( j != 0 ) warning("trouble with internal [package spc] function xe2_sf_deluxe");
+ if ( nstop_ > nsm ) nsm = nstop_;
+ if ( nstop_ < 1) nsm = nmax;
+ }
+ }
+ nn = nsm;
+ }
+
+ for (n=0; n<nmax; n++) p0[n] = 0.;
+
+ for (i=0; i<qm; i++) {
+ Nlocal = qm_for_l_and_c(l, zz[i]*c);
+ j = xe2_sf_deluxe(l, zz[i]*c, hs, mu, Nlocal, nn, BOUND, SF, &nstop, &rho);
+ if ( j != 0 ) warning("trouble with internal [package spc] function xe2_sf_deluxe");
+ if ( nstop < 1 ) {
+ nstop = nn;
+ warning("The geometric tail approximation might not work.");
+ }
+ rhomany[i] = rho;
+ for (n=0; n<nstop; n++) p0[n] += ww[i] * SF[n];
+ if ( nstop < nn) {
+ for (n=nstop; n<nn; n++) p0[n] += ww[i] * SF[nstop-1] * pow(rho, n-nstop+1);
+ }
+ SFlast[i] = SF[nstop-1] * pow(rho, nn-nstop);
+ }
+
+ sf_level_adj = 1. - p;
+ if ( p0[nn-1] <= sf_level_adj ) {
+ n = nn-1;
+ while ( p0[n] <= sf_level_adj && n > 0 ) n--;
+ if ( p0[n] > 1.-p ) Lp = (double)( n + 2 ); else Lp = 1.;
+ } else {
+ for (n=nn; n<nmax; n++) {
+ p0[n] = 0.;
+ for (i=0; i<qm; i++) p0[n] += ww[i] * SFlast[i] * pow(rhomany[i], n-nn+1);
+ if ( p0[n] <= sf_level_adj ) {
+ Lp = (double)( n + 1 );
+ n = nmax+1;
+ }
+ }
+ }
+
+ Free(p0);
+ Free(ww);
+ Free(zz);
+ Free(SF);
+ Free(SFlast);
+ Free(rhomany);
+
+ return Lp;
+}
+
+
+double xe2_Wqm_prerun_SIGMA_deluxe(double l, double c, double p, double hs, int q, double mu0, double mu1, int pn, int mode, int nmax, int qm, double truncate, double BOUND)
+{ double *ww, *zz, b1, b2, ddf, *SF, *p0, rho, *rhomany, *SFlast, Lp=-1., sf_level_adj;
+ int i, j, n, nstop, nstop_, nsm, nn, qnspecial=0, Nlocal;
+
+ p0 = vector(nmax);
+ SF = vector(nmax);
+
+ rhomany = vector(qm);
+ SFlast = vector(qm);
+ ww = vector(qm);
+ zz = vector(qm);
+
+ ddf = (double)(pn-1);
+ b1 = sqrt(qCHI( truncate/2., pn-1)/ddf);
+ b2 = sqrt(qCHI(1. - truncate/2., pn-1)/ddf);
+ gausslegendre(qm, b1, b2, zz, ww);
+ for (i=0; i<qm; i++) ww[i] *= 2.*ddf*zz[i] * chi( ddf*zz[i]*zz[i], pn-1);
+
+ /*qnspecial = qm-1;*/
+ qnspecial = (qm+1) / 2;
+
+ Nlocal = qm_for_l_and_c(l, zz[qnspecial]*c);
+ j = xe2_sfm_deluxe(l, zz[qnspecial]*c, hs, q, mu0, mu1, mode, Nlocal, nmax, BOUND, SF, &nsm, &rho);
+ if ( j != 0 ) warning("trouble with internal [package spc] function xe2_sfm_deluxe");
+ n = nsm;
+
+ if ( nsm < 1 ) { /* did not converge yet -- should be the rare case */
+ nn = nmax;
+ warning("The geometric tail approximation might not work.");
+ } else {
+ nstop = nsm;
+
+ Nlocal = qm_for_l_and_c(l, zz[qnspecial+1]*c);
+ j = xe2_sfm_deluxe(l, zz[qnspecial+1]*c, hs, q, mu0, mu1, mode, Nlocal, nmax, BOUND, SF, &nstop_, &rho);
+ if ( j != 0 ) warning("trouble with internal [package spc] function xe2_sfm_deluxe");
+ if ( nstop_ > nsm ) nsm = nstop_;
+ if ( nstop_ < 1) nsm = nmax;
+ if ( nstop_ >= nstop && nsm<nmax ) {
+ i = 1;
+ while ( nstop_ >= nstop && nsm<nmax ) {
+ nstop = nstop_;
+ i++;
+ Nlocal = qm_for_l_and_c(l, zz[qnspecial+i]*c);
+ j = xe2_sfm_deluxe(l, zz[qnspecial+i]*c, hs, q, mu0, mu1, mode, Nlocal, nmax, BOUND, SF, &nstop_, &rho);
+ if ( j != 0 ) warning("trouble with internal [package spc] function xe2_sfm_deluxe");
+ if ( nstop_ > nsm ) nsm = nstop_;
+ if ( nstop_ < 1) nsm = nmax;
+ }
+ }
+
+ nstop = n;
+ Nlocal = qm_for_l_and_c(l, zz[qnspecial-1]*c);
+ j = xe2_sfm_deluxe(l, zz[qnspecial-1]*c, hs, q, mu0, mu1, mode, Nlocal, nmax, BOUND, SF, &nstop_, &rho);
+ if ( j != 0 ) warning("trouble with internal [package spc] function xe2_sfm_deluxe");
+ if ( nstop_ > nsm ) nsm = nstop_;
+ if ( nstop_ < 1) nsm = nmax;
+ if ( nstop_ >= nstop && nsm<nmax ) {
+ i = 1;
+ while ( nstop_ >= nstop && nsm<nmax ) {
+ nstop = nstop_;
+ i++;
+ Nlocal = qm_for_l_and_c(l, zz[qnspecial-i]*c);
+ j = xe2_sfm_deluxe(l, zz[qnspecial-i]*c, hs, q, mu0, mu1, mode, Nlocal, nmax, BOUND, SF, &nstop_, &rho);
+ if ( j != 0 ) warning("trouble with internal [package spc] function xe2_sfm_deluxe");
+ if ( nstop_ > nsm ) nsm = nstop_;
+ if ( nstop_ < 1) nsm = nmax;
+ }
+ }
+ nn = nsm;
+ }
+
+ for (n=0; n<nmax; n++) p0[n] = 0.;
+
+ for (i=0; i<qm; i++) {
+ Nlocal = qm_for_l_and_c(l, zz[i]*c);
+ j = xe2_sfm_deluxe(l, zz[i]*c, hs, q, mu0, mu1, mode, Nlocal, nn, BOUND, SF, &nstop, &rho);
+ if ( j != 0 ) warning("trouble with internal [package spc] function xe2_sfm_deluxe");
+ if ( nstop < 1 ) {
+ nstop = nn;
+ warning("The geometric tail approximation might not work.");
+ }
+ rhomany[i] = rho;
+ for (n=0; n<nstop; n++) p0[n] += ww[i] * SF[n];
+ if ( nstop < nn) {
+ for (n=nstop; n<nn; n++) p0[n] += ww[i] * SF[nstop-1] * pow(rho, n-nstop+1);
+ }
+ SFlast[i] = SF[nstop-1] * pow(rho, nn-nstop);
+ }
+
+ sf_level_adj = 1. - p;
+ if ( q > 1 ) sf_level_adj *= p0[q-2];
+ if ( p0[nn-1] <= sf_level_adj ) {
+ n = nn-1;
+ while ( p0[n] <= sf_level_adj && n > 0 ) n--;
+ if ( p0[n] > sf_level_adj ) Lp = (double)( n + 2 - q + 1 ); else Lp = 1.;
+ } else {
+ for (n=nn; n<nmax; n++) {
+ p0[n] = 0.;
+ for (i=0; i<qm; i++) p0[n] += ww[i] * SFlast[i] * pow(rhomany[i], n-nn+1);
+ if ( p0[n] <= sf_level_adj ) {
+ Lp = (double)( n + 1 - q + 1 );
+ n = nmax+1;
+ }
+ }
+ }
+
+ Free(p0);
+ Free(ww);
+ Free(zz);
+ Free(SF);
+ Free(SFlast);
+ Free(rhomany);
+
+ return Lp;
+}
+
+
+double xe2_Wq_prerun_BOTH_deluxe(double l, double c, double p, double hs, double mu, int pn, int df, int nmax, int qm1, int qm2, double truncate, double BOUND)
+{ double *ww1, *zz1, *ww2, *zz2, b, b1, b2, dn, sdn, ddf, *p0, *SF, rho, *rhomany, *SFlast, Lp=-1., sf_level_adj;
+ int i, j, m, n, nstop, nstop_, nn, nsm, qnspecial1=0, qnspecial2=0, Nlocal;
+
+ p0 = vector(nmax);
+ SF = vector(nmax);
+
+ rhomany = vector(qm1*qm2);
+ SFlast = vector(qm1*qm2);
+
+ ww1 = vector(qm1);
+ zz1 = vector(qm1);
+ ww2 = vector(qm2);
+ zz2 = vector(qm2);
+
+ dn = (double)pn;
+ sdn = sqrt(dn);
+ b = -qPHI(truncate/2.)/sdn;
+ gausslegendre(qm1, -b, b, zz1, ww1);
+ for (i=0; i<qm1; i++) ww1[i] *= sdn * phi( zz1[i]*sdn, 0.);
+ qnspecial1 = qm1 - 1;
+
+ ddf = (double)(df);
+ b1 = sqrt(qCHI( truncate/2., df)/ddf);
+ b2 = sqrt(qCHI(1. - truncate/2., df)/ddf);
+ gausslegendre(qm2, b1, b2, zz2, ww2);
+ for (j=0; j<qm2; j++) ww2[j] *= 2.*ddf*zz2[j] * chi( ddf*zz2[j]*zz2[j], df);
+ qnspecial2 = qm2 - 1;
+
+ Nlocal = qm_for_l_and_c(l, zz2[qnspecial2]*c);
+ m = xe2_sf_deluxe(l, zz2[qnspecial2]*c, hs, zz1[qnspecial1]+mu, Nlocal, nmax, BOUND, SF, &nsm, &rho);
+ if ( m != 0 ) warning("trouble with internal [package spc] function xe2_sf_deluxe");
+
+ if ( nsm < 1 ) { /* did not converge yet -- should be the rare case */
+ nn = nmax;
+ warning("The geometric tail approximation might not work.");
+ } else {
+ nstop = nsm;
+
+ m = xe2_sf_deluxe(l, zz2[qnspecial2]*c, hs, zz1[qnspecial1-1]+mu, Nlocal, nmax, BOUND, SF, &nstop_, &rho);
+ if ( m != 0 ) warning("trouble with internal [package spc] function xe2_sf_deluxe");
+ if ( nstop_ > nsm ) nsm = nstop_;
+ if ( nstop_ < 1) nsm = nmax;
+ if ( nstop_ >= nstop && nsm<nmax ) {
+ i = 1;
+ while ( nstop_ >= nstop && nsm<nmax ) {
+ nstop = nstop_;
+ i++;
+ m = xe2_sf_deluxe(l, zz2[qnspecial2]*c, hs, zz1[qnspecial1-i]+mu, Nlocal, nmax, BOUND, SF, &nstop_, &rho);
+ if ( m != 0 ) warning("trouble with internal [package spc] function xe2_sf_deluxe");
+ if ( nstop_ > nsm ) nsm = nstop_;
+ if ( nstop_ < 1) nsm = nmax;
+ }
+ }
+ nn = nsm;
+ }
+
+ for (n=0; n<nmax; n++) p0[n] = 0.;
+
+ for (i=0; i<qm1; i++) {
+ for (j=0; j<qm2; j++) {
+ Nlocal = qm_for_l_and_c(l, zz2[j]*c);
+ m = xe2_sf_deluxe(l, zz2[j]*c, hs, zz1[i]+mu, Nlocal, nn, BOUND, SF, &nstop, &rho);
+ if ( m != 0 ) warning("trouble with internal [package spc] function xe2_sf_deluxe");
+ if ( nstop < 1 ) {
+ nstop = nn;
+ warning("The geometric tail approximation might not work.");
+ }
+ rhomany[i + j*qm1] = rho;
+ for (n=0; n<nstop; n++) p0[n] += ww1[i] * ww2[j] * SF[n];
+ if ( nn > nstop ) {
+ for (n=nstop; n<nn; n++) p0[n] += ww1[i] * ww2[j] * SF[nstop-1] * pow(rho, n-nstop+1);
+ }
+ SFlast[i + j*qm1] = SF[nstop-1] * pow(rho, nn-nstop);
+ }
+ }
+
+ sf_level_adj = 1. - p;
+ if ( p0[nn-1] <= sf_level_adj ) {
+ n = nn-1;
+ while ( p0[n] <= sf_level_adj && n > 0 ) n--;
+ if ( p0[n] > 1.-p ) Lp = (double)( n + 2 ); else Lp = 1.;
+ } else {
+ for (n=nn; n<nmax; n++) {
+ p0[n] = 0.;
+ for (i=0; i<qm1; i++)
+ for (j=0; j<qm2; j++)
+ p0[n] += ww1[i] * ww2[j] * SFlast[i + j*qm1] * pow(rhomany[i + j*qm1], n-nn+1);
+ if ( p0[n] <= sf_level_adj ) {
+ Lp = (double)( n + 1 );
+ n = nmax+1;
+ }
+ }
+ }
+
+ Free(p0);
+ Free(ww1);
+ Free(zz1);
+ Free(ww2);
+ Free(zz2);
+ Free(SF);
+ Free(SFlast);
+ Free(rhomany);
+
+ return Lp;
+}
+
+
+double xe2_Wqm_prerun_BOTH_deluxe(double l, double c, double p, double hs, int q, double mu0, double mu1, int pn, int df, int mode, int nmax, int qm1, int qm2, double truncate, double BOUND)
+{ double *ww1, *zz1, *ww2, *zz2, b, b1, b2, dn, sdn, ddf, *p0, *SF, rho, *rhomany, *SFlast, Lp=-1., sf_level_adj;
+ int i, j, m, n, nstop, nstop_, nn, nsm, qnspecial1=0, qnspecial2=0, Nlocal;
+
+ p0 = vector(nmax);
+ SF = vector(nmax);
+
+ rhomany = vector(qm1*qm2);
+ SFlast = vector(qm1*qm2);
+
+ ww1 = vector(qm1);
+ zz1 = vector(qm1);
+ ww2 = vector(qm2);
+ zz2 = vector(qm2);
+
+ dn = (double)pn;
+ sdn = sqrt(dn);
+ b = -qPHI(truncate/2.)/sdn;
+ gausslegendre(qm1, -b, b, zz1, ww1);
+ for (i=0; i<qm1; i++) ww1[i] *= sdn * phi( zz1[i]*sdn, 0.);
+ qnspecial1 = qm1 - 1;
+
+ ddf = (double)(df);
+ b1 = sqrt(qCHI( truncate/2., df)/ddf);
+ b2 = sqrt(qCHI(1. - truncate/2., df)/ddf);
+ gausslegendre(qm2, b1, b2, zz2, ww2);
+ for (j=0; j<qm2; j++) ww2[j] *= 2.*ddf*zz2[j] * chi( ddf*zz2[j]*zz2[j], df);
+ qnspecial2 = qm2 - 1;
+
+ Nlocal = qm_for_l_and_c(l, zz2[qnspecial2]*c);
+ m = xe2_sfm_deluxe(l, zz2[qnspecial2]*c, hs, q, zz1[qnspecial1]+mu0, zz1[qnspecial1]+mu1, mode, Nlocal, nmax, BOUND, SF, &nsm, &rho);
+ if ( m != 0 ) warning("trouble with internal [package spc] function xe2_sfm_deluxe");
+
+ if ( nsm < 1 ) { /* did not converge yet -- should be the rare case */
+ nn = nmax;
+ warning("The geometric tail approximation might not work.");
+ } else {
+ nstop = nsm;
+
+ m = xe2_sfm_deluxe(l, zz2[qnspecial2]*c, hs, q, zz1[qnspecial1-1]+mu0, zz1[qnspecial1-1]+mu1, mode, Nlocal, nmax, BOUND, SF, &nstop_, &rho);
+ if ( m != 0 ) warning("trouble with internal [package spc] function xe2_sfm_deluxe");
+ if ( nstop_ > nsm ) nsm = nstop_;
+ if ( nstop_ < 1) nsm = nmax;
+ if ( nstop_ >= nstop && nsm<nmax ) {
+ i = 1;
+ while ( nstop_ >= nstop && nsm<nmax ) {
+ nstop = nstop_;
+ i++;
+ m = xe2_sfm_deluxe(l, zz2[qnspecial2]*c, hs, q, zz1[qnspecial1-i]+mu0, zz1[qnspecial1-i]+mu1, mode, Nlocal, nmax, BOUND, SF, &nstop_, &rho);
+ if ( m != 0 ) warning("trouble with internal [package spc] function xe2_sfm_deluxe");
+ if ( nstop_ > nsm ) nsm = nstop_;
+ if ( nstop_ < 1) nsm = nmax;
+ }
+ }
+ nn = nsm;
+ }
+
+ for (n=0; n<nmax; n++) p0[n] = 0.;
+
+ for (i=0; i<qm1; i++) {
+ for (j=0; j<qm2; j++) {
+ Nlocal = qm_for_l_and_c(l, zz2[j]*c);
+ m = xe2_sfm_deluxe(l, zz2[j]*c, hs, q, zz1[i]+mu0, zz1[i]+mu1, mode, Nlocal, nn, BOUND, SF, &nstop, &rho);
+ if ( m != 0 ) warning("trouble with internal [package spc] function xe2_sfm_deluxe");
+ if ( nstop < 1 ) {
+ nstop = nn;
+ warning("The geometric tail approximation might not work.");
+ }
+ rhomany[i + j*qm1] = rho;
+ for (n=0; n<nstop; n++) p0[n] += ww1[i] * ww2[j] * SF[n];
+ if ( nn > nstop ) {
+ for (n=nstop; n<nn; n++) p0[n] += ww1[i] * ww2[j] * SF[nstop-1] * pow(rho, n-nstop+1);
+ }
+ SFlast[i + j*qm1] = SF[nstop-1] * pow(rho, nn-nstop);
+ }
+ }
+
+ sf_level_adj = 1. - p;
+ if ( q > 1 ) sf_level_adj *= p0[q-2];
+ if ( p0[nn-1] <= sf_level_adj ) {
+ n = nn-1;
+ while ( p0[n] <= sf_level_adj && n > 0 ) n--;
+ if ( p0[n] > sf_level_adj ) Lp = (double)( n + 2 - q + 1 ); else Lp = 1.;
+ } else {
+ for (n=nn; n<nmax; n++) {
+ p0[n] = 0.;
+ for (i=0; i<qm1; i++)
+ for (j=0; j<qm2; j++)
+ p0[n] += ww1[i] * ww2[j] * SFlast[i + j*qm1] * pow(rhomany[i + j*qm1], n-nn+1);
+ if ( p0[n] <= sf_level_adj ) {
+ Lp = (double)( n + 1 - q + 1 );
+ n = nmax+1;
+ }
+ }
+ }
+
+ Free(p0);
+ Free(ww1);
+ Free(zz1);
+ Free(ww2);
+ Free(zz2);
+ Free(SF);
+ Free(SFlast);
+ Free(rhomany);
+
+ return Lp;
+}
+
+
+double xc2_iglad (double k, double h, double mu0, double mu1, int N)
+{ double *a, *arl, *psi, rho, ad, norm, z1, z2, z11, z12, z21, z22, w;
+ int i1, i2, j1, j2, status, noofit, NN, N3;
+
+ NN = N*N; N3 = NN*N;
+ a = matrix(NN,NN);
+ arl = vector(NN);
+ psi = vector(NN);
+
+ w = 2.*h/(2.*N - 1.);
+
+ for (i1=0;i1<N;i1++)
+ for (j1=0;j1<N;j1++)
+ for (i2=0;i2<N;i2++)
+ for (j2=0;j2<N;j2++) {
+ z11 = (i2-i1)*w - w/2. + k; if (i2==0) z11 = -10000.;
+ z12 = (i2-i1)*w + w/2. + k;
+ z21 = -2.*k - (j2-j1)*w - w/2. + k;
+ z22 = -2.*k - (j2-j1)*w + w/2. + k; if (j2==0) z22 = 10000.;
+ if (z11<z21) z1 = z21; else z1 = z11;
+ if (z12<z22) z2 = z12; else z2 = z22;
+ if (z1>z2) a[i1*N3+j1*NN+i2*N+j2] = 0.;
+ else a[i1*N3+j1*NN+i2*N+j2] = -PHI(z2,mu1) + PHI(z1,mu1);
+ if (i1==i2 && j1==j2) a[i1*N3+j1*NN+i2*N+j2]++;
+ }
+
+ for (j1=0;j1<NN;j1++) arl[j1] = 1.;
+ LU_solve(a,arl,NN);
+
+ for (i1=0;i1<N;i1++)
+ for (j1=0;j1<N;j1++)
+ for (i2=0;i2<N;i2++)
+ for (j2=0;j2<N;j2++) {
+ z11 = (i2-i1)*w - w/2. + k; if (i2==0) z11 = -10000.;
+ z12 = (i2-i1)*w + w/2. + k;
+ z21 = -2.*k - (j2-j1)*w - w/2. + k;
+ z22 = -2.*k - (j2-j1)*w + w/2. + k; if (j2==0) z22 = 10000.;
+ if (z11<z21) z1 = z21; else z1 = z11;
+ if (z12<z22) z2 = z12; else z2 = z22;
+ if (z1>z2) a[i2*N3+j2*NN+i1*N+j1] = 0.;
+ else a[i2*N3+j2*NN+i1*N+j1] = PHI(z2,mu0) - PHI(z1,mu0);
+ }
+
+ pmethod(NN,a,&status,&rho,psi,&noofit);
+
+ ad = 0.;
+ norm = 0.;
+ for (i1=0;i1<N;i1++)
+ for (j1=0;j1<N;j1++) {
+ ad += arl[i1*N+j1] * psi[i1*N+j1];
+ norm += psi[i1*N+j1];
+ }
+ ad /= norm;
+ rho0 = rho;
+
+ Free(a);
+ Free(arl);
+ Free(psi);
+
+ return ad;
+}
+
+
+/* Richardson extrapolation */
+double xc2_igladR (double k, double h, double mu0, double mu1, int r)
+{ double *a, *b, ad;
+ int i, j, N;
+
+ a = matrix(r,r);
+ b = vector(r);
+
+ for (i=0;i<r;i++) {
+ N = (int)pow(2.,(double)(i)+1.);
+ b[i] = -xc2_iglad(k,h,mu0,mu1,N);
+ a[i*r+0] = -1.;
+ for (j=0;j<r;j++)
+ if (i==0) a[i*r+j] = 1.;
+ else a[i*r+j] = pow( 2, -(double)(j+1.)*(double)(i) );
+ }
+
+ LU_solve(a,b,r);
+
+ ad = b[0];
+
+ Free(a);
+ Free(b);
+
+ return ad;
+}
+
+
+/* variance control charts */
+
+/* -------------- Chebyshev polynomials on [-1,1] ----------------- */
+
+double Tn(double z, int n)
+{ double result=1.;
+
+ if ( fabs(z)<1-1e-12 ) {
+ switch (n) {
+ case 0: result = 1.; break;
+ case 1: result = z; break;
+ case 2: result = 2.*z*z-1.; break;
+ case 3: result = 4.*z*z*z-3.*z; break;
+ case 4: result = 8.*pow(z,4.)-8.*z*z+1.; break;
+ case 5: result = 16.*pow(z,5.)-20.*z*z*z+5.*z; break;
+ }
+ if ( n > 5 ) result = cos( (double)(n)*acos(z) );
+ }
+ else { if ( z<0. && (n % 2 == 1) ) result = -1.; else result = 1.; }
+ return result;
+}
+
+
+/* -------------- indefinite integrals of Chebyshev polynomials on [-1,1] ----------------- */
+double iTn(double z, int n)
+{ double result=1.;
+
+ switch (n) {
+ case 0: result = z; break;
+ case 1: result = z*z/2.; break;
+ case 2: result = 2.*z*z*z/3. - z; break;
+ }
+ if ( n > 2 ) result = ( Tn(z,n+1)/(n+1.) - Tn(z,n-1)/(n-1.) )/2.;
+ return result;
+}
+
+
+/* -------------- derivatives of Chebyshev polynomials on [-1,1] ----------------- */
+double dTn(double z, int n)
+{ double result=1., dn;
+ dn = (double)n;
+ if ( fabs(z)<1-1e-12 ) {
+ switch (n) {
+ case 0: result = 0.; break;
+ case 1: result = 1.; break;
+ case 2: result = 4.*z; break;
+ case 3: result = 12.*z*z-3.; break;
+ case 4: result = 32.*z*z*z-16.*z; break;
+ case 5: result = 80.*pow(z,4.)-60.*z*z+5.; break;
+ }
+ if ( n > 5 ) result = dn * ( Tn(z,n-1) - z*Tn(z,n) ) / (1.-z*z);
+ }
+ else { if ( z<0. && (n % 2 == 0) ) result = -dn*dn; else result = dn*dn; }
+ return result;
+}
+
+
+double seU_iglarl(double l, double cu, double hs, double sigma, int df, int N, int qm)
+{ double *a, *g, *w, *z, arl, Hij, xi, xl, za, xu, dN, ddf, s2, v;
+ int i, j, k;
+
+ s2 = sigma*sigma;
+ ddf = (double)df;
+ dN = (double)N;
+
+ a = matrix(N,N);
+ g = vector(N);
+ w = vector(qm);
+ z = vector(qm);
+
+ for (i=0;i<N;i++) {
+ xi = cu/2.*(1.+cos(PI*(2.*(i+1.)-1.)/2./dN));
+
+ za = (1.-l)*xi;
+
+ xl = za;
+ xu = cu;
+ if ( df!=2 ) {
+ xl = 0.;
+ xu = sqrt(cu-za);
+ }
+
+ gausslegendre(qm,xl,xu,z,w);
+
+ v = (cu - za) / l;
+ if (df==2) a[i*N] = exp(-v/s2);
+ else a[i*N] = 1. - CHI( ddf/s2*v, df);
+
+ for (j=1;j<N;j++) {
+ Hij = 0.;
+ for (k=0;k<qm;k++) {
+ v = (z[k] - za) / l;
+ if ( df==2 )
+ Hij += w[k] * Tn( (2.*z[k]-cu)/cu, j) * exp(-v/s2);
+ if ( df!=2 )
+ Hij += w[k] * Tn( (2.*(z[k]*z[k]+za)-cu)/cu ,j) * 2. * pow(z[k], ddf-1.) * exp(-ddf*z[k]*z[k]/2./s2/l);
+ }
+ if (df==2) Hij /= s2*l;
+ else Hij /= gammafn(ddf/2.) * pow(2.*s2*l/ddf,ddf/2.);
+ a[i*N+j] = Tn( (2.*xi-cu)/cu ,j) - Hij;
+ }
+ }
+
+ for (j=0;j<N;j++) g[j] = 1.;
+ LU_solve(a,g,N);
+
+ arl = g[0];
+ for (j=1;j<N;j++)
+ arl += g[j] * Tn( (2.*hs-cu)/cu ,j);
+
+ Free(z);
+ Free(w);
+ Free(g);
+ Free(a);
+
+ return arl;
+}
+
+
+double stdeU_iglarl(double l, double cu, double hs, double sigma, int df, int N, int qm)
+{ double *a, *g, *w, *z, arl, Hij, xi, xl, za, xu, dN, ddf, s2, v;
+ int i, j, k;
+
+ s2 = sigma*sigma;
+ ddf = (double)df;
+ dN = (double)N;
+
+ a = matrix(N,N);
+ g = vector(N);
+ w = vector(qm);
+ z = vector(qm);
+
+ for (i=0;i<N;i++) {
+ xi = cu/2.*(1.+cos(PI*(2.*(i+1.)-1.)/2./dN));
+
+ za = (1.-l)*xi;
+
+ xl = za;
+ xu = cu;
+
+ gausslegendre(qm,xl,xu,z,w);
+
+ v = (cu - za) / l;
+ a[i*N] = 1. - CHI( ddf/s2*v*v, df);
+
+ for (j=1;j<N;j++) {
+ Hij = 0.;
+ for (k=0;k<qm;k++) {
+ v = (z[k] - za) / l;
+ Hij += w[k] * Tn( (2.*z[k]-cu)/cu ,j) * pow(v,ddf-1.)*exp(-ddf/2./s2*v*v);
+ }
+ Hij *= 2./l/gammafn(ddf/2.)/pow(2.*s2/ddf,ddf/2.);
+ a[i*N+j] = Tn( (2.*xi-cu)/cu ,j) - Hij;
+ }
+ }
+
+ for (j=0;j<N;j++) g[j] = 1.;
+ LU_solve(a,g,N);
+
+ arl = g[0];
+ for (j=1;j<N;j++)
+ arl += g[j] * Tn( (2.*hs-cu)/cu ,j);
+
+ Free(z);
+ Free(w);
+ Free(g);
+ Free(a);
+
+ return arl;
+}
+
+
+double seU_sf(double l, double cu, double hs, double sigma, int df, int N, int nmax, int qm, double *p0)
+{ double *S1s, *S2s, *Pns, *ws, *zs, *zch, *rside, za=0., s2, ddf, xl, xu;
+ int i, j, k, n, *ps;
+
+ s2 = sigma*sigma;
+ ddf = (double)df;
+
+ S1s = matrix(N,N);
+ S2s = matrix(N,N);
+ ps = ivector(N);
+ zch = vector(N);
+ rside = vector(N);
+ ws = vector(qm);
+ zs = vector(qm);
+ Pns = matrix(nmax,N);
+
+/* Chebyshev nodes on [0,cu] */
+ for (i=0; i<N; i++) zch[i] = cu/2.*(1.+cos(PI*(2.*(i+1.)-1.)/2./(double)N) );
+
+/* P(L>1)(zch[i]) */
+ for (i=0; i<N; i++) rside[i] = CHI( ddf/s2*(cu-(1.-l)*zch[i])/l, df);
+
+ for (i=0; i<N; i++) {
+ za = (1.-l)*zch[i];
+ if ( df==2 ) { xl = za; xu = cu; }
+ else { xl = 0.; xu = sqrt(cu-za); }
+ gausslegendre(qm, xl, xu, zs, ws);
+ for (j=0; j<N; j++) {
+ S1s[i*N+j] = 0.;
+ for (k=0; k<qm; k++)
+ if ( df==2 )
+ S1s[i*N+j] += ws[k]*Tn((2.*zs[k]-cu)/cu, j) * exp((za-zs[k])/s2/l);
+ else
+ S1s[i*N+j] += ws[k]*Tn((2.*(zs[k]*zs[k]+za)-cu)/cu, j) * 2.*pow(zs[k], ddf-1.) * exp(-ddf*zs[k]*zs[k]/2./s2/l);
+ if ( df==2 ) S1s[i*N+j] /= s2*l;
+ else S1s[i*N+j] /= gammafn(ddf/2.) * pow(2.*s2*l/ddf,ddf/2.);
+ }
+ }
+
+ for (i=0; i<N; i++)
+ for (j=0; j<N; j++) S2s[i*N+j] = Tn( (2.*zch[i]-cu)/cu, j);
+
+ LU_decompose(S2s, ps, N);
+
+ for (n=1;n<=nmax;n++) {
+ if (n==1)
+ for (i=0; i<N; i++) {
+ Pns[i] = 0.;
+ for (j=0; j<N; j++)
+ Pns[i] += 2./N * Tn( (2.*zch[j]-cu)/cu, i) * rside[j];
+ if ( i==0 ) Pns[i] /= 2.;
+ }
+ else {
+ for (i=0; i<N; i++) {
+ rside[i] = 0.;
+ for (j=0; j<N; j++) rside[i] += S1s[i*N+j] * Pns[(n-2)*N+j];
+ }
+ LU_solve2(S2s, rside, ps, N);
+ for (i=0; i<N; i++) Pns[(n-1)*N+i] = rside[i];
+ }
+
+ p0[n-1] = 0.;
+ if ( n==1 )
+ p0[0] = CHI(ddf/s2*(cu-(1.-l)*hs)/l, df);
+ else
+ for (j=0; j<N; j++)
+ p0[n-1] += Pns[(n-1)*N+j] * Tn( (2.*hs-cu)/cu, j);
+ }
+
+ Free(Pns);
+ Free(zs);
+ Free(ws);
+ Free(rside);
+ Free(zch);
+ Free(ps);
+ Free(S2s);
+ Free(S1s);
+
+ return 0;
+}
+
+
+double seU_sf_deluxe(double l, double cu, double hs, double sigma, int df, int N, int nmax, int qm, double *p0, int *nstop, double *rho)
+{ double *S1s, *S2s, *Pns, *ws, *zs, *zch, *rside, za=0., s2, ddf, xl, xu, mn_minus=1., mn_plus=0., oben, unten, q;
+ int i, j, k, n, *ps;
+
+ s2 = sigma*sigma;
+ ddf = (double)df;
+
+ S1s = matrix(N,N);
+ S2s = matrix(N,N);
+ ps = ivector(N);
+ zch = vector(N);
+ rside = vector(N);
+ ws = vector(qm);
+ zs = vector(qm);
+ Pns = matrix(nmax,N);
+
+/* Chebyshev nodes on [0,cu] */
+ for (i=0; i<N; i++) zch[i] = cu/2.*(1.+cos(PI*(2.*(i+1.)-1.)/2./(double)N) );
+
+/* P(L>1)(zch[i]) */
+ for (i=0; i<N; i++) rside[i] = CHI( ddf/s2*(cu-(1.-l)*zch[i])/l, df);
+
+ for (i=0; i<N; i++) {
+ za = (1.-l)*zch[i];
+ if ( df==2 ) { xl = za; xu = cu; }
+ else { xl = 0.; xu = sqrt(cu-za); }
+ gausslegendre(qm, xl, xu, zs, ws);
+ for (j=0; j<N; j++) {
+ S1s[i*N+j] = 0.;
+ for (k=0; k<qm; k++)
+ if ( df==2 )
+ S1s[i*N+j] += ws[k]*Tn((2.*zs[k]-cu)/cu, j) * exp((za-zs[k])/s2/l);
+ else
+ S1s[i*N+j] += ws[k]*Tn((2.*(zs[k]*zs[k]+za)-cu)/cu, j) * 2.*pow(zs[k], ddf-1.) * exp(-ddf*zs[k]*zs[k]/2./s2/l);
+ if ( df==2 ) S1s[i*N+j] /= s2*l;
+ else S1s[i*N+j] /= gammafn(ddf/2.) * pow(2.*s2*l/ddf,ddf/2.);
+ }
+ }
+
+ for (i=0; i<N; i++)
+ for (j=0; j<N; j++) S2s[i*N+j] = Tn( (2.*zch[i]-cu)/cu, j);
+
+ LU_decompose(S2s, ps, N);
+
+ for (n=1;n<=nmax;n++) {
+ if (n==1)
+ for (i=0; i<N; i++) {
+ Pns[i] = 0.;
+ for (j=0; j<N; j++)
+ Pns[i] += 2./N * Tn( (2.*zch[j]-cu)/cu, i) * rside[j];
+ if ( i==0 ) Pns[i] /= 2.;
+ }
+ else {
+ for (i=0; i<N; i++) {
+ rside[i] = 0.;
+ for (j=0; j<N; j++) rside[i] += S1s[i*N+j] * Pns[(n-2)*N+j];
+ }
+ LU_solve2(S2s, rside, ps, N);
+ for (i=0; i<N; i++) Pns[(n-1)*N+i] = rside[i];
+ }
+
+ p0[n-1] = 0.;
+ if ( n==1 )
+ p0[0] = CHI(ddf/s2*(cu-(1.-l)*hs)/l, df);
+ else
+ for (j=0; j<N; j++)
+ p0[n-1] += Pns[(n-1)*N+j] * Tn( (2.*hs-cu)/cu, j);
+
+ mn_minus = 1.; mn_plus = 0.;
+ if ( n > 1 ) {
+ for (i=0; i<N; i++) {
+ oben = 0.; unten = 0.;
+ for (j=0; j<N; j++) {
+ oben += Pns[(n-1)*N+j] * Tn( (2.*zch[i]-cu)/cu, j);
+ unten += Pns[(n-2)*N+j] * Tn( (2.*zch[i]-cu)/cu, j);
+ }
+ if ( fabs(unten)<1e-16 )
+ if ( fabs(oben)<1e-16 ) q = 0.;
+ else q = 1.;
+ else q = oben/unten;
+
+ if ( q<mn_minus ) mn_minus = q;
+ if ( q>mn_plus ) mn_plus = q;
+ }
+ *rho = (mn_minus + mn_plus)/2.;
+ if ( fabs(mn_plus - mn_minus) < FINALeps ) {
+ *nstop = n;
+ n = nmax + 1;
+ }
+ } /* n > 1 */
+ } /* n=1; n<=nmax; n++ */
+
+ Free(Pns);
+ Free(zs);
+ Free(ws);
+ Free(rside);
+ Free(zch);
+ Free(ps);
+ Free(S2s);
+ Free(S1s);
+
+ return 0;
+}
+
+
+int choose_N_for_seU(double lambda)
+{ int N=20;
+
+ N = 25;
+ if ( 0.1 <= lambda && lambda < 0.2 ) N = 35;
+ if ( 0.05 <= lambda && lambda < 0.1 ) N = 50;
+ if ( 0.02 <= lambda && lambda < 0.05) N = 70;
+ if ( 0.01 <= lambda && lambda < 0.02) N = 100;
+ if ( lambda < 0.01 ) N = 150;
+
+ return N;
+}
+
+
+int choose_N_for_se2(double lambda, double cl, double cu)
+{ int N=20, M=1;
+
+ M = ceil( ( log(cl) - log(cu) )/log( 1. - lambda ) );
+
+ N = 5;
+ if ( 0.1 <= lambda && lambda < 0.2 ) N = 10;
+ if ( 0.05 <= lambda && lambda < 0.1 ) N = 20;
+ if ( 0.02 <= lambda && lambda < 0.05) N = 40;
+ if ( 0.01 <= lambda && lambda < 0.02) N = 60;
+ if ( lambda < 0.01 ) N = 90;
+ N *= M;
+
+ if ( N < 30 ) N = 30;
+ if ( N > 200 ) N = 200;
+
+ return N;
+}
+
+
+double seU_sf_prerun_SIGMA_deluxe(double l, double cu, double hs, double sigma, int df1, int df2, int nmax, int qm1, int qm2, double truncate, double *p0)
+{ double *ww, *zz, b1, b2, ddf2, *SF, rho, s2;
+ int i, m, n, nstop, Nlocal;
+
+ Nlocal = choose_N_for_seU(l);
+
+ SF = vector(nmax);
+ ww = vector(qm2);
+ zz = vector(qm2);
+
+ ddf2 = (double)(df2);
+ b1 = qCHI( truncate/2., df2)/ddf2;
+ b2 = qCHI(1. - truncate/2., df2)/ddf2;
+ gausslegendre(qm2, b1, b2, zz, ww);
+ for (i=0; i<qm2; i++) ww[i] *= ddf2 * chi( ddf2*zz[i], df2);
+
+ for (n=0; n<nmax; n++) p0[n] = 0.;
+
+ for (i=0; i<qm2; i++) {
+ s2 = zz[i];
+ m = seU_sf_deluxe(l, s2*cu, s2*hs, sigma, df1, Nlocal, nmax, qm1, SF, &nstop, &rho);
+ if ( m != 0 ) warning("trouble with internal [package spc] function seU_sf_deluxe");
+ if ( nstop > 0 ) {
+ for (n=0; n<nstop; n++) p0[n] += ww[i] * SF[n];
+ for (n=nstop; n<nmax; n++) p0[n] += ww[i] * SF[nstop-1] * pow(rho, n-nstop+1);
+ } else {
+ for (n=0; n<nmax; n++) p0[n] += ww[i] * SF[n];
+ }
+ }
+
+ Free(ww);
+ Free(zz);
+ Free(SF);
+
+ return 0;
+}
+
+
+double seU_sf_prerun_SIGMA(double l, double cu, double hs, double sigma, int df1, int df2, int nmax, int qm1, int qm2, double truncate, double *p0)
+{ double *ww, *zz, b1, b2, ddf2, *SF, s2;
+ int i, m, n, Nlocal;
+
+ Nlocal = choose_N_for_seU(l);
+
+ SF = vector(nmax);
+ ww = vector(qm2);
+ zz = vector(qm2);
+
+ ddf2 = (double)(df2);
+ b1 = qCHI( truncate/2., df2)/ddf2;
+ b2 = qCHI(1. - truncate/2., df2)/ddf2;
+ gausslegendre(qm2, b1, b2, zz, ww);
+ for (i=0; i<qm2; i++) ww[i] *= ddf2 * chi( ddf2*zz[i], df2);
+
+ for (n=0; n<nmax; n++) p0[n] = 0.;
+
+ for (i=0; i<qm2; i++) {
+ s2 = zz[i];
+ m = seU_sf(l, s2*cu, s2*hs, sigma, df1, Nlocal, nmax, qm1, SF);
+ if ( m != 0 ) warning("trouble with internal [package spc] function seU_sf");
+ for (n=0; n<nmax; n++) p0[n] += ww[i] * SF[n];
+ }
+
+ Free(ww);
+ Free(zz);
+ Free(SF);
+
+ return 0;
+}
+
+
+double seU_Wq_prerun_SIGMA_deluxe(double l, double cu, double p, double hs, double sigma, int df1, int df2, int nmax, int qm1, int qm2, double truncate)
+{ double *ww, *zz, b1, b2, ddf2, *SF, *p0, rho, *rhomany, *SFlast, Lp=-1., sf_level_adj, s2;
+ int i, j, n, nstop, nstop_, nsm, nn, qnspecial=0, Nlocal;
+
+ Nlocal = choose_N_for_seU(l);
+
+ p0 = vector(nmax);
+ SF = vector(nmax);
+ rhomany = vector(qm2);
+ SFlast = vector(qm2);
+ ww = vector(qm2);
+ zz = vector(qm2);
+
+ ddf2 = (double)(df2);
+ b1 = qCHI( truncate/2., df2)/ddf2;
+ b2 = qCHI(1. - truncate/2., df2)/ddf2;
+ gausslegendre(qm2, b1, b2, zz, ww);
+ for (i=0; i<qm2; i++) ww[i] *= ddf2 * chi( ddf2*zz[i], df2);
+
+ qnspecial = (qm2+1) / 2;
+
+ s2 = zz[qnspecial];
+ j = seU_sf_deluxe(l, s2*cu, s2*hs, sigma, df1, Nlocal, nmax, qm1, SF, &nsm, &rho);
+ if ( j != 0 ) warning("trouble with internal [package spc] function seU_sf_deluxe");
+ n = nsm;
+
+ if ( nsm < 1 ) { /* did not converge yet -- should be the rare case */
+ nn = nmax;
+ warning("The geometric tail approximation might not work.");
+ } else {
+ nstop = nsm;
+
+ s2 = zz[qnspecial+1];
+ j = seU_sf_deluxe(l, s2*cu, s2*hs, sigma, df1, Nlocal, nmax, qm1, SF, &nstop_, &rho);
+ if ( j != 0 ) warning("trouble with internal [package spc] function seU_sf_deluxe");
+ if ( nstop_ > nsm ) nsm = nstop_;
+ if ( nstop_ < 1) nsm = nmax;
+ if ( nstop_ >= nstop && nsm<nmax ) {
+ i = 1;
+ while ( nstop_ >= nstop && nsm<nmax ) {
+ nstop = nstop_;
+ i++;
+ s2 = zz[qnspecial+i];
+ j = seU_sf_deluxe(l, s2*cu, s2*hs, sigma, df1, Nlocal, nmax, qm1, SF, &nstop_, &rho);
+ if ( j != 0 ) warning("trouble with internal [package spc] function seU_sf_deluxe");
+ if ( nstop_ > nsm ) nsm = nstop_;
+ if ( nstop_ < 1) nsm = nmax;
+ }
+ }
+
+ nstop = n;
+ s2 = zz[qnspecial-1];
+ j = seU_sf_deluxe(l, s2*cu, s2*hs, sigma, df1, Nlocal, nmax, qm1, SF, &nstop_, &rho);
+ if ( j != 0 ) warning("trouble with internal [package spc] function seU_sf_deluxe");
+ if ( nstop_ > nsm ) nsm = nstop_;
+ if ( nstop_ < 1) nsm = nmax;
+ if ( nstop_ >= nstop && nsm<nmax ) {
+ i = 1;
+ while ( nstop_ >= nstop && nsm<nmax ) {
+ nstop = nstop_;
+ i++;
+ s2 = zz[qnspecial-i];
+ j = seU_sf_deluxe(l, s2*cu, s2*hs, sigma, df1, Nlocal, nmax, qm1, SF, &nstop_, &rho);
+ if ( j != 0 ) warning("trouble with internal [package spc] function seU_sf_deluxe");
+ if ( nstop_ > nsm ) nsm = nstop_;
+ if ( nstop_ < 1) nsm = nmax;
+ }
+ }
+ nn = nsm;
+ }
+
+ for (n=0; n<nmax; n++) p0[n] = 0.;
+
+ for (i=0; i<qm2; i++) {
+ s2 = zz[i];
+ j = seU_sf_deluxe(l, s2*cu, s2*hs, sigma, df1, Nlocal, nn, qm1, SF, &nstop, &rho);
+ if ( j != 0 ) warning("trouble with internal [package spc] function seU_sf_deluxe");
+ if ( nstop < 1 ) {
+ nstop = nn;
+ warning("The geometric tail approximation might not work.");
+ }
+ rhomany[i] = rho;
+ for (n=0; n<nstop; n++) p0[n] += ww[i] * SF[n];
+ if ( nstop < nn) {
+ for (n=nstop; n<nn; n++) p0[n] += ww[i] * SF[nstop-1] * pow(rho, n-nstop+1);
+ }
+ SFlast[i] = SF[nstop-1] * pow(rho, nn-nstop);
+ }
+
+ sf_level_adj = 1.-p;
+ if ( p0[nn-1] <= sf_level_adj ) {
+ n = nn-1;
+ while ( p0[n] <= sf_level_adj && n > 0 ) n--;
+ if ( p0[n] > 1.-p ) Lp = (double)( n + 2 ); else Lp = 1.;
+ } else {
+ for (n=nn; n<nmax; n++) {
+ p0[n] = 0.;
+ for (i=0; i<qm2; i++) p0[n] += ww[i] * SFlast[i] * pow(rhomany[i], n-nn+1);
+ if ( p0[n] <= sf_level_adj ) {
+ Lp = (double)( n + 1 );
+ n = nmax+1;
+ }
+ }
+ }
+
+ Free(p0);
+ Free(ww);
+ Free(zz);
+ Free(SF);
+ Free(SFlast);
+ Free(rhomany);
+
+ return Lp;
+}
+
+
+
+double seU_iglarl_prerun_SIGMA(double l, double cu, double hs, double sigma, int df1, int df2, int N, int qm1, int qm2, double truncate)
+{ double *ww, *zz, b1, b2, result, ddf2, s2;
+ int i;
+
+ ww = vector(qm2);
+ zz = vector(qm2);
+ ddf2 = (double)(df2);
+ b1 = qCHI( truncate/2., df2)/ddf2;
+ b2 = qCHI(1. - truncate/2., df2)/ddf2;
+ gausslegendre(qm2, b1, b2, zz, ww);
+ result = 0.;
+ for (i=0; i<qm2; i++) {
+ s2 = zz[i];
+ result += ww[i] * ddf2 * chi( ddf2*s2, df2) * seU_iglarl(l, s2*cu, s2*hs, sigma, df1, N, qm1);
+ }
+ Free(ww);
+ Free(zz);
+
+ return result;
+}
+
+
+double seU_Wq(double l, double cu, double p, double hs, double sigma, int df, int N, int nmax, int qm)
+{ double *S1s, *S2s, *Pns, *p0, *ws, *zs, *zch, *rside, za=0., s2, ddf, xl, xu, q_minus=0., q_plus=0., mn_minus=1., mn_plus=0., oben, unten, q, enumerator=0., Wq=0.;
+ int i, j, k, n, *ps;
+
+ s2 = sigma*sigma;
+ ddf = (double)df;
+
+ S1s = matrix(N,N);
+ S2s = matrix(N,N);
+ ps = ivector(N);
+ zch = vector(N);
+ rside = vector(N);
+ ws = vector(qm);
+ zs = vector(qm);
+ p0 = vector(nmax);
+ Pns = matrix(nmax,N);
+
+/* Chebyshev nodes on [0,cu] */
+ for (i=0; i<N; i++) zch[i] = cu/2.*(1.+cos(PI*(2.*(i+1.)-1.)/2./(double)N) );
+
+/* P(L>1)(zch[i]) */
+ for (i=0; i<N; i++) rside[i] = CHI( ddf/s2*(cu-(1.-l)*zch[i])/l, df);
+
+ for (i=0; i<N; i++) {
+ za = (1.-l)*zch[i];
+ if ( df==2 ) { xl = za; xu = cu; }
+ else { xl = 0.; xu = sqrt(cu-za); }
+ gausslegendre(qm, xl, xu, zs, ws);
+ for (j=0; j<N; j++) {
+ S1s[i*N+j] = 0.;
+ for (k=0; k<qm; k++)
+ if ( df==2 )
+ S1s[i*N+j] += ws[k]*Tn((2.*zs[k]-cu)/cu, j) * exp((za-zs[k])/s2/l);
+ else
+ S1s[i*N+j] += ws[k]*Tn((2.*(zs[k]*zs[k]+za)-cu)/cu, j) * 2.*pow(zs[k], ddf-1.) * exp(-ddf*zs[k]*zs[k]/2./s2/l);
+ if ( df==2 ) S1s[i*N+j] /= s2*l;
+ else S1s[i*N+j] /= gammafn(ddf/2.) * pow(2.*s2*l/ddf,ddf/2.);
+ }
+ }
+
+ for (i=0; i<N; i++)
+ for (j=0; j<N; j++) S2s[i*N+j] = Tn( (2.*zch[i]-cu)/cu, j);
+
+ LU_decompose(S2s, ps, N);
+
+ for (n=1;n<=nmax;n++) {
+ if (n==1)
+ for (i=0; i<N; i++) {
+ Pns[i] = 0.;
+ for (j=0; j<N; j++)
+ Pns[i] += 2./N * Tn( (2.*zch[j]-cu)/cu, i) * rside[j];
+ if ( i==0 ) Pns[i] /= 2.;
+ }
+ else {
+ for (i=0; i<N; i++) {
+ rside[i] = 0.;
+ for (j=0; j<N; j++) rside[i] += S1s[i*N+j] * Pns[(n-2)*N+j];
+ }
+ LU_solve2(S2s, rside, ps, N);
+ for (i=0; i<N; i++) Pns[(n-1)*N+i] = rside[i];
+ }
+
+ p0[n-1] = 0.;
+ if ( n==1 )
+ p0[0] = CHI(ddf/s2*(cu-(1.-l)*hs)/l, df);
+ else
+ for (j=0; j<N; j++)
+ p0[n-1] += Pns[(n-1)*N+j] * Tn( (2.*hs-cu)/cu, j);
+
+ if ( p0[n-1] < 1.-p ) {
+ Wq = (double)n;
+ n = nmax+1;
+ } else {
+ mn_minus = 1.; mn_plus = 0.;
+ if ( n > 1 ) {
+ for (i=0; i<N; i++) {
+ oben = 0.; unten = 0.;
+ for (j=0; j<N; j++) {
+ oben += Pns[(n-1)*N+j] * Tn( (2.*zch[i]-cu)/cu, j);
+ unten += Pns[(n-2)*N+j] * Tn( (2.*zch[i]-cu)/cu, j);
+ }
+ if ( fabs(unten)<1e-16 )
+ if ( fabs(oben)<1e-16 ) q = 0.;
+ else q = 1.;
+ else q = oben/unten;
+ if ( q<mn_minus ) mn_minus = q;
+ if ( q>mn_plus ) mn_plus = q;
+ }
+ enumerator = log( (1.-p)/p0[n-1] );
+ q_minus = (double)n + enumerator/log(mn_minus);
+ q_plus = (double)n + enumerator/log(mn_plus);
+ /*if ( fabs( (q_plus-q_minus)/q_minus )<FINALeps ) n = nmax+1;*/
+ if ( fabs( ceil(q_plus) - ceil(q_minus) ) < .5 ) {
+ Wq = ceil(q_plus);
+ n = nmax +1;
+ }
+ } /* n > 1 */
+ } /* p0[n-1] >= 1.-p */
+ } /* n=1; n<=nmax; n++ */
+
+ Free(Pns);
+ Free(p0);
+ Free(zs);
+ Free(ws);
+ Free(rside);
+ Free(zch);
+ Free(ps);
+ Free(S2s);
+ Free(S1s);
+
+ return Wq;
+}
+
+
+double seU_crit(double l, double L0, double hs, double sigma, int df, int N, int qm)
+{ double s1, s2, s3, ds, L1, L2, L3, norm;
+
+ norm = sqrt(df);
+ s2 = hs - .15;
+ L2 = 0.;
+ do {
+ s1 = s2;
+ L1 = L2;
+ s2 += .2/norm;
+ L2 = seU_iglarl(l,s2,hs,sigma,df,N,qm);
+ } while ( L2 < L0 );
+
+ do {
+ s3 = s1 + (L0-L1)/(L2-L1) * (s2-s1);
+ L3 = seU_iglarl(l,s3,hs,sigma,df,N,qm);
+ ds = s3-s2; s1 = s2; L1 = L2; s2 = s3; L2 = L3;
+ } while ( fabs(L0-L3)>1e-7 && fabs(ds)>1e-9 );
+
+ return s3;
+}
+
+
+double stdeU_crit(double l, double L0, double hs, double sigma, int df, int N, int qm)
+{ double s1, s2, s3, ds, L1, L2, L3, norm;
+
+ norm = sqrt(df);
+ s2 = hs - .15;
+ L2 = 0.;
+ do {
+ s1 = s2;
+ L1 = L2;
+ s2 += .2/norm;
+ L2 = stdeU_iglarl(l,s2,hs,sigma,df,N,qm);
+ } while ( L2 < L0 );
+
+ do {
+ s3 = s1 + (L0-L1)/(L2-L1) * (s2-s1);
+ L3 = stdeU_iglarl(l,s3,hs,sigma,df,N,qm);
+ ds = s3-s2; s1 = s2; L1 = L2; s2 = s3; L2 = L3;
+ } while ( fabs(L0-L3)>1e-7 && fabs(ds)>1e-9 );
+
+ return s3;
+}
+
+
+double seU_crit_prerun_SIGMA(double l, double L0, double hs, double sigma, int df1, int df2, int N, int qm1, int qm2, double truncate)
+{ double s1, s2, s3, ds, L1=0., L2=0., L3=0.;
+
+ s2 = hs;
+ do {
+ L1 = L2;
+ s2 += .2;
+ L2 = seU_iglarl_prerun_SIGMA(l, s2, hs, sigma, df1, df2, N, qm1, qm2, truncate);
+ } while ( L2 < L0 );
+
+ s1 = s2 - .2;
+
+ do {
+ s3 = s1 + (L0-L1)/(L2-L1) * (s2-s1);
+ L3 = seU_iglarl_prerun_SIGMA(l, s3, hs, sigma, df1, df2, N, qm1, qm2, truncate);
+ ds = s3-s2; s1 = s2; L1 = L2; s2 = s3; L2 = L3;
+ } while ( fabs(L0-L3)>1e-6 && fabs(ds)>1e-9 );
+
+ return s3;
+}
+
+
+double seU_q_crit(double l, int L0, double alpha, double hs, double sigma, int df, int N, int qm, double c_error, double a_error)
+{ double s1, s2, s3, ds, p1, p2, p3, *SF;
+ int result=1;
+
+ SF = vector(L0);
+
+ s2 = hs; p2 = 1.;
+ do {
+ p1 = p2;
+ s2 += .2;
+ result = seU_sf(l, s2, hs, sigma, df, N, L0, qm, SF);
+ if ( result != 0 ) warning("trouble in seU_q_crit [package spc]");
+ p2 = 1. - SF[L0-1];
+ } while ( p2 > alpha );
+
+ s1 = s2 - .2;
+
+ do {
+ s3 = s1 + (alpha - p1)/( p2 - p1 ) * (s2-s1);
+ result = seU_sf(l, s3, hs, sigma, df, N, L0, qm, SF);
+ if ( result != 0 ) warning("trouble in seU_q_crit [package spc]");
+ p3 = 1. - SF[L0-1];
+ ds = s3 - s2; s1 = s2; p1 = p2; s2 = s3; p2 = p3;
+ } while ( fabs(alpha - p3)>a_error && fabs(ds)>c_error );
+
+ Free(SF);
+
+ return s3;
+}
+
+
+double seU_q_crit_prerun_SIGMA(double l, int L0, double alpha, double hs, double sigma, int df1, int df2, int N, int qm1, int qm2, double truncate, int tail_approx, double c_error, double a_error)
+{ double s1, s2, s3, ds, p1, p2, p3, *SF;
+ int result=1;
+
+ SF = vector(L0);
+
+ s2 = seU_q_crit(l, L0, alpha, hs, sigma, df1, N, qm1, c_error, a_error);
+ if ( tail_approx ) result = seU_sf_prerun_SIGMA_deluxe(l, s2, hs, sigma, df1, df2, L0, qm1, qm2, truncate, SF);
+ else result = seU_sf_prerun_SIGMA(l, s2, hs, sigma, df1, df2, L0, qm1, qm2, truncate, SF);
+ if ( result != 0 ) warning("trouble in seU_q_crit_prerun_SIGMA [package spc]");
+ p2 = 1. - SF[L0-1];
+
+ if ( p2 > alpha ) {
+ do {
+ p1 = p2;
+ s2 += .2;
+ if ( tail_approx ) result = seU_sf_prerun_SIGMA_deluxe(l, s2, hs, sigma, df1, df2, L0, qm1, qm2, truncate, SF);
+ else result = seU_sf_prerun_SIGMA(l, s2, hs, sigma, df1, df2, L0, qm1, qm2, truncate, SF);
+ if ( result != 0 ) warning("trouble in seU_q_crit_prerun_SIGMA [package spc]");
+ p2 = 1. - SF[L0-1];
+ } while ( p2 > alpha );
+ s1 = s2 - .2;
+ } else {
+ do {
+ p1 = p2;
+ s2 -= .2;
+ if ( tail_approx ) result = seU_sf_prerun_SIGMA_deluxe(l, s2, hs, sigma, df1, df2, L0, qm1, qm2, truncate, SF);
+ else result = seU_sf_prerun_SIGMA(l, s2, hs, sigma, df1, df2, L0, qm1, qm2, truncate, SF);
+ if ( result != 0 ) warning("trouble in seU_q_crit_prerun_SIGMA [package spc]");
+ p2 = 1. - SF[L0-1];
+ } while ( p2 <= alpha && s2 > hs );
+ s1 = s2 + .2;
+ }
+
+ do {
+ s3 = s1 + (alpha - p1)/( p2 - p1 ) * (s2-s1);
+ if ( tail_approx ) result = seU_sf_prerun_SIGMA_deluxe(l, s3, hs, sigma, df1, df2, L0, qm1, qm2, truncate, SF);
+ else result = seU_sf_prerun_SIGMA(l, s3, hs, sigma, df1, df2, L0, qm1, qm2, truncate, SF);
+ if ( result != 0 ) warning("trouble in seU_q_crit_prerun_SIGMA [package spc]");
+ p3 = 1. - SF[L0-1];
+ ds = s3 - s2; s1 = s2; p1 = p2; s2 = s3; p2 = p3;
+ } while ( fabs(alpha - p3)>a_error && fabs(ds)>c_error );
+
+ Free(SF);
+
+ return s3;
+}
+
+
+double se2_iglarl(double l, double cl, double cu, double hs, double sigma, int df, int N, int qm)
+{ double *a, *g, *w, *z, *t, h, arl, Hij, xl, za, dN, ddf, s2,
+ t0, t1, x0, x1;
+ int i, j, k, qi, qj, M, Ntilde, NN, ii, it, jj;
+
+ M = ceil( (log(cl) - log(cu))/log(1.-l) );
+ Ntilde = ceil( (double)N/(double)M );
+ NN = M*Ntilde;
+ s2 = sigma*sigma;
+ ddf = (double)df;
+ dN = (double)Ntilde - 1.;
+
+ a = matrix(NN, NN);
+ g = vector(NN);
+ t = vector(NN);
+ w = vector(qm);
+ z = vector(qm);
+
+ for(i=0;i<M;i++) {
+ t0 = cl/pow(1.-l,(double)(i));
+ t1 = t0/(1.-l);
+ if (t1>cu) t1 = cu;
+
+ for (j=1;j<Ntilde;j++) { /* node_i,Ntilde-1 = node_i+1,0 */
+ h = cos( PI/dN *(dN-j) );
+ t[i*(Ntilde-1)+j] = t0 + (h+1.)/2.*(t1-t0);
+ /* Chebyshev Gauss-Lobatto nodes on [t0,t1] */
+ }
+ }
+ t[0] = cl;
+
+ for (i=0;i<M;i++) {
+ for (j=1;j<=Ntilde;j++) {
+ ii = i*Ntilde + j-1;
+ it = i*(Ntilde-1) + j-1;
+
+ za = (1.-l)*t[it];
+ if (za<cl) xl = cl; else xl = za;
+
+ for (qi=0;qi<i-1;qi++)
+ for (qj=1;qj<=Ntilde;qj++) {
+ jj = qi*Ntilde + qj-1;
+ a[ii*NN+jj] = 0.;
+ }
+
+ if (i>0) {
+ qi = i-1;
+ t0 = cl/pow(1.-l,(double)qi);
+ t1 = t0/(1.-l);
+ if (t1>cu) t1 = cu;
+ if (t0<xl) x0 = xl; else x0 = t0;
+ if (df==2)
+ x1 = t1;
+ else {
+ if (x0-za>1e-10) x0 = sqrt(x0-za); else x0 = 0.;
+ if (t1-za>1e-10) x1 = sqrt(t1-za); else x1 = 0.;
+ }
+
+ for (qj=1;qj<=Ntilde;qj++) {
+ jj = qi*Ntilde + qj-1;
+
+ if (j==1) a[ii*NN+jj] = - Tn((2.*t[it]-t0-t1)/(t1-t0),qj-1);
+ else {
+ if (fabs(t1-x0)>1e-8) {
+ gausslegendre(qm,x0,x1,z,w);
+ Hij = 0.;
+ for (k=0;k<qm;k++) {
+ if (df==2)
+ Hij += w[k] * Tn( (2.*z[k]-t0-t1)/(t1-t0), qj-1) *
+ exp((za-z[k])/s2/l);
+ if (df!=2)
+ Hij += w[k] * Tn( (2.*(z[k]*z[k]+za)-t0-t1)/(t1-t0) ,qj-1) *
+ 2. * pow(z[k], ddf-1.) * exp(-ddf*z[k]*z[k]/2./s2/l);
+ }
+ if (df==2) Hij /= s2*l;
+ else Hij /= gammafn(ddf/2.) * pow(2.*s2*l/ddf,ddf/2.);
+ a[ii*NN+jj] = -Hij;
+ }
+ else a[ii*NN+jj] = 0.;
+ }
+ }
+ }
+
+ for (qi=i;qi<M;qi++) {
+ t0 = cl/pow(1.-l,(double)qi);
+ t1 = t0/(1.-l);
+ if (t1>cu) t1 = cu;
+ if (t0<xl) x0 = xl; else x0 = t0;
+ if (df==2)
+ x1 = t1;
+ else {
+ if (x0-za>1e-10) x0 = sqrt(x0-za); else x0 = 0.;
+ if (t1-za>1e-10) x1 = sqrt(t1-za); else x1 = 0.;
+ }
+
+ if (i>0 && j==1 && qi==i) {
+ for (qj=1;qj<=Ntilde;qj++) {
+ jj = qi*Ntilde + qj-1;
+ a[ii*NN+jj] = Tn((2.*t[it]-t0-t1)/(t1-t0),qj-1);
+ }
+ }
+
+ if (i>0 && j==1 && qi>i) {
+ for (qj=1;qj<=Ntilde;qj++) {
+ jj = qi*Ntilde + qj-1;
+ a[ii*NN+jj] = 0.;
+ }
+ }
+
+ if (i==0 || j>1) {
+ for (qj=1;qj<=Ntilde;qj++) {
+ jj = qi*Ntilde + qj-1;
+ gausslegendre(qm,x0,x1,z,w);
+ Hij = 0.;
+ for (k=0;k<qm;k++) {
+ if (df==2)
+ Hij += w[k] * Tn( (2.*z[k]-t0-t1)/(t1-t0), qj-1) *
+ exp((za-z[k])/s2/l);
+ if (df!=2)
+ Hij += w[k] * Tn( (2.*(z[k]*z[k]+za)-t0-t1)/(t1-t0),qj-1) *
+ 2. * pow(z[k], ddf-1.) * exp(-ddf*z[k]*z[k]/2./s2/l);
+ }
+ if (df==2) Hij /= s2*l;
+ else Hij /= gammafn(ddf/2.) * pow(2.*s2*l/ddf,ddf/2.);
+ if (qi==i) a[ii*NN+jj] = Tn((2.*t[it]-t0-t1)/(t1-t0),qj-1) -
+ Hij;
+ else a[ii*NN+jj] = -Hij;
+ }
+ }
+ }
+ }
+ }
+
+ for (j=0;j<NN;j++) g[j] = 1.;
+ for (j=1;j<M;j++) g[Ntilde*j] = 0.;
+
+ LU_solve(a,g,NN);
+
+ arl = 0.;
+ for (i=0;i<M;i++) {
+ t0 = cl/pow(1.-l,(double)i);
+ t1 = t0/(1.-l);
+ if (t1>cu) t1 = cu;
+
+ if (t0<=hs && hs<t1)
+ for (j=1;j<=Ntilde;j++) {
+ ii = i*Ntilde + j-1;
+ arl += g[ii] * Tn((2.*hs-t0-t1)/(t1-t0),j-1);
+ }
+ }
+
+ Free(z);
+ Free(w);
+ Free(t);
+ Free(g);
+ Free(a);
+
+ return arl;
+}
+
+
+double stde2_iglarl(double l, double cl, double cu, double hs, double sigma, int df, int N, int qm)
+{ double *a, *g, *w, *z, *t, h, arl, Hij, xl, za, dN, ddf, s2, t0, t1, x0, x1, v;
+ int i, j, k, qi, qj, M, Ntilde, NN, ii, it, jj;
+
+ M = ceil( (log(cl) - log(cu))/log(1.-l) );
+ Ntilde = ceil( (double)N/(double)M );
+ NN = M*Ntilde;
+ s2 = sigma*sigma;
+ ddf = (double)df;
+ dN = (double)Ntilde - 1.;
+
+ a = matrix(NN, NN);
+ g = vector(NN);
+ t = vector(NN);
+ w = vector(qm);
+ z = vector(qm);
+
+ for(i=0; i<M; i++) {
+ t0 = cl/pow(1.-l,(double)(i));
+ t1 = t0/(1.-l);
+ if ( t1>cu ) t1 = cu;
+
+ for (j=1; j<Ntilde; j++) { /* node_i,Ntilde-1 = node_i+1,0 */
+ h = cos( PI/dN *(dN-j) );
+ t[i*(Ntilde-1)+j] = t0 + (h+1.)/2.*(t1-t0); /* Chebyshev Gauss-Lobatto nodes on [t0,t1] */
+ }
+ }
+ t[0] = cl;
+
+ for (i=0; i<M; i++) {
+ for (j=1; j<=Ntilde; j++) {
+ ii = i*Ntilde + j-1;
+ it = i*(Ntilde-1) + j-1;
+
+ za = (1.-l)*t[it];
+ if ( za<cl ) xl = cl; else xl = za;
+
+ for (qi=0; qi<i-1; qi++)
+ for (qj=1; qj<=Ntilde; qj++) {
+ jj = qi*Ntilde + qj-1;
+ a[ii*NN+jj] = 0.;
+ }
+
+ if ( i>0 ) {
+ qi = i-1;
+ t0 = cl/pow(1.-l,(double)qi);
+ t1 = t0/(1.-l);
+ if ( t1>cu ) t1 = cu;
+ if ( t0<xl ) x0 = xl; else x0 = t0;
+ x1 = t1;
+
+ for (qj=1; qj<=Ntilde; qj++) {
+ jj = qi*Ntilde + qj-1;
+
+ if ( j==1 ) a[ii*NN+jj] = - Tn((2.*t[it]-t0-t1)/(t1-t0),qj-1);
+ else {
+ if ( fabs(t1-x0)>1e-8 ) {
+ gausslegendre(qm, x0, x1, z, w);
+ Hij = 0.;
+ for (k=0; k<qm; k++) {
+ v = (z[k] - za) / l;
+ Hij += w[k] * Tn( (2.*z[k]-t0-t1)/(t1-t0), qj-1) * pow(v,ddf-1.)*exp(-ddf/2./s2*v*v);
+ }
+ Hij *= 2./l/gammafn(ddf/2.)/pow(2.*s2/ddf,ddf/2.);
+ a[ii*NN+jj] = -Hij;
+ }
+ else a[ii*NN+jj] = 0.;
+ }
+ }
+ }
+
+ for (qi=i; qi<M; qi++) {
+ t0 = cl/pow(1.-l,(double)qi);
+ t1 = t0/(1.-l);
+ if ( t1>cu ) t1 = cu;
+ if ( t0<xl ) x0 = xl; else x0 = t0;
+ x1 = t1;
+
+ if ( i>0 && j==1 && qi==i ) {
+ for (qj=1; qj<=Ntilde; qj++) {
+ jj = qi*Ntilde + qj-1;
+ a[ii*NN+jj] = Tn((2.*t[it]-t0-t1)/(t1-t0),qj-1);
+ }
+ }
+
+ if ( i>0 && j==1 && qi>i ) {
+ for (qj=1;qj<=Ntilde;qj++) {
+ jj = qi*Ntilde + qj-1;
+ a[ii*NN+jj] = 0.;
+ }
+ }
+
+ if ( i==0 || j>1 ) {
+ for ( qj=1; qj<=Ntilde; qj++) {
+ jj = qi*Ntilde + qj-1;
+ gausslegendre(qm, x0, x1, z, w);
+ Hij = 0.;
+ for (k=0; k<qm; k++) {
+ v = (z[k] - za) / l;
+ Hij += w[k] * Tn( (2.*z[k]-t0-t1)/(t1-t0), qj-1) * pow(v,ddf-1.)*exp(-ddf/2./s2*v*v);
+ }
+ Hij *= 2./l/gammafn(ddf/2.)/pow(2.*s2/ddf,ddf/2.);
+ if ( qi==i ) a[ii*NN+jj] = Tn((2.*t[it]-t0-t1)/(t1-t0),qj-1) - Hij;
+ else a[ii*NN+jj] = -Hij;
+ }
+ }
+ }
+ }
+ }
+
+ for (j=0; j<NN; j++) g[j] = 1.;
+ for (j=1; j<M; j++) g[Ntilde*j] = 0.;
+
+ LU_solve(a,g,NN);
+
+ arl = 0.;
+ for (i=0; i<M; i++) {
+ t0 = cl/pow(1.-l,(double)i);
+ t1 = t0/(1.-l);
+ if ( t1>cu ) t1 = cu;
+
+ if ( t0<=hs && hs<t1 )
+ for (j=1; j<=Ntilde; j++) {
+ ii = i*Ntilde + j-1;
+ arl += g[ii] * Tn((2.*hs-t0-t1)/(t1-t0),j-1);
+ }
+ }
+
+ Free(z);
+ Free(w);
+ Free(t);
+ Free(g);
+ Free(a);
+
+ return arl;
+}
+
+
+double se2_sf(double l, double cl, double cu, double hs, double sigma, int df, int N, int nmax, int qm, double *p0)
+{ double *S1s, *S2s, *Pns, *ws, *zs, *zch, *rside, *b, za=0., s2, ddf, xl, xu, dN, Hij;
+ int i, j, k, n, *ps, Ntilde, ihs, M, NN, ii, jj;
+
+ M = ceil( (log(cl) - log(cu))/log(1.-l) );
+ Ntilde = ceil( (double)N/(double)M );
+ NN = M*Ntilde;
+ s2 = sigma*sigma;
+ ddf = (double)df;
+ dN = (double)Ntilde;
+
+ ihs = floor( (log(cl) - log(hs))/log(1.-l) );
+ if ( ihs<0 ) ihs = 0;
+
+ S1s = matrix(NN,NN);
+ S2s = matrix(NN,NN);
+ ps = ivector(NN);
+ zch = matrix(M,Ntilde);
+ rside = vector(NN);
+ b = vector(M+1);
+ ws = vector(qm);
+ zs = vector(qm);
+ Pns = matrix(nmax,NN);
+
+/* interval borders b_i = cl/(1-l)^i */
+ for (i=0; i<M; i++) b[i] = cl/pow(1.-l, (double)(i));
+ b[M] = cu;
+
+ /* Chebyshev nodes on [b_0,b_1],[b_1,b_2],...,[b_M-1,cu] */
+ for (i=0; i<M; i++)
+ for (j=0; j<Ntilde; j++) {
+ zch[ i*Ntilde+j ] = b[i] + (b[i+1]-b[i])/2.*(1.+cos(PI*(2.*j+1.)/2./dN));
+ }
+
+ /* P(L>1)(zch[i,j]) */
+ for (i=0; i<M; i++)
+ for (j=0; j<Ntilde; j++) {
+ rside[ i*Ntilde+j ] = CHI( ddf/s2*(cu-(1.-l)*zch[ i*Ntilde+j ])/l, df)
+ - CHI( ddf/s2*(cl-(1.-l)*zch[ i*Ntilde+j ])/l, df);
+ }
+
+ for (i=0; i<M; i++)
+ for (j=0; j<Ntilde; j++) {
+ za = (1.-l)*zch[ i*Ntilde+j ];
+ for (ii=0; ii<M; ii++)
+ for (jj=0; jj<Ntilde; jj++) {
+ if ( b[ii+1]<za ) S1s[ (i*Ntilde+j)*NN + ii*Ntilde+jj ] = 0.;
+ else {
+ if ( za<b[ii] ) xl = b[ii]; else xl = za;
+ xu = b[ii+1];
+ if ( df!=2 ) {
+ xl = sqrt(xl-za);
+ xu = sqrt(xu-za);
+ }
+ gausslegendre(qm, xl, xu, zs, ws);
+ Hij = 0.;
+ for (k=0; k<qm; k++)
+ if ( df==2 )
+ Hij += ws[k]*Tn( (2.*zs[k]-b[ii+1]-b[ii])/(b[ii+1]-b[ii]), jj) * exp(-zs[k]/s2/l);
+ else
+ Hij += ws[k]*Tn( (2.*(zs[k]*zs[k]+za)-b[ii+1]-b[ii])/(b[ii+1]-b[ii]), jj)
+ * 2. * pow(zs[k], ddf-1.) * exp(-ddf*zs[k]*zs[k]/2./s2/l);
+ if ( df==2 ) Hij *= exp(za/s2/l)/s2/l;
+ else Hij /= gammafn(ddf/2.) * pow(2.*s2*l/ddf, ddf/2.);
+ S1s[ (i*Ntilde+j)*NN + ii*Ntilde+jj ] = Hij;
+ }
+ }
+ }
+
+ for (i=0; i<NN; i++)
+ for (j=0; j<NN; j++) S2s[i*NN+j] = 0.;
+
+ for (i=0; i<M; i++)
+ for (j=0; j<Ntilde; j++)
+ for (jj=0; jj<Ntilde; jj++)
+ S2s[ (i*Ntilde+j)*NN + i*Ntilde+jj ] = Tn( (2.*zch[ i*Ntilde+j ]-b[i+1]-b[i])/(b[i+1]-b[i]), jj);
+
+ LU_decompose(S2s,ps,NN);
+
+ for (n=1; n<=nmax; n++) {
+ if ( n==1)
+ for (i=0; i<M; i++)
+ for (j=0; j<Ntilde; j++) {
+ Pns[ i*Ntilde+j ] = 0.;
+ for (jj=0; jj<Ntilde; jj++)
+ Pns[ i*Ntilde+j ] += /* usual Chebyshev approximation */
+ 2./Ntilde * Tn( (2.*zch[i*Ntilde+jj]-b[i+1]-b[i])/(b[i+1]-b[i]), j) * rside[ i*Ntilde+jj ];
+ if ( j==0 ) Pns[ i*Ntilde+j ] /= 2.;
+ }
+ else {
+ for (i=0; i<NN; i++) {
+ rside[i] = 0.;
+ for (j=0; j<NN; j++) rside[i] += S1s[ i*NN+j ] * Pns[ (n-2)*NN+j ];
+ }
+ LU_solve2(S2s, rside, ps, NN);
+ for (i=0; i<NN; i++) Pns[ (n-1)*NN+i ] = rside[i];
+ }
+
+ p0[n-1] = 0.;
+ if ( n==1 )
+ p0[0] = CHI( ddf/s2*(cu-(1.-l)*hs)/l, df)
+ - CHI( ddf/s2*(cl-(1.-l)*hs)/l, df);
+ else
+ for (j=0; j<Ntilde; j++)
+ p0[n-1] += Pns[ (n-1)*NN + ihs*Ntilde+j ] * Tn( (2.*hs-b[ihs+1]-b[ihs])/(b[ihs+1]-b[ihs]), j);
+ }
+
+ Free(Pns);
+ Free(zs);
+ Free(ws);
+ Free(rside);
+ Free(zch);
+ Free(ps);
+ Free(S2s);
+ Free(S1s);
+
+ return 0;
+}
+
+
+double se2_sf_deluxe(double l, double cl, double cu, double hs, double sigma, int df, int N, int nmax, int qm, double *p0, int *nstop, double *rho)
+{ double *S1s, *S2s, *Pns, *ws, *zs, *zch, *rside, *b, za=0., s2, ddf, xl, xu, dN, Hij, mn_minus=1., mn_plus=0., oben, unten, q;
+ int i, j, k, n, *ps, Ntilde, ihs, M, NN, ii, jj;
+
+ M = ceil( (log(cl)-log(cu))/log(1.-l) );
+ Ntilde = ceil( (double)N/(double)M );
+ NN = M*Ntilde;
+ s2 = sigma*sigma;
+ ddf = (double)df;
+ dN = (double)Ntilde;
+
+ ihs = floor( (log(cl) - log(hs))/log(1.-l) );
+ if ( ihs<0 ) ihs = 0;
+
+ S1s = matrix(NN,NN);
+ S2s = matrix(NN,NN);
+ ps = ivector(NN);
+ zch = matrix(M,Ntilde);
+ rside = vector(NN);
+ b = vector(M+1);
+ ws = vector(qm);
+ zs = vector(qm);
+ Pns = matrix(nmax,NN);
+
+/* interval borders b_i = cl/(1-l)^i */
+ for (i=0; i<M; i++) b[i] = cl/pow(1.-l, (double)(i));
+ b[M] = cu;
+
+ /* Chebyshev nodes on [b_0,b_1],[b_1,b_2],...,[b_M-1,cu] */
+ for (i=0; i<M; i++)
+ for (j=0; j<Ntilde; j++) {
+ zch[ i*Ntilde+j ] = b[i] + (b[i+1]-b[i])/2.*(1.+cos(PI*(2.*j+1.)/2./dN));
+ }
+
+ /* P(L>1)(zch[i,j]) */
+ for (i=0; i<M; i++)
+ for (j=0; j<Ntilde; j++) {
+ rside[ i*Ntilde+j ] = CHI( ddf/s2*(cu-(1.-l)*zch[ i*Ntilde+j ])/l, df)
+ - CHI( ddf/s2*(cl-(1.-l)*zch[ i*Ntilde+j ])/l, df);
+ }
+
+ for (i=0; i<M; i++)
+ for (j=0; j<Ntilde; j++) {
+ za = (1.-l)*zch[ i*Ntilde+j ];
+ for (ii=0; ii<M; ii++)
+ for (jj=0; jj<Ntilde; jj++) {
+ if ( b[ii+1]<za ) S1s[ (i*Ntilde+j)*NN + ii*Ntilde+jj ] = 0.;
+ else {
+ if ( za<b[ii] ) xl = b[ii]; else xl = za;
+ xu = b[ii+1];
+ if ( df!=2 ) {
+ xl = sqrt(xl-za);
+ xu = sqrt(xu-za);
+ }
+ gausslegendre(qm, xl, xu, zs, ws);
+ Hij = 0.;
+ for (k=0; k<qm; k++)
+ if ( df==2 )
+ Hij += ws[k]*Tn( (2.*zs[k]-b[ii+1]-b[ii])/(b[ii+1]-b[ii]), jj) * exp(-zs[k]/s2/l);
+ else
+ Hij += ws[k]*Tn( (2.*(zs[k]*zs[k]+za)-b[ii+1]-b[ii])/(b[ii+1]-b[ii]), jj)
+ * 2. * pow(zs[k], ddf-1.) * exp(-ddf*zs[k]*zs[k]/2./s2/l);
+ if ( df==2 ) Hij *= exp(za/s2/l)/s2/l;
+ else Hij /= gammafn(ddf/2.) * pow(2.*s2*l/ddf, ddf/2.);
+ S1s[ (i*Ntilde+j)*NN + ii*Ntilde+jj ] = Hij;
+ }
+ }
+ }
+
+ for (i=0; i<NN; i++)
+ for (j=0; j<NN; j++) S2s[i*NN+j] = 0.;
+
+ for (i=0; i<M; i++)
+ for (j=0; j<Ntilde; j++)
+ for (jj=0; jj<Ntilde; jj++)
+ S2s[ (i*Ntilde+j)*NN + i*Ntilde+jj ] = Tn( (2.*zch[ i*Ntilde+j ]-b[i+1]-b[i])/(b[i+1]-b[i]), jj);
+
+ LU_decompose(S2s,ps,NN);
+
+ for (n=1; n<=nmax; n++) {
+ if ( n==1)
+ for (i=0; i<M; i++)
+ for (j=0; j<Ntilde; j++) {
+ Pns[ i*Ntilde+j ] = 0.;
+ for (jj=0; jj<Ntilde; jj++)
+ Pns[ i*Ntilde+j ] += /* usual Chebyshev approximation */
+ 2./Ntilde * Tn( (2.*zch[i*Ntilde+jj]-b[i+1]-b[i])/(b[i+1]-b[i]), j) * rside[ i*Ntilde+jj ];
+ if ( j==0 ) Pns[ i*Ntilde+j ] /= 2.;
+ }
+ else {
+ for (i=0; i<NN; i++) {
+ rside[i] = 0.;
+ for (j=0; j<NN; j++) rside[i] += S1s[ i*NN+j ] * Pns[ (n-2)*NN+j ];
+ }
+ LU_solve2(S2s, rside, ps, NN);
+ for (i=0; i<NN; i++) Pns[ (n-1)*NN+i ] = rside[i];
+ }
+
+ p0[n-1] = 0.;
+ if ( n==1 )
+ p0[0] = CHI( ddf/s2*(cu-(1.-l)*hs)/l, df)
+ - CHI( ddf/s2*(cl-(1.-l)*hs)/l, df);
+ else
+ for (j=0; j<Ntilde; j++)
+ p0[n-1] += Pns[ (n-1)*NN + ihs*Ntilde+j ] * Tn( (2.*hs-b[ihs+1]-b[ihs])/(b[ihs+1]-b[ihs]), j);
+
+ mn_minus = 1.; mn_plus = 0.;
+ if ( n > 1) {
+ for (i=0; i<M; i++)
+ for (j=0; j<Ntilde; j++) {
+ oben = 0.;
+ unten = 0.;
+ for (jj=0; jj<Ntilde; jj++) {
+ oben += Pns[ (n-1)*NN + i*Ntilde+jj ] * Tn((2.*zch[i*Ntilde+j]-b[i+1]-b[i])/(b[i+1]-b[i]), jj);
+ unten+= Pns[ (n-2)*NN + i*Ntilde+jj ] * Tn((2.*zch[i*Ntilde+j]-b[i+1]-b[i])/(b[i+1]-b[i]), jj);
+ }
+ if ( fabs(unten)<1e-16 )
+ if ( fabs(oben)<1e-16 ) q = 0.;
+ else q = 1.;
+ else q = oben/unten;
+ if ( q<mn_minus ) mn_minus = q;
+ if ( q>mn_plus ) mn_plus = q;
+ }
+ *rho = (mn_minus + mn_plus)/2.;
+ if ( fabs(mn_plus - mn_minus) < FINALeps ) {
+ *nstop = n;
+ n = nmax + 1;
+ }
+ } /* n > 1 */
+ } /* n=1; n<=nmax; n++ */
+
+
+ Free(Pns);
+ Free(zs);
+ Free(ws);
+ Free(rside);
+ Free(zch);
+ Free(ps);
+ Free(S2s);
+ Free(S1s);
+
+ return 0;
+}
+
+
+double se2_sf_prerun_SIGMA_deluxe(double l, double cl, double cu, double hs, double sigma, int df1, int df2, int nmax, int qm1, int qm2, double truncate, double *p0)
+{ double *ww, *zz, b1, b2, ddf2, *SF, rho, s2;
+ int i, m, n, nstop, Nlocal;
+
+ Nlocal = choose_N_for_se2(l, cl, cu);
+
+ SF = vector(nmax);
+ ww = vector(qm2);
+ zz = vector(qm2);
+
+ ddf2 = (double)(df2);
+ b1 = qCHI( truncate/2., df2)/ddf2;
+ b2 = qCHI(1. - truncate/2., df2)/ddf2;
+ gausslegendre(qm2, b1, b2, zz, ww);
+ for (i=0; i<qm2; i++) ww[i] *= ddf2 * chi( ddf2*zz[i], df2);
+
+ for (n=0; n<nmax; n++) p0[n] = 0.;
+
+ for (i=0; i<qm2; i++) {
+ s2 = zz[i];
+ m = se2_sf_deluxe(l, s2*cl, s2*cu, s2*hs, sigma, df1, Nlocal, nmax, qm1, SF, &nstop, &rho);
+ if ( m != 0 ) warning("trouble with internal [package spc] function se2_sf_deluxe");
+ if ( nstop > 0 ) {
+ for (n=0; n<nstop; n++) p0[n] += ww[i] * SF[n];
+ for (n=nstop; n<nmax; n++) p0[n] += ww[i] * SF[nstop-1] * pow(rho, n-nstop+1);
+ } else {
+ for (n=0; n<nmax; n++) p0[n] += ww[i] * SF[n];
+ }
+ }
+
+ Free(ww);
+ Free(zz);
+ Free(SF);
+
+ return 0;
+}
+
+
+double se2_sf_prerun_SIGMA(double l, double cl, double cu, double hs, double sigma, int df1, int df2, int nmax, int qm1, int qm2, double truncate, double *p0)
+{ double *ww, *zz, b1, b2, ddf2, *SF, s2;
+ int i, m, n, Nlocal;
+
+ Nlocal = choose_N_for_se2(l, cl, cu);
+
+ SF = vector(nmax);
+ ww = vector(qm2);
+ zz = vector(qm2);
+
+ ddf2 = (double)(df2);
+ b1 = qCHI( truncate/2., df2)/ddf2;
+ b2 = qCHI(1. - truncate/2., df2)/ddf2;
+ gausslegendre(qm2, b1, b2, zz, ww);
+ for (i=0; i<qm2; i++) ww[i] *= ddf2 * chi( ddf2*zz[i], df2);
+
+ for (n=0; n<nmax; n++) p0[n] = 0.;
+
+ for (i=0; i<qm2; i++) {
+ s2 = zz[i];
+ m = se2_sf(l, s2*cl, s2*cu, s2*hs, sigma, df1, Nlocal, nmax, qm1, SF);
+ if ( m != 0 ) warning("trouble with internal [package spc] function se2_sf");
+ for (n=0; n<nmax; n++) p0[n] += ww[i] * SF[n];
+ }
+
+ Free(ww);
+ Free(zz);
+ Free(SF);
+
+ return 0;
+}
+
+
+double se2_Wq_prerun_SIGMA_deluxe(double l, double cl, double cu, double p, double hs, double sigma, int df1, int df2, int nmax, int qm1, int qm2, double truncate)
+{ double *ww, *zz, b1, b2, ddf2, *SF, *p0, rho, *rhomany, *SFlast, Lp=-1., sf_level_adj, s2;
+ int i, j, n, nstop, nstop_, nsm, nn, qnspecial=0, Nlocal;
+
+ Nlocal = choose_N_for_se2(l, cl, cu);
+
+ p0 = vector(nmax);
+ SF = vector(nmax);
+ rhomany = vector(qm2);
+ SFlast = vector(qm2);
+ ww = vector(qm2);
+ zz = vector(qm2);
+
+ ddf2 = (double)(df2);
+ b1 = qCHI( truncate/2., df2)/ddf2;
+ b2 = qCHI(1. - truncate/2., df2)/ddf2;
+ gausslegendre(qm2, b1, b2, zz, ww);
+ for (i=0; i<qm2; i++) ww[i] *= ddf2 * chi( ddf2*zz[i], df2);
+
+ qnspecial = (qm2+1) / 2;
+
+ s2 = zz[qnspecial];
+ j = se2_sf_deluxe(l, s2*cl, s2*cu, s2*hs, sigma, df1, Nlocal, nmax, qm1, SF, &nsm, &rho);
+ if ( j != 0 ) warning("trouble with internal [package spc] function seU_sf_deluxe");
+ n = nsm;
+
+ if ( nsm < 1 ) { /* did not converge yet -- should be the rare case */
+ nn = nmax;
+ warning("The geometric tail approximation might not work.");
+ } else {
+ nstop = nsm;
+
+ s2 = zz[qnspecial+1];
+ j = se2_sf_deluxe(l, s2*cl, s2*cu, s2*hs, sigma, df1, Nlocal, nmax, qm1, SF, &nstop_, &rho);
+ if ( j != 0 ) warning("trouble with internal [package spc] function seU_sf_deluxe");
+ if ( nstop_ > nsm ) nsm = nstop_;
+ if ( nstop_ < 1) nsm = nmax;
+ if ( nstop_ >= nstop && nsm<nmax ) {
+ i = 1;
+ while ( nstop_ >= nstop && nsm<nmax ) {
+ nstop = nstop_;
+ i++;
+ s2 = zz[qnspecial+i];
+ j = se2_sf_deluxe(l, s2*cl, s2*cu, s2*hs, sigma, df1, Nlocal, nmax, qm1, SF, &nstop_, &rho);
+ if ( j != 0 ) warning("trouble with internal [package spc] function seU_sf_deluxe");
+ if ( nstop_ > nsm ) nsm = nstop_;
+ if ( nstop_ < 1) nsm = nmax;
+ }
+ }
+
+ nstop = n;
+ s2 = zz[qnspecial-1];
+ j = se2_sf_deluxe(l, s2*cl, s2*cu, s2*hs, sigma, df1, Nlocal, nmax, qm1, SF, &nstop_, &rho);
+ if ( j != 0 ) warning("trouble with internal [package spc] function seU_sf_deluxe");
+ if ( nstop_ > nsm ) nsm = nstop_;
+ if ( nstop_ < 1) nsm = nmax;
+ if ( nstop_ >= nstop && nsm<nmax ) {
+ i = 1;
+ while ( nstop_ >= nstop && nsm<nmax ) {
+ nstop = nstop_;
+ i++;
+ s2 = zz[qnspecial-i];
+ j = se2_sf_deluxe(l, s2*cl, s2*cu, s2*hs, sigma, df1, Nlocal, nmax, qm1, SF, &nstop_, &rho);
+ if ( j != 0 ) warning("trouble with internal [package spc] function seU_sf_deluxe");
+ if ( nstop_ > nsm ) nsm = nstop_;
+ if ( nstop_ < 1) nsm = nmax;
+ }
+ }
+ nn = nsm;
+ }
+
+ for (n=0; n<nmax; n++) p0[n] = 0.;
+
+ for (i=0; i<qm2; i++) {
+ s2 = zz[i];
+ j = se2_sf_deluxe(l, s2*cl, s2*cu, s2*hs, sigma, df1, Nlocal, nn, qm1, SF, &nstop, &rho);
+ if ( j != 0 ) warning("trouble with internal [package spc] function seU_sf_deluxe");
+ if ( nstop < 1 ) {
+ nstop = nn;
+ warning("The geometric tail approximation might not work.");
+ }
+ rhomany[i] = rho;
+ for (n=0; n<nstop; n++) p0[n] += ww[i] * SF[n];
+ if ( nstop < nn) {
+ for (n=nstop; n<nn; n++) p0[n] += ww[i] * SF[nstop-1] * pow(rho, n-nstop+1);
+ }
+ SFlast[i] = SF[nstop-1] * pow(rho, nn-nstop);
+ }
+
+ sf_level_adj = 1.-p;
+ if ( p0[nn-1] <= sf_level_adj ) {
+ n = nn-1;
+ while ( p0[n] <= sf_level_adj && n > 0 ) n--;
+ if ( p0[n] > 1.-p ) Lp = (double)( n + 2 ); else Lp = 1.;
+ } else {
+ for (n=nn; n<nmax; n++) {
+ p0[n] = 0.;
+ for (i=0; i<qm2; i++) p0[n] += ww[i] * SFlast[i] * pow(rhomany[i], n-nn+1);
+ if ( p0[n] <= sf_level_adj ) {
+ Lp = (double)( n + 1 );
+ n = nmax+1;
+ }
+ }
+ }
+
+ Free(p0);
+ Free(ww);
+ Free(zz);
+ Free(SF);
+ Free(SFlast);
+ Free(rhomany);
+
+ return Lp;
+}
+
+
+double se2_iglarl_prerun_SIGMA(double l, double cl, double cu, double hs, double sigma, int df1, int df2, int N, int qm1, int qm2, double truncate)
+{ double *ww, *zz, b1, b2, result, ddf2, s2;
+ int i;
+
+ ww = vector(qm2);
+ zz = vector(qm2);
+ ddf2 = (double)(df2);
+ b1 = qCHI( truncate/2., df2)/ddf2;
+ b2 = qCHI(1. - truncate/2., df2)/ddf2;
+ gausslegendre(qm2, b1, b2, zz, ww);
+ result = 0.;
+ for (i=0; i<qm2; i++) {
+ s2 = zz[i];
+ result += ww[i] * ddf2 * chi( ddf2*s2, df2) * se2_iglarl(l, s2*cl, s2*cu, s2*hs, sigma, df1, N, qm1);
+ }
+ Free(ww);
+ Free(zz);
+
+ return result;
+}
+
+
+double se2_Wq(double l, double cl, double cu, double p, double hs, double sigma, int df, int N, int nmax, int qm)
+{ double *S1s, *S2s, *Pns, *p0, *ws, *zs, *zch, *rside, *b, za=0., s2, ddf, xl, xu, q_minus=0., q_plus=0., dN, Hij, mn_minus=1., mn_plus=0., oben, unten, q, enumerator=0., Wq=0.;
+ int i, j, k, n, *ps, Ntilde, ihs, M, NN, ii, jj;
+
+ M = ceil( (log(cl)-log(cu))/log(1.-l) );
+ Ntilde = ceil( (double)N/(double)M );
+ NN = M*Ntilde;
+ s2 = sigma*sigma;
+ ddf = (double)df;
+ dN = (double)Ntilde;
+
+ ihs = floor( (log(cl) - log(hs))/log(1.-l) );
+ if ( ihs<0 ) ihs = 0;
+
+ S1s = matrix(NN,NN);
+ S2s = matrix(NN,NN);
+ ps = ivector(NN);
+ zch = matrix(M,Ntilde);
+ rside = vector(NN);
+ b = vector(M+1);
+ ws = vector(qm);
+ zs = vector(qm);
+ p0 = vector(nmax);
+ Pns = matrix(nmax,NN);
+
+/* interval borders b_i = cl/(1-l)^i */
+ for (i=0; i<M; i++) b[i] = cl/pow(1.-l, (double)(i));
+ b[M] = cu;
+
+ /* Chebyshev nodes on [b_0,b_1],[b_1,b_2],...,[b_M-1,cu] */
+ for (i=0; i<M; i++)
+ for (j=0; j<Ntilde; j++) {
+ zch[ i*Ntilde+j ] = b[i] + (b[i+1]-b[i])/2.*(1.+cos(PI*(2.*j+1.)/2./dN));
+ }
+
+ /* P(L>1)(zch[i,j]) */
+ for (i=0; i<M; i++)
+ for (j=0; j<Ntilde; j++) {
+ rside[ i*Ntilde+j ] = CHI( ddf/s2*(cu-(1.-l)*zch[ i*Ntilde+j ])/l, df)
+ - CHI( ddf/s2*(cl-(1.-l)*zch[ i*Ntilde+j ])/l, df);
+ }
+
+ for (i=0; i<M; i++)
+ for (j=0; j<Ntilde; j++) {
+ za = (1.-l)*zch[ i*Ntilde+j ];
+ for (ii=0; ii<M; ii++)
+ for (jj=0; jj<Ntilde; jj++) {
+ if ( b[ii+1]<za ) S1s[ (i*Ntilde+j)*NN + ii*Ntilde+jj ] = 0.;
+ else {
+ if ( za<b[ii] ) xl = b[ii]; else xl = za;
+ xu = b[ii+1];
+ if ( df!=2 ) {
+ xl = sqrt(xl-za);
+ xu = sqrt(xu-za);
+ }
+ gausslegendre(qm, xl, xu, zs, ws);
+ Hij = 0.;
+ for (k=0; k<qm; k++)
+ if ( df==2 )
+ Hij += ws[k]*Tn( (2.*zs[k]-b[ii+1]-b[ii])/(b[ii+1]-b[ii]), jj) * exp(-zs[k]/s2/l);
+ else
+ Hij += ws[k]*Tn( (2.*(zs[k]*zs[k]+za)-b[ii+1]-b[ii])/(b[ii+1]-b[ii]), jj)
+ * 2. * pow(zs[k], ddf-1.) * exp(-ddf*zs[k]*zs[k]/2./s2/l);
+ if ( df==2 ) Hij *= exp(za/s2/l)/s2/l;
+ else Hij /= gammafn(ddf/2.) * pow(2.*s2*l/ddf, ddf/2.);
+ S1s[ (i*Ntilde+j)*NN + ii*Ntilde+jj ] = Hij;
+ }
+ }
+ }
+
+ for (i=0; i<NN; i++)
+ for (j=0; j<NN; j++) S2s[i*NN+j] = 0.;
+
+ for (i=0; i<M; i++)
+ for (j=0; j<Ntilde; j++)
+ for (jj=0; jj<Ntilde; jj++)
+ S2s[ (i*Ntilde+j)*NN + i*Ntilde+jj ] = Tn( (2.*zch[ i*Ntilde+j ]-b[i+1]-b[i])/(b[i+1]-b[i]), jj);
+
+ LU_decompose(S2s,ps,NN);
+
+ for (n=1; n<=nmax; n++) {
+ if ( n==1)
+ for (i=0; i<M; i++)
+ for (j=0; j<Ntilde; j++) {
+ Pns[ i*Ntilde+j ] = 0.;
+ for (jj=0; jj<Ntilde; jj++)
+ Pns[ i*Ntilde+j ] += /* usual Chebyshev approximation */
+ 2./Ntilde * Tn( (2.*zch[i*Ntilde+jj]-b[i+1]-b[i])/(b[i+1]-b[i]), j) * rside[ i*Ntilde+jj ];
+ if ( j==0 ) Pns[ i*Ntilde+j ] /= 2.;
+ }
+ else {
+ for (i=0; i<NN; i++) {
+ rside[i] = 0.;
+ for (j=0; j<NN; j++) rside[i] += S1s[ i*NN+j ] * Pns[ (n-2)*NN+j ];
+ }
+ LU_solve2(S2s, rside, ps, NN);
+ for (i=0; i<NN; i++) Pns[ (n-1)*NN+i ] = rside[i];
+ }
+
+ p0[n-1] = 0.;
+ if ( n==1 )
+ p0[0] = CHI( ddf/s2*(cu-(1.-l)*hs)/l, df)
+ - CHI( ddf/s2*(cl-(1.-l)*hs)/l, df);
+ else
+ for (j=0; j<Ntilde; j++)
+ p0[n-1] += Pns[ (n-1)*NN + ihs*Ntilde+j ] * Tn( (2.*hs-b[ihs+1]-b[ihs])/(b[ihs+1]-b[ihs]), j);
+
+ if ( p0[n-1] < 1.-p ) {
+ Wq = (double)n;
+ n = nmax+1;
+ } else {
+ mn_minus = 1.; mn_plus = 0.;
+ if ( n > 1) {
+ for (i=0; i<M; i++)
+ for (j=0; j<Ntilde; j++) {
+ oben = 0.;
+ unten = 0.;
+ for (jj=0; jj<Ntilde; jj++) {
+ oben += Pns[ (n-1)*NN + i*Ntilde+jj ] * Tn((2.*zch[i*Ntilde+j]-b[i+1]-b[i])/(b[i+1]-b[i]), jj);
+ unten+= Pns[ (n-2)*NN + i*Ntilde+jj ] * Tn((2.*zch[i*Ntilde+j]-b[i+1]-b[i])/(b[i+1]-b[i]), jj);
+ }
+ if ( fabs(unten)<1e-16 )
+ if ( fabs(oben)<1e-16 ) q = 0.;
+ else q = 1.;
+ else q = oben/unten;
+ if ( q<mn_minus ) mn_minus = q;
+ if ( q>mn_plus ) mn_plus = q;
+ }
+ enumerator = log( (1.-p)/p0[n-1] );
+ q_minus = (double)n + enumerator/log(mn_minus);
+ q_plus = (double)n + enumerator/log(mn_plus);
+ /*if ( fabs( (q_plus-q_minus)/q_minus )<FINALeps ) n = nmax+1;*/
+ if ( fabs( ceil(q_plus) - ceil(q_minus) ) < .5 ) {
+ Wq = ceil(q_plus);
+ n = nmax +1;
+ }
+ } /* n > 1 */
+ } /* p0[n-1] >= 1.-p */
+ } /* n=1; n<=nmax; n++ */
+
+
+ Free(Pns);
+ Free(p0);
+ Free(zs);
+ Free(ws);
+ Free(rside);
+ Free(zch);
+ Free(ps);
+ Free(S2s);
+ Free(S1s);
+
+ return Wq;
+}
+
+
+double se2lu_crit(double l, double L0, double cl, double hs, double sigma, int df, int N, int qm)
+{ double s1, s2, s3, ds, L1, L2, L3;
+
+ s2 = hs;
+ do {
+ s2 += .2;
+ L2 = se2_iglarl(l,cl,s2,hs,sigma,df,N,qm);
+ } while ( L2 < L0 );
+
+ s1 = s2 - .2;
+ L1 = se2_iglarl(l,cl,s1,hs,sigma,df,N,qm);
+
+ do {
+ s3 = s1 + (L0-L1)/(L2-L1) * (s2-s1);
+ L3 = se2_iglarl(l,cl,s3,hs,sigma,df,N,qm);
+ ds = s3-s2; s1 = s2; L1 = L2; s2 = s3; L2 = L3;
+ } while ( fabs(L0-L3)>1e-6 && fabs(ds)>1e-9 );
+
+ return s3;
+}
+
+
+double stde2lu_crit(double l, double L0, double cl, double hs, double sigma, int df, int N, int qm)
+{ double s1, s2, s3, ds, L1, L2, L3;
+
+ s2 = hs;
+ L2 = 0.;
+ do {
+ s1 = s2;
+ L1 = L2;
+ s2 += .2;
+ L2 = stde2_iglarl(l, cl, s2, hs, sigma, df, N, qm);
+ } while ( L2 < L0 );
+
+ do {
+ s3 = s1 + (L0-L1)/(L2-L1) * (s2-s1);
+ L3 = stde2_iglarl(l, cl, s3, hs, sigma, df, N, qm);
+ ds = s3-s2; s1 = s2; L1 = L2; s2 = s3; L2 = L3;
+ } while ( fabs(L0-L3)>1e-7 && fabs(ds)>1e-9 );
+
+ return s3;
+}
+
+
+double se2lu_crit_prerun_SIGMA(double l, double L0, double cl, double hs, double sigma, int df1, int df2, int N, int qm1, int qm2, double truncate)
+{ double s1, s2, s3, ds, L1=0., L2=0., L3=0.;
+
+ s2 = hs;
+ do {
+ L1 = L2;
+ s2 += .2;
+ L2 = se2_iglarl_prerun_SIGMA(l, cl, s2, hs, sigma, df1, df2, N, qm1, qm2, truncate);
+ } while ( L2 < L0 );
+
+ s1 = s2 - .2;
+
+ do {
+ s3 = s1 + (L0-L1)/(L2-L1) * (s2-s1);
+ L3 = se2_iglarl_prerun_SIGMA(l, cl, s3, hs, sigma, df1, df2, N, qm1, qm2, truncate);
+ ds = s3 - s2; s1 = s2; L1 = L2; s2 = s3; L2 = L3;
+ } while ( fabs(L0-L3)>1e-6 && fabs(ds)>1e-9 );
+
+ return s3;
+}
+
+
+double se2lu_q_crit(double l, int L0, double alpha, double cl, double hs, double sigma, int df, int N, int qm, double c_error, double a_error)
+{ double s1, s2, s3, ds, p1, p2, p3, *SF;
+ int result=1;
+
+ SF = vector(L0);
+
+ s2 = hs; p2 = 1.;
+ do {
+ p1 = p2;
+ s2 += .2;
+ result = se2_sf(l, cl, s2, hs, sigma, df, N, L0, qm, SF);
+ if ( result != 0 ) warning("trouble in se2lu_q_crit [package spc]");
+ p2 = 1. - SF[L0-1];
+ } while ( p2 > alpha );
+
+ s1 = s2 - .2;
+
+ do {
+ s3 = s1 + (alpha - p1)/( p2 - p1 ) * (s2-s1);
+ result = se2_sf(l, cl, s3, hs, sigma, df, N, L0, qm, SF);
+ if ( result != 0 ) warning("trouble in se2lu_q_crit [package spc]");
+ p3 = 1. - SF[L0-1];
+ ds = s3 - s2; s1 = s2; p1 = p2; s2 = s3; p2 = p3;
+ } while ( fabs(alpha - p3)>a_error && fabs(ds)>c_error );
+
+ Free(SF);
+
+ return s3;
+}
+
+
+double se2lu_q_crit_prerun_SIGMA(double l, int L0, double alpha, double cl, double hs, double sigma, int df1, int df2, int N, int qm1, int qm2, double truncate, int tail_approx, double c_error, double a_error)
+{ double s1, s2, s3, ds, p1, p2, p3, *SF;
+ int result=1;
+
+ SF = vector(L0);
+
+ s2 = se2lu_q_crit(l, L0, alpha, cl, hs, sigma, df1, N, qm1, c_error, a_error);
+ if ( tail_approx ) result = se2_sf_prerun_SIGMA_deluxe(l, cl, s2, hs, sigma, df1, df2, L0, qm1, qm2, truncate, SF);
+ else result = se2_sf_prerun_SIGMA(l, cl, s2, hs, sigma, df1, df2, L0, qm1, qm2, truncate, SF);
+ if ( result != 0 ) warning("trouble in se2lu_q_crit_prerun_SIGMA [package spc]");
+ p2 = 1. - SF[L0-1];
+
+ if ( p2 > alpha ) {
+ do {
+ p1 = p2;
+ s2 += .2;
+ if ( tail_approx ) result = se2_sf_prerun_SIGMA_deluxe(l, cl, s2, hs, sigma, df1, df2, L0, qm1, qm2, truncate, SF);
+ else result = se2_sf_prerun_SIGMA(l, cl, s2, hs, sigma, df1, df2, L0, qm1, qm2, truncate, SF);
+ if ( result != 0 ) warning("trouble in se2lu_q_crit_prerun_SIGMA [package spc]");
+ p2 = 1. - SF[L0-1];
+ } while ( p2 > alpha );
+ s1 = s2 - .2;
+ } else {
+ do {
+ p1 = p2;
+ s2 -= .2;
+ if ( tail_approx ) result = se2_sf_prerun_SIGMA_deluxe(l, cl, s2, hs, sigma, df1, df2, L0, qm1, qm2, truncate, SF);
+ else result = se2_sf_prerun_SIGMA(l, cl, s2, hs, sigma, df1, df2, L0, qm1, qm2, truncate, SF);
+ if ( result != 0 ) warning("trouble in se2lu_q_crit_prerun_SIGMA [package spc]");
+ p2 = 1. - SF[L0-1];
+ } while ( p2 <= alpha && s2 > hs );
+ s1 = s2 + .2;
+ }
+
+ do {
+ s3 = s1 + (alpha - p1)/( p2 - p1 ) * (s2-s1);
+ if ( tail_approx ) result = se2_sf_prerun_SIGMA_deluxe(l, cl, s3, hs, sigma, df1, df2, L0, qm1, qm2, truncate, SF);
+ else result = se2_sf_prerun_SIGMA(l, cl, s3, hs, sigma, df1, df2, L0, qm1, qm2, truncate, SF);
+ if ( result != 0 ) warning("trouble in se2lu_q_crit_prerun_SIGMA [package spc]");
+ p3 = 1. - SF[L0-1];
+ ds = s3 - s2; s1 = s2; p1 = p2; s2 = s3; p2 = p3;
+ } while ( fabs(alpha - p3)>a_error && fabs(ds)>c_error );
+
+ Free(SF);
+
+ return s3;
+}
+
+
+double se2fu_crit(double l, double L0, double cu, double hs, double sigma, int df, int N, int qm)
+{ double s1, s2, s3, ds, L1, L2, L3, norm;
+
+ norm = sqrt(df);
+ s2 = 2. - cu;
+ if ( s2 < 0.1 ) s2 = 0.1;
+ L2 = se2_iglarl(l,s2,cu,hs,sigma,df,N,qm);
+ if ( L2 < L0 ) {
+ do {
+ s2 -= .2/norm;
+ L2 = se2_iglarl(l,s2,cu,hs,sigma,df,N,qm);
+ } while ( L2 < L0 );
+ s1 = s2 + .2/norm;
+ } else {
+ do {
+ s2 += .2/norm;
+ L2 = se2_iglarl(l,s2,cu,hs,sigma,df,N,qm);
+ } while ( L2 > L0 );
+ s1 = s2 - .2/norm;
+ }
+
+ L1 = se2_iglarl(l,s1,cu,hs,sigma,df,N,qm);
+
+ do {
+ s3 = s1 + (L0-L1)/(L2-L1) * (s2-s1);
+ L3 = se2_iglarl(l,s3,cu,hs,sigma,df,N,qm);
+ ds = s3-s2; s1 = s2; L1 = L2; s2 = s3; L2 = L3;
+ } while ( fabs(L0-L3)>1e-7 && fabs(ds)>1e-9 );
+
+ return s3;
+}
+
+
+double stde2fu_crit(double l, double L0, double cu, double hs, double sigma, int df, int N, int qm)
+{ double s1, s2, s3, ds, L1, L2, L3, norm;
+
+ norm = sqrt(df);
+ s2 = 2. - cu;
+ if ( s2 < 0.1 ) s2 = 0.1;
+ L2 = stde2_iglarl(l, s2, cu, hs, sigma, df, N, qm);
+
+ if ( L2 < L0 ) {
+ do {
+ s1 = s2;
+ L1 = L2;
+ s2 -= .2/norm;
+ L2 = stde2_iglarl(l, s2, cu, hs, sigma, df, N, qm);
+ } while ( L2 < L0 );
+ } else {
+ do {
+ s1 = s2;
+ L1 = L2;
+ s2 += .2/norm;
+ L2 = stde2_iglarl(l, s2, cu, hs, sigma, df, N, qm);
+ } while ( L2 > L0 );
+ }
+
+ do {
+ s3 = s1 + (L0-L1)/(L2-L1) * (s2-s1);
+ L3 = stde2_iglarl(l, s3, cu, hs, sigma, df, N,qm);
+ ds = s3-s2; s1 = s2; L1 = L2; s2 = s3; L2 = L3;
+ } while ( fabs(L0-L3)>1e-7 && fabs(ds)>1e-9 );
+
+ return s3;
+}
+
+
+double se2fu_crit_prerun_SIGMA(double l, double L0, double cu, double hs, double sigma, int df1, int df2, int N, int qm1, int qm2, double truncate)
+{ double s1, s2, s3, ds, L1=0., L2=0., L3=0.;
+
+ s2 = cu/2.;
+ L2 = se2_iglarl_prerun_SIGMA(l, s2, cu, hs, sigma, df1, df2, N, qm1, qm2, truncate);
+ if ( L2 < L0 ) {
+ do {
+ L1 = L2;
+ s2 -= .1;
+ L2 = se2_iglarl_prerun_SIGMA(l, s2, cu, hs, sigma, df1, df2, N, qm1, qm2, truncate);
+ } while ( L2 < L0 && s2 > 0.);
+ s1 = s2 + .1;
+ } else {
+ do {
+ L1 = L2;
+ s2 += .1;
+ L2 = se2_iglarl_prerun_SIGMA(l, s2, cu, hs, sigma, df1, df2, N, qm1, qm2, truncate);
+ } while ( L2 > L0 && s2 < hs );
+ s1 = s2 - .1;
+ }
+
+ do {
+ s3 = s1 + (L0-L1)/(L2-L1) * (s2-s1);
+ L3 = se2_iglarl_prerun_SIGMA(l, s3, cu, hs, sigma, df1, df2, N, qm1, qm2, truncate);
+ ds = s3-s2; s1 = s2; L1 = L2; s2 = s3; L2 = L3;
+ } while ( fabs(L0-L3)>1e-6 && fabs(ds)>1e-9 );
+
+ return s3;
+}
+
+
+double se2fu_q_crit(double l, int L0, double alpha, double cu, double hs, double sigma, int df, int N, int qm, double c_error, double a_error)
+{ double s1, s2, s3, ds, p1, p2, p3, *SF;
+ int result=1;
+
+ SF = vector(L0);
+
+ s2 = cu/2.;
+ result = se2_sf(l, s2, cu, hs, sigma, df, N, L0, qm, SF);
+ if ( result != 0 ) warning("trouble in se2fu_q_crit [package spc]");
+ p2 = 1. - SF[L0-1];
+
+ if ( p2 < alpha ) {
+ do {
+ p1 = p2;
+ s2 += .1;
+ result = se2_sf(l, s2, cu, hs, sigma, df, N, L0, qm, SF);
+ if ( result != 0 ) warning("trouble in se2fu_q_crit [package spc]");
+ p2 = 1. - SF[L0-1];
+ } while ( p2 < alpha );
+ s1 = s2 - .1;
+ } else {
+ do {
+ p1 = p2;
+ s2 -= .1;
+ result = se2_sf(l, s2, cu, hs, sigma, df, N, L0, qm, SF);
+ if ( result != 0 ) warning("trouble in se2fu_q_crit [package spc]");
+ p2 = 1. - SF[L0-1];
+ } while ( p2 >= alpha );
+ s1 = s2 + .1;
+ }
+
+ do {
+ s3 = s1 + (alpha - p1)/( p2 - p1 ) * (s2-s1);
+ result = se2_sf(l, s3, cu, hs, sigma, df, N, L0, qm, SF);
+ if ( result != 0 ) warning("trouble in se2fu_q_crit [package spc]");
+ p3 = 1. - SF[L0-1];
+ ds = s3 - s2; s1 = s2; p1 = p2; s2 = s3; p2 = p3;
+ } while ( fabs(alpha - p3)>a_error && fabs(ds)>c_error );
+
+ Free(SF);
+
+ return s3;
+}
+
+
+double se2fu_q_crit_prerun_SIGMA(double l, int L0, double alpha, double cu, double hs, double sigma, int df1, int df2, int N, int qm1, int qm2, double truncate, int tail_approx, double c_error, double a_error)
+{ double s1, s2, s3, ds, p1, p2, p3, *SF;
+ int result=1, schritt=0, maxschritt=30;
+
+ SF = vector(L0);
+
+ s2 = se2fu_q_crit(l, L0, alpha, cu, hs, sigma, df1, N, qm1, c_error, a_error);
+ if ( tail_approx ) result = se2_sf_prerun_SIGMA_deluxe(l, s2, cu, hs, sigma, df1, df2, L0, qm1, qm2, truncate, SF);
+ else result = se2_sf_prerun_SIGMA(l, s2, cu, hs, sigma, df1, df2, L0, qm1, qm2, truncate, SF);
+ if ( result != 0 ) warning("trouble in se2fu_q_crit_prerun_SIGMA [package spc]");
+ p2 = 1. - SF[L0-1];
+
+ if ( p2 < alpha ) {
+ do {
+ p1 = p2;
+ s2 += .1;
+ if ( tail_approx ) result = se2_sf_prerun_SIGMA_deluxe(l, s2, cu, hs, sigma, df1, df2, L0, qm1, qm2, truncate, SF);
+ else result = se2_sf_prerun_SIGMA(l, s2, cu, hs, sigma, df1, df2, L0, qm1, qm2, truncate, SF);
+ if ( result != 0 ) warning("trouble in se2fu_q_crit_prerun_SIGMA [package spc]");
+ p2 = 1. - SF[L0-1];
+ } while ( p2 < alpha && s2 < hs );
+ s1 = s2 - .1;
+ } else {
+ do {
+ p1 = p2;
+ s2 -= .1;
+ if ( tail_approx ) result = se2_sf_prerun_SIGMA_deluxe(l, s2, cu, hs, sigma, df1, df2, L0, qm1, qm2, truncate, SF);
+ else result = se2_sf_prerun_SIGMA(l, s2, cu, hs, sigma, df1, df2, L0, qm1, qm2, truncate, SF);
+ if ( result != 0 ) warning("trouble in se2fu_q_crit_prerun_SIGMA [package spc]");
+ p2 = 1. - SF[L0-1];
+ } while ( p2 >= alpha && s2 > 0. );
+ s1 = s2 + .1;
+ }
+
+ schritt = 0;
+ do {
+ schritt++;
+ s3 = s1 + (alpha - p1)/( p2 - p1 ) * (s2-s1);
+ if ( tail_approx ) result = se2_sf_prerun_SIGMA_deluxe(l, s3, cu, hs, sigma, df1, df2, L0, qm1, qm2, truncate, SF);
+ else result = se2_sf_prerun_SIGMA(l, s3, cu, hs, sigma, df1, df2, L0, qm1, qm2, truncate, SF);
+ if ( result != 0 ) warning("trouble in se2fu_q_crit_prerun_SIGMA [package spc]");
+ p3 = 1. - SF[L0-1];
+ ds = s3 - s2; s1 = s2; p1 = p2; s2 = s3; p2 = p3;
+ } while ( fabs(alpha - p3)>a_error && fabs(ds)>c_error && schritt<maxschritt );
+
+ if ( schritt >= maxschritt ) warning("secant rule in se2fu_q_crit_prerun_SIGMA did not converge");
+
+ Free(SF);
+
+ return s3;
+}
+
+
+int se2_crit_prerun_SIGMA(double l, double L0, double *cl, double *cu, double hs, double sigma, int df1, int df2, int N, int qm1, int qm2, double truncate)
+{ double s1, s2, s3, ds, sl1, sl2, sl3, csl, Lm, Lp;
+
+ csl = hs/2.;
+ s1 = se2lu_crit_prerun_SIGMA(l, L0, csl, hs, sigma, df1, df2, N, qm1, qm2, truncate);
+ Lm = se2_iglarl_prerun_SIGMA(l, csl, s1, hs, sigma-lmEPS, df1, df2, N, qm1, qm2, truncate);
+ Lp = se2_iglarl_prerun_SIGMA(l, csl, s1, hs, sigma+lmEPS, df1, df2, N, qm1, qm2, truncate);
+ sl1 = (Lp-Lm)/(2.*lmEPS);
+
+ s2 = s1 + .05;
+ csl = se2fu_crit_prerun_SIGMA(l, L0, s2, hs, sigma, df1, df2, N, qm1, qm2, truncate);
+ Lm = se2_iglarl_prerun_SIGMA(l, csl, s2, hs, sigma-lmEPS, df1, df2, N, qm1, qm2, truncate);
+ Lp = se2_iglarl_prerun_SIGMA(l, csl, s2, hs, sigma+lmEPS, df1, df2, N, qm1, qm2, truncate);
+ sl2 = (Lp-Lm)/(2.*lmEPS);
+
+ do {
+ s3 = s1 - sl1/(sl2-sl1) * (s2-s1);
+ csl = se2fu_crit_prerun_SIGMA(l, L0, s3, hs, sigma, df1, df2, N, qm1, qm2, truncate);
+ Lm = se2_iglarl_prerun_SIGMA(l, csl, s3, hs, sigma-lmEPS, df1, df2, N, qm1, qm2, truncate);
+ Lp = se2_iglarl_prerun_SIGMA(l, csl, s3, hs, sigma+lmEPS, df1, df2, N, qm1, qm2, truncate);
+ sl3 = (Lp-Lm)/(2.*lmEPS);
+ ds = s3-s2; s1 = s2; sl1 = sl2; s2 = s3; sl2 = sl3;
+ } while ( fabs(sl3)>1e-6 && fabs(ds)>1e-9 );
+
+ *cl = csl; *cu = s3;
+
+ return 0;
+}
+
+
+int se2_crit_unbiased(double l, double L0, double *cl, double *cu, double hs, double sigma, int df, int N, int qm)
+{ double s1, s2, s3, ds, sl1, sl2, sl3, csl, Lm, Lp, step;
+
+ step = .1/sqrt(df);
+ s1 = seU_crit(l,L0,hs,sigma,df,N,qm);
+ csl = 0.;
+ Lm = seU_iglarl(l,s1,hs,sigma-lmEPS,df,N,qm);
+ Lp = seU_iglarl(l,s1,hs,sigma+lmEPS,df,N,qm);
+ sl1 = (Lp-Lm)/(2.*lmEPS);
+
+ s2 = s1;
+ sl2 = sl1;
+ do {
+ s1 = s2;
+ sl1 = sl2;
+ s2 = s1 + step;
+ csl = se2fu_crit(l,L0,s2,hs,sigma,df,N,qm);
+ Lm = se2_iglarl(l,csl,s2,hs,sigma-lmEPS,df,N,qm);
+ Lp = se2_iglarl(l,csl,s2,hs,sigma+lmEPS,df,N,qm);
+ sl2 = (Lp-Lm)/(2.*lmEPS);
+ } while ( sl2 < 0. );
+
+ do {
+ s3 = s1 - sl1/(sl2-sl1) * (s2-s1);
+ csl = se2fu_crit(l,L0,s3,hs,sigma,df,N,qm);
+ Lm = se2_iglarl(l,csl,s3,hs,sigma-lmEPS,df,N,qm);
+ Lp = se2_iglarl(l,csl,s3,hs,sigma+lmEPS,df,N,qm);
+ sl3 = (Lp-Lm)/(2.*lmEPS);
+ ds = s3-s2; s1 = s2; sl1 = sl2; s2 = s3; sl2 = sl3;
+ } while ( fabs(sl3)>1e-7 && fabs(ds)>1e-9 );
+
+ *cl = csl; *cu = s3;
+
+ return 0;
+}
+
+
+int stde2_crit_unbiased(double l, double L0, double *cl, double *cu, double hs, double sigma, int df, int N, int qm)
+{ double s1, s2, s3, ds, sl1, sl2, sl3, csl, Lm, Lp, step;
+
+ step = .1/sqrt(df);
+ s1 = stdeU_crit(l, L0, hs, sigma, df, N, qm);
+ csl = 0.;
+ Lm = stdeU_iglarl(l, s1, hs, sigma-lmEPS, df, N, qm);
+ Lp = stdeU_iglarl(l, s1, hs, sigma+lmEPS, df, N, qm);
+ sl1 = (Lp-Lm)/(2.*lmEPS);
+
+ s2 = s1;
+ sl2 = sl1;
+ do {
+ s1 = s2;
+ sl1 = sl2;
+ s2 = s1 + step;
+ csl = stde2fu_crit(l, L0, s2, hs, sigma, df, N, qm);
+ Lm = stde2_iglarl(l, csl, s2, hs, sigma-lmEPS, df, N, qm);
+ Lp = stde2_iglarl(l, csl, s2, hs, sigma+lmEPS, df, N, qm);
+ sl2 = (Lp-Lm)/(2.*lmEPS);
+ } while ( sl2 < 0. );
+
+ do {
+ s3 = s1 - sl1/(sl2-sl1) * (s2-s1);
+ csl = stde2fu_crit(l, L0, s3, hs, sigma, df, N, qm);
+ Lm = stde2_iglarl(l, csl, s3, hs, sigma-lmEPS, df, N, qm);
+ Lp = stde2_iglarl(l, csl, s3, hs, sigma+lmEPS, df, N, qm);
+ sl3 = (Lp-Lm)/(2.*lmEPS);
+ ds = s3-s2; s1 = s2; sl1 = sl2; s2 = s3; sl2 = sl3;
+ } while ( fabs(sl3)>1e-7 && fabs(ds)>1e-9 );
+
+ *cl = csl; *cu = s3;
+
+ return 0;
+}
+
+
+int se2_crit_eqtails(double l, double L0, double *cl, double *cu, double hs, double sigma, int df, double ur, int N, int qm)
+{ double u1, u2, du, l1, l2, dl, lARL1, lARL2, uARL1, uARL2, ARL22, ARL12, ARL21,
+ f11, f22, f21, f12, d11, d22, d21, d12, nenner;
+
+ l1 = seLR_crit(l, 2.*L0, ur, hs, sigma, df, N, qm);
+ l2 = l1 - .05;
+ u1 = seU_crit(l, 2.*L0, hs, sigma, df, N, qm);
+ u2 = u1 + .05;
+ ARL22 = se2_iglarl(l, l1, u1, hs, sigma, df, N, qm);
+
+ lARL2 = seLR_iglarl(l, l2, ur, hs, sigma, df, N, qm);
+ uARL2 = seU_iglarl(l, u2, hs, sigma, df, N, qm);
+ ARL22 = se2_iglarl(l, l2, u2, hs, sigma, df, N, qm);
+
+ do {
+ lARL1 = seLR_iglarl(l, l1, ur, hs, sigma, df, N, qm);
+ uARL1 = seU_iglarl(l, u1, hs, sigma, df, N, qm);
+ ARL12 = se2_iglarl(l, l1, u2, hs, sigma, df, N, qm);
+ ARL21 = se2_iglarl(l, l2, u1, hs, sigma, df, N, qm);
+
+ /* difference quotient */
+ f11 = (ARL22 - ARL12)/(l2-l1); f12 = (ARL22 - ARL21)/(u2-u1);
+ f21 = (lARL2 - lARL1)/(l2-l1); f22 = (uARL1 - uARL2)/(u2-u1);
+
+ /* inverse of the difference quotient */
+ nenner = f11*f22 - f12*f21;
+ d11 = f22/nenner; d12 = -f12/nenner;
+ d21 = -f21/nenner; d22 = f11/nenner;
+
+ dl = d11*(ARL22-L0) + d12*(lARL2-uARL2);
+ du = d21*(ARL22-L0) + d22*(lARL2-uARL2);
+
+ l1 = l2; u1 = u2;
+ l2 -= dl; u2 -= du;
+
+ lARL2 = seLR_iglarl(l, l2, ur, hs, sigma, df, N, qm);
+ uARL2 = seU_iglarl(l, u2, hs, sigma, df, N, qm);
+ ARL22 = se2_iglarl(l, l2, u2, hs, sigma, df, N, qm);
+
+ } while ( (fabs(L0-ARL22)>1e-6 || fabs(lARL2-uARL2)>1e-6) && (fabs(l2-l1)>1e-9 || fabs(u2-u1)>1e-9) );
+
+ *cl = l2; *cu = u2;
+
+ return 0;
+}
+
+
+int stde2_crit_eqtails(double l, double L0, double *cl, double *cu, double hs, double sigma, int df, double ur, int N, int qm)
+{ double u1, u2, du, l1, l2, dl, lARL1, lARL2, uARL1, uARL2, ARL22, ARL12, ARL21,
+ f11, f22, f21, f12, d11, d22, d21, d12, nenner;
+
+ l1 = stdeLR_crit(l, 2.*L0, ur, hs, sigma, df, N, qm);
+ l2 = l1 - .05;
+ u1 = stdeU_crit(l, 2.*L0, hs, sigma, df, N, qm);
+ u2 = u1 + .05;
+ ARL22 = stde2_iglarl(l, l1, u1, hs, sigma, df, N, qm);
+
+ lARL2 = stdeLR_iglarl(l, l2, ur, hs, sigma, df, N, qm);
+ uARL2 = stdeU_iglarl(l, u2, hs, sigma, df, N, qm);
+ ARL22 = stde2_iglarl(l, l2, u2, hs, sigma, df, N, qm);
+
+ do {
+ lARL1 = stdeLR_iglarl(l, l1, ur, hs, sigma, df, N, qm);
+ uARL1 = stdeU_iglarl(l, u1, hs, sigma, df, N, qm);
+ ARL12 = stde2_iglarl(l, l1, u2, hs, sigma, df, N, qm);
+ ARL21 = stde2_iglarl(l, l2, u1, hs, sigma, df, N, qm);
+
+ /* difference quotient */
+ f11 = (ARL22 - ARL12)/(l2-l1); f12 = (ARL22 - ARL21)/(u2-u1);
+ f21 = (lARL2 - lARL1)/(l2-l1); f22 = (uARL1 - uARL2)/(u2-u1);
+
+ /* inverse of the difference quotient */
+ nenner = f11*f22 - f12*f21;
+ d11 = f22/nenner; d12 = -f12/nenner;
+ d21 = -f21/nenner; d22 = f11/nenner;
+
+ dl = d11*(ARL22-L0) + d12*(lARL2-uARL2);
+ du = d21*(ARL22-L0) + d22*(lARL2-uARL2);
+
+ l1 = l2; u1 = u2;
+ l2 -= dl; u2 -= du;
+
+ lARL2 = stdeLR_iglarl(l, l2, ur, hs, sigma, df, N, qm);
+ uARL2 = stdeU_iglarl(l, u2, hs, sigma, df, N, qm);
+ ARL22 = stde2_iglarl(l, l2, u2, hs, sigma, df, N, qm);
+
+ } while ( (fabs(L0-ARL22)>1e-6 || fabs(lARL2-uARL2)>1e-6) && (fabs(l2-l1)>1e-9 || fabs(u2-u1)>1e-9) );
+
+ *cl = l2; *cu = u2;
+
+ return 0;
+}
+
+
+double se2_crit_sym(double l, double L0, double hs, double sigma, int df, int N, int qm)
+{ double cu1, cu2, cu3, cl1, cl2, cl3, L1, L2, L3, du, step;
+
+ cu2 = seU_crit(l, L0, hs, sigma, df, N, qm);
+ if ( cu2 < 2. ) {
+ step = (2.-cu2)/10.;
+ cu2 += step;
+ cl2 = 2. - cu2;
+ L2 = se2_iglarl(l, cl2, cu2, hs, sigma, df, N, qm);
+ cu1 = cu2 + step;
+ cl1 = 2. - cu1;
+ L1 = se2_iglarl(l, cl1, cu1, hs, sigma, df, N, qm);
+
+ do {
+ cu3 = cu1 + (L0-L1)/(L2-L1) * (cu2-cu1);
+ cl3 = 2. - cu3;
+ L3 = se2_iglarl(l, cl3, cu3, hs, sigma, df, N, qm);
+ du = cu3-cu2; cu1 = cu2; L1 = L2; cu2 = cu3; L2 = L3;
+ if ( L3 < 1. ) error("invalid ARL value");
+ } while ( (fabs(L0-L3)>1e-6) && (fabs(du)>1e-9) );
+ } else {
+ error("symmetric design not possible");
+ cu3 = -1.;
+ }
+ return cu3;
+}
+
+
+double stde2_crit_sym(double l, double L0, double hs, double sigma, int df, int N, int qm)
+{ double cu1, cu2, cu3, cl1, cl2, cl3, L1, L2, L3, du, step, mitte;
+
+ mitte = c_four((double)df);
+ cu2 = stdeU_crit(l, L0, hs, sigma, df, N, qm);
+ if ( cu2 < 2. ) {
+ step = (2.-cu2)/10.;
+ cu2 += step;
+ cl2 = 2.*mitte - cu2;
+ L2 = stde2_iglarl(l, cl2, cu2, hs, sigma, df, N, qm);
+
+ cu1 = cu2 + step;
+ cl1 = 2.*mitte - cu1;
+ L1 = stde2_iglarl(l, cl1, cu1, hs, sigma, df, N, qm);
+
+ do {
+ cu3 = cu1 + (L0-L1)/(L2-L1) * (cu2-cu1);
+ cl3 = 2.*mitte - cu3;
+ L3 = stde2_iglarl(l, cl3, cu3, hs, sigma, df, N, qm);
+ du = cu3-cu2; cu1 = cu2; L1 = L2; cu2 = cu3; L2 = L3;
+ if ( L3 < 1. ) error("invalid ARL value");
+ } while ( (fabs(L0-L3)>1e-7) && (fabs(du)>1e-9) );
+ } else {
+ error("symmetric design not possible");
+ cu3 = -1.;
+ }
+ return cu3;
+}
+
+
+int se2_q_crit(double l, int L0, double alpha, double *cl, double *cu, double hs, double sigma, int df, int N, int qm, double c_error, double a_error)
+{ double s1, s2, s3, ds, sl1, sl2, sl3, csl, Pm, Pp, *SF;
+ int result=1;
+
+ SF = vector(L0);
+
+ s1 = seU_q_crit(l, L0, alpha, hs, sigma, df, N, qm, c_error, a_error);
+ csl = 0.;
+ result = seU_sf(l, s1, hs, sigma-lmEPS, df, N, L0, qm, SF);
+ if ( result != 0 ) warning("trouble in se2_q_crit [package spc]");
+ Pm = 1. - SF[L0-1];
+ result = seU_sf(l, s1, hs, sigma+lmEPS, df, N, L0, qm, SF);
+ if ( result != 0 ) warning("trouble in se2_q_crit [package spc]");
+ Pp = 1. - SF[L0-1];
+ sl1 = ( Pp - Pm )/(2.*lmEPS);
+
+ s2 = s1 + .05;
+ csl = se2fu_q_crit(l, L0, alpha, s2, hs, sigma, df, N, qm, c_error, a_error);
+ result = se2_sf(l, csl, s2, hs, sigma-lmEPS, df, N, L0, qm, SF);
+ if ( result != 0 ) warning("trouble in se2_q_crit [package spc]");
+ Pm = 1. - SF[L0-1];
+ result = se2_sf(l, csl, s2, hs, sigma+lmEPS, df, N, L0, qm, SF);
+ if ( result != 0 ) warning("trouble in se2_q_crit [package spc]");
+ Pp = 1. - SF[L0-1];
+ sl2 = ( Pp - Pm )/(2.*lmEPS);
+
+ do {
+ s3 = s1 - sl1/(sl2-sl1) * (s2-s1);
+ csl = se2fu_q_crit(l, L0, alpha, s3, hs, sigma, df, N, qm, c_error, a_error);
+ result = se2_sf(l, csl, s3, hs, sigma-lmEPS, df, N, L0, qm, SF);
+ if ( result != 0 ) warning("trouble in se2_q_crit [package spc]");
+ Pm = 1. - SF[L0-1];
+ result = se2_sf(l, csl, s3, hs, sigma+lmEPS, df, N, L0, qm, SF);
+ if ( result != 0 ) warning("trouble in se2_q_crit [package spc]");
+ Pp = 1. - SF[L0-1];
+ sl3 = ( Pp - Pm )/(2.*lmEPS);
+ ds = s3-s2; s1 = s2; sl1 = sl2; s2 = s3; sl2 = sl3;
+ } while ( fabs(sl3)>a_error && fabs(ds)>c_error );
+
+ *cl = csl; *cu = s3;
+
+ Free(SF);
+
+ return 0;
+}
+
+
+int se2_q_crit_class(double l, int L0, double alpha, double *cl, double *cu, double hs, double sigma, int df, double ur, int N, int qm, double c_error, double a_error)
+{ double u1, u2, du, l1, l2, dl, lA1, lA2, uA1, uA2, A22, A12, A21,
+ f11, f22, f21, f12, d11, d22, d21, d12, nenner, *SF;
+ int result=1;
+
+ SF = vector(L0);
+
+ l1 = seLR_q_crit(l, L0, alpha/2., ur, hs, sigma, df, N, qm, c_error, a_error);
+ l2 = l1 - .05;
+ u1 = seU_q_crit(l, L0, alpha/2., hs, sigma, df, N, qm, c_error, a_error);
+ u2 = u1 + .05;
+
+ result = seLR_sf(l, l2, ur, hs, sigma, df, N, L0, qm, SF);
+ if ( result != 0 ) warning("trouble in se2_q_crit_class [package spc]");
+ lA2 = 1. - SF[L0-1];
+ result = seU_sf(l, u2, hs, sigma, df, N, L0, qm, SF);
+ if ( result != 0 ) warning("trouble in se2_q_crit_class [package spc]");
+ uA2 = 1. - SF[L0-1];
+ result = se2_sf(l, l2, u2, hs, sigma, df, N, L0, qm, SF);
+ if ( result != 0 ) warning("trouble in se2_q_crit_class [package spc]");
+ A22 = 1. - SF[L0-1];
+
+ do {
+ result = seLR_sf(l, l1, ur, hs, sigma, df, N, L0, qm, SF);
+ if ( result != 0 ) warning("trouble in se2_q_crit_class [package spc]");
+ lA1 = 1. - SF[L0-1];
+ result = seU_sf(l, u1, hs, sigma, df, N, L0, qm, SF);
+ if ( result != 0 ) warning("trouble in se2_q_crit_class [package spc]");
+ uA1 = 1. - SF[L0-1];
+ result = se2_sf(l, l1, u2, hs, sigma, df, N, L0, qm, SF);
+ if ( result != 0 ) warning("trouble in se2_q_crit_class [package spc]");
+ A12 = 1. - SF[L0-1];
+ result = se2_sf(l, l2, u1, hs, sigma, df, N, L0, qm, SF);
+ if ( result != 0 ) warning("trouble in se2_q_crit_class [package spc]");
+ A21 = 1. - SF[L0-1];
+
+ /* difference quotient */
+ f11 = (A22 - A12)/(l2-l1); f12 = (A22 - A21)/(u2-u1);
+ f21 = (lA2 - lA1)/(l2-l1); f22 = (uA1 - uA2)/(u2-u1);
+
+ /* inverse of the difference quotient */
+ nenner = f11*f22 - f12*f21;
+ d11 = f22/nenner; d12 = -f12/nenner;
+ d21 = -f21/nenner; d22 = f11/nenner;
+
+ dl = d11*(A22-alpha) + d12*(lA2-uA2);
+ du = d21*(A22-alpha) + d22*(lA2-uA2);
+
+ l1 = l2; u1 = u2;
+ l2 -= dl; u2 -= du;
+
+ result = seLR_sf(l, l2, ur, hs, sigma, df, N, L0, qm, SF);
+ if ( result != 0 ) warning("trouble in se2_q_crit_class [package spc]");
+ lA2 = 1. - SF[L0-1];
+ result = seU_sf(l, u2, hs, sigma, df, N, L0, qm, SF);
+ if ( result != 0 ) warning("trouble in se2_q_crit_class [package spc]");
+ uA2 = 1. - SF[L0-1];
+ result = se2_sf(l, l2, u2, hs, sigma, df, N, L0, qm, SF);
+ if ( result != 0 ) warning("trouble in se2_q_crit_class [package spc]");
+ A22 = 1. - SF[L0-1];
+
+ } while ( (fabs(alpha-A22)>1e-9 || fabs(lA2-uA2)>1e-9) && (fabs(l2-l1)>1e-9 || fabs(u2-u1)>1e-9) );
+
+ *cl = l2; *cu = u2;
+
+ Free(SF);
+
+ return 0;
+}
+
+
+int se2_q_crit_prerun_SIGMA(double l, int L0, double alpha, double *cl, double *cu, double hs, double sigma, int df1, int df2, int N, int qm1, int qm2, double truncate, int tail_approx, double c_error, double a_error)
+{ double s1, s2, s3, ds, sl1, sl2, sl3, csl, Pm, Pp, *SF;
+ int result=1;
+
+ SF = vector(L0);
+
+ s1 = seU_q_crit_prerun_SIGMA(l, L0, alpha, hs, sigma, df1, df2, N, qm1, qm2, truncate, tail_approx, c_error, a_error);
+ csl = 0.;
+
+ if ( tail_approx ) result = seU_sf_prerun_SIGMA_deluxe(l, s1, hs, sigma-lmEPS, df1, df2, L0, qm1, qm2, truncate, SF);
+ else result = seU_sf_prerun_SIGMA(l, s1, hs, sigma-lmEPS, df1, df2, L0, qm1, qm2, truncate, SF);
+ if ( result != 0 ) warning("trouble in se2_q_crit_prerun_SIGMA [package spc]");
+ Pm = 1. - SF[L0-1];
+ if ( tail_approx ) result = seU_sf_prerun_SIGMA_deluxe(l, s1, hs, sigma+lmEPS, df1, df2, L0, qm1, qm2, truncate, SF);
+ else result = seU_sf_prerun_SIGMA(l, s1, hs, sigma+lmEPS, df1, df2, L0, qm1, qm2, truncate, SF);
+ if ( result != 0 ) warning("trouble in se2_q_crit_prerun_SIGMA [package spc]");
+ Pp = 1. - SF[L0-1];
+ sl1 = ( Pp - Pm )/(2.*lmEPS);
+
+ s2 = s1 + .05;
+ csl = se2fu_q_crit_prerun_SIGMA(l, L0, alpha, s2, hs, sigma, df1, df2, N, qm1, qm2, truncate, tail_approx, c_error, a_error);
+ if ( tail_approx ) result = se2_sf_prerun_SIGMA_deluxe(l, csl, s2, hs, sigma-lmEPS, df1, df2, L0, qm1, qm2, truncate, SF);
+ else result = se2_sf_prerun_SIGMA(l, csl, s2, hs, sigma-lmEPS, df1, df2, L0, qm1, qm2, truncate, SF);
+ if ( result != 0 ) warning("trouble in se2_q_crit_prerun_SIGMA [package spc]");
+ Pm = 1. - SF[L0-1];
+ if ( tail_approx ) result = se2_sf_prerun_SIGMA_deluxe(l, csl, s2, hs, sigma+lmEPS, df1, df2, L0, qm1, qm2, truncate, SF);
+ else result = se2_sf_prerun_SIGMA(l, csl, s2, hs, sigma+lmEPS, df1, df2, L0, qm1, qm2, truncate, SF);
+ if ( result != 0 ) warning("trouble in se2_q_crit_prerun_SIGMA [package spc]");
+ Pp = 1. - SF[L0-1];
+ sl2 = ( Pp - Pm )/(2.*lmEPS);
+
+ do {
+ s3 = s1 - sl1/(sl2-sl1) * (s2-s1);
+ csl = se2fu_q_crit_prerun_SIGMA(l, L0, alpha, s3, hs, sigma, df1, df2, N, qm1, qm2, truncate, tail_approx, c_error, a_error);
+ if ( tail_approx ) result = se2_sf_prerun_SIGMA_deluxe(l, csl, s3, hs, sigma-lmEPS, df1, df2, L0, qm1, qm2, truncate, SF);
+ else result = se2_sf_prerun_SIGMA(l, csl, s3, hs, sigma-lmEPS, df1, df2, L0, qm1, qm2, truncate, SF);
+ if ( result != 0 ) warning("trouble in se2_q_crit_prerun_SIGMA [package spc]");
+ Pm = 1. - SF[L0-1];
+ if ( tail_approx ) result = se2_sf_prerun_SIGMA_deluxe(l, csl, s3, hs, sigma+lmEPS, df1, df2, L0, qm1, qm2, truncate, SF);
+ else result = se2_sf_prerun_SIGMA(l, csl, s3, hs, sigma+lmEPS, df1, df2, L0, qm1, qm2, truncate, SF);
+ if ( result != 0 ) warning("trouble in se2_q_crit_prerun_SIGMA [package spc]");
+ Pp = 1. - SF[L0-1];
+ sl3 = ( Pp - Pm )/(2.*lmEPS);
+ ds = s3-s2; s1 = s2; sl1 = sl2; s2 = s3; sl2 = sl3;
+ } while ( fabs(sl3)>a_error && fabs(ds)>c_error );
+
+ *cl = csl; *cu = s3;
+
+ Free(SF);
+
+ return 0;
+}
+
+
+double seUR_iglarl(double l, double cl, double cu, double hs, double sigma, int df, int N, int qm)
+{ double *a, *g, *w, *z, *t, h, arl, Hij, xl, za, dN, ddf, s2,
+ t0, t1, x0, x1, dummy;
+ int i, j, k, qi, qj, M, Ntilde, NN, ii, it, jj;
+
+ M = ceil( (log(cl)-log(cu))/log(1.-l) );
+ Ntilde = ceil( (double)N/(double)M );
+ NN = M*Ntilde;
+ s2 = sigma*sigma;
+ ddf = (double)df;
+ dN = (double)Ntilde - 1.;
+
+ a = matrix(NN,NN);
+ g = vector(NN);
+ t = vector(NN);
+ w = vector(qm);
+ z = vector(qm);
+
+ for(i=0;i<M;i++) {
+ t0 = cl/pow(1.-l,(double)(i));
+ t1 = t0/(1.-l);
+ if (t1>cu) t1 = cu;
+
+ for (j=1;j<Ntilde;j++) { /* node_i,Ntilde-1 = node_i+1,0 */
+ h = cos( PI/dN *(dN-j) );
+ t[i*(Ntilde-1)+j] = t0 + (h+1.)/2.*(t1-t0);
+ /* Chebyshev Gauss-Lobatto nodes on [t0,t1] */
+ }
+ }
+ t[0] = cl;
+
+ for (i=0;i<M;i++) {
+ for (j=1;j<=Ntilde;j++) {
+ ii = i*Ntilde + j-1;
+ it = i*(Ntilde-1) + j-1;
+
+ za = (1.-l)*t[it];
+ if (za<cl) xl = cl; else xl = za;
+
+ for (qi=0;qi<i-1;qi++)
+ for (qj=1;qj<=Ntilde;qj++) {
+ jj = qi*Ntilde + qj-1;
+ a[ii*NN+jj] = 0.;
+ }
+
+ if (i>0) {
+ qi = i-1;
+ t0 = cl/pow(1.-l,(double)qi);
+ t1 = t0/(1.-l);
+ if (t1>cu) t1 = cu;
+ if (t0<xl) x0 = xl; else x0 = t0;
+ if (df==2)
+ x1 = t1;
+ else {
+ if (x0-za>1e-10) x0 = sqrt(x0-za); else x0 = 0.;
+ if (t1-za>1e-10) x1 = sqrt(t1-za); else x1 = 0.;
+ }
+
+ for (qj=1;qj<=Ntilde;qj++) {
+ jj = qi*Ntilde + qj-1;
+
+ if (j==1) a[ii*NN+jj] = - Tn((2.*t[it]-t0-t1)/(t1-t0),qj-1);
+ else {
+ if (fabs(t1-x0)>1e-8) {
+ gausslegendre(qm,x0,x1,z,w);
+ Hij = 0.;
+ for (k=0;k<qm;k++) {
+ if (df==2)
+ Hij += w[k] * Tn( (2.*z[k]-t0-t1)/(t1-t0), qj-1) *
+ exp((za-z[k])/s2/l);
+ if (df!=2)
+ Hij += w[k] * Tn( (2.*(z[k]*z[k]+za)-t0-t1)/(t1-t0) ,qj-1) *
+ 2. * pow(z[k], ddf-1.) * exp(-ddf*z[k]*z[k]/2./s2/l);
+ }
+ if (df==2) Hij /= s2*l;
+ else Hij /= gammafn(ddf/2.) * pow(2.*s2*l/ddf,ddf/2.);
+ a[ii*NN+jj] = -Hij;
+ }
+ else a[ii*NN+jj] = 0.;
+ }
+ }
+ }
+
+ for (qi=i;qi<M;qi++) {
+ t0 = cl/pow(1.-l,(double)qi);
+ t1 = t0/(1.-l);
+ if (t1>cu) t1 = cu;
+ if (t0<xl) x0 = xl; else x0 = t0;
+ if (df==2)
+ x1 = t1;
+ else {
+ if (x0-za>1e-10) x0 = sqrt(x0-za); else x0 = 0.;
+ if (t1-za>1e-10) x1 = sqrt(t1-za); else x1 = 0.;
+ }
+
+ if (i>0 && j==1 && qi==i) {
+ for (qj=1;qj<=Ntilde;qj++) {
+ jj = qi*Ntilde + qj-1;
+ a[ii*NN+jj] = Tn((2.*t[it]-t0-t1)/(t1-t0),qj-1);
+ }
+ }
+
+ if (i>0 && j==1 && qi>i) {
+ for (qj=1;qj<=Ntilde;qj++) {
+ jj = qi*Ntilde + qj-1;
+ a[ii*NN+jj] = 0.;
+ }
+ }
+
+ if (i==0 || j>1) {
+ for (qj=1;qj<=Ntilde;qj++) {
+ jj = qi*Ntilde + qj-1;
+ gausslegendre(qm,x0,x1,z,w);
+ Hij = 0.;
+ for (k=0;k<qm;k++) {
+ if (df==2)
+ Hij += w[k] * Tn( (2.*z[k]-t0-t1)/(t1-t0), qj-1) *
+ exp((za-z[k])/s2/l);
+ if (df!=2)
+ Hij += w[k] * Tn( (2.*(z[k]*z[k]+za)-t0-t1)/(t1-t0),qj-1) *
+ 2. * pow(z[k], ddf-1.) * exp(-ddf*z[k]*z[k]/2./s2/l);
+ }
+ if (df==2) Hij /= s2*l;
+ else Hij /= gammafn(ddf/2.) * pow(2.*s2*l/ddf,ddf/2.);
+ if (qi==i) a[ii*NN+jj] = Tn((2.*t[it]-t0-t1)/(t1-t0),qj-1) -
+ Hij;
+ else a[ii*NN+jj] = -Hij;
+ }
+ }
+ }
+ if (i==0) {
+ t0 = cl;
+ t1 = t0/(1.-l);
+ if (t1>cu) t1 = cu;
+
+ for (qj=1;qj<=Ntilde;qj++) {
+ dummy = (cl-za)/l/s2;
+ if (dummy>0.) {
+ if (df==1) dummy = 2.*PHI( sqrt(dummy), 0. ) - 1.;
+ if (df==2) dummy = 1. - exp( -dummy );
+ if (df>2) dummy = CHI( df*dummy, df);
+ }
+ else dummy = 0.;
+
+ a[ii*NN+qj-1] -= dummy * Tn((2.*cl-t0-t1)/(t1-t0),qj-1);
+ }
+ }
+ }
+ }
+
+ for (j=0;j<NN;j++) g[j] = 1.;
+ for (j=1;j<M;j++) g[Ntilde*j] = 0.;
+
+ LU_solve(a,g,NN);
+
+ arl = 0.;
+ for (i=0;i<M;i++) {
+ t0 = cl/pow(1.-l,(double)i);
+ t1 = t0/(1.-l);
+ if (t1>cu) t1 = cu;
+
+ if (t0<=hs && hs<t1)
+ for (j=1;j<=Ntilde;j++) {
+ ii = i*Ntilde + j-1;
+ arl += g[ii] * Tn((2.*hs-t0-t1)/(t1-t0),j-1);
+ }
+ }
+
+ Free(z);
+ Free(w);
+ Free(t);
+ Free(g);
+ Free(a);
+
+ return arl;
+}
+
+
+double stdeUR_iglarl(double l, double cl, double cu, double hs, double sigma, int df, int N, int qm)
+{ double *a, *g, *w, *z, *t, h, arl, Hij, xl, za, dN, ddf, s2, t0, t1, x0=0., x1, dummy, v;
+ int i, j, k, qi, qj, M, Ntilde, NN, ii, it, jj;
+
+ M = ceil( (log(cl)-log(cu))/log(1.-l) );
+ Ntilde = ceil( (double)N/(double)M );
+ NN = M*Ntilde;
+ s2 = sigma*sigma;
+ ddf = (double)df;
+ dN = (double)Ntilde - 1.;
+
+ a = matrix(NN,NN);
+ g = vector(NN);
+ t = vector(NN);
+ w = vector(qm);
+ z = vector(qm);
+
+ for(i=0; i<M; i++) {
+ t0 = cl/pow(1.-l,(double)(i));
+ t1 = t0/(1.-l);
+ if ( t1>cu ) t1 = cu;
+
+ for (j=1; j<Ntilde; j++) { /* node_i,Ntilde-1 = node_i+1,0 */
+ h = cos( PI/dN *(dN-j) );
+ t[i*(Ntilde-1)+j] = t0 + (h+1.)/2.*(t1-t0); /* Chebyshev Gauss-Lobatto nodes on [t0,t1] */
+ }
+ }
+ t[0] = cl;
+
+ for (i=0; i<M; i++) {
+ for (j=1; j<=Ntilde; j++) {
+ ii = i*Ntilde + j-1;
+ it = i*(Ntilde-1) + j-1;
+
+ za = (1.-l)*t[it];
+ if ( za<cl ) xl = cl; else xl = za;
+
+ for (qi=0; qi<i-1; qi++)
+ for (qj=1; qj<=Ntilde; qj++) {
+ jj = qi*Ntilde + qj-1;
+ a[ii*NN+jj] = 0.;
+ }
+
+ if ( i>0 ) {
+ qi = i-1;
+ t0 = cl/pow(1.-l,(double)qi);
+ t1 = t0/(1.-l);
+ if ( t1>cu ) t1 = cu;
+ if ( t0<xl ) x0 = xl; else x0 = t0;
+ x1 = t1;
+
+ for (qj=1; qj<=Ntilde; qj++) {
+ jj = qi*Ntilde + qj-1;
+
+ if ( j==1 ) a[ii*NN+jj] = - Tn((2.*t[it]-t0-t1)/(t1-t0),qj-1);
+ else {
+ if (fabs(t1-x0)>1e-8) {
+ gausslegendre(qm, x0, x1, z, w);
+ Hij = 0.;
+ for (k=0; k<qm; k++) {
+ v = (z[k] - za) / l;
+ Hij += w[k] * Tn( (2.*z[k]-t0-t1)/(t1-t0), qj-1) * pow(v,ddf-1.)*exp(-ddf/2./s2*v*v);
+ }
+ Hij *= 2./l/gammafn(ddf/2.)/pow(2.*s2/ddf,ddf/2.);
+ a[ii*NN+jj] = -Hij;
+ }
+ else a[ii*NN+jj] = 0.;
+ }
+ }
+ }
+
+ for (qi=i; qi<M; qi++) {
+ t0 = cl/pow(1.-l,(double)qi);
+ t1 = t0/(1.-l);
+ if ( t1>cu ) t1 = cu;
+ if ( t0<xl ) x0 = xl; else x0 = t0; /* Hong Kong & Inez */
+ x1 = t1;
+
+ if ( i>0 && j==1 && qi==i ) {
+ for (qj=1; qj<=Ntilde; qj++) {
+ jj = qi*Ntilde + qj-1;
+ a[ii*NN+jj] = Tn((2.*t[it]-t0-t1)/(t1-t0),qj-1);
+ }
+ }
+
+ if ( i>0 && j==1 && qi>i ) {
+ for (qj=1;qj<=Ntilde;qj++) {
+ jj = qi*Ntilde + qj-1;
+ a[ii*NN+jj] = 0.;
+ }
+ }
+
+ if ( i==0 || j>1 ) {
+ for (qj=1; qj<=Ntilde; qj++) {
+ jj = qi*Ntilde + qj-1;
+ gausslegendre(qm, x0, x1, z, w);
+ Hij = 0.;
+ for (k=0;k<qm;k++) {
+ v = (z[k] - za) / l;
+ Hij += w[k] * Tn( (2.*z[k]-t0-t1)/(t1-t0), qj-1) * pow(v,ddf-1.)*exp(-ddf/2./s2*v*v);
+ }
+ Hij *= 2./l/gammafn(ddf/2.)/pow(2.*s2/ddf,ddf/2.);
+ if ( qi==i ) a[ii*NN+jj] = Tn((2.*t[it]-t0-t1)/(t1-t0),qj-1) - Hij;
+ else a[ii*NN+jj] = -Hij;
+ }
+ }
+ }
+
+ if ( i==0 ) {
+ t0 = cl;
+ t1 = t0/(1.-l);
+ if ( t1>cu ) t1 = cu;
+
+ for (qj=1; qj<=Ntilde; qj++) {
+ dummy = 0.;
+ v = (cl-za)/l;
+ if ( v>0. ) dummy = CHI(ddf/s2*v*v, df);
+ a[ii*NN+qj-1] -= dummy * Tn((2.*cl-t0-t1)/(t1-t0),qj-1);
+ }
+ }
+ }
+ }
+
+ for ( j=0; j<NN; j++) g[j] = 1.;
+ for ( j=1; j<M; j++) g[Ntilde*j] = 0.;
+
+ LU_solve(a, g, NN);
+
+ arl = 0.;
+ for (i=0; i<M; i++) {
+ t0 = cl/pow(1.-l,(double)i);
+ t1 = t0/(1.-l);
+ if ( t1>cu ) t1 = cu;
+
+ if ( t0<=hs && hs<t1 )
+ for (j=1; j<=Ntilde; j++) {
+ ii = i*Ntilde + j-1;
+ arl += g[ii] * Tn((2.*hs-t0-t1)/(t1-t0),j-1);
+ }
+ }
+
+ Free(z);
+ Free(w);
+ Free(t);
+ Free(g);
+ Free(a);
+
+ return arl;
+}
+
+
+double seUR_sf(double l, double cl, double cu, double hs, double sigma, int df, int N, int nmax, int qm, double *p0)
+{ double *S1s, *S2s, *Pns, *ws, *zs, *zch, *rside, *b, za=0., s2, ddf, xl, xu, dN, Hij, *S00, *p00, *VF0;
+ int i, j, k, n, *ps, Ntilde, ihs, M, NN, ii, jj;
+
+ M = ceil( (log(cl)-log(cu))/log(1.-l) );
+ Ntilde = ceil( (double)N/(double)M );
+ NN = M*Ntilde;
+ s2 = sigma*sigma;
+ ddf = (double)df;
+ dN = (double)Ntilde;
+
+ ihs = floor( (log(cl) - log(hs))/log(1.-l) );
+ if ( ihs<0 ) ihs = 0;
+
+ S1s = matrix(NN,NN);
+ S2s = matrix(NN,NN);
+ ps = ivector(NN);
+ zch = matrix(M,Ntilde);
+ rside = vector(NN+1);
+ b = vector(M+1);
+ ws = vector(qm);
+ zs = vector(qm);
+ Pns = matrix(nmax,NN);
+
+ S00 = vector(NN);
+ p00 = vector(nmax);
+ VF0 = vector(NN+1);
+
+/* interval borders b_i = cl/(1-l)^i */
+ for (i=0; i<M; i++) b[i] = cl/pow(1.-l, (double)(i));
+ b[M] = cu;
+
+ /* Chebyshev nodes on [b_0,b_1],[b_1,b_2],...,[b_M-1,cu] */
+ for (i=0; i<M; i++)
+ for (j=0; j<Ntilde; j++) {
+ zch[ i*Ntilde+j ] = b[i] + (b[i+1]-b[i])/2.*(1.+cos(PI*(2.*j+1.)/2./dN));
+ }
+
+ /* P(L>1)(zch[i,j]) */
+ for (i=0; i<M; i++)
+ for (j=0; j<Ntilde; j++) {
+ rside[ i*Ntilde+j ] = CHI( ddf/s2*(cu-(1.-l)*zch[ i*Ntilde+j ])/l, df);
+ }
+ rside[NN] = CHI( ddf/s2*(cu-(1.-l)*cl)/l, df); /* reflexion at cl */
+
+ /* P(zch[i,j] -> zreflect) */
+ for (i=0; i<M; i++)
+ for (j=0; j<Ntilde; j++)
+ VF0[ i*Ntilde+j ] = CHI( ddf/s2*(cl-(1.-l)*zch[ i*Ntilde+j ])/l, df) ;
+ VF0[NN] = CHI( ddf/s2*cl, df);
+
+ for (i=0; i<M; i++)
+ for (j=0; j<Ntilde; j++) {
+ za = (1.-l)*zch[ i*Ntilde+j ];
+ for (ii=0; ii<M; ii++)
+ for (jj=0; jj<Ntilde; jj++) {
+ if ( b[ii+1]<za ) S1s[ (i*Ntilde+j)*NN + ii*Ntilde+jj ] = 0.;
+ else {
+ if ( za<b[ii] ) xl = b[ii]; else xl = za;
+ xu = b[ii+1];
+ if ( df!=2 ) {
+ xl = sqrt(xl-za);
+ xu = sqrt(xu-za);
+ }
+ gausslegendre(qm, xl, xu, zs, ws);
+ Hij = 0.;
+ for (k=0; k<qm; k++)
+ if ( df==2 )
+ Hij += ws[k]*Tn( (2.*zs[k]-b[ii+1]-b[ii])/(b[ii+1]-b[ii]), jj) * exp(-zs[k]/s2/l);
+ else
+ Hij += ws[k]*Tn( (2.*(zs[k]*zs[k]+za)-b[ii+1]-b[ii])/(b[ii+1]-b[ii]), jj)
+ * 2. * pow(zs[k], ddf-1.) * exp(-ddf*zs[k]*zs[k]/2./s2/l);
+ if ( df==2 ) Hij *= exp(za/s2/l)/s2/l;
+ else Hij /= gammafn(ddf/2.) * pow(2.*s2*l/ddf, ddf/2.);
+ S1s[ (i*Ntilde+j)*NN + ii*Ntilde+jj ] = Hij;
+ }
+ }
+ }
+
+ za = (1.-l)*cl;
+ for (ii=0; ii<M; ii++)
+ for (jj=0; jj<Ntilde; jj++) {
+ if ( b[ii+1]<za ) S00[ ii*Ntilde+jj ] = 0.;
+ else {
+ if ( za<b[ii] ) xl = b[ii]; else xl = za;
+ xu = b[ii+1];
+ if ( df!=2 ) {
+ xl = sqrt(xl-za);
+ xu = sqrt(xu-za);
+ }
+ gausslegendre(qm, xl, xu, zs, ws);
+ Hij = 0.;
+ for (k=0; k<qm; k++)
+ if ( df==2 )
+ Hij += ws[k]*Tn((2.*zs[k]-b[ii+1]-b[ii])/(b[ii+1]-b[ii]), jj) * exp(-zs[k]/s2/l);
+ else
+ Hij += ws[k] * Tn((2.*(zs[k]*zs[k]+za)-b[ii+1]-b[ii])/(b[ii+1]-b[ii]), jj)
+ * 2. * pow(zs[k], ddf-1.) * exp(-ddf*zs[k]*zs[k]/2./s2/l);
+ if ( df==2 ) Hij *= exp(za/s2/l)/s2/l;
+ else Hij /= gammafn(ddf/2.) * pow(2.*s2*l/ddf, ddf/2.);
+ S00[ ii*Ntilde+jj ] = Hij;
+ }
+ }
+
+ for (i=0; i<NN; i++)
+ for (j=0; j<NN; j++) S2s[i*NN+j] = 0.;
+
+ for (i=0; i<M; i++)
+ for (j=0; j<Ntilde; j++)
+ for (jj=0; jj<Ntilde; jj++)
+ S2s[ (i*Ntilde+j)*NN + i*Ntilde+jj ] = Tn( (2.*zch[ i*Ntilde+j ]-b[i+1]-b[i])/(b[i+1]-b[i]), jj);
+
+ LU_decompose(S2s,ps,NN);
+
+ for (n=1; n<=nmax; n++) {
+ if ( n==1) {
+ for (i=0; i<M; i++)
+ for (j=0; j<Ntilde; j++) {
+ Pns[ i*Ntilde+j ] = 0.;
+ for (jj=0; jj<Ntilde; jj++)
+ Pns[ i*Ntilde+j ] += /* usual Chebyshev approximation */
+ 2./Ntilde * Tn( (2.*zch[i*Ntilde+jj]-b[i+1]-b[i])/(b[i+1]-b[i]), j) * rside[ i*Ntilde+jj ];
+ if ( j==0 ) Pns[ i*Ntilde+j ] /= 2.;
+ }
+ p00[0] = rside[NN];
+ }
+ else {
+ for (i=0; i<NN; i++) {
+ rside[i] = VF0[i] * p00[n-2];
+ for (j=0; j<NN; j++) rside[i] += S1s[ i*NN+j ] * Pns[ (n-2)*NN+j ];
+ }
+ LU_solve2(S2s, rside, ps, NN);
+ for (i=0; i<NN; i++) Pns[ (n-1)*NN+i ] = rside[i];
+ p00[n-1] = VF0[NN] * p00[n-2];
+ for (i=0 ;i<NN; i++) p00[n-1] += S00[i] * Pns[ (n-2)*NN+i ];
+ }
+
+ p0[n-1] = 0.;
+ if ( n==1 )
+ p0[0] = CHI( ddf/s2*(cu-(1.-l)*hs)/l, df);
+ else
+ for (j=0; j<Ntilde; j++)
+ p0[n-1] += Pns[ (n-1)*NN + ihs*Ntilde+j ] * Tn( (2.*hs-b[ihs+1]-b[ihs])/(b[ihs+1]-b[ihs]), j);
+ }
+
+ Free(Pns);
+ Free(zs);
+ Free(ws);
+ Free(rside);
+ Free(zch);
+ Free(ps);
+ Free(S2s);
+ Free(S1s);
+
+ Free(S00);
+ Free(p00);
+ Free(VF0);
+
+ return 0;
+}
+
+
+double seUR_sf_deluxe(double l, double cl, double cu, double hs, double sigma, int df, int N, int nmax, int qm, double *p0, int *nstop, double *rho)
+{ double *S1s, *S2s, *Pns, *ws, *zs, *zch, *rside, *b, za=0., s2, ddf, xl, xu, dN, Hij, *S00, *p00, *VF0, mn_minus=1., mn_plus=0., oben, unten, q;
+ int i, j, k, n, *ps, Ntilde, ihs, M, NN, ii, jj;
+
+ M = ceil( (log(cl)-log(cu))/log(1.-l) );
+ Ntilde = ceil( (double)N/(double)M );
+ NN = M*Ntilde;
+ s2 = sigma*sigma;
+ ddf = (double)df;
+ dN = (double)Ntilde;
+
+ ihs = floor( (log(cl) - log(hs))/log(1.-l) );
+ if ( ihs<0 ) ihs = 0;
+
+ S1s = matrix(NN,NN);
+ S2s = matrix(NN,NN);
+ ps = ivector(NN);
+ zch = matrix(M,Ntilde);
+ rside = vector(NN+1);
+ b = vector(M+1);
+ ws = vector(qm);
+ zs = vector(qm);
+ Pns = matrix(nmax,NN);
+
+ S00 = vector(NN);
+ p00 = vector(nmax);
+ VF0 = vector(NN+1);
+
+/* interval borders b_i = cl/(1-l)^i */
+ for (i=0; i<M; i++) b[i] = cl/pow(1.-l, (double)(i));
+ b[M] = cu;
+
+ /* Chebyshev nodes on [b_0,b_1],[b_1,b_2],...,[b_M-1,cu] */
+ for (i=0; i<M; i++)
+ for (j=0; j<Ntilde; j++) {
+ zch[ i*Ntilde+j ] = b[i] + (b[i+1]-b[i])/2.*(1.+cos(PI*(2.*j+1.)/2./dN));
+ }
+
+ /* P(L>1)(zch[i,j]) */
+ for (i=0; i<M; i++)
+ for (j=0; j<Ntilde; j++) {
+ rside[ i*Ntilde+j ] = CHI( ddf/s2*(cu-(1.-l)*zch[ i*Ntilde+j ])/l, df);
+ }
+ rside[NN] = CHI( ddf/s2*(cu-(1.-l)*cl)/l, df); /* reflexion at cl */
+
+ /* P(zch[i,j] -> zreflect) */
+ for (i=0; i<M; i++)
+ for (j=0; j<Ntilde; j++)
+ VF0[ i*Ntilde+j ] = CHI( ddf/s2*(cl-(1.-l)*zch[ i*Ntilde+j ])/l, df) ;
+ VF0[NN] = CHI( ddf/s2*cl, df);
+
+ for (i=0; i<M; i++)
+ for (j=0; j<Ntilde; j++) {
+ za = (1.-l)*zch[ i*Ntilde+j ];
+ for (ii=0; ii<M; ii++)
+ for (jj=0; jj<Ntilde; jj++) {
+ if ( b[ii+1]<za ) S1s[ (i*Ntilde+j)*NN + ii*Ntilde+jj ] = 0.;
+ else {
+ if ( za<b[ii] ) xl = b[ii]; else xl = za;
+ xu = b[ii+1];
+ if ( df!=2 ) {
+ xl = sqrt(xl-za);
+ xu = sqrt(xu-za);
+ }
+ gausslegendre(qm, xl, xu, zs, ws);
+ Hij = 0.;
+ for (k=0; k<qm; k++)
+ if ( df==2 )
+ Hij += ws[k]*Tn( (2.*zs[k]-b[ii+1]-b[ii])/(b[ii+1]-b[ii]), jj) * exp(-zs[k]/s2/l);
+ else
+ Hij += ws[k]*Tn( (2.*(zs[k]*zs[k]+za)-b[ii+1]-b[ii])/(b[ii+1]-b[ii]), jj)
+ * 2. * pow(zs[k], ddf-1.) * exp(-ddf*zs[k]*zs[k]/2./s2/l);
+ if ( df==2 ) Hij *= exp(za/s2/l)/s2/l;
+ else Hij /= gammafn(ddf/2.) * pow(2.*s2*l/ddf, ddf/2.);
+ S1s[ (i*Ntilde+j)*NN + ii*Ntilde+jj ] = Hij;
+ }
+ }
+ }
+
+ za = (1.-l)*cl;
+ for (ii=0; ii<M; ii++)
+ for (jj=0; jj<Ntilde; jj++) {
+ if ( b[ii+1]<za ) S00[ ii*Ntilde+jj ] = 0.;
+ else {
+ if ( za<b[ii] ) xl = b[ii]; else xl = za;
+ xu = b[ii+1];
+ if ( df!=2 ) {
+ xl = sqrt(xl-za);
+ xu = sqrt(xu-za);
+ }
+ gausslegendre(qm, xl, xu, zs, ws);
+ Hij = 0.;
+ for (k=0; k<qm; k++)
+ if ( df==2 )
+ Hij += ws[k]*Tn((2.*zs[k]-b[ii+1]-b[ii])/(b[ii+1]-b[ii]), jj) * exp(-zs[k]/s2/l);
+ else
+ Hij += ws[k] * Tn((2.*(zs[k]*zs[k]+za)-b[ii+1]-b[ii])/(b[ii+1]-b[ii]), jj)
+ * 2. * pow(zs[k], ddf-1.) * exp(-ddf*zs[k]*zs[k]/2./s2/l);
+ if ( df==2 ) Hij *= exp(za/s2/l)/s2/l;
+ else Hij /= gammafn(ddf/2.) * pow(2.*s2*l/ddf, ddf/2.);
+ S00[ ii*Ntilde+jj ] = Hij;
+ }
+ }
+
+ for (i=0; i<NN; i++)
+ for (j=0; j<NN; j++) S2s[i*NN+j] = 0.;
+
+ for (i=0; i<M; i++)
+ for (j=0; j<Ntilde; j++)
+ for (jj=0; jj<Ntilde; jj++)
+ S2s[ (i*Ntilde+j)*NN + i*Ntilde+jj ] = Tn( (2.*zch[ i*Ntilde+j ]-b[i+1]-b[i])/(b[i+1]-b[i]), jj);
+
+ LU_decompose(S2s,ps,NN);
+
+ for (n=1; n<=nmax; n++) {
+ if ( n==1) {
+ for (i=0; i<M; i++)
+ for (j=0; j<Ntilde; j++) {
+ Pns[ i*Ntilde+j ] = 0.;
+ for (jj=0; jj<Ntilde; jj++)
+ Pns[ i*Ntilde+j ] += /* usual Chebyshev approximation */
+ 2./Ntilde * Tn( (2.*zch[i*Ntilde+jj]-b[i+1]-b[i])/(b[i+1]-b[i]), j) * rside[ i*Ntilde+jj ];
+ if ( j==0 ) Pns[ i*Ntilde+j ] /= 2.;
+ }
+ p00[0] = rside[NN];
+ }
+ else {
+ for (i=0; i<NN; i++) {
+ rside[i] = VF0[i] * p00[n-2];
+ for (j=0; j<NN; j++) rside[i] += S1s[ i*NN+j ] * Pns[ (n-2)*NN+j ];
+ }
+ LU_solve2(S2s, rside, ps, NN);
+ for (i=0; i<NN; i++) Pns[ (n-1)*NN+i ] = rside[i];
+ p00[n-1] = VF0[NN] * p00[n-2];
+ for (i=0 ;i<NN; i++) p00[n-1] += S00[i] * Pns[ (n-2)*NN+i ];
+ }
+
+ p0[n-1] = 0.;
+ if ( n==1 )
+ p0[0] = CHI( ddf/s2*(cu-(1.-l)*hs)/l, df);
+ else
+ for (j=0; j<Ntilde; j++)
+ p0[n-1] += Pns[ (n-1)*NN + ihs*Ntilde+j ] * Tn( (2.*hs-b[ihs+1]-b[ihs])/(b[ihs+1]-b[ihs]), j);
+
+ mn_minus = 1.; mn_plus = 0.;
+ if ( n > 1) {
+ for (i=0; i<M; i++)
+ for (j=0; j<Ntilde; j++) {
+ oben = 0.;
+ unten = 0.;
+ for (jj=0; jj<Ntilde; jj++) {
+ oben += Pns[ (n-1)*NN + i*Ntilde+jj ] * Tn((2.*zch[i*Ntilde+j]-b[i+1]-b[i])/(b[i+1]-b[i]), jj);
+ unten+= Pns[ (n-2)*NN + i*Ntilde+jj ] * Tn((2.*zch[i*Ntilde+j]-b[i+1]-b[i])/(b[i+1]-b[i]), jj);
+ }
+ if ( fabs(unten)<1e-16 )
+ if ( fabs(oben)<1e-16 ) q = 0.;
+ else q = 1.;
+ else q = oben/unten;
+ if ( q<mn_minus ) mn_minus = q;
+ if ( q>mn_plus ) mn_plus = q;
+ }
+ *rho = (mn_minus + mn_plus)/2.;
+ if ( fabs(mn_plus - mn_minus) < FINALeps ) {
+ *nstop = n;
+ n = nmax + 1;
+ }
+ } /* n > 1 */
+ } /* n=1; n<=nmax; n++ */
+
+ Free(Pns);
+ Free(zs);
+ Free(ws);
+ Free(rside);
+ Free(zch);
+ Free(ps);
+ Free(S2s);
+ Free(S1s);
+
+ Free(S00);
+ Free(p00);
+ Free(VF0);
+
+ return 0;
+}
+
+
+double seUR_sf_prerun_SIGMA_deluxe(double l, double cl, double cu, double hs, double sigma, int df1, int df2, int nmax, int qm1, int qm2, double truncate, double *p0)
+{ double *ww, *zz, b1, b2, ddf2, *SF, rho, s2;
+ int i, m, n, nstop, Nlocal;
+
+ Nlocal = choose_N_for_se2(l, cl, cu);
+
+ SF = vector(nmax);
+ ww = vector(qm2);
+ zz = vector(qm2);
+
+ ddf2 = (double)(df2);
+ b1 = qCHI( truncate/2., df2)/ddf2;
+ b2 = qCHI(1. - truncate/2., df2)/ddf2;
+ gausslegendre(qm2, b1, b2, zz, ww);
+ for (i=0; i<qm2; i++) ww[i] *= ddf2 * chi( ddf2*zz[i], df2);
+
+ for (n=0; n<nmax; n++) p0[n] = 0.;
+
+ for (i=0; i<qm2; i++) {
+ s2 = zz[i];
+ m = seUR_sf_deluxe(l, s2*cl, s2*cu, s2*hs, sigma, df1, Nlocal, nmax, qm1, SF, &nstop, &rho);
+ if ( m != 0 ) warning("trouble with internal [package spc] function seUR_sf_deluxe");
+ if ( nstop > 0 ) {
+ for (n=0; n<nstop; n++) p0[n] += ww[i] * SF[n];
+ for (n=nstop; n<nmax; n++) p0[n] += ww[i] * SF[nstop-1] * pow(rho, n-nstop+1);
+ } else {
+ for (n=0; n<nmax; n++) p0[n] += ww[i] * SF[n];
+ }
+ }
+
+ Free(ww);
+ Free(zz);
+ Free(SF);
+
+ return 0;
+}
+
+
+double seUR_sf_prerun_SIGMA(double l, double cl, double cu, double hs, double sigma, int df1, int df2, int nmax, int qm1, int qm2, double truncate, double *p0)
+{ double *ww, *zz, b1, b2, ddf2, *SF, s2;
+ int i, m, n, Nlocal;
+
+ Nlocal = choose_N_for_se2(l, cl, cu);
+
+ SF = vector(nmax);
+ ww = vector(qm2);
+ zz = vector(qm2);
+
+ ddf2 = (double)(df2);
+ b1 = qCHI( truncate/2., df2)/ddf2;
+ b2 = qCHI(1. - truncate/2., df2)/ddf2;
+ gausslegendre(qm2, b1, b2, zz, ww);
+ for (i=0; i<qm2; i++) ww[i] *= ddf2 * chi( ddf2*zz[i], df2);
+
+ for (n=0; n<nmax; n++) p0[n] = 0.;
+
+ for (i=0; i<qm2; i++) {
+ s2 = zz[i];
+ m = seUR_sf(l, s2*cl, s2*cu, s2*hs, sigma, df1, Nlocal, nmax, qm1, SF);
+ if ( m != 0 ) warning("trouble with internal [package spc] function seUR_sf");
+ for (n=0; n<nmax; n++) p0[n] += ww[i] * SF[n];
+ }
+
+ Free(ww);
+ Free(zz);
+ Free(SF);
+
+ return 0;
+}
+
+
+double seUR_Wq_prerun_SIGMA_deluxe(double l, double cl, double cu, double p, double hs, double sigma, int df1, int df2, int nmax, int qm1, int qm2, double truncate)
+{ double *ww, *zz, b1, b2, ddf2, *SF, *p0, rho, *rhomany, *SFlast, Lp=-1., sf_level_adj, s2;
+ int i, j, n, nstop, nstop_, nsm, nn, qnspecial=0, Nlocal;
+
+ Nlocal = choose_N_for_se2(l, cl, cu);
+
+ p0 = vector(nmax);
+ SF = vector(nmax);
+ rhomany = vector(qm2);
+ SFlast = vector(qm2);
+ ww = vector(qm2);
+ zz = vector(qm2);
+
+ ddf2 = (double)(df2);
+ b1 = qCHI( truncate/2., df2)/ddf2;
+ b2 = qCHI(1. - truncate/2., df2)/ddf2;
+ gausslegendre(qm2, b1, b2, zz, ww);
+ for (i=0; i<qm2; i++) ww[i] *= ddf2 * chi( ddf2*zz[i], df2);
+
+ qnspecial = (qm2+1) / 2;
+
+ s2 = zz[qnspecial];
+ j = seUR_sf_deluxe(l, s2*cl, s2*cu, s2*hs, sigma, df1, Nlocal, nmax, qm1, SF, &nsm, &rho);
+ if ( j != 0 ) warning("trouble with internal [package spc] function seU_sf_deluxe");
+ n = nsm;
+
+ if ( nsm < 1 ) { /* did not converge yet -- should be the rare case */
+ nn = nmax;
+ warning("The geometric tail approximation might not work.");
+ } else {
+ nstop = nsm;
+
+ s2 = zz[qnspecial+1];
+ j = seUR_sf_deluxe(l, s2*cl, s2*cu, s2*hs, sigma, df1, Nlocal, nmax, qm1, SF, &nstop_, &rho);
+ if ( j != 0 ) warning("trouble with internal [package spc] function seU_sf_deluxe");
+ if ( nstop_ > nsm ) nsm = nstop_;
+ if ( nstop_ < 1) nsm = nmax;
+ if ( nstop_ >= nstop && nsm<nmax ) {
+ i = 1;
+ while ( nstop_ >= nstop && nsm<nmax ) {
+ nstop = nstop_;
+ i++;
+ s2 = zz[qnspecial+i];
+ j = seUR_sf_deluxe(l, s2*cl, s2*cu, s2*hs, sigma, df1, Nlocal, nmax, qm1, SF, &nstop_, &rho);
+ if ( j != 0 ) warning("trouble with internal [package spc] function seU_sf_deluxe");
+ if ( nstop_ > nsm ) nsm = nstop_;
+ if ( nstop_ < 1) nsm = nmax;
+ }
+ }
+
+ nstop = n;
+ s2 = zz[qnspecial-1];
+ j = seUR_sf_deluxe(l, s2*cl, s2*cu, s2*hs, sigma, df1, Nlocal, nmax, qm1, SF, &nstop_, &rho);
+ if ( j != 0 ) warning("trouble with internal [package spc] function seU_sf_deluxe");
+ if ( nstop_ > nsm ) nsm = nstop_;
+ if ( nstop_ < 1) nsm = nmax;
+ if ( nstop_ >= nstop && nsm<nmax ) {
+ i = 1;
+ while ( nstop_ >= nstop && nsm<nmax ) {
+ nstop = nstop_;
+ i++;
+ s2 = zz[qnspecial-i];
+ j = seUR_sf_deluxe(l, s2*cl, s2*cu, s2*hs, sigma, df1, Nlocal, nmax, qm1, SF, &nstop_, &rho);
+ if ( j != 0 ) warning("trouble with internal [package spc] function seU_sf_deluxe");
+ if ( nstop_ > nsm ) nsm = nstop_;
+ if ( nstop_ < 1) nsm = nmax;
+ }
+ }
+ nn = nsm;
+ }
+
+ for (n=0; n<nmax; n++) p0[n] = 0.;
+
+ for (i=0; i<qm2; i++) {
+ s2 = zz[i];
+ j = seUR_sf_deluxe(l, s2*cl, s2*cu, s2*hs, sigma, df1, Nlocal, nn, qm1, SF, &nstop, &rho);
+ if ( j != 0 ) warning("trouble with internal [package spc] function seU_sf_deluxe");
+ if ( nstop < 1 ) {
+ nstop = nn;
+ warning("The geometric tail approximation might not work.");
+ }
+ rhomany[i] = rho;
+ for (n=0; n<nstop; n++) p0[n] += ww[i] * SF[n];
+ if ( nstop < nn) {
+ for (n=nstop; n<nn; n++) p0[n] += ww[i] * SF[nstop-1] * pow(rho, n-nstop+1);
+ }
+ SFlast[i] = SF[nstop-1] * pow(rho, nn-nstop);
+ }
+
+ sf_level_adj = 1.-p;
+ if ( p0[nn-1] <= sf_level_adj ) {
+ n = nn-1;
+ while ( p0[n] <= sf_level_adj && n > 0 ) n--;
+ if ( p0[n] > 1.-p ) Lp = (double)( n + 2 ); else Lp = 1.;
+ } else {
+ for (n=nn; n<nmax; n++) {
+ p0[n] = 0.;
+ for (i=0; i<qm2; i++) p0[n] += ww[i] * SFlast[i] * pow(rhomany[i], n-nn+1);
+ if ( p0[n] <= sf_level_adj ) {
+ Lp = (double)( n + 1 );
+ n = nmax+1;
+ }
+ }
+ }
+
+ Free(p0);
+ Free(ww);
+ Free(zz);
+ Free(SF);
+ Free(SFlast);
+ Free(rhomany);
+
+ return Lp;
+}
+
+
+double seUR_iglarl_prerun_SIGMA(double l, double cl, double cu, double hs, double sigma, int df1, int df2, int N, int qm1, int qm2, double truncate)
+{ double *ww, *zz, b1, b2, result, ddf2, s2;
+ int i;
+
+ ww = vector(qm2);
+ zz = vector(qm2);
+ ddf2 = (double)(df2);
+ b1 = qCHI( truncate/2., df2)/ddf2;
+ b2 = qCHI(1. - truncate/2., df2)/ddf2;
+ gausslegendre(qm2, b1, b2, zz, ww);
+ result = 0.;
+ for (i=0; i<qm2; i++) {
+ s2 = zz[i];
+ result += ww[i] * ddf2 * chi( ddf2*s2, df2) * seUR_iglarl(l, s2*cl, s2*cu, s2*hs, sigma, df1, N, qm1);
+ }
+ Free(ww);
+ Free(zz);
+
+ return result;
+}
+
+
+double seUR_Wq(double l, double cl, double cu, double p, double hs, double sigma, int df, int N, int nmax, int qm)
+{ double *S1s, *S2s, *Pns, *p0, *ws, *zs, *zch, *rside, *b, za=0., s2, ddf, xl, xu, q_minus=0., q_plus=0., dN, Hij, *S00, *p00, *VF0, mn_minus=1., mn_plus=0., oben, unten, q, enumerator=0., Wq=0.;
+ int i, j, k, n, *ps, Ntilde, ihs, M, NN, ii, jj;
+
+ M = ceil( (log(cl)-log(cu))/log(1.-l) );
+ Ntilde = ceil( (double)N/(double)M );
+ NN = M*Ntilde;
+ s2 = sigma*sigma;
+ ddf = (double)df;
+ dN = (double)Ntilde;
+
+ ihs = floor( (log(cl) - log(hs))/log(1.-l) );
+ if ( ihs<0 ) ihs = 0;
+
+ S1s = matrix(NN,NN);
+ S2s = matrix(NN,NN);
+ ps = ivector(NN);
+ zch = matrix(M,Ntilde);
+ rside = vector(NN+1);
+ b = vector(M+1);
+ ws = vector(qm);
+ zs = vector(qm);
+ p0 = vector(nmax);
+ Pns = matrix(nmax,NN);
+
+ S00 = vector(NN);
+ p00 = vector(nmax);
+ VF0 = vector(NN+1);
+
+/* interval borders b_i = cl/(1-l)^i */
+ for (i=0; i<M; i++) b[i] = cl/pow(1.-l, (double)(i));
+ b[M] = cu;
+
+ /* Chebyshev nodes on [b_0,b_1],[b_1,b_2],...,[b_M-1,cu] */
+ for (i=0; i<M; i++)
+ for (j=0; j<Ntilde; j++) {
+ zch[ i*Ntilde+j ] = b[i] + (b[i+1]-b[i])/2.*(1.+cos(PI*(2.*j+1.)/2./dN));
+ }
+
+ /* P(L>1)(zch[i,j]) */
+ for (i=0; i<M; i++)
+ for (j=0; j<Ntilde; j++) {
+ rside[ i*Ntilde+j ] = CHI( ddf/s2*(cu-(1.-l)*zch[ i*Ntilde+j ])/l, df);
+ }
+ rside[NN] = CHI( ddf/s2*(cu-(1.-l)*cl)/l, df); /* reflexion at cl */
+
+ /* P(zch[i,j] -> zreflect) */
+ for (i=0; i<M; i++)
+ for (j=0; j<Ntilde; j++)
+ VF0[ i*Ntilde+j ] = CHI( ddf/s2*(cl-(1.-l)*zch[ i*Ntilde+j ])/l, df) ;
+ VF0[NN] = CHI( ddf/s2*cl, df);
+
+ for (i=0; i<M; i++)
+ for (j=0; j<Ntilde; j++) {
+ za = (1.-l)*zch[ i*Ntilde+j ];
+ for (ii=0; ii<M; ii++)
+ for (jj=0; jj<Ntilde; jj++) {
+ if ( b[ii+1]<za ) S1s[ (i*Ntilde+j)*NN + ii*Ntilde+jj ] = 0.;
+ else {
+ if ( za<b[ii] ) xl = b[ii]; else xl = za;
+ xu = b[ii+1];
+ if ( df!=2 ) {
+ xl = sqrt(xl-za);
+ xu = sqrt(xu-za);
+ }
+ gausslegendre(qm, xl, xu, zs, ws);
+ Hij = 0.;
+ for (k=0; k<qm; k++)
+ if ( df==2 )
+ Hij += ws[k]*Tn( (2.*zs[k]-b[ii+1]-b[ii])/(b[ii+1]-b[ii]), jj) * exp(-zs[k]/s2/l);
+ else
+ Hij += ws[k]*Tn( (2.*(zs[k]*zs[k]+za)-b[ii+1]-b[ii])/(b[ii+1]-b[ii]), jj)
+ * 2. * pow(zs[k], ddf-1.) * exp(-ddf*zs[k]*zs[k]/2./s2/l);
+ if ( df==2 ) Hij *= exp(za/s2/l)/s2/l;
+ else Hij /= gammafn(ddf/2.) * pow(2.*s2*l/ddf, ddf/2.);
+ S1s[ (i*Ntilde+j)*NN + ii*Ntilde+jj ] = Hij;
+ }
+ }
+ }
+
+ za = (1.-l)*cl;
+ for (ii=0; ii<M; ii++)
+ for (jj=0; jj<Ntilde; jj++) {
+ if ( b[ii+1]<za ) S00[ ii*Ntilde+jj ] = 0.;
+ else {
+ if ( za<b[ii] ) xl = b[ii]; else xl = za;
+ xu = b[ii+1];
+ if ( df!=2 ) {
+ xl = sqrt(xl-za);
+ xu = sqrt(xu-za);
+ }
+ gausslegendre(qm, xl, xu, zs, ws);
+ Hij = 0.;
+ for (k=0; k<qm; k++)
+ if ( df==2 )
+ Hij += ws[k]*Tn((2.*zs[k]-b[ii+1]-b[ii])/(b[ii+1]-b[ii]), jj) * exp(-zs[k]/s2/l);
+ else
+ Hij += ws[k] * Tn((2.*(zs[k]*zs[k]+za)-b[ii+1]-b[ii])/(b[ii+1]-b[ii]), jj)
+ * 2. * pow(zs[k], ddf-1.) * exp(-ddf*zs[k]*zs[k]/2./s2/l);
+ if ( df==2 ) Hij *= exp(za/s2/l)/s2/l;
+ else Hij /= gammafn(ddf/2.) * pow(2.*s2*l/ddf, ddf/2.);
+ S00[ ii*Ntilde+jj ] = Hij;
+ }
+ }
+
+ for (i=0; i<NN; i++)
+ for (j=0; j<NN; j++) S2s[i*NN+j] = 0.;
+
+ for (i=0; i<M; i++)
+ for (j=0; j<Ntilde; j++)
+ for (jj=0; jj<Ntilde; jj++)
+ S2s[ (i*Ntilde+j)*NN + i*Ntilde+jj ] = Tn( (2.*zch[ i*Ntilde+j ]-b[i+1]-b[i])/(b[i+1]-b[i]), jj);
+
+ LU_decompose(S2s,ps,NN);
+
+ for (n=1; n<=nmax; n++) {
+ if ( n==1) {
+ for (i=0; i<M; i++)
+ for (j=0; j<Ntilde; j++) {
+ Pns[ i*Ntilde+j ] = 0.;
+ for (jj=0; jj<Ntilde; jj++)
+ Pns[ i*Ntilde+j ] += /* usual Chebyshev approximation */
+ 2./Ntilde * Tn( (2.*zch[i*Ntilde+jj]-b[i+1]-b[i])/(b[i+1]-b[i]), j) * rside[ i*Ntilde+jj ];
+ if ( j==0 ) Pns[ i*Ntilde+j ] /= 2.;
+ }
+ p00[0] = rside[NN];
+ }
+ else {
+ for (i=0; i<NN; i++) {
+ rside[i] = VF0[i] * p00[n-2];
+ for (j=0; j<NN; j++) rside[i] += S1s[ i*NN+j ] * Pns[ (n-2)*NN+j ];
+ }
+ LU_solve2(S2s, rside, ps, NN);
+ for (i=0; i<NN; i++) Pns[ (n-1)*NN+i ] = rside[i];
+ p00[n-1] = VF0[NN] * p00[n-2];
+ for (i=0 ;i<NN; i++) p00[n-1] += S00[i] * Pns[ (n-2)*NN+i ];
+ }
+
+ p0[n-1] = 0.;
+ if ( n==1 )
+ p0[0] = CHI( ddf/s2*(cu-(1.-l)*hs)/l, df);
+ else
+ for (j=0; j<Ntilde; j++)
+ p0[n-1] += Pns[ (n-1)*NN + ihs*Ntilde+j ] * Tn( (2.*hs-b[ihs+1]-b[ihs])/(b[ihs+1]-b[ihs]), j);
+
+ if ( p0[n-1] < 1.-p ) {
+ Wq = (double)n;
+ n = nmax+1;
+ } else {
+ mn_minus = 1.; mn_plus = 0.;
+ if ( n > 1) {
+ for (i=0; i<M; i++)
+ for (j=0; j<Ntilde; j++) {
+ oben = 0.;
+ unten = 0.;
+ for (jj=0; jj<Ntilde; jj++) {
+ oben += Pns[ (n-1)*NN + i*Ntilde+jj ] * Tn((2.*zch[i*Ntilde+j]-b[i+1]-b[i])/(b[i+1]-b[i]), jj);
+ unten+= Pns[ (n-2)*NN + i*Ntilde+jj ] * Tn((2.*zch[i*Ntilde+j]-b[i+1]-b[i])/(b[i+1]-b[i]), jj);
+ }
+ if ( fabs(unten)<1e-16 )
+ if ( fabs(oben)<1e-16 ) q = 0.;
+ else q = 1.;
+ else q = oben/unten;
+ if ( q<mn_minus ) mn_minus = q;
+ if ( q>mn_plus ) mn_plus = q;
+ }
+ enumerator = log( (1.-p)/p0[n-1] );
+ q_minus = (double)n + enumerator/log(mn_minus);
+ q_plus = (double)n + enumerator/log(mn_plus);
+ /*if ( fabs( (q_plus-q_minus)/q_minus )<FINALeps ) n = nmax+1;*/
+ if ( fabs( ceil(q_plus) - ceil(q_minus) ) < .5 ) {
+ Wq = ceil(q_plus);
+ n = nmax +1;
+ }
+ } /* n > 1 */
+ } /* p0[n-1] >= 1.-p */
+ } /* n=1; n<=nmax; n++ */
+
+ Free(Pns);
+ Free(p0);
+ Free(zs);
+ Free(ws);
+ Free(rside);
+ Free(zch);
+ Free(ps);
+ Free(S2s);
+ Free(S1s);
+
+ Free(S00);
+ Free(p00);
+ Free(VF0);
+
+ return Wq;
+}
+
+
+double seUR_crit(double l, double L0, double cl, double hs, double sigma, int df, int N, int qm)
+{ double s1, s2, s3, ds, L1, L2, L3;
+
+ s2 = hs;
+ do {
+ s2 += .2;
+ L2 = seUR_iglarl(l, cl, s2, hs, sigma, df, N, qm);
+ } while (L2<L0);
+
+ s1 = s2 - .2;
+ L1 = seUR_iglarl(l, cl, s1, hs, sigma, df, N, qm);
+
+ do {
+ s3 = s1 + (L0-L1)/(L2-L1) * (s2-s1);
+ L3 = seUR_iglarl(l, cl, s3, hs, sigma, df, N, qm);
+ ds = s3-s2; s1 = s2; L1 = L2; s2 = s3; L2 = L3;
+ } while ( fabs(L0-L3)>1e-6 && fabs(ds)>1e-7 );
+
+ return s3;
+}
+
+
+double stdeUR_crit(double l, double L0, double cl, double hs, double sigma, int df, int N, int qm)
+{ double s1, s2, s3, ds, L1, L2, L3;
+
+ s2 = hs;
+ L2 = 0.;
+ do {
+ s1 = s2;
+ L1 = L2;
+ s2 += .2;
+ L2 = stdeUR_iglarl(l, cl, s2, hs, sigma, df, N, qm);
+ } while ( L2<L0 );
+
+ do {
+ s3 = s1 + (L0-L1)/(L2-L1) * (s2-s1);
+ L3 = stdeUR_iglarl(l, cl, s3, hs, sigma, df, N, qm);
+ ds = s3-s2; s1 = s2; L1 = L2; s2 = s3; L2 = L3;
+ } while ( fabs(L0-L3)>1e-7 && fabs(ds)>1e-8 );
+
+ return s3;
+}
+
+
+double seUR_crit_prerun_SIGMA(double l, double L0, double cl, double hs, double sigma, int df1, int df2, int N, int qm1, int qm2, double truncate)
+{ double s1, s2, s3, ds, L1=0., L2=0., L3=0.;
+
+ s2 = hs;
+ do {
+ L1 = L2;
+ s2 += .2;
+ L2 = seUR_iglarl_prerun_SIGMA(l, cl, s2, hs, sigma, df1, df2, N, qm1, qm2, truncate);
+ } while ( L2 < L0 );
+
+ s1 = s2 - .2;
+
+ do {
+ s3 = s1 + (L0-L1)/(L2-L1) * (s2-s1);
+ L3 = seUR_iglarl_prerun_SIGMA(l, cl, s3, hs, sigma, df1, df2, N, qm1, qm2, truncate);
+ ds = s3-s2; s1 = s2; L1 = L2; s2 = s3; L2 = L3;
+ } while ( fabs(L0-L3)>1e-6 && fabs(ds)>1e-7 );
+
+ return s3;
+}
+
+
+double seUR_q_crit(double l, int L0, double alpha, double cl, double hs, double sigma, int df, int N, int qm, double c_error, double a_error)
+{ double s1, s2, s3, ds, p1, p2, p3, *SF;
+ int result=1;
+
+ SF = vector(L0);
+
+ s2 = hs; p2 = 1.;
+ do {
+ p1 = p2;
+ s2 += .2;
+ result = seUR_sf(l, cl, s2, hs, sigma, df, N, L0, qm, SF);
+ if ( result != 0 ) warning("trouble in seUR_q_crit [package spc]");
+ p2 = 1. - SF[L0-1];
+ } while ( p2 > alpha );
+
+ s1 = s2 - .2;
+
+ do {
+ s3 = s1 + (alpha - p1)/( p2 - p1 ) * (s2-s1);
+ result = seUR_sf(l, cl, s3, hs, sigma, df, N, L0, qm, SF);
+ if ( result != 0 ) warning("trouble in seUR_q_crit [package spc]");
+ p3 = 1. - SF[L0-1];
+ ds = s3 - s2; s1 = s2; p1 = p2; s2 = s3; p2 = p3;
+ } while ( fabs(alpha - p3)>a_error && fabs(ds)>c_error );
+
+ Free(SF);
+
+ return s3;
+}
+
+
+double seUR_q_crit_prerun_SIGMA(double l, int L0, double alpha, double cl, double hs, double sigma, int df1, int df2, int N, int qm1, int qm2, double truncate, int tail_approx, double c_error, double a_error)
+{ double s1, s2, s3, ds, p1, p2, p3, *SF;
+ int result=1;
+
+ SF = vector(L0);
+
+ s2 = seUR_q_crit(l, L0, alpha, cl, hs, sigma, df1, N, qm1, c_error, a_error);
+ if ( tail_approx ) result = seUR_sf_prerun_SIGMA_deluxe(l, cl, s2, hs, sigma, df1, df2, L0, qm1, qm2, truncate, SF);
+ else result = seUR_sf_prerun_SIGMA(l, cl, s2, hs, sigma, df1, df2, L0, qm1, qm2, truncate, SF);
+ if ( result != 0 ) warning("trouble in seUR_q_crit_prerun_SIGMA [package spc]");
+ p2 = 1. - SF[L0-1];
+
+ if ( p2 > alpha ) {
+ do {
+ p1 = p2;
+ s2 += .2;
+ if ( tail_approx ) result = seUR_sf_prerun_SIGMA_deluxe(l, cl, s2, hs, sigma, df1, df2, L0, qm1, qm2, truncate, SF);
+ else result = seUR_sf_prerun_SIGMA(l, cl, s2, hs, sigma, df1, df2, L0, qm1, qm2, truncate, SF);
+ if ( result != 0 ) warning("trouble in seUR_q_crit_prerun_SIGMA [package spc]");
+ p2 = 1. - SF[L0-1];
+ } while ( p2 > alpha );
+ s1 = s2 - .2;
+ } else {
+ do {
+ p1 = p2;
+ s2 -= .2;
+ if ( tail_approx ) result = seUR_sf_prerun_SIGMA_deluxe(l, cl, s2, hs, sigma, df1, df2, L0, qm1, qm2, truncate, SF);
+ else result = seUR_sf_prerun_SIGMA(l, cl, s2, hs, sigma, df1, df2, L0, qm1, qm2, truncate, SF);
+ if ( result != 0 ) warning("trouble in seUR_q_crit_prerun_SIGMA [package spc]");
+ p2 = 1. - SF[L0-1];
+ } while ( p2 <= alpha && s2 > hs );
+ s1 = s2 + .2;
+ }
+
+ do {
+ s3 = s1 + (alpha - p1)/( p2 - p1 ) * (s2-s1);
+ if ( tail_approx ) result = seUR_sf_prerun_SIGMA_deluxe(l, cl, s3, hs, sigma, df1, df2, L0, qm1, qm2, truncate, SF);
+ else result = seUR_sf_prerun_SIGMA(l, cl, s3, hs, sigma, df1, df2, L0, qm1, qm2, truncate, SF);
+ if ( result != 0 ) warning("trouble in seUR_q_crit_prerun_SIGMA [package spc]");
+ p3 = 1. - SF[L0-1];
+ ds = s3 - s2; s1 = s2; p1 = p2; s2 = s3; p2 = p3;
+ } while ( fabs(alpha - p3)>a_error && fabs(ds)>c_error );
+
+ Free(SF);
+
+ return s3;
+}
+
+
+double seLR_iglarl(double l, double cl, double cu, double hs, double sigma, int df, int N, int qm)
+{ double *a, *g, *w, *z, *t, h, arl, Hij, xl, za, dN, ddf, s2, t0, t1, x0, x1, dummy;
+ int i, j, k, qi, qj, M, Ntilde, NN, ii, it, jj;
+
+ M = ceil( (log(cl)-log(cu))/log(1.-l) );
+ Ntilde = ceil( (double)N/(double)M );
+ NN = M*Ntilde;
+ s2 = sigma*sigma;
+ ddf = (double)df;
+ dN = (double)Ntilde - 1.;
+
+ a = matrix(NN, NN);
+ g = vector(NN);
+ t = vector(NN);
+ w = vector(qm);
+ z = vector(qm);
+
+ for(i=0;i<M;i++) {
+ t0 = cl/pow(1.-l,(double)(i));
+ t1 = t0/(1.-l);
+ if (t1>cu) t1 = cu;
+
+ for (j=1;j<Ntilde;j++) { /* node_i,Ntilde-1 = node_i+1,0 */
+ h = cos( PI/dN *(dN-j) );
+ t[i*(Ntilde-1)+j] = t0 + (h+1.)/2.*(t1-t0);
+ /* Chebyshev Gauss-Lobatto nodes on [t0,t1] */
+ }
+ }
+ t[0] = cl;
+
+ for (i=0;i<M;i++) {
+ for (j=1;j<=Ntilde;j++) {
+ ii = i*Ntilde + j-1;
+ it = i*(Ntilde-1) + j-1;
+
+ za = (1.-l)*t[it];
+ if (za<cl) xl = cl; else xl = za;
+
+ for (qi=0;qi<i-1;qi++)
+ for (qj=1;qj<=Ntilde;qj++) {
+ jj = qi*Ntilde + qj-1;
+ a[ii*NN+jj] = 0.;
+ }
+
+ if (i>0) {
+ qi = i-1;
+ t0 = cl/pow(1.-l,(double)qi);
+ t1 = t0/(1.-l);
+ if (t1>cu) t1 = cu;
+ if (t0<xl) x0 = xl; else x0 = t0;
+ if (df==2)
+ x1 = t1;
+ else {
+ if (x0-za>1e-10) x0 = sqrt(x0-za); else x0 = 0.;
+ if (t1-za>1e-10) x1 = sqrt(t1-za); else x1 = 0.;
+ }
+
+ for (qj=1;qj<=Ntilde;qj++) {
+ jj = qi*Ntilde + qj-1;
+
+ if (j==1) a[ii*NN+jj] = - Tn((2.*t[it]-t0-t1)/(t1-t0),qj-1);
+ else {
+ if (fabs(t1-x0)>1e-8) {
+ gausslegendre(qm,x0,x1,z,w);
+ Hij = 0.;
+ for (k=0;k<qm;k++) {
+ if (df==2)
+ Hij += w[k] * Tn( (2.*z[k]-t0-t1)/(t1-t0), qj-1) *
+ exp((za-z[k])/s2/l);
+ if (df!=2)
+ Hij += w[k] * Tn( (2.*(z[k]*z[k]+za)-t0-t1)/(t1-t0) ,qj-1) *
+ 2. * pow(z[k], ddf-1.) * exp(-ddf*z[k]*z[k]/2./s2/l);
+ }
+ if (df==2) Hij /= s2*l;
+ else Hij /= gammafn(ddf/2.) * pow(2.*s2*l/ddf,ddf/2.);
+ a[ii*NN+jj] = -Hij;
+ }
+ else a[ii*NN+jj] = 0.;
+ }
+ }
+ }
+
+ for (qi=i;qi<M;qi++) {
+ t0 = cl/pow(1.-l,(double)qi);
+ t1 = t0/(1.-l);
+ if (t1>cu) t1 = cu;
+ if (t0<xl) x0 = xl; else x0 = t0;
+ if (df==2)
+ x1 = t1;
+ else {
+ if (x0-za>1e-10) x0 = sqrt(x0-za); else x0 = 0.;
+ if (t1-za>1e-10) x1 = sqrt(t1-za); else x1 = 0.;
+ }
+
+ if (i>0 && j==1 && qi==i) {
+ for (qj=1;qj<=Ntilde;qj++) {
+ jj = qi*Ntilde + qj-1;
+ a[ii*NN+jj] = Tn((2.*t[it]-t0-t1)/(t1-t0),qj-1);
+ }
+ }
+
+ if (i>0 && j==1 && qi>i) {
+ for (qj=1;qj<=Ntilde;qj++) {
+ jj = qi*Ntilde + qj-1;
+ a[ii*NN+jj] = 0.;
+ }
+ }
+
+ if (i==0 || j>1) {
+ for (qj=1;qj<=Ntilde;qj++) {
+ jj = qi*Ntilde + qj-1;
+ gausslegendre(qm,x0,x1,z,w);
+ Hij = 0.;
+ for (k=0;k<qm;k++) {
+ if (df==2)
+ Hij += w[k] * Tn( (2.*z[k]-t0-t1)/(t1-t0), qj-1) *
+ exp((za-z[k])/s2/l);
+ if (df!=2)
+ Hij += w[k] * Tn( (2.*(z[k]*z[k]+za)-t0-t1)/(t1-t0),qj-1) *
+ 2. * pow(z[k], ddf-1.) * exp(-ddf*z[k]*z[k]/2./s2/l);
+ }
+ if (df==2) Hij /= s2*l;
+ else Hij /= gammafn(ddf/2.) * pow(2.*s2*l/ddf,ddf/2.);
+ if (qi==i) a[ii*NN+jj] = Tn((2.*t[it]-t0-t1)/(t1-t0),qj-1) -
+ Hij;
+ else a[ii*NN+jj] = -Hij;
+ }
+ }
+ }
+
+/* "reflection area" */
+ if (i==0 || j>1) {
+ t0 = cl/pow(1.-l, (double)(M-1.));
+ t1 = cu;
+ for (qj=1;qj<=Ntilde;qj++) {
+ dummy = (cu-za)/l/s2;
+ if (dummy>0.) {
+ if (df==1) dummy = 2.*( 1. - PHI( sqrt(dummy), 0. ) );
+ if (df==2) dummy = exp( -dummy );
+ if (df>2) dummy = 1. - CHI( df*dummy, df);
+ }
+ else dummy = 0.;
+ jj = (M-1)*Ntilde + qj-1;
+ a[ii*NN+jj] -= dummy;
+ }
+ }
+ }
+ }
+
+ for (j=0;j<NN;j++) g[j] = 1.;
+ for (j=1;j<M;j++) g[Ntilde*j] = 0.;
+
+ LU_solve(a,g,NN);
+
+ arl = 0.;
+ for (i=0;i<M;i++) {
+ t0 = cl/pow(1.-l,(double)i);
+ t1 = t0/(1.-l);
+ if (t1>cu) t1 = cu;
+
+ if (t0<hs && hs<=t1)
+ for (j=1;j<=Ntilde;j++) {
+ ii = i*Ntilde + j-1;
+ arl += g[ii] * Tn((2.*hs-t0-t1)/(t1-t0),j-1);
+ }
+ }
+
+ Free(z);
+ Free(w);
+ Free(t);
+ Free(g);
+ Free(a);
+
+ return arl;
+}
+
+
+double stdeLR_iglarl(double l, double cl, double cu, double hs, double sigma, int df, int N, int qm)
+{ double *a, *g, *w, *z, *t, h, arl, Hij, xl, za, dN, ddf, s2, t0, t1, x0, x1, dummy, v;
+ int i, j, k, qi, qj, M, Ntilde, NN, ii, it, jj;
+
+ M = ceil( (log(cl)-log(cu))/log(1.-l) );
+ Ntilde = ceil( (double)N/(double)M );
+ NN = M*Ntilde;
+ s2 = sigma*sigma;
+ ddf = (double)df;
+ dN = (double)Ntilde - 1.;
+
+ a = matrix(NN, NN);
+ g = vector(NN);
+ t = vector(NN);
+ w = vector(qm);
+ z = vector(qm);
+
+ for(i=0; i<M; i++) {
+ t0 = cl/pow(1.-l,(double)(i));
+ t1 = t0/(1.-l);
+ if ( t1>cu ) t1 = cu;
+
+ for (j=1; j<Ntilde; j++) { /* node_i,Ntilde-1 = node_i+1,0 */
+ h = cos( PI/dN *(dN-j) );
+ t[i*(Ntilde-1)+j] = t0 + (h+1.)/2.*(t1-t0); /* Chebyshev Gauss-Lobatto nodes on [t0,t1] */
+ }
+ }
+ t[0] = cl;
+
+ for (i=0; i<M; i++) {
+ for (j=1; j<=Ntilde; j++) {
+ ii = i*Ntilde + j-1;
+ it = i*(Ntilde-1) + j-1;
+
+ za = (1.-l)*t[it];
+ if ( za<cl ) xl = cl; else xl = za;
+
+ for (qi=0; qi<i-1; qi++)
+ for (qj=1; qj<=Ntilde; qj++) {
+ jj = qi*Ntilde + qj-1;
+ a[ii*NN+jj] = 0.;
+ }
+
+ if ( i>0 ) {
+ qi = i-1;
+ t0 = cl/pow(1.-l,(double)qi);
+ t1 = t0/(1.-l);
+ if ( t1>cu ) t1 = cu;
+ if ( t0<xl ) x0 = xl; else x0 = t0;
+ x1 = t1;
+
+ for (qj=1; qj<=Ntilde; qj++) {
+ jj = qi*Ntilde + qj-1;
+
+ if ( j==1 ) a[ii*NN+jj] = - Tn((2.*t[it]-t0-t1)/(t1-t0),qj-1);
+ else {
+ if ( fabs(t1-x0)>1e-8 ) {
+ gausslegendre(qm, x0, x1, z, w);
+ Hij = 0.;
+ for (k=0; k<qm; k++) {
+ v = (z[k] - za) / l;
+ Hij += w[k] * Tn( (2.*z[k]-t0-t1)/(t1-t0), qj-1) * pow(v,ddf-1.)*exp(-ddf/2./s2*v*v);
+ }
+ Hij *= 2./l/gammafn(ddf/2.)/pow(2.*s2/ddf,ddf/2.);
+ a[ii*NN+jj] = -Hij;
+ }
+ else a[ii*NN+jj] = 0.;
+ }
+ }
+ }
+
+ for (qi=i; qi<M; qi++) {
+ t0 = cl/pow(1.-l,(double)qi);
+ t1 = t0/(1.-l);
+ if ( t1>cu ) t1 = cu;
+ if ( t0<xl ) x0 = xl; else x0 = t0;
+ x1 = t1;
+
+ if ( i>0 && j==1 && qi==i ) {
+ for (qj=1; qj<=Ntilde; qj++) {
+ jj = qi*Ntilde + qj-1;
+ a[ii*NN+jj] = Tn((2.*t[it]-t0-t1)/(t1-t0),qj-1);
+ }
+ }
+
+ if ( i>0 && j==1 && qi>i ) {
+ for (qj=1; qj<=Ntilde; qj++) {
+ jj = qi*Ntilde + qj-1;
+ a[ii*NN+jj] = 0.;
+ }
+ }
+
+ if ( i==0 || j>1 ) {
+ for (qj=1; qj<=Ntilde; qj++) {
+ jj = qi*Ntilde + qj-1;
+ gausslegendre(qm, x0, x1, z, w);
+ Hij = 0.;
+ for (k=0; k<qm; k++) {
+ v = (z[k] - za) / l;
+ Hij += w[k] * Tn( (2.*z[k]-t0-t1)/(t1-t0), qj-1) * pow(v,ddf-1.)*exp(-ddf/2./s2*v*v);
+ }
+ Hij *= 2./l/gammafn(ddf/2.)/pow(2.*s2/ddf,ddf/2.);
+ if ( qi==i ) a[ii*NN+jj] = Tn((2.*t[it]-t0-t1)/(t1-t0),qj-1) - Hij;
+ else a[ii*NN+jj] = -Hij;
+ }
+ }
+ }
+
+/* "reflection area" */
+ if ( i==0 || j>1 ) {
+ t0 = cl/pow(1.-l, (double)(M-1.));
+ t1 = cu;
+ for (qj=1; qj<=Ntilde; qj++) {
+ dummy = 0.;
+ v = (cu-za)/l;
+ if ( v>0. ) dummy = 1. - CHI( ddf/s2*v*v, df);
+ jj = (M-1)*Ntilde + qj-1;
+ a[ii*NN+jj] -= dummy;
+ }
+ }
+ }
+ }
+
+ for (j=0; j<NN; j++) g[j] = 1.;
+ for (j=1; j<M; j++) g[Ntilde*j] = 0.;
+
+ LU_solve(a,g,NN);
+
+ arl = 0.;
+ for (i=0; i<M; i++) {
+ t0 = cl/pow(1.-l,(double)i);
+ t1 = t0/(1.-l);
+ if ( t1>cu ) t1 = cu;
+
+ if ( t0<hs && hs<=t1 )
+ for (j=1; j<=Ntilde; j++) {
+ ii = i*Ntilde + j-1;
+ arl += g[ii] * Tn((2.*hs-t0-t1)/(t1-t0),j-1);
+ }
+ }
+
+ Free(z);
+ Free(w);
+ Free(t);
+ Free(g);
+ Free(a);
+
+ return arl;
+}
+
+
+double lns2ewmaU_arl_igl(double l, double cl, double cu, double hs, double sigma, int df, int N)
+{ double *a, *g, *w, *z, arl, lns, ddf, s2;
+ int i, j, NN;
+
+ NN = N + 1;
+ s2 = sigma*sigma;
+ ddf = (double)df;
+
+ a = matrix(NN, NN);
+ g = vector(NN);
+ w = vector(N);
+ z = vector(N);
+
+ gausslegendre(N, cl, cu, z, w);
+
+ for (i=0; i<N; i++) {
+ for (j=0; j<N; j++) {
+ lns = exp( (z[j]-(1.-l)*z[i])/l );
+ a[i*NN+j] = -w[j]/l * chi( ddf/s2*lns, df)*ddf/s2*lns;
+ }
+ ++a[i*NN+i];
+ lns = exp( (cl-(1.-l)*z[i])/l );
+ a[i*NN+NN-1] = -CHI( ddf/s2*lns, df);
+ }
+
+ for (j=0; j<N; j++) {
+ lns = exp( (z[j]-(1.-l)*cl)/l );
+ a[N*NN+j] = -w[j]/l * chi( ddf/s2*lns, df)*ddf/s2*lns;
+ }
+ a[N*NN+N] = 1. - CHI( ddf/s2*exp(cl), df);
+
+ for (j=0; j<NN; j++) g[j] = 1.;
+ LU_solve(a, g, NN);
+
+ lns = exp( (cl-(1.-l)*hs)/l );
+ arl = 1. + CHI( ddf/s2*lns, df) * g[N];
+ for (j=0; j<N; j++) {
+ lns = exp( (z[j]-(1.-l)*hs)/l );
+ arl += w[j]/l * chi( ddf/s2*lns, df)*ddf/s2*lns * g[j];
+ }
+
+ Free(a);
+ Free(g);
+ Free(w);
+ Free(z);
+
+ return arl;
+}
+
+
+double lns2ewmaU_crit(double l, double L0, double cl, double hs, double sigma, int df, int N)
+{ double s1, s2, s3, ds, L1, L2, L3;
+
+ L2 = 1.;
+ s2 = hs;
+ do {
+ s1 = s2;
+ L1 = L2;
+ s2 += .1;
+ L2 = lns2ewmaU_arl_igl(l,cl,s2,hs,sigma,df,N);
+ } while ( L2<L0 );
+
+ if ( L2 > 10.*L0 ) {
+ do {
+ s1 = s2;
+ L1 = L2;
+ s2 -= .01;
+ L2 = lns2ewmaU_arl_igl(l,cl,s2,hs,sigma,df,N);
+ } while ( L2>L0 );
+ }
+
+ do {
+ s3 = s1 + (L0-L1)/(L2-L1) * (s2-s1);
+ L3 = lns2ewmaU_arl_igl(l,cl,s3,hs,sigma,df,N);
+ ds = s3-s2; s1 = s2; L1 = L2; s2 = s3; L2 = L3;
+ } while ( fabs(L0-L3)>1e-7 && fabs(ds)>1e-8 );
+
+ return s3;
+}
+
+
+double lns2ewma2_arl_igl(double l, double cl, double cu, double hs, double sigma, int df, int N)
+{ double *a, *g, *w, *z, arl, lns, ddf, s2;
+ int i, j;
+
+ s2 = sigma*sigma;
+ ddf = (double)df;
+
+ a = matrix(N,N);
+ g = vector(N);
+ w = vector(N);
+ z = vector(N);
+
+ gausslegendre(N, cl, cu, z, w);
+
+ for (i=0; i<N; i++) {
+ for (j=0; j<N; j++) {
+ lns = exp( (z[j]-(1.-l)*z[i])/l );
+ a[i*N+j] = -w[j]/l * chi( ddf/s2*lns, df)*ddf/s2*lns;
+ }
+ ++a[i*N+i];
+ }
+
+ for (j=0;j<N;j++) g[j] = 1.;
+ LU_solve(a,g,N);
+
+ arl = 1.;
+ for (j=0; j<N; j++) {
+ lns = exp( (z[j]-(1.-l)*hs)/l );
+ arl += w[j]/l * chi( ddf/s2*lns, df)*ddf/s2*lns * g[j];
+ }
+
+ Free(a);
+ Free(g);
+ Free(w);
+ Free(z);
+
+ return arl;
+}
+
+
+double lns2ewma2_crit_cufix(double l, double cu, double L0, double hs, double sigma, int df, int N)
+{ double s1, s2, s3, ds, L1, L2, L3;
+
+ L2 = 1.;
+ s2 = hs;
+ do {
+ s1 = s2;
+ L1 = L2;
+ s2 -= .1;
+ L2 = lns2ewma2_arl_igl(l,s2,cu,hs,sigma,df,N);
+ } while ( L2<L0 );
+
+ if ( L2 > 10.*L0 ) {
+ do {
+ s1 = s2;
+ L1 = L2;
+ s2 += .01;
+ L2 = lns2ewma2_arl_igl(l,s2,cu,hs,sigma,df,N);
+ } while ( L2>L0 );
+ }
+
+ do {
+ s3 = s1 + (L0-L1)/(L2-L1) * (s2-s1);
+ L3 = lns2ewma2_arl_igl(l,s3,cu,hs,sigma,df,N);
+ ds = s3-s2; s1 = s2; L1 = L2; s2 = s3; L2 = L3;
+ } while ( fabs(L0-L3)>1e-7 && fabs(ds)>1e-8 );
+
+ return s3;
+}
+
+
+int lns2ewma2_crit_unbiased(double l, double L0, double *cl, double *cu, double hs, double sigma, int df, int N)
+{ double s1, s2, s3, ds, sl1, sl2, sl3, csl, Lm, Lp, mitte, ddf;
+
+ ddf = (double)df;
+ /*mitte = -1./ddf - 1./3./ddf/ddf + 2./15./ddf/ddf/ddf/ddf;*/
+ mitte = E_log_gamma(ddf);
+
+ csl = lns2ewma2_crit_sym(l, L0, hs, sigma, df, N);
+ s1 = 2.*mitte - csl;
+ Lm = lns2ewma2_arl_igl(l,csl,s1,hs,sigma-lmEPS,df,N);
+ Lp = lns2ewma2_arl_igl(l,csl,s1,hs,sigma+lmEPS,df,N);
+ sl1 = (Lp-Lm)/(2.*lmEPS);
+
+ do {
+ s2 = s1;
+ sl2 = sl1;
+ s1 -= .1;
+ csl = lns2ewma2_crit_cufix(l,s1,L0,hs,sigma,df,N);
+ Lm = lns2ewma2_arl_igl(l,csl,s1,hs,sigma-lmEPS,df,N);
+ Lp = lns2ewma2_arl_igl(l,csl,s1,hs,sigma+lmEPS,df,N);
+ sl1 = (Lp-Lm)/(2.*lmEPS);
+ } while ( sl1>0. );
+
+ do {
+ s3 = s1 - sl1/(sl2-sl1) * (s2-s1);
+ csl = lns2ewma2_crit_cufix(l,s3,L0,hs,sigma,df,N);
+ Lm = lns2ewma2_arl_igl(l,csl,s3,hs,sigma-lmEPS,df,N);
+ Lp = lns2ewma2_arl_igl(l,csl,s3,hs,sigma+lmEPS,df,N);
+ sl3 = (Lp-Lm)/(2.*lmEPS);
+ ds = s3-s2; s1 = s2; sl1 = sl2; s2 = s3; sl2 = sl3;
+ } while ( fabs(sl3)>1e-7 && fabs(ds)>1e-8 );
+
+ *cl = csl; *cu = s3;
+
+ return 0;
+}
+
+
+double lns2ewma2_crit_sym(double l, double L0, double hs, double sigma, int df, int N)
+{ double cu, cl1, cl2, cl3, L1, L2, L3, dl, mitte, ddf;
+
+ ddf = (double)df;
+ /*mitte = -1./ddf - 1./3./ddf/ddf + 2./15./ddf/ddf/ddf/ddf;*/
+ mitte = E_log_gamma(ddf);
+
+ L2 = 1.;
+ cl2 = mitte;
+ do {
+ cl1 = cl2;
+ L1 = L2;
+ cl2 -= .1;
+ cu = 2.*mitte - cl2;
+ L2 = lns2ewma2_arl_igl(l, cl2, cu, hs, sigma, df, N);
+ } while ( L2<L0 );
+
+ do {
+ cl3 = cl1 + (L0-L1)/(L2-L1) * (cl2-cl1);
+ cu = 2.*mitte - cl3;
+ L3 = lns2ewma2_arl_igl(l, cl3, cu, hs, sigma, df, N);
+ dl = cl3-cl2; cl1 = cl2; L1 = L2; cl2 = cl3; L2 = L3;
+ if ( L3 < 1. ) error("invalid ARL value");
+ } while ( (fabs(L0-L3)>1e-7) && (fabs(dl)>1e-8) );
+
+ return cl3;
+}
+
+
+double seLR_sf(double l, double cl, double cu, double hs, double sigma, int df, int N, int nmax, int qm, double *p0)
+{ double *S1s, *S2s, *Pns, *ws, *zs, *zch, *rside, *b, za=0., s2, ddf, xl, xu, dN, Hij, *S00, *p00, *VF0;
+ int i, j, k, n, *ps, Ntilde, ihs, M, NN, ii, jj;
+
+ M = ceil( (log(cl)-log(cu))/log(1.-l) );
+ Ntilde = ceil( (double)N/(double)M );
+ NN = M*Ntilde;
+ s2 = sigma*sigma;
+ ddf = (double)df;
+ dN = (double)Ntilde;
+
+ ihs = floor( (log(cl) - log(hs))/log(1.-l) );
+ if ( ihs<0 ) ihs = 0;
+
+ S1s = matrix(NN,NN);
+ S2s = matrix(NN,NN);
+ ps = ivector(NN);
+ zch = matrix(M,Ntilde);
+ rside = vector(NN+1);
+ b = vector(M+1);
+ ws = vector(qm);
+ zs = vector(qm);
+ Pns = matrix(nmax,NN);
+
+ S00 = vector(NN);
+ p00 = vector(nmax);
+ VF0 = vector(NN+1);
+
+/* interval borders b_i = cl/(1-l)^i */
+ for (i=0; i<M; i++) b[i] = cl/pow(1.-l, (double)(i));
+ b[M] = cu;
+
+ /* Chebyshev nodes on [b_0,b_1],[b_1,b_2],...,[b_M-1,cu] */
+ for (i=0; i<M; i++)
+ for (j=0; j<Ntilde; j++) {
+ zch[ i*Ntilde+j ] = b[i] + (b[i+1]-b[i])/2.*(1.+cos(PI*(2.*j+1.)/2./dN));
+ }
+
+ /* P(L>1)(zch[i,j]) */
+ for (i=0; i<M; i++)
+ for (j=0; j<Ntilde; j++) {
+ rside[ i*Ntilde+j ] = 1. - CHI( ddf/s2*(cl-(1.-l)*zch[ i*Ntilde+j ])/l, df);
+ }
+ rside[NN] = 1. - CHI( ddf/s2*(cl-(1.-l)*cu)/l, df); /* reflexion at cu */
+
+ /* P(zch[i,j] -> zreflect) */
+ for (i=0; i<M; i++)
+ for (j=0; j<Ntilde; j++)
+ VF0[ i*Ntilde+j ] = 1. - CHI( ddf/s2*(cu-(1.-l)*zch[ i*Ntilde+j ])/l, df) ;
+ VF0[NN] = 1. - CHI( ddf/s2*cu, df);
+
+ for (i=0; i<M; i++)
+ for (j=0; j<Ntilde; j++) {
+ za = (1.-l)*zch[ i*Ntilde+j ];
+ for (ii=0; ii<M; ii++)
+ for (jj=0; jj<Ntilde; jj++) {
+ if ( b[ii+1]<za ) S1s[ (i*Ntilde+j)*NN + ii*Ntilde+jj ] = 0.;
+ else {
+ if ( za<b[ii] ) xl = b[ii]; else xl = za;
+ xu = b[ii+1];
+ if ( df!=2 ) {
+ xl = sqrt(xl-za);
+ xu = sqrt(xu-za);
+ }
+ gausslegendre(qm, xl, xu, zs, ws);
+ Hij = 0.;
+ for (k=0; k<qm; k++)
+ if ( df==2 )
+ Hij += ws[k]*Tn( (2.*zs[k]-b[ii+1]-b[ii])/(b[ii+1]-b[ii]), jj) * exp(-zs[k]/s2/l);
+ else
+ Hij += ws[k]*Tn( (2.*(zs[k]*zs[k]+za)-b[ii+1]-b[ii])/(b[ii+1]-b[ii]), jj)
+ * 2. * pow(zs[k], ddf-1.) * exp(-ddf*zs[k]*zs[k]/2./s2/l);
+ if ( df==2 ) Hij *= exp(za/s2/l)/s2/l;
+ else Hij /= gammafn(ddf/2.) * pow(2.*s2*l/ddf, ddf/2.);
+ S1s[ (i*Ntilde+j)*NN + ii*Ntilde+jj ] = Hij;
+ }
+ }
+ }
+
+ za = (1.-l)*cu;
+ for (ii=0; ii<M; ii++)
+ for (jj=0; jj<Ntilde; jj++) {
+ if ( b[ii+1]<za ) S00[ ii*Ntilde+jj ] = 0.;
+ else {
+ if ( za<b[ii] ) xl = b[ii]; else xl = za;
+ xu = b[ii+1];
+ if ( df!=2 ) {
+ xl = sqrt(xl-za);
+ xu = sqrt(xu-za);
+ }
+ gausslegendre(qm, xl, xu, zs, ws);
+ Hij = 0.;
+ for (k=0; k<qm; k++)
+ if ( df==2 )
+ Hij += ws[k]*Tn((2.*zs[k]-b[ii+1]-b[ii])/(b[ii+1]-b[ii]), jj) * exp(-zs[k]/s2/l);
+ else
+ Hij += ws[k] * Tn((2.*(zs[k]*zs[k]+za)-b[ii+1]-b[ii])/(b[ii+1]-b[ii]), jj)
+ * 2. * pow(zs[k], ddf-1.) * exp(-ddf*zs[k]*zs[k]/2./s2/l);
+ if ( df==2 ) Hij *= exp(za/s2/l)/s2/l;
+ else Hij /= gammafn(ddf/2.) * pow(2.*s2*l/ddf, ddf/2.);
+ S00[ ii*Ntilde+jj ] = Hij;
+ }
+ }
+
+ for (i=0; i<NN; i++)
+ for (j=0; j<NN; j++) S2s[i*NN+j] = 0.;
+
+ for (i=0; i<M; i++)
+ for (j=0; j<Ntilde; j++)
+ for (jj=0; jj<Ntilde; jj++)
+ S2s[ (i*Ntilde+j)*NN + i*Ntilde+jj ] = Tn( (2.*zch[ i*Ntilde+j ]-b[i+1]-b[i])/(b[i+1]-b[i]), jj);
+
+ LU_decompose(S2s,ps,NN);
+
+ for (n=1; n<=nmax; n++) {
+ if ( n==1) {
+ for (i=0; i<M; i++)
+ for (j=0; j<Ntilde; j++) {
+ Pns[ i*Ntilde+j ] = 0.;
+ for (jj=0; jj<Ntilde; jj++)
+ Pns[ i*Ntilde+j ] += /* usual Chebyshev approximation */
+ 2./Ntilde * Tn( (2.*zch[i*Ntilde+jj]-b[i+1]-b[i])/(b[i+1]-b[i]), j) * rside[ i*Ntilde+jj ];
+ if ( j==0 ) Pns[ i*Ntilde+j ] /= 2.;
+ }
+ p00[0] = rside[NN];
+ }
+ else {
+ for (i=0; i<NN; i++) {
+ rside[i] = VF0[i] * p00[n-2];
+ for (j=0; j<NN; j++) rside[i] += S1s[ i*NN+j ] * Pns[ (n-2)*NN+j ];
+ }
+ LU_solve2(S2s, rside, ps, NN);
+ for (i=0; i<NN; i++) Pns[ (n-1)*NN+i ] = rside[i];
+ p00[n-1] = VF0[NN] * p00[n-2];
+ for (i=0 ;i<NN; i++) p00[n-1] += S00[i] * Pns[ (n-2)*NN+i ];
+ }
+
+ p0[n-1] = 0.;
+ if ( n==1 )
+ p0[0] = 1. - CHI( ddf/s2*(cl-(1.-l)*hs)/l, df);
+ else
+ for (j=0; j<Ntilde; j++)
+ p0[n-1] += Pns[ (n-1)*NN + ihs*Ntilde+j ] * Tn( (2.*hs-b[ihs+1]-b[ihs])/(b[ihs+1]-b[ihs]), j);
+ }
+
+ Free(Pns);
+ Free(zs);
+ Free(ws);
+ Free(rside);
+ Free(zch);
+ Free(ps);
+ Free(S2s);
+ Free(S1s);
+
+ Free(S00);
+ Free(p00);
+ Free(VF0);
+
+ return 0;
+}
+
+
+double seLR_sf_deluxe(double l, double cl, double cu, double hs, double sigma, int df, int N, int nmax, int qm, double *p0, int *nstop, double *rho)
+{ double *S1s, *S2s, *Pns, *ws, *zs, *zch, *rside, *b, za=0., s2, ddf, xl, xu, dN, Hij, *S00, *p00, *VF0, mn_minus=1., mn_plus=0., oben, unten, q;
+ int i, j, k, n, *ps, Ntilde, ihs, M, NN, ii, jj;
+
+ M = ceil( (log(cl)-log(cu))/log(1.-l) );
+ Ntilde = ceil( (double)N/(double)M );
+ NN = M*Ntilde;
+ s2 = sigma*sigma;
+ ddf = (double)df;
+ dN = (double)Ntilde;
+
+ ihs = floor( (log(cl) - log(hs))/log(1.-l) );
+ if ( ihs<0 ) ihs = 0;
+
+ S1s = matrix(NN,NN);
+ S2s = matrix(NN,NN);
+ ps = ivector(NN);
+ zch = matrix(M,Ntilde);
+ rside = vector(NN+1);
+ b = vector(M+1);
+ ws = vector(qm);
+ zs = vector(qm);
+ Pns = matrix(nmax,NN);
+
+ S00 = vector(NN);
+ p00 = vector(nmax);
+ VF0 = vector(NN+1);
+
+/* interval borders b_i = cl/(1-l)^i */
+ for (i=0; i<M; i++) b[i] = cl/pow(1.-l, (double)(i));
+ b[M] = cu;
+
+ /* Chebyshev nodes on [b_0,b_1],[b_1,b_2],...,[b_M-1,cu] */
+ for (i=0; i<M; i++)
+ for (j=0; j<Ntilde; j++) {
+ zch[ i*Ntilde+j ] = b[i] + (b[i+1]-b[i])/2.*(1.+cos(PI*(2.*j+1.)/2./dN));
+ }
+
+ /* P(L>1)(zch[i,j]) */
+ for (i=0; i<M; i++)
+ for (j=0; j<Ntilde; j++) {
+ rside[ i*Ntilde+j ] = 1. - CHI( ddf/s2*(cl-(1.-l)*zch[ i*Ntilde+j ])/l, df);
+ }
+ rside[NN] = 1. - CHI( ddf/s2*(cl-(1.-l)*cu)/l, df); /* reflexion at cu */
+
+ /* P(zch[i,j] -> zreflect) */
+ for (i=0; i<M; i++)
+ for (j=0; j<Ntilde; j++)
+ VF0[ i*Ntilde+j ] = 1. - CHI( ddf/s2*(cu-(1.-l)*zch[ i*Ntilde+j ])/l, df) ;
+ VF0[NN] = 1. - CHI( ddf/s2*cu, df);
+
+ for (i=0; i<M; i++)
+ for (j=0; j<Ntilde; j++) {
+ za = (1.-l)*zch[ i*Ntilde+j ];
+ for (ii=0; ii<M; ii++)
+ for (jj=0; jj<Ntilde; jj++) {
+ if ( b[ii+1]<za ) S1s[ (i*Ntilde+j)*NN + ii*Ntilde+jj ] = 0.;
+ else {
+ if ( za<b[ii] ) xl = b[ii]; else xl = za;
+ xu = b[ii+1];
+ if ( df!=2 ) {
+ xl = sqrt(xl-za);
+ xu = sqrt(xu-za);
+ }
+ gausslegendre(qm, xl, xu, zs, ws);
+ Hij = 0.;
+ for (k=0; k<qm; k++)
+ if ( df==2 )
+ Hij += ws[k]*Tn( (2.*zs[k]-b[ii+1]-b[ii])/(b[ii+1]-b[ii]), jj) * exp(-zs[k]/s2/l);
+ else
+ Hij += ws[k]*Tn( (2.*(zs[k]*zs[k]+za)-b[ii+1]-b[ii])/(b[ii+1]-b[ii]), jj)
+ * 2. * pow(zs[k], ddf-1.) * exp(-ddf*zs[k]*zs[k]/2./s2/l);
+ if ( df==2 ) Hij *= exp(za/s2/l)/s2/l;
+ else Hij /= gammafn(ddf/2.) * pow(2.*s2*l/ddf, ddf/2.);
+ S1s[ (i*Ntilde+j)*NN + ii*Ntilde+jj ] = Hij;
+ }
+ }
+ }
+
+ za = (1.-l)*cu;
+ for (ii=0; ii<M; ii++)
+ for (jj=0; jj<Ntilde; jj++) {
+ if ( b[ii+1]<za ) S00[ ii*Ntilde+jj ] = 0.;
+ else {
+ if ( za<b[ii] ) xl = b[ii]; else xl = za;
+ xu = b[ii+1];
+ if ( df!=2 ) {
+ xl = sqrt(xl-za);
+ xu = sqrt(xu-za);
+ }
+ gausslegendre(qm, xl, xu, zs, ws);
+ Hij = 0.;
+ for (k=0; k<qm; k++)
+ if ( df==2 )
+ Hij += ws[k]*Tn((2.*zs[k]-b[ii+1]-b[ii])/(b[ii+1]-b[ii]), jj) * exp(-zs[k]/s2/l);
+ else
+ Hij += ws[k] * Tn((2.*(zs[k]*zs[k]+za)-b[ii+1]-b[ii])/(b[ii+1]-b[ii]), jj)
+ * 2. * pow(zs[k], ddf-1.) * exp(-ddf*zs[k]*zs[k]/2./s2/l);
+ if ( df==2 ) Hij *= exp(za/s2/l)/s2/l;
+ else Hij /= gammafn(ddf/2.) * pow(2.*s2*l/ddf, ddf/2.);
+ S00[ ii*Ntilde+jj ] = Hij;
+ }
+ }
+
+ for (i=0; i<NN; i++)
+ for (j=0; j<NN; j++) S2s[i*NN+j] = 0.;
+
+ for (i=0; i<M; i++)
+ for (j=0; j<Ntilde; j++)
+ for (jj=0; jj<Ntilde; jj++)
+ S2s[ (i*Ntilde+j)*NN + i*Ntilde+jj ] = Tn( (2.*zch[ i*Ntilde+j ]-b[i+1]-b[i])/(b[i+1]-b[i]), jj);
+
+ LU_decompose(S2s,ps,NN);
+
+ for (n=1; n<=nmax; n++) {
+ if ( n==1) {
+ for (i=0; i<M; i++)
+ for (j=0; j<Ntilde; j++) {
+ Pns[ i*Ntilde+j ] = 0.;
+ for (jj=0; jj<Ntilde; jj++)
+ Pns[ i*Ntilde+j ] += /* usual Chebyshev approximation */
+ 2./Ntilde * Tn( (2.*zch[i*Ntilde+jj]-b[i+1]-b[i])/(b[i+1]-b[i]), j) * rside[ i*Ntilde+jj ];
+ if ( j==0 ) Pns[ i*Ntilde+j ] /= 2.;
+ }
+ p00[0] = rside[NN];
+ }
+ else {
+ for (i=0; i<NN; i++) {
+ rside[i] = VF0[i] * p00[n-2];
+ for (j=0; j<NN; j++) rside[i] += S1s[ i*NN+j ] * Pns[ (n-2)*NN+j ];
+ }
+ LU_solve2(S2s, rside, ps, NN);
+ for (i=0; i<NN; i++) Pns[ (n-1)*NN+i ] = rside[i];
+ p00[n-1] = VF0[NN] * p00[n-2];
+ for (i=0 ;i<NN; i++) p00[n-1] += S00[i] * Pns[ (n-2)*NN+i ];
+ }
+
+ p0[n-1] = 0.;
+ if ( n==1 )
+ p0[0] = 1. - CHI( ddf/s2*(cl-(1.-l)*hs)/l, df);
+ else
+ for (j=0; j<Ntilde; j++)
+ p0[n-1] += Pns[ (n-1)*NN + ihs*Ntilde+j ] * Tn( (2.*hs-b[ihs+1]-b[ihs])/(b[ihs+1]-b[ihs]), j);
+
+ mn_minus = 1.; mn_plus = 0.;
+ if ( n > 1) {
+ for (i=0; i<M; i++)
+ for (j=0; j<Ntilde; j++) {
+ oben = 0.;
+ unten = 0.;
+ for (jj=0; jj<Ntilde; jj++) {
+ oben += Pns[ (n-1)*NN + i*Ntilde+jj ] * Tn((2.*zch[i*Ntilde+j]-b[i+1]-b[i])/(b[i+1]-b[i]), jj);
+ unten+= Pns[ (n-2)*NN + i*Ntilde+jj ] * Tn((2.*zch[i*Ntilde+j]-b[i+1]-b[i])/(b[i+1]-b[i]), jj);
+ }
+ if ( fabs(unten)<1e-16 )
+ if ( fabs(oben)<1e-16 ) q = 0.;
+ else q = 1.;
+ else q = oben/unten;
+ if ( q<mn_minus ) mn_minus = q;
+ if ( q>mn_plus ) mn_plus = q;
+ }
+ *rho = (mn_minus + mn_plus)/2.;
+ if ( fabs(mn_plus - mn_minus) < FINALeps ) {
+ *nstop = n;
+ n = nmax + 1;
+ }
+ } /* n > 1 */
+ } /* n=1; n<=nmax; n++ */
+
+ Free(Pns);
+ Free(zs);
+ Free(ws);
+ Free(rside);
+ Free(zch);
+ Free(ps);
+ Free(S2s);
+ Free(S1s);
+
+ Free(S00);
+ Free(p00);
+ Free(VF0);
+
+ return 0;
+}
+
+
+double seLR_sf_prerun_SIGMA_deluxe(double l, double cl, double cu, double hs, double sigma, int df1, int df2, int nmax, int qm1, int qm2, double truncate, double *p0)
+{ double *ww, *zz, b1, b2, ddf2, *SF, rho, s2;
+ int i, m, n, nstop, Nlocal;
+
+ Nlocal = choose_N_for_se2(l, cl, cu);
+
+ SF = vector(nmax);
+ ww = vector(qm2);
+ zz = vector(qm2);
+
+ ddf2 = (double)(df2);
+ b1 = qCHI( truncate/2., df2)/ddf2;
+ b2 = qCHI(1. - truncate/2., df2)/ddf2;
+ gausslegendre(qm2, b1, b2, zz, ww);
+ for (i=0; i<qm2; i++) ww[i] *= ddf2 * chi( ddf2*zz[i], df2);
+
+ for (n=0; n<nmax; n++) p0[n] = 0.;
+
+ for (i=0; i<qm2; i++) {
+ s2 = zz[i];
+ m = seLR_sf_deluxe(l, s2*cl, s2*cu, s2*hs, sigma, df1, Nlocal, nmax, qm1, SF, &nstop, &rho);
+ if ( m != 0 ) warning("trouble with internal [package spc] function seLR_sf_deluxe");
+ if ( nstop > 0 ) {
+ for (n=0; n<nstop; n++) p0[n] += ww[i] * SF[n];
+ for (n=nstop; n<nmax; n++) p0[n] += ww[i] * SF[nstop-1] * pow(rho, n-nstop+1);
+ } else {
+ for (n=0; n<nmax; n++) p0[n] += ww[i] * SF[n];
+ }
+ }
+
+ Free(ww);
+ Free(zz);
+ Free(SF);
+
+ return 0;
+}
+
+
+double seLR_sf_prerun_SIGMA(double l, double cl, double cu, double hs, double sigma, int df1, int df2, int nmax, int qm1, int qm2, double truncate, double *p0)
+{ double *ww, *zz, b1, b2, ddf2, *SF, s2;
+ int i, m, n, Nlocal;
+
+ Nlocal = choose_N_for_se2(l, cl, cu);
+
+ SF = vector(nmax);
+ ww = vector(qm2);
+ zz = vector(qm2);
+
+ ddf2 = (double)(df2);
+ b1 = qCHI( truncate/2., df2)/ddf2;
+ b2 = qCHI(1. - truncate/2., df2)/ddf2;
+ gausslegendre(qm2, b1, b2, zz, ww);
+ for (i=0; i<qm2; i++) ww[i] *= ddf2 * chi( ddf2*zz[i], df2);
+
+ for (n=0; n<nmax; n++) p0[n] = 0.;
+
+ for (i=0; i<qm2; i++) {
+ s2 = zz[i];
+ m = seLR_sf(l, s2*cl, s2*cu, s2*hs, sigma, df1, Nlocal, nmax, qm1, SF);
+ if ( m != 0 ) warning("trouble with internal [package spc] function seLR_sf");
+ for (n=0; n<nmax; n++) p0[n] += ww[i] * SF[n];
+ }
+
+ Free(ww);
+ Free(zz);
+ Free(SF);
+
+ return 0;
+}
+
+
+double seLR_Wq_prerun_SIGMA_deluxe(double l, double cl, double cu, double p, double hs, double sigma, int df1, int df2, int nmax, int qm1, int qm2, double truncate)
+{ double *ww, *zz, b1, b2, ddf2, *SF, *p0, rho, *rhomany, *SFlast, Lp=-1., sf_level_adj, s2;
+ int i, j, n, nstop, nstop_, nsm, nn, qnspecial=0, Nlocal;
+
+ Nlocal = choose_N_for_se2(l, cl, cu);
+
+ p0 = vector(nmax);
+ SF = vector(nmax);
+ rhomany = vector(qm2);
+ SFlast = vector(qm2);
+ ww = vector(qm2);
+ zz = vector(qm2);
+
+ ddf2 = (double)(df2);
+ b1 = qCHI( truncate/2., df2)/ddf2;
+ b2 = qCHI(1. - truncate/2., df2)/ddf2;
+ gausslegendre(qm2, b1, b2, zz, ww);
+ for (i=0; i<qm2; i++) ww[i] *= ddf2 * chi( ddf2*zz[i], df2);
+
+ qnspecial = (qm2+1) / 2;
+
+ s2 = zz[qnspecial];
+ j = seLR_sf_deluxe(l, s2*cl, s2*cu, s2*hs, sigma, df1, Nlocal, nmax, qm1, SF, &nsm, &rho);
+ if ( j != 0 ) warning("trouble with internal [package spc] function seU_sf_deluxe");
+ n = nsm;
+
+ if ( nsm < 1 ) { /* did not converge yet -- should be the rare case */
+ nn = nmax;
+ warning("The geometric tail approximation might not work.");
+ } else {
+ nstop = nsm;
+
+ s2 = zz[qnspecial+1];
+ j = seLR_sf_deluxe(l, s2*cl, s2*cu, s2*hs, sigma, df1, Nlocal, nmax, qm1, SF, &nstop_, &rho);
+ if ( j != 0 ) warning("trouble with internal [package spc] function seU_sf_deluxe");
+ if ( nstop_ > nsm ) nsm = nstop_;
+ if ( nstop_ < 1) nsm = nmax;
+ if ( nstop_ >= nstop && nsm<nmax ) {
+ i = 1;
+ while ( nstop_ >= nstop && nsm<nmax ) {
+ nstop = nstop_;
+ i++;
+ s2 = zz[qnspecial+i];
+ j = seLR_sf_deluxe(l, s2*cl, s2*cu, s2*hs, sigma, df1, Nlocal, nmax, qm1, SF, &nstop_, &rho);
+ if ( j != 0 ) warning("trouble with internal [package spc] function seU_sf_deluxe");
+ if ( nstop_ > nsm ) nsm = nstop_;
+ if ( nstop_ < 1) nsm = nmax;
+ }
+ }
+
+ nstop = n;
+ s2 = zz[qnspecial-1];
+ j = seLR_sf_deluxe(l, s2*cl, s2*cu, s2*hs, sigma, df1, Nlocal, nmax, qm1, SF, &nstop_, &rho);
+ if ( j != 0 ) warning("trouble with internal [package spc] function seU_sf_deluxe");
+ if ( nstop_ > nsm ) nsm = nstop_;
+ if ( nstop_ < 1) nsm = nmax;
+ if ( nstop_ >= nstop && nsm<nmax ) {
+ i = 1;
+ while ( nstop_ >= nstop && nsm<nmax ) {
+ nstop = nstop_;
+ i++;
+ s2 = zz[qnspecial-i];
+ j = seLR_sf_deluxe(l, s2*cl, s2*cu, s2*hs, sigma, df1, Nlocal, nmax, qm1, SF, &nstop_, &rho);
+ if ( j != 0 ) warning("trouble with internal [package spc] function seU_sf_deluxe");
+ if ( nstop_ > nsm ) nsm = nstop_;
+ if ( nstop_ < 1) nsm = nmax;
+ }
+ }
+ nn = nsm;
+ }
+
+ for (n=0; n<nmax; n++) p0[n] = 0.;
+
+ for (i=0; i<qm2; i++) {
+ s2 = zz[i];
+ j = seLR_sf_deluxe(l, s2*cl, s2*cu, s2*hs, sigma, df1, Nlocal, nn, qm1, SF, &nstop, &rho);
+ if ( j != 0 ) warning("trouble with internal [package spc] function seU_sf_deluxe");
+ if ( nstop < 1 ) {
+ nstop = nn;
+ warning("The geometric tail approximation might not work.");
+ }
+ rhomany[i] = rho;
+ for (n=0; n<nstop; n++) p0[n] += ww[i] * SF[n];
+ if ( nstop < nn) {
+ for (n=nstop; n<nn; n++) p0[n] += ww[i] * SF[nstop-1] * pow(rho, n-nstop+1);
+ }
+ SFlast[i] = SF[nstop-1] * pow(rho, nn-nstop);
+ }
+
+ sf_level_adj = 1.-p;
+ if ( p0[nn-1] <= sf_level_adj ) {
+ n = nn-1;
+ while ( p0[n] <= sf_level_adj && n > 0 ) n--;
+ if ( p0[n] > 1.-p ) Lp = (double)( n + 2 ); else Lp = 1.;
+ } else {
+ for (n=nn; n<nmax; n++) {
+ p0[n] = 0.;
+ for (i=0; i<qm2; i++) p0[n] += ww[i] * SFlast[i] * pow(rhomany[i], n-nn+1);
+ if ( p0[n] <= sf_level_adj ) {
+ Lp = (double)( n + 1 );
+ n = nmax+1;
+ }
+ }
+ }
+
+ Free(p0);
+ Free(ww);
+ Free(zz);
+ Free(SF);
+ Free(SFlast);
+ Free(rhomany);
+
+ return Lp;
+}
+
+
+double seLR_iglarl_prerun_SIGMA(double l, double cl, double cu, double hs, double sigma, int df1, int df2, int N, int qm1, int qm2, double truncate)
+{ double *ww, *zz, b1, b2, result, ddf2, s2;
+ int i;
+
+ ww = vector(qm2);
+ zz = vector(qm2);
+ ddf2 = (double)(df2);
+ b1 = qCHI( truncate/2., df2)/ddf2;
+ b2 = qCHI(1. - truncate/2., df2)/ddf2;
+ gausslegendre(qm2, b1, b2, zz, ww);
+ result = 0.;
+ for (i=0; i<qm2; i++) {
+ s2 = zz[i];
+ result += ww[i] * ddf2 * chi( ddf2*s2, df2) * seLR_iglarl(l, s2*cl, s2*cu, s2*hs, sigma, df1, N, qm1);
+ }
+ Free(ww);
+ Free(zz);
+
+ return result;
+}
+
+
+double seLR_Wq(double l, double cl, double cu, double p, double hs, double sigma, int df, int N, int nmax, int qm)
+{ double *S1s, *S2s, *Pns, *p0, *ws, *zs, *zch, *rside, *b, za=0., s2, ddf, xl, xu, q_minus=0., q_plus=0., dN, Hij, *S00, *p00, *VF0, mn_minus=1., mn_plus=0., oben, unten, q, enumerator=0., Wq=0.;
+ int i, j, k, n, *ps, Ntilde, ihs, M, NN, ii, jj;
+
+ M = ceil( (log(cl)-log(cu))/log(1.-l) );
+ Ntilde = ceil( (double)N/(double)M );
+ NN = M*Ntilde;
+ s2 = sigma*sigma;
+ ddf = (double)df;
+ dN = (double)Ntilde;
+
+ ihs = floor( (log(cl) - log(hs))/log(1.-l) );
+ if ( ihs<0 ) ihs = 0;
+
+ S1s = matrix(NN,NN);
+ S2s = matrix(NN,NN);
+ ps = ivector(NN);
+ zch = matrix(M,Ntilde);
+ rside = vector(NN+1);
+ b = vector(M+1);
+ ws = vector(qm);
+ zs = vector(qm);
+ p0 = vector(nmax);
+ Pns = matrix(nmax,NN);
+
+ S00 = vector(NN);
+ p00 = vector(nmax);
+ VF0 = vector(NN+1);
+
+/* interval borders b_i = cl/(1-l)^i */
+ for (i=0; i<M; i++) b[i] = cl/pow(1.-l, (double)(i));
+ b[M] = cu;
+
+ /* Chebyshev nodes on [b_0,b_1],[b_1,b_2],...,[b_M-1,cu] */
+ for (i=0; i<M; i++)
+ for (j=0; j<Ntilde; j++) {
+ zch[ i*Ntilde+j ] = b[i] + (b[i+1]-b[i])/2.*(1.+cos(PI*(2.*j+1.)/2./dN));
+ }
+
+ /* P(L>1)(zch[i,j]) */
+ for (i=0; i<M; i++)
+ for (j=0; j<Ntilde; j++) {
+ rside[ i*Ntilde+j ] = 1. - CHI( ddf/s2*(cl-(1.-l)*zch[ i*Ntilde+j ])/l, df);
+ }
+ rside[NN] = 1. - CHI( ddf/s2*(cl-(1.-l)*cu)/l, df); /* reflexion at cu */
+
+ /* P(zch[i,j] -> zreflect) */
+ for (i=0; i<M; i++)
+ for (j=0; j<Ntilde; j++)
+ VF0[ i*Ntilde+j ] = 1. - CHI( ddf/s2*(cu-(1.-l)*zch[ i*Ntilde+j ])/l, df) ;
+ VF0[NN] = 1. - CHI( ddf/s2*cu, df);
+
+ for (i=0; i<M; i++)
+ for (j=0; j<Ntilde; j++) {
+ za = (1.-l)*zch[ i*Ntilde+j ];
+ for (ii=0; ii<M; ii++)
+ for (jj=0; jj<Ntilde; jj++) {
+ if ( b[ii+1]<za ) S1s[ (i*Ntilde+j)*NN + ii*Ntilde+jj ] = 0.;
+ else {
+ if ( za<b[ii] ) xl = b[ii]; else xl = za;
+ xu = b[ii+1];
+ if ( df!=2 ) {
+ xl = sqrt(xl-za);
+ xu = sqrt(xu-za);
+ }
+ gausslegendre(qm, xl, xu, zs, ws);
+ Hij = 0.;
+ for (k=0; k<qm; k++)
+ if ( df==2 )
+ Hij += ws[k]*Tn( (2.*zs[k]-b[ii+1]-b[ii])/(b[ii+1]-b[ii]), jj) * exp(-zs[k]/s2/l);
+ else
+ Hij += ws[k]*Tn( (2.*(zs[k]*zs[k]+za)-b[ii+1]-b[ii])/(b[ii+1]-b[ii]), jj)
+ * 2. * pow(zs[k], ddf-1.) * exp(-ddf*zs[k]*zs[k]/2./s2/l);
+ if ( df==2 ) Hij *= exp(za/s2/l)/s2/l;
+ else Hij /= gammafn(ddf/2.) * pow(2.*s2*l/ddf, ddf/2.);
+ S1s[ (i*Ntilde+j)*NN + ii*Ntilde+jj ] = Hij;
+ }
+ }
+ }
+
+ za = (1.-l)*cu;
+ for (ii=0; ii<M; ii++)
+ for (jj=0; jj<Ntilde; jj++) {
+ if ( b[ii+1]<za ) S00[ ii*Ntilde+jj ] = 0.;
+ else {
+ if ( za<b[ii] ) xl = b[ii]; else xl = za;
+ xu = b[ii+1];
+ if ( df!=2 ) {
+ xl = sqrt(xl-za);
+ xu = sqrt(xu-za);
+ }
+ gausslegendre(qm, xl, xu, zs, ws);
+ Hij = 0.;
+ for (k=0; k<qm; k++)
+ if ( df==2 )
+ Hij += ws[k]*Tn((2.*zs[k]-b[ii+1]-b[ii])/(b[ii+1]-b[ii]), jj) * exp(-zs[k]/s2/l);
+ else
+ Hij += ws[k] * Tn((2.*(zs[k]*zs[k]+za)-b[ii+1]-b[ii])/(b[ii+1]-b[ii]), jj)
+ * 2. * pow(zs[k], ddf-1.) * exp(-ddf*zs[k]*zs[k]/2./s2/l);
+ if ( df==2 ) Hij *= exp(za/s2/l)/s2/l;
+ else Hij /= gammafn(ddf/2.) * pow(2.*s2*l/ddf, ddf/2.);
+ S00[ ii*Ntilde+jj ] = Hij;
+ }
+ }
+
+ for (i=0; i<NN; i++)
+ for (j=0; j<NN; j++) S2s[i*NN+j] = 0.;
+
+ for (i=0; i<M; i++)
+ for (j=0; j<Ntilde; j++)
+ for (jj=0; jj<Ntilde; jj++)
+ S2s[ (i*Ntilde+j)*NN + i*Ntilde+jj ] = Tn( (2.*zch[ i*Ntilde+j ]-b[i+1]-b[i])/(b[i+1]-b[i]), jj);
+
+ LU_decompose(S2s,ps,NN);
+
+ for (n=1; n<=nmax; n++) {
+ if ( n==1) {
+ for (i=0; i<M; i++)
+ for (j=0; j<Ntilde; j++) {
+ Pns[ i*Ntilde+j ] = 0.;
+ for (jj=0; jj<Ntilde; jj++)
+ Pns[ i*Ntilde+j ] += /* usual Chebyshev approximation */
+ 2./Ntilde * Tn( (2.*zch[i*Ntilde+jj]-b[i+1]-b[i])/(b[i+1]-b[i]), j) * rside[ i*Ntilde+jj ];
+ if ( j==0 ) Pns[ i*Ntilde+j ] /= 2.;
+ }
+ p00[0] = rside[NN];
+ }
+ else {
+ for (i=0; i<NN; i++) {
+ rside[i] = VF0[i] * p00[n-2];
+ for (j=0; j<NN; j++) rside[i] += S1s[ i*NN+j ] * Pns[ (n-2)*NN+j ];
+ }
+ LU_solve2(S2s, rside, ps, NN);
+ for (i=0; i<NN; i++) Pns[ (n-1)*NN+i ] = rside[i];
+ p00[n-1] = VF0[NN] * p00[n-2];
+ for (i=0 ;i<NN; i++) p00[n-1] += S00[i] * Pns[ (n-2)*NN+i ];
+ }
+
+ p0[n-1] = 0.;
+ if ( n==1 )
+ p0[0] = 1. - CHI( ddf/s2*(cl-(1.-l)*hs)/l, df);
+ else
+ for (j=0; j<Ntilde; j++)
+ p0[n-1] += Pns[ (n-1)*NN + ihs*Ntilde+j ] * Tn( (2.*hs-b[ihs+1]-b[ihs])/(b[ihs+1]-b[ihs]), j);
+
+ if ( p0[n-1] < 1.-p ) {
+ Wq = (double)n;
+ n = nmax+1;
+ } else {
+ mn_minus = 1.; mn_plus = 0.;
+ if ( n > 1) {
+ for (i=0; i<M; i++)
+ for (j=0; j<Ntilde; j++) {
+ oben = 0.;
+ unten = 0.;
+ for (jj=0; jj<Ntilde; jj++) {
+ oben += Pns[ (n-1)*NN + i*Ntilde+jj ] * Tn((2.*zch[i*Ntilde+j]-b[i+1]-b[i])/(b[i+1]-b[i]), jj);
+ unten+= Pns[ (n-2)*NN + i*Ntilde+jj ] * Tn((2.*zch[i*Ntilde+j]-b[i+1]-b[i])/(b[i+1]-b[i]), jj);
+ }
+ if ( fabs(unten)<1e-16 )
+ if ( fabs(oben)<1e-16 ) q = 0.;
+ else q = 1.;
+ else q = oben/unten;
+ if ( q<mn_minus ) mn_minus = q;
+ if ( q>mn_plus ) mn_plus = q;
+ }
+ enumerator = log( (1.-p)/p0[n-1] );
+ q_minus = (double)n + enumerator/log(mn_minus);
+ q_plus = (double)n + enumerator/log(mn_plus);
+ /*if ( fabs( (q_plus-q_minus)/q_minus )<FINALeps ) n = nmax+1;*/
+ if ( fabs( ceil(q_plus) - ceil(q_minus) ) < .5 ) {
+ Wq = ceil(q_plus);
+ n = nmax +1;
+ }
+ } /* n > 1 */
+ } /* p0[n-1] >= 1.-p */
+ } /* n=1; n<=nmax; n++ */
+
+ Free(Pns);
+ Free(p0);
+ Free(zs);
+ Free(ws);
+ Free(rside);
+ Free(zch);
+ Free(ps);
+ Free(S2s);
+ Free(S1s);
+
+ Free(S00);
+ Free(p00);
+ Free(VF0);
+
+ return Wq;
+}
+
+
+double seLR_crit(double l, double L0, double cu, double hs, double sigma, int df, int N, int qm)
+{ double s1, s2, s3, ds, L1, L2, L3;
+
+ s2 = hs;
+ L2 = 0.;
+ do {
+ s1 = s2;
+ L1 = L2;
+ s2 -= .1;
+ L2 = seLR_iglarl(l, s2, cu, hs, sigma, df, N, qm);
+ } while ( L2<L0 && s2>0. );
+
+ do {
+ s3 = s1 + (L0-L1)/(L2-L1) * (s2-s1);
+ L3 = seLR_iglarl(l, s3, cu, hs, sigma, df, N, qm);
+ ds = s3-s2; s1 = s2; L1 = L2; s2 = s3; L2 = L3;
+ } while ( fabs(L0-L3)>1e-6 && fabs(ds)>1e-7 && s3>0.);
+
+ return s3;
+}
+
+
+double stdeLR_crit(double l, double L0, double cu, double hs, double sigma, int df, int N, int qm)
+{ double s1, s2, s3, ds, L1, L2, L3;
+
+ s2 = hs;
+ L2 = 0.;
+ do {
+ s1 = s2;
+ L1 = L2;
+ s2 -= .1;
+ L2 = stdeLR_iglarl(l, s2, cu, hs, sigma, df, N, qm);
+ } while ( L2<L0 && s2>0. );
+
+ do {
+ s3 = s1 + (L0-L1)/(L2-L1) * (s2-s1);
+ L3 = stdeLR_iglarl(l, s3, cu, hs, sigma, df, N, qm);
+ ds = s3-s2; s1 = s2; L1 = L2; s2 = s3; L2 = L3;
+ } while ( fabs(L0-L3)>1e-7 && fabs(ds)>1e-8 && s3>0.);
+
+ return s3;
+}
+
+
+double seLR_crit_prerun_SIGMA(double l, double L0, double cu, double hs, double sigma, int df1, int df2, int N, int qm1, int qm2, double truncate)
+{ double s1, s2, s3, ds, L1=0., L2=0., L3=0.;
+
+ s2 = hs;
+ do {
+ L1 = L2;
+ s2 -= .1;
+ L2 = seLR_iglarl_prerun_SIGMA(l, s2, cu, hs, sigma, df1, df2, N, qm1, qm2, truncate);
+ } while ( L2 < L0 && s2 > 0. );
+
+ s1 = s2 + .1;
+
+ do {
+ s3 = s1 + (L0-L1)/(L2-L1) * (s2-s1);
+ L3 = seLR_iglarl_prerun_SIGMA(l, s3, cu, hs, sigma, df1, df2, N, qm1, qm2, truncate);
+ ds = s3-s2; s1 = s2; L1 = L2; s2 = s3; L2 = L3;
+ } while ( fabs(L0-L3)>1e-6 && fabs(ds)>1e-7 && s3>0.);
+
+ return s3;
+}
+
+
+double seLR_q_crit(double l, int L0, double alpha, double cu, double hs, double sigma, int df, int N, int qm, double c_error, double a_error)
+{ double s1, s2, s3, ds, p1, p2, p3, *SF;
+ int result=1;
+
+ SF = vector(L0);
+
+ s2 = hs; p2 = 1.;
+ do {
+ p1 = p2;
+ s2 -= .1;
+ result = seLR_sf(l, s2, cu, hs, sigma, df, N, L0, qm, SF);
+ if ( result != 0 ) warning("trouble in seLR_q_crit [package spc]");
+ p2 = 1. - SF[L0-1];
+ } while ( p2 > alpha && s2>0.);
+
+ s1 = s2 + .1;
+
+ do {
+ s3 = s1 + (alpha - p1)/( p2 - p1 ) * (s2-s1);
+ result = seLR_sf(l, s3, cu, hs, sigma, df, N, L0, qm, SF);
+ if ( result != 0 ) warning("trouble in seLR_q_crit [package spc]");
+ p3 = 1. - SF[L0-1];
+ ds = s3 - s2; s1 = s2; p1 = p2; s2 = s3; p2 = p3;
+ } while ( fabs(alpha - p3)>a_error && fabs(ds)>c_error );
+
+ Free(SF);
+
+ return s3;
+}
+
+
+double seLR_q_crit_prerun_SIGMA(double l, int L0, double alpha, double cu, double hs, double sigma, int df1, int df2, int N, int qm1, int qm2, double truncate, int tail_approx, double c_error, double a_error)
+{ double s1, s2, s3, ds, p1, p2, p3, *SF;
+ int result=1;
+
+ SF = vector(L0);
+
+ s2 = seLR_q_crit(l, L0, alpha, cu, hs, sigma, df1, N, qm1, c_error, a_error);
+ if ( tail_approx ) result = seLR_sf_prerun_SIGMA_deluxe(l, s2, cu, hs, sigma, df1, df2, L0, qm1, qm2, truncate, SF);
+ else result = seLR_sf_prerun_SIGMA(l, s2, cu, hs, sigma, df1, df2, L0, qm1, qm2, truncate, SF);
+ if ( result != 0 ) warning("trouble in seLR_q_crit_prerun_SIGMA [package spc]");
+ p2 = 1. - SF[L0-1];
+
+ if ( p2 > alpha ) {
+ do {
+ p1 = p2;
+ s2 -= .1;
+ if ( tail_approx ) result = seLR_sf_prerun_SIGMA_deluxe(l, s2, cu, hs, sigma, df1, df2, L0, qm1, qm2, truncate, SF);
+ else result = seLR_sf_prerun_SIGMA(l, s2, cu, hs, sigma, df1, df2, L0, qm1, qm2, truncate, SF);
+ if ( result != 0 ) warning("trouble in seLR_q_crit_prerun_SIGMA [package spc]");
+ p2 = 1. - SF[L0-1];
+ } while ( p2 > alpha && s2 > 0. );
+ s1 = s2 + .1;
+ } else {
+ do {
+ p1 = p2;
+ s2 += .1;
+ if ( tail_approx ) result = seLR_sf_prerun_SIGMA_deluxe(l, s2, cu, hs, sigma, df1, df2, L0, qm1, qm2, truncate, SF);
+ else result = seLR_sf_prerun_SIGMA(l, s2, cu, hs, sigma, df1, df2, L0, qm1, qm2, truncate, SF);
+ if ( result != 0 ) warning("trouble in seLR_q_crit_prerun_SIGMA [package spc]");
+ p2 = 1. - SF[L0-1];
+ } while ( p2 <= alpha && s2 < hs );
+ s1 = s2 - .1;
+ }
+
+ do {
+ s3 = s1 + (alpha - p1)/( p2 - p1 ) * (s2-s1);
+ if ( tail_approx ) result = seLR_sf_prerun_SIGMA_deluxe(l, s3, cu, hs, sigma, df1, df2, L0, qm1, qm2, truncate, SF);
+ else result = seLR_sf_prerun_SIGMA(l, s3, cu, hs, sigma, df1, df2, L0, qm1, qm2, truncate, SF);
+ if ( result != 0 ) warning("trouble in seLR_q_crit_prerun_SIGMA [package spc]");
+ p3 = 1. - SF[L0-1];
+ ds = s3 - s2; s1 = s2; p1 = p2; s2 = s3; p2 = p3;
+ } while ( fabs(alpha - p3)>a_error && fabs(ds)>c_error );
+
+ Free(SF);
+
+ return s3;
+}
+
+
+/* MEWMA: Rigdon (1995a,b) */
+
+
+/* classical GL Nyström */
+double mxewma_arl_0a(double lambda, double ce, int p, double hs, int N)
+{ double *a, *g, *w, *z, arl, rr, r2;
+ int i, j;
+
+ a = matrix(N, N);
+ g = vector(N);
+ w = vector(N);
+ z = vector(N);
+
+ ce *= lambda/(2.-lambda);
+ hs *= lambda/(2.-lambda);
+ rr = ((1.-lambda)/lambda)*((1.-lambda)/lambda);
+ r2 = lambda*lambda;
+
+ gausslegendre(N, 0., ce, z, w);
+
+ for (i=0; i<N; i++) {
+ for (j=0; j<N; j++) a[i*N+j] = -w[j] * nchi( z[j]/r2, p, rr*z[i] ) / r2;
+ ++a[i*N+i];
+ }
+
+ for (j=0; j<N; j++) g[j] = 1.;
+ LU_solve(a, g, N);
+
+ arl = 1.;
+ for (j=0; j<N; j++) arl += w[j] * nchi(z[j]/r2, p, rr*hs)/r2 * g[j];
+
+ Free(a);
+ Free(g);
+ Free(w);
+ Free(z);
+
+ return arl;
+}
+
+
+double mxewma_arl_f_0a(double lambda, double ce, int p, int N, double *g, double *w, double *z)
+{ double *a, rr, r2;
+ int i, j;
+
+ a = matrix(N, N);
+
+ ce *= lambda/(2.-lambda);
+ rr = ((1.-lambda)/lambda)*((1.-lambda)/lambda);
+ r2 = lambda*lambda;
+
+ gausslegendre(N, 0., ce, z, w);
+
+ for (i=0; i<N; i++) {
+ for (j=0; j<N; j++) a[i*N+j] = -w[j] * nchi( z[j]/r2, p, rr*z[i] ) / r2;
+ ++a[i*N+i];
+ }
+
+ for (j=0; j<N; j++) g[j] = 1.;
+ LU_solve(a, g, N);
+
+ Free(a);
+
+ return 0.;
+}
+
+
+/* GL Nyström with changed arguments */
+double mxewma_arl_0a2(double lambda, double ce, int p, double hs, int N)
+{ double *a, *g, *w, *z, arl, rr, r2;
+ int i, j;
+
+ a = matrix(N, N);
+ g = vector(N);
+ w = vector(N);
+ z = vector(N);
+
+ ce *= lambda/(2.-lambda);
+ hs *= lambda/(2.-lambda);
+ rr = ((1.-lambda)/lambda)*((1.-lambda)/lambda);
+ r2 = lambda*lambda;
+
+ gausslegendre(N, 0., sqrt(ce), z, w);
+
+ for (i=0; i<N; i++) {
+ for (j=0; j<N; j++) a[i*N+j] = -w[j] * nchi( z[j]*z[j]/r2, p, rr*z[i]*z[i] ) / r2 * 2.*z[j];
+ ++a[i*N+i];
+ }
+
+ for (j=0; j<N; j++) g[j] = 1.;
+ LU_solve(a, g, N);
+
+ arl = 1.;
+ for (j=0; j<N; j++) arl += w[j] * nchi( z[j]*z[j]/r2, p, rr*hs)/r2 * g[j] * 2.*z[j];
+
+ Free(a);
+ Free(g);
+ Free(w);
+ Free(z);
+
+ return arl;
+}
+
+
+double mxewma_arl_f_0a2(double lambda, double ce, int p, int N, double *g, double *w, double *z)
+{ double *a, rr, r2;
+ int i, j;
+
+ a = matrix(N, N);
+
+ ce *= lambda/(2.-lambda);
+ rr = ((1.-lambda)/lambda)*((1.-lambda)/lambda);
+ r2 = lambda*lambda;
+
+ gausslegendre(N, 0., sqrt(ce), z, w);
+
+ for (i=0; i<N; i++) {
+ for (j=0; j<N; j++) a[i*N+j] = -w[j] * nchi( z[j]*z[j]/r2, p, rr*z[i]*z[i] ) / r2 * 2.*z[j];
+ ++a[i*N+i];
+ }
+
+ for (j=0; j<N; j++) g[j] = 1.;
+ LU_solve(a, g, N);
+
+ Free(a);
+
+ return 0.;
+}
+
+/* collocation */
+double mxewma_arl_0b(double lambda, double ce, int p, double hs, int N, int qm)
+{ double *a, *g, *w, *z, arl, rr, r2, xi, dN;
+ int i, j, k;
+
+ a = matrix(N, N);
+ g = vector(N);
+ w = vector(qm);
+ z = vector(qm);
+
+ ce *= lambda/(2.-lambda);
+ hs *= lambda/(2.-lambda);
+ rr = ((1.-lambda)/lambda)*((1.-lambda)/lambda);
+ r2 = lambda*lambda;
+ dN = (double)N;
+
+ gausslegendre(qm, 0, sqrt(ce), z, w);
+
+ for (i=0; i<N; i++) {
+ xi = ce/2. * ( 1. + cos(PI*(2.*(i+1.)-1.)/2./dN) );
+ for (j=0; j<N; j++) {
+ a[i*N+j] = Tn( (2.*xi-ce)/ce, j);
+ for (k=0; k<qm; k++) a[i*N+j] -= w[k] * Tn( (2.*z[k]*z[k]-ce)/ce, j) * 2.*z[k] * nchi( z[k]*z[k]/r2, p, rr*xi ) / r2;
+ }
+ }
+
+ for (j=0; j<N; j++) g[j] = 1.;
+ LU_solve(a, g, N);
+
+ arl = 0.;
+ for (j=0; j<N; j++) arl += g[j] * Tn( (2.*hs-ce)/ce ,j);
+
+ Free(a);
+ Free(g);
+ Free(w);
+ Free(z);
+
+ return arl;
+}
+
+
+double mxewma_arl_f_0b(double lambda, double ce, int p, int N, int qm, double *g)
+{ double *a, *w, *z, rr, r2, xi, dN;
+ int i, j, k;
+
+ a = matrix(N, N);
+ w = vector(qm);
+ z = vector(qm);
+
+ ce *= lambda/(2.-lambda);
+ rr = ((1.-lambda)/lambda)*((1.-lambda)/lambda);
+ r2 = lambda*lambda;
+ dN = (double)N;
+
+ gausslegendre(qm, 0, sqrt(ce), z, w);
+
+ for (i=0; i<N; i++) {
+ xi = ce/2. * ( 1. + cos(PI*(2.*(i+1.)-1.)/2./dN) );
+ for (j=0; j<N; j++) {
+ a[i*N+j] = Tn( (2.*xi-ce)/ce, j);
+ for (k=0; k<qm; k++) a[i*N+j] -= w[k] * Tn( (2.*z[k]*z[k]-ce)/ce, j) * 2.*z[k] * nchi( z[k]*z[k]/r2, p, rr*xi ) / r2;
+ }
+ }
+
+ for (j=0; j<N; j++) g[j] = 1.;
+ LU_solve(a, g, N);
+
+ Free(a);
+ Free(w);
+ Free(z);
+
+ return 0.;
+}
+
+
+/* Rigdon's approach -- Radau quadrature */
+double mxewma_arl_0c(double lambda, double ce, int p, double hs, int N)
+{ double *a, *g, *w, *z, arl, rr, r2;
+ int i, j;
+
+ a = matrix(N, N);
+ g = vector(N);
+ w = vector(N);
+ z = vector(N);
+
+ ce *= lambda/(2.-lambda);
+ hs *= lambda/(2.-lambda);
+ rr = ((1.-lambda)/lambda)*((1.-lambda)/lambda);
+ r2 = lambda*lambda;
+
+ radau(N, 0., ce, z, w);
+
+ for (i=0; i<N; i++) {
+ for (j=0; j<N; j++) a[i*N+j] = -w[j] * nchi( z[j]/r2, p, rr*z[i] ) / r2;
+ ++a[i*N+i];
+ }
+
+ for (j=0; j<N; j++) g[j] = 1.;
+ LU_solve(a, g, N);
+
+ if ( hs > 1e-10 ) {
+ arl = 1.;
+ for (j=0; j<N; j++) arl += w[j] * nchi(z[j]/r2, p, rr*hs)/r2 * g[j];
+ } else arl = g[0]; /* Rigdon's rationale behind the Radau quadrature */
+
+ Free(a);
+ Free(g);
+ Free(w);
+ Free(z);
+
+ return arl;
+}
+
+
+double mxewma_arl_f_0c(double lambda, double ce, int p, int N, double *g, double *w, double *z)
+{ double *a, rr, r2;
+ int i, j;
+
+ a = matrix(N, N);
+
+ ce *= lambda/(2.-lambda);
+ rr = ((1.-lambda)/lambda)*((1.-lambda)/lambda);
+ r2 = lambda*lambda;
+
+ radau(N, 0., ce, z, w);
+
+ for (i=0; i<N; i++) {
+ for (j=0; j<N; j++) a[i*N+j] = -w[j] * nchi( z[j]/r2, p, rr*z[i] ) / r2;
+ ++a[i*N+i];
+ }
+
+ for (j=0; j<N; j++) g[j] = 1.;
+ LU_solve(a, g, N);
+
+ Free(a);
+
+ return 0.;
+}
+
+
+
+/* Clenshaw–Curtis quadrature */
+double mxewma_arl_0d(double lambda, double ce, int p, double hs, int N)
+{ double *a, *g, *w, *z, arl, rr, r2, dN;
+ int i, j;
+
+ a = matrix(N, N);
+ g = vector(N);
+ w = vector(N);
+ z = vector(N);
+
+ dN = (double)N;
+ ce *= lambda/(2.-lambda);
+ hs *= lambda/(2.-lambda);
+ rr = ((1.-lambda)/lambda)*((1.-lambda)/lambda);
+ r2 = lambda*lambda;
+
+ /* nodes */
+ for (i=0; i<N; i++) z[i] = ce * ( ( cos( i*PI/(dN-1.) ) + 1.)/2. );
+
+ /* weights */
+ for (i=0; i<N; i++) {
+ for (j=0; j<N; j++) a[i*N+j] = cos( i*j*PI/(dN-1.) );
+ }
+ for (j=0; j<N; j++) w[j] = iTn(1.,j) - iTn(-1,j);
+ LU_solve(a, w, N);
+
+ /* usual linear equation system */
+ for (i=0; i<N; i++) {
+ for (j=0; j<N; j++) a[i*N+j] = -w[j] * nchi( z[j]/r2, p, rr*z[i] ) / r2 * (ce/2.);
+ ++a[i*N+i];
+ }
+ for (j=0; j<N; j++) g[j] = 1.;
+ LU_solve(a, g, N);
+
+ arl = 1.;
+ for (j=0; j<N; j++) arl += w[j] * nchi(z[j]/r2, p, rr*hs)/r2 * g[j] * (ce/2.);
+
+ Free(a);
+ Free(g);
+ Free(w);
+ Free(z);
+
+ return arl;
+}
+
+
+double mxewma_arl_f_0d(double lambda, double ce, int p, int N, double *g, double *w, double *z)
+{ double *a, rr, r2, dN;
+ int i, j;
+
+ a = matrix(N, N);
+
+ dN = (double)N;
+ ce *= lambda/(2.-lambda);
+ rr = ((1.-lambda)/lambda)*((1.-lambda)/lambda);
+ r2 = lambda*lambda;
+
+ /* nodes */
+ for (i=0; i<N; i++) z[i] = ce * ( ( cos( i*PI/(dN-1.) ) + 1.)/2. );
+
+ /* weights */
+ for (i=0; i<N; i++) {
+ for (j=0; j<N; j++) a[i*N+j] = cos( i*j*PI/(dN-1.) );
+ }
+ for (j=0; j<N; j++) w[j] = iTn(1.,j) - iTn(-1,j);
+ LU_solve(a, w, N);
+
+ /* usual linear equation system */
+ for (i=0; i<N; i++) {
+ for (j=0; j<N; j++) a[i*N+j] = -w[j] * nchi( z[j]/r2, p, rr*z[i] ) / r2 * (ce/2.);
+ ++a[i*N+i];
+ }
+ for (j=0; j<N; j++) g[j] = 1.;
+ LU_solve(a, g, N);
+
+ Free(a);
+
+ return 0.;
+}
+
+
+
+/* Markov chain (Runger and Prabhu 1996) */
+double mxewma_arl_0e(double lambda, double ce, int p, double hs, int N)
+{ double *a, *g, arl, rr, w, ncp, wl;
+ int i, j;
+
+ a = matrix(N, N);
+ g = vector(N);
+
+ ce = sqrt( ce * lambda/(2.-lambda) );
+ hs = sqrt( hs * lambda/(2.-lambda) );
+ rr = ((1.-lambda)/lambda)*((1.-lambda)/lambda);
+ w = 2.*ce/(2.*N-1.);
+ wl = w*w/(lambda*lambda);
+
+ for (i=0; i<N; i++) {
+ ncp = (w*i*i*w) * rr;
+ a[i*N] = -nCHI( 0.25*wl, p, ncp );
+ for (j=1; j<N; j++) a[i*N+j] = -( nCHI( (j+.5)*(j+.5)*wl, p, ncp ) - nCHI( (j-.5)*(j-.5)*wl, p, ncp ) );
+ ++a[i*N+i];
+ }
+ for (j=0; j<N; j++) g[j] = 1.;
+ LU_solve(a, g, N);
+
+ arl = g[ (int)floor(hs/w + .5) ];
+
+ Free(a);
+ Free(g);
+
+ return arl;
+}
+
+
+double mxewma_arl_f_0e(double lambda, double ce, int p, int N, double *g, double *z)
+{ double *a, rr, w, ncp, wl;
+ int i, j;
+
+ a = matrix(N, N);
+
+ ce = sqrt( ce * lambda/(2.-lambda) );
+ rr = ((1.-lambda)/lambda)*((1.-lambda)/lambda);
+ w = 2.*ce/(2.*N-1.);
+ wl = w*w/(lambda*lambda);
+
+ for (i=0; i<N; i++) {
+ ncp = (w*i*i*w)*rr;
+ a[i*N] = -nCHI( 0.25*wl, p, ncp );
+ for (j=1; j<N; j++) a[i*N+j] = -( nCHI( (j+.5)*(j+.5)*wl, p, ncp ) - nCHI( (j-.5)*(j-.5)*wl, p, ncp ) );
+ ++a[i*N+i];
+ }
+ for (j=0; j<N; j++) { g[j] = 1.; z[j] = w*(j+.5); }
+ LU_solve(a, g, N);
+
+ Free(a);
+
+ return 0.;
+}
+
+
+/* Nyström with Simpson rule */
+double mxewma_arl_0f(double lambda, double ce, int p, double hs, int N)
+{ double *a, *g, *w, *z, arl, rr, r2, b;
+ int i, j;
+
+ a = matrix(N, N);
+ g = vector(N);
+ w = vector(N);
+ z = vector(N);
+
+ ce *= lambda/(2.-lambda);
+ hs *= lambda/(2.-lambda);
+ rr = ((1.-lambda)/lambda)*((1.-lambda)/lambda);
+ r2 = lambda*lambda;
+
+ b = ce/((double)N-1.);
+ for (i=0; i<N; i++) {
+ z[i] = (double)i * b;
+ if ( (i+1) % 2 == 0 ) w[i] = 4.;
+ if ( (i+1) % 2 == 1 ) w[i] = 2.;
+ if ( i==0 || i==(N-1) ) w[i] = 1.;
+ w[i] *= b/3.;
+ }
+
+ for (i=0; i<N; i++) {
+ for (j=0; j<N; j++) a[i*N+j] = -w[j] * nchi( z[j]/r2, p, rr*z[i] ) / r2;
+ ++a[i*N+i];
+ }
+
+ for (j=0; j<N; j++) g[j] = 1.;
+ LU_solve(a, g, N);
+
+ if ( hs > 1e-10 ) {
+ arl = 1.;
+ for (j=0; j<N; j++) arl += w[j] * nchi(z[j]/r2, p, rr*hs)/r2 * g[j];
+ } else arl = g[0];
+
+ Free(a);
+ Free(g);
+ Free(w);
+ Free(z);
+
+ return arl;
+}
+
+
+double mxewma_arl_f_0f(double lambda, double ce, int p, int N, double *g, double *w, double *z)
+{ double *a, rr, r2, b;
+ int i, j;
+
+ a = matrix(N, N);
+
+ ce *= lambda/(2.-lambda);
+ rr = ((1.-lambda)/lambda)*((1.-lambda)/lambda);
+ r2 = lambda*lambda;
+
+ b = ce/((double)N-1.);
+ for (i=0; i<N; i++) {
+ z[i] = (double)i * b;
+ if ( (i+1) % 2 == 0 ) w[i] = 4.;
+ if ( (i+1) % 2 == 1 ) w[i] = 2.;
+ if ( i==0 || i==(N-1) ) w[i] = 1.;
+ w[i] *= b/3.;
+ }
+
+ for (i=0; i<N; i++) {
+ for (j=0; j<N; j++) a[i*N+j] = -w[j] * nchi( z[j]/r2, p, rr*z[i] ) / r2;
+ ++a[i*N+i];
+ }
+
+ for (j=0; j<N; j++) g[j] = 1.;
+ LU_solve(a, g, N);
+
+ Free(a);
+
+ return 0.;
+}
+
+
+/* classical GL Nyström */
+double mxewma_arl_1a(double lambda, double ce, int p, double delta, double hs, int N)
+{ double rdc, r2, rr, a, b, *z0, *w0, *z1, *w1, *M, *g, term1, term2,arl, mean, sigma, eta, korr;
+ int i, j, k, l, N2, N3, p1;
+
+ N2 = N*N;
+ N3 = N2*N;
+
+ M = matrix(N2, N2);
+ g = vector(N2);
+ z0 = vector(N);
+ w0 = vector(N);
+ z1 = vector(N);
+ w1 = vector(N);
+
+ ce *= lambda/(2.-lambda);
+ hs *= lambda/(2.-lambda);
+
+ sigma = lambda/sqrt(ce);
+ rdc = lambda*sqrt(delta/ce);
+ r2 = lambda*lambda;
+ rr = ((1.-lambda)/lambda)*((1.-lambda)/lambda);
+ p1 = p - 1;
+
+ gausslegendre(N, 0., 1., z0, w0);
+ gausslegendre(N, -1., 1., z1, w1);
+
+ for (i=0; i<N; i++) {
+ mean = rdc + (1.-lambda)*z1[i];
+ for (j=0; j<N; j++) {
+ eta = rr * ce * (1. - z1[i]*z1[i]) * z0[j];
+ for (k=0; k<N; k++) {
+ korr = ce * (1.-z1[k]*z1[k]) / r2;
+ term1 = w1[k] * phi( ( z1[k]-mean)/sigma, 0.)/sigma * korr;
+ for (l=0; l<N; l++) {
+ term2 = w0[l] * nchi( korr*z0[l], p1, eta );
+ M[i*N3 + j*N2 + k*N + l] = - term1 * term2;
+ } /* l = 0 .. N-1 */
+ } /* k = 0 .. N-1 */
+ ++M[i*N3 + j*N2 + i*N + j];
+ } /* j = 0 .. N-1 */
+ } /* i = 0 .. N-1 */
+
+ for (j=0; j<N2; j++) g[j] = 1.;
+ LU_solve(M, g, N2);
+
+ b = 0.;
+ a = 0.;
+ mean = rdc + (1.-lambda)*b;
+ eta = rr * ce*(1. - b*b)*a;
+ arl = 1.;
+ for (k=0; k<N; k++) {
+ korr = ce*(1.-z1[k]*z1[k])/r2;
+ term1 = w1[k] * phi( ( z1[k]-mean)/sigma, 0.)/sigma * korr;
+ for (l=0; l<N; l++) {
+ term2 = w0[l] * nchi( korr*z0[l], p1, eta );
+ arl += term1 * term2 * g[k*N + l];
+ } /* l = 0 .. N-1 */
+ } /* k = 0 .. N-1 */
+
+ Free(w0);
+ Free(z0);
+ Free(w1);
+ Free(z1);
+ Free(g);
+ Free(M);
+
+ return arl;
+}
+
+
+double mxewma_arl_f_1a(double lambda, double ce, int p, double delta, int N, double *g, double *w0, double *z0, double *w1, double *z1)
+{ double rdc, r2, rr, *M, term1, term2, mean, sigma, eta, korr;
+ int i, j, k, l, N2, N3, p1;
+
+ N2 = N*N;
+ N3 = N2*N;
+
+ M = matrix(N2, N2);
+
+ ce *= lambda/(2.-lambda);
+
+ sigma = lambda/sqrt(ce);
+ rdc = lambda*sqrt(delta/ce);
+ r2 = lambda*lambda;
+ rr = ((1.-lambda)/lambda)*((1.-lambda)/lambda);
+ p1 = p - 1;
+
+ gausslegendre(N, 0., 1., z0, w0);
+ gausslegendre(N, -1., 1., z1, w1);
+
+ for (i=0; i<N; i++) {
+ mean = rdc + (1.-lambda)*z1[i];
+ for (j=0; j<N; j++) {
+ eta = rr * ce * (1. - z1[i]*z1[i]) * z0[j];
+ for (k=0; k<N; k++) {
+ korr = ce * (1.-z1[k]*z1[k]) / r2;
+ term1 = w1[k] * phi( ( z1[k]-mean)/sigma, 0.)/sigma * korr;
+ for (l=0; l<N; l++) {
+ term2 = w0[l] * nchi( korr*z0[l], p1, eta );
+ M[i*N3 + j*N2 + k*N + l] = - term1 * term2;
+ } /* l = 0 .. N-1 */
+ } /* k = 0 .. N-1 */
+ ++M[i*N3 + j*N2 + i*N + j];
+ } /* j = 0 .. N-1 */
+ } /* i = 0 .. N-1 */
+
+ for (j=0; j<N2; j++) g[j] = 1.;
+ LU_solve(M, g, N2);
+
+ Free(M);
+
+ return 0.;
+}
+
+
+/* GL Nyström with inner argument changed */
+double mxewma_arl_1a2(double lambda, double ce, int p, double delta, double hs, int N)
+{ double rdc, r2, rr, a, b, *z0, *w0, *z1, *w1, *M, *g, term1, term2,arl, mean, sigma, eta, korr;
+ int i, j, k, l, N2, N3, p1;
+
+ N2 = N*N;
+ N3 = N2*N;
+
+ M = matrix(N2, N2);
+ g = vector(N2);
+ z0 = vector(N);
+ w0 = vector(N);
+ z1 = vector(N);
+ w1 = vector(N);
+
+ ce *= lambda/(2.-lambda);
+ hs *= lambda/(2.-lambda);
+
+ sigma = lambda/sqrt(ce);
+ rdc = lambda*sqrt(delta/ce);
+ r2 = lambda*lambda;
+ rr = ((1.-lambda)/lambda)*((1.-lambda)/lambda);
+ p1 = p - 1;
+
+ gausslegendre(N, 0., 1., z0, w0);
+ gausslegendre(N, -1., 1., z1, w1);
+
+ for (i=0; i<N; i++) {
+ mean = rdc + (1.-lambda)*z1[i];
+ for (j=0; j<N; j++) {
+ eta = rr * ce * (1. - z1[i]*z1[i]) * z0[j]*z0[j];
+ for (k=0; k<N; k++) {
+ korr = ce * (1.-z1[k]*z1[k]) / r2;
+ term1 = w1[k] * phi( ( z1[k]-mean)/sigma, 0.)/sigma * korr;
+ for (l=0; l<N; l++) {
+ term2 = w0[l] * nchi( korr*z0[l]*z0[l], p1, eta ) * 2.*z0[l];
+ M[i*N3 + j*N2 + k*N + l] = - term1 * term2;
+ } /* l = 0 .. N-1 */
+ } /* k = 0 .. N-1 */
+ ++M[i*N3 + j*N2 + i*N + j];
+ } /* j = 0 .. N-1 */
+ } /* i = 0 .. N-1 */
+
+ for (j=0; j<N2; j++) g[j] = 1.;
+ LU_solve(M, g, N2);
+
+ b = 0.;
+ a = 0.;
+ mean = rdc + (1.-lambda)*b;
+ eta = rr * ce*(1. - b*b)*a*a;
+ arl = 1.;
+ for (k=0; k<N; k++) {
+ korr = ce*(1.-z1[k]*z1[k])/r2;
+ term1 = w1[k] * phi( ( z1[k]-mean)/sigma, 0.)/sigma * korr;
+ for (l=0; l<N; l++) {
+ term2 = w0[l] * nchi( korr*z0[l]*z0[l], p1, eta ) * 2.*z0[l];
+ arl += term1 * term2 * g[k*N + l];
+ } /* l = 0 .. N-1 */
+ } /* k = 0 .. N-1 */
+
+ Free(w0);
+ Free(z0);
+ Free(w1);
+ Free(z1);
+ Free(g);
+ Free(M);
+
+ return arl;
+}
+
+
+double mxewma_arl_f_1a2(double lambda, double ce, int p, double delta, int N, double *g, double *w0, double *z0, double *w1, double *z1)
+{ double rdc, r2, rr, *M, term1, term2, mean, sigma, eta, korr;
+ int i, j, k, l, N2, N3, p1;
+
+ N2 = N*N;
+ N3 = N2*N;
+
+ M = matrix(N2, N2);
+
+ ce *= lambda/(2.-lambda);
+
+ sigma = lambda/sqrt(ce);
+ rdc = lambda*sqrt(delta/ce);
+ r2 = lambda*lambda;
+ rr = ((1.-lambda)/lambda)*((1.-lambda)/lambda);
+ p1 = p - 1;
+
+ gausslegendre(N, 0., 1., z0, w0);
+ gausslegendre(N, -1., 1., z1, w1);
+
+ for (i=0; i<N; i++) {
+ mean = rdc + (1.-lambda)*z1[i];
+ for (j=0; j<N; j++) {
+ eta = rr * ce * (1. - z1[i]*z1[i]) * z0[j]*z0[j];
+ for (k=0; k<N; k++) {
+ korr = ce * (1.-z1[k]*z1[k]) / r2;
+ term1 = w1[k] * phi( ( z1[k]-mean)/sigma, 0.)/sigma * korr;
+ for (l=0; l<N; l++) {
+ term2 = w0[l] * nchi( korr*z0[l]*z0[l], p1, eta ) * 2.*z0[l];
+ M[i*N3 + j*N2 + k*N + l] = - term1 * term2;
+ } /* l = 0 .. N-1 */
+ } /* k = 0 .. N-1 */
+ ++M[i*N3 + j*N2 + i*N + j];
+ } /* j = 0 .. N-1 */
+ } /* i = 0 .. N-1 */
+
+ for (j=0; j<N2; j++) g[j] = 1.;
+ LU_solve(M, g, N2);
+
+ Free(M);
+
+ return 0.;
+}
+
+
+/* GL Nyström with both arguments changed -- sin */
+double mxewma_arl_1a3(double lambda, double ce, int p, double delta, double hs, int N)
+{ double rdc, r2, rr, a, b, *z0, *w0, *z1, *w1, *M, *g, term1, term2,arl, mean, sigma, eta, korr, vi, vk;
+ int i, j, k, l, N2, N3, p1;
+
+ N2 = N*N;
+ N3 = N2*N;
+
+ M = matrix(N2, N2);
+ g = vector(N2);
+ z0 = vector(N);
+ w0 = vector(N);
+ z1 = vector(N);
+ w1 = vector(N);
+
+ ce *= lambda/(2.-lambda);
+ hs *= lambda/(2.-lambda);
+
+ sigma = lambda/sqrt(ce);
+ rdc = lambda*sqrt(delta/ce);
+ r2 = lambda*lambda;
+ rr = ((1.-lambda)/lambda)*((1.-lambda)/lambda);
+ p1 = p - 1;
+
+ gausslegendre(N, 0., 1., z0, w0);
+ gausslegendre(N, -PI/2., PI/2., z1, w1);
+
+ for (i=0; i<N; i++) {
+ vi = sin(z1[i]);
+ mean = rdc + (1.-lambda)*vi;
+ for (j=0; j<N; j++) {
+ eta = rr * ce * (1. - vi*vi) * z0[j]*z0[j];
+ for (k=0; k<N; k++) {
+ vk = sin(z1[k]);
+ korr = ce * (1.-vk*vk) / r2;
+ term1 = w1[k] * phi( ( vk-mean)/sigma, 0.)/sigma * korr * cos(z1[k]);
+ for (l=0; l<N; l++) {
+ term2 = w0[l] * nchi( korr*z0[l]*z0[l], p1, eta ) * 2.*z0[l];
+ M[i*N3 + j*N2 + k*N + l] = - term1 * term2;
+ } /* l = 0 .. N-1 */
+ } /* k = 0 .. N-1 */
+ ++M[i*N3 + j*N2 + i*N + j];
+ } /* j = 0 .. N-1 */
+ } /* i = 0 .. N-1 */
+
+ for (j=0; j<N2; j++) g[j] = 1.;
+ LU_solve(M, g, N2);
+
+ b = 0.;
+ a = 0.;
+ mean = rdc + (1.-lambda)*sin(b);
+ eta = rr * ce*(1. - b*b)*a*a;
+ arl = 1.;
+ for (k=0; k<N; k++) {
+ vk = sin(z1[k]);
+ korr = ce*(1.-vk*vk)/r2;
+ term1 = w1[k] * phi( ( vk-mean)/sigma, 0.)/sigma * korr * cos(z1[k]);
+ for (l=0; l<N; l++) {
+ term2 = w0[l] * nchi( korr*z0[l]*z0[l], p1, eta ) * 2.*z0[l];
+ arl += term1 * term2 * g[k*N + l];
+ } /* l = 0 .. N-1 */
+ } /* k = 0 .. N-1 */
+
+ Free(w0);
+ Free(z0);
+ Free(w1);
+ Free(z1);
+ Free(g);
+ Free(M);
+
+ return arl;
+}
+
+
+double mxewma_arl_f_1a3(double lambda, double ce, int p, double delta, int N, double *g, double *w0, double *z0, double *w1, double *z1)
+{ double rdc, r2, rr, *M, term1, term2, mean, sigma, eta, korr, vi, vk;
+ int i, j, k, l, N2, N3, p1;
+
+ N2 = N*N;
+ N3 = N2*N;
+
+ M = matrix(N2, N2);
+
+ ce *= lambda/(2.-lambda);
+
+ sigma = lambda/sqrt(ce);
+ rdc = lambda*sqrt(delta/ce);
+ r2 = lambda*lambda;
+ rr = ((1.-lambda)/lambda)*((1.-lambda)/lambda);
+ p1 = p - 1;
+
+ gausslegendre(N, 0., 1., z0, w0);
+ gausslegendre(N, -PI/2., PI/2., z1, w1);
+
+ for (i=0; i<N; i++) {
+ vi = sin(z1[i]);
+ mean = rdc + (1.-lambda)*vi;
+ for (j=0; j<N; j++) {
+ eta = rr * ce * (1. - vi*vi) * z0[j]*z0[j];
+ for (k=0; k<N; k++) {
+ vk = sin(z1[k]);
+ korr = ce * (1.-vk*vk) / r2;
+ term1 = w1[k] * phi( ( vk-mean)/sigma, 0.)/sigma * korr * cos(z1[k]);
+ for (l=0; l<N; l++) {
+ term2 = w0[l] * nchi( korr*z0[l]*z0[l], p1, eta ) * 2.*z0[l];
+ M[i*N3 + j*N2 + k*N + l] = - term1 * term2;
+ } /* l = 0 .. N-1 */
+ } /* k = 0 .. N-1 */
+ ++M[i*N3 + j*N2 + i*N + j];
+ } /* j = 0 .. N-1 */
+ } /* i = 0 .. N-1 */
+
+ for (j=0; j<N2; j++) g[j] = 1.;
+ LU_solve(M, g, N2);
+
+ Free(M);
+
+ return 0.;
+}
+
+
+/* GL Nyström with both arguments changed -- tan */
+double mxewma_arl_1a4(double lambda, double ce, int p, double delta, double hs, int N)
+{ double rdc, r2, rr, a, b, *z0, *w0, *z1, *w1, *M, *g, term1, term2,arl, mean, sigma, eta, korr, vi, vk;
+ int i, j, k, l, N2, N3, p1;
+
+ N2 = N*N;
+ N3 = N2*N;
+
+ M = matrix(N2, N2);
+ g = vector(N2);
+ z0 = vector(N);
+ w0 = vector(N);
+ z1 = vector(N);
+ w1 = vector(N);
+
+ ce *= lambda/(2.-lambda);
+ hs *= lambda/(2.-lambda);
+
+ sigma = lambda/sqrt(ce);
+ rdc = lambda*sqrt(delta/ce);
+ r2 = lambda*lambda;
+ rr = ((1.-lambda)/lambda)*((1.-lambda)/lambda);
+ p1 = p - 1;
+
+ gausslegendre(N, 0., 1., z0, w0);
+ gausslegendre(N, -PI/4., PI/4., z1, w1);
+
+ for (i=0; i<N; i++) {
+ vi = tan(z1[i]);
+ mean = rdc + (1.-lambda)*vi;
+ for (j=0; j<N; j++) {
+ eta = rr * ce * (1. - vi*vi) * z0[j]*z0[j];
+ for (k=0; k<N; k++) {
+ vk = tan(z1[k]);
+ korr = ce * (1.-vk*vk) / r2;
+ term1 = w1[k] * phi( ( vk-mean)/sigma, 0.)/sigma * korr / ( cos(z1[k])*cos(z1[k]) );
+ for (l=0; l<N; l++) {
+ term2 = w0[l] * nchi( korr*z0[l]*z0[l], p1, eta ) * 2.*z0[l];
+ M[i*N3 + j*N2 + k*N + l] = - term1 * term2;
+ } /* l = 0 .. N-1 */
+ } /* k = 0 .. N-1 */
+ ++M[i*N3 + j*N2 + i*N + j];
+ } /* j = 0 .. N-1 */
+ } /* i = 0 .. N-1 */
+
+ for (j=0; j<N2; j++) g[j] = 1.;
+ LU_solve(M, g, N2);
+
+ b = 0.;
+ a = 0.;
+ mean = rdc + (1.-lambda)*tan(b);
+ eta = rr * ce*(1. - b*b)*a*a;
+ arl = 1.;
+ for (k=0; k<N; k++) {
+ vk = tan(z1[k]);
+ korr = ce*(1.-vk*vk)/r2;
+ term1 = w1[k] * phi( ( vk-mean)/sigma, 0.)/sigma * korr / ( cos(z1[k])*cos(z1[k]) );
+ for (l=0; l<N; l++) {
+ term2 = w0[l] * nchi( korr*z0[l]*z0[l], p1, eta ) * 2.*z0[l];
+ arl += term1 * term2 * g[k*N + l];
+ } /* l = 0 .. N-1 */
+ } /* k = 0 .. N-1 */
+
+ Free(w0);
+ Free(z0);
+ Free(w1);
+ Free(z1);
+ Free(g);
+ Free(M);
+
+ return arl;
+}
+
+
+double mxewma_arl_f_1a4(double lambda, double ce, int p, double delta, int N, double *g, double *w0, double *z0, double *w1, double *z1)
+{ double rdc, r2, rr, *M, term1, term2, mean, sigma, eta, korr, vi, vk;
+ int i, j, k, l, N2, N3, p1;
+
+ N2 = N*N;
+ N3 = N2*N;
+
+ M = matrix(N2, N2);
+
+ ce *= lambda/(2.-lambda);
+
+ sigma = lambda/sqrt(ce);
+ rdc = lambda*sqrt(delta/ce);
+ r2 = lambda*lambda;
+ rr = ((1.-lambda)/lambda)*((1.-lambda)/lambda);
+ p1 = p - 1;
+
+ gausslegendre(N, 0., 1., z0, w0);
+ gausslegendre(N, -PI/4., PI/4., z1, w1);
+
+ for (i=0; i<N; i++) {
+ vi = tan(z1[i]);
+ mean = rdc + (1.-lambda)*vi;
+ for (j=0; j<N; j++) {
+ eta = rr * ce * (1. - vi*vi) * z0[j]*z0[j];
+ for (k=0; k<N; k++) {
+ vk = tan(z1[k]);
+ korr = ce * (1.-vk*vk) / r2;
+ term1 = w1[k] * phi( ( vk-mean)/sigma, 0.)/sigma * korr / ( cos(z1[k])*cos(z1[k]) );
+ for (l=0; l<N; l++) {
+ term2 = w0[l] * nchi( korr*z0[l]*z0[l], p1, eta ) * 2.*z0[l];
+ M[i*N3 + j*N2 + k*N + l] = - term1 * term2;
+ } /* l = 0 .. N-1 */
+ } /* k = 0 .. N-1 */
+ ++M[i*N3 + j*N2 + i*N + j];
+ } /* j = 0 .. N-1 */
+ } /* i = 0 .. N-1 */
+
+ for (j=0; j<N2; j++) g[j] = 1.;
+ LU_solve(M, g, N2);
+
+ Free(M);
+
+ return 0.;
+}
+
+
+/* GL Nyström with both arguments changed -- sinh */
+double mxewma_arl_1a5(double lambda, double ce, int p, double delta, double hs, int N)
+{ double rdc, r2, rr, a, b, *z0, *w0, *z1, *w1, *M, *g, term1, term2,arl, mean, sigma, eta, korr, vi, vk, norm;
+ int i, j, k, l, N2, N3, p1;
+
+ N2 = N*N;
+ N3 = N2*N;
+
+ M = matrix(N2, N2);
+ g = vector(N2);
+ z0 = vector(N);
+ w0 = vector(N);
+ z1 = vector(N);
+ w1 = vector(N);
+
+ ce *= lambda/(2.-lambda);
+ hs *= lambda/(2.-lambda);
+
+ sigma = lambda/sqrt(ce);
+ rdc = lambda*sqrt(delta/ce);
+ r2 = lambda*lambda;
+ rr = ((1.-lambda)/lambda)*((1.-lambda)/lambda);
+ p1 = p - 1;
+
+ gausslegendre(N, 0., 1., z0, w0);
+ gausslegendre(N, -1., 1., z1, w1);
+ norm = sinh(1.);
+
+ for (i=0; i<N; i++) {
+ vi = sinh(z1[i])/norm;
+ mean = rdc + (1.-lambda)*vi;
+ for (j=0; j<N; j++) {
+ eta = rr * ce * (1. - vi*vi) * z0[j]*z0[j];
+ for (k=0; k<N; k++) {
+ vk = sinh(z1[k])/norm;
+ korr = ce * (1.-vk*vk) / r2;
+ term1 = w1[k] * phi( ( vk-mean)/sigma, 0.)/sigma * korr * cosh(z1[k])/norm;
+ for (l=0; l<N; l++) {
+ term2 = w0[l] * nchi( korr*z0[l]*z0[l], p1, eta ) * 2.*z0[l];
+ M[i*N3 + j*N2 + k*N + l] = - term1 * term2;
+ } /* l = 0 .. N-1 */
+ } /* k = 0 .. N-1 */
+ ++M[i*N3 + j*N2 + i*N + j];
+ } /* j = 0 .. N-1 */
+ } /* i = 0 .. N-1 */
+
+ for (j=0; j<N2; j++) g[j] = 1.;
+ LU_solve(M, g, N2);
+
+ b = 0.;
+ a = 0.;
+ mean = rdc + (1.-lambda)*sinh(b);
+ eta = rr * ce*(1. - b*b)*a*a;
+ arl = 1.;
+ for (k=0; k<N; k++) {
+ vk = sinh(z1[k])/norm;
+ korr = ce*(1.-vk*vk)/r2;
+ term1 = w1[k] * phi( ( vk-mean)/sigma, 0.)/sigma * korr * cosh(z1[k])/norm;
+ for (l=0; l<N; l++) {
+ term2 = w0[l] * nchi( korr*z0[l]*z0[l], p1, eta ) * 2.*z0[l];
+ arl += term1 * term2 * g[k*N + l];
+ } /* l = 0 .. N-1 */
+ } /* k = 0 .. N-1 */
+
+ Free(w0);
+ Free(z0);
+ Free(w1);
+ Free(z1);
+ Free(g);
+ Free(M);
+
+ return arl;
+}
+
+
+double mxewma_arl_f_1a5(double lambda, double ce, int p, double delta, int N, double *g, double *w0, double *z0, double *w1, double *z1)
+{ double rdc, r2, rr, *M, term1, term2, mean, sigma, eta, korr, vi, vk, norm;
+ int i, j, k, l, N2, N3, p1;
+
+ N2 = N*N;
+ N3 = N2*N;
+
+ M = matrix(N2, N2);
+
+ ce *= lambda/(2.-lambda);
+
+ sigma = lambda/sqrt(ce);
+ rdc = lambda*sqrt(delta/ce);
+ r2 = lambda*lambda;
+ rr = ((1.-lambda)/lambda)*((1.-lambda)/lambda);
+ p1 = p - 1;
+
+ gausslegendre(N, 0., 1., z0, w0);
+ gausslegendre(N, -1., 1., z1, w1);
+ norm = sinh(1.);
+
+ for (i=0; i<N; i++) {
+ vi = sinh(z1[i])/norm;
+ mean = rdc + (1.-lambda)*vi;
+ for (j=0; j<N; j++) {
+ eta = rr * ce * (1. - vi*vi) * z0[j]*z0[j];
+ for (k=0; k<N; k++) {
+ vk = sinh(z1[k])/norm;
+ korr = ce * (1.-vk*vk) / r2;
+ term1 = w1[k] * phi( ( vk-mean)/sigma, 0.)/sigma * korr * cosh(z1[k])/norm;
+ for (l=0; l<N; l++) {
+ term2 = w0[l] * nchi( korr*z0[l]*z0[l], p1, eta ) * 2.*z0[l];
+ M[i*N3 + j*N2 + k*N + l] = - term1 * term2;
+ } /* l = 0 .. N-1 */
+ } /* k = 0 .. N-1 */
+ ++M[i*N3 + j*N2 + i*N + j];
+ } /* j = 0 .. N-1 */
+ } /* i = 0 .. N-1 */
+
+ for (j=0; j<N2; j++) g[j] = 1.;
+ LU_solve(M, g, N2);
+
+ Free(M);
+
+ return 0.;
+}
+
+
+double sign (double x) {
+ double result;
+ result = (double)(x > 1e-12) - (double)(x < -1e-12);
+ return result;
+}
+
+
+/* collocation with two halfs in the same step + sin() */
+double mxewma_arl_1b(double lambda, double ce, int p, double delta, double hs, int N, int qm0, int qm1)
+{ double rdc, r2, rr, a, b, *z0, *w0, *z1, *w1, *M, *g, dN,
+ term1, term2, term2a, term2b, innen, arl, mean, sigma, eta, u, u2, uu, v, v2, alpha;
+ int r, s, i, j, k, l, N2, N3, p1;
+
+ N2 = N*N;
+ N3 = N2*N;
+
+ M = matrix(N2, N2);
+ g = vector(N2);
+ z0 = vector(qm0);
+ w0 = vector(qm0);
+ z1 = vector(qm1);
+ w1 = vector(qm1);
+
+ ce *= lambda/(2.-lambda);
+ hs *= lambda/(2.-lambda);
+
+ sigma = lambda/sqrt(ce);
+ rdc = lambda*sqrt(delta/ce);
+ r2 = lambda*lambda;
+ rr = ((1.-lambda)/lambda)*((1.-lambda)/lambda);
+ dN = (double)N;
+ p1 = p - 1;
+
+ /* canonical Gauss-Legendre nodes and weights */
+ gausslegendre(qm0, 0., 1., z0, w0);
+ gausslegendre(qm1, 0., 1., z1, w1);
+
+ for (s=0; s<N; s++) {
+ b = cos(PI*(2.*(s+1.)-1.)/2./dN); /* Chebyshev nodes */
+ mean = rdc + (1.-lambda)*b;
+ for (r=0; r<N; r++) {
+ a = 1/2. * ( 1. + cos(PI*(2.*(r+1.)-1.)/2./dN) ); /* Chebyshev nodes */
+ eta = rr * ce*(1. - b*b)*a;
+ for (i=0; i<N; i++) {
+ for (j=0; j<N; j++) {
+ term1 = Tn( 2.*a-1., i) * Tn( b, j);
+ term2a = 0.;
+ term2b = 0.;
+ for (k=0; k<qm1; k++) {
+ innen = 0.;
+ alpha = PI/2. * z1[k];
+ v = sin(alpha);
+ v2 = v*v;
+ if ( i==0 ) {
+ uu = ce * (1.-v2) / r2;
+ innen = nCHI(uu, p1, eta);
+ } else {
+ for (l=0; l<qm0; l++) {
+ u = z0[l];
+ u2 = u*u;
+ /*uu = ce * (1.-v2*v2) * u2 / r2;*/
+ uu = ce * (1. - v2) * u2/ r2;
+ innen += w0[l] * Tn( 2.*u2-1., i) * nchi( uu, p1, eta ) * 2.*u;
+ } /* l = 0 .. qm-1*/
+ innen *= ce * (1. - v2) / r2;
+ }
+ /*term2a += w1[k] * Tn( v2, j) * phi( ( v2-mean)/sigma, 0.)/sigma * innen * ce * (1. - v2*v2) / r2 * 2.*v;
+ term2b += w1[k] * Tn( -v2, j) * phi( (-v2-mean)/sigma, 0.)/sigma * innen * ce * (1. - v2*v2) / r2 * 2.*v;*/
+ term2a += PI/2. * w1[k] * Tn( v, j) * phi( ( v-mean)/sigma, 0.)/sigma * cos(alpha) * innen;
+ term2b += PI/2. * w1[k] * Tn( -v, j) * phi( (-v-mean)/sigma, 0.)/sigma * cos(alpha) * innen;
+ } /* k = 0 .. qm-1*/
+ term2 = term2a + term2b;
+ M[r*N3 + s*N2 + i*N + j] = term1 - term2;
+ } /* j = 0 .. n-1 */
+ } /* i = 0 .. n-1 */
+ } /* r = 0 .. n-1 */
+ } /* s = 0 .. n-1 */
+
+ for (i=0; i<N2; i++) g[i] = 1.;
+ LU_solve(M, g, N2);
+
+ b = 0.;
+ a = 0.;
+ arl = 0.;
+ for (i=0; i<N; i++) {
+ for (j=0; j<N; j++) {
+ arl += g[i*N + j] * Tn( 2.*a-1., i) * Tn( b, j);
+ }
+ }
+
+ Free(w0);
+ Free(z0);
+ Free(w1);
+ Free(z1);
+ Free(g);
+ Free(M);
+
+ return arl;
+}
+
+
+double mxewma_arl_f_1b(double lambda, double ce, int p, double delta, int N, int qm0, int qm1, double *g)
+{ double rdc, r2, rr, a, b, *z0, *w0, *z1, *w1, *M, dN,
+ term1, term2, term2a, term2b, innen, mean, sigma, eta, u, u2, uu, v, v2, alpha;
+ int r, s, i, j, k, l, N2, N3, p1;
+
+ N2 = N*N;
+ N3 = N2*N;
+
+ M = matrix(N2, N2);
+ z0 = vector(qm0);
+ w0 = vector(qm0);
+ z1 = vector(qm1);
+ w1 = vector(qm1);
+
+ ce *= lambda/(2.-lambda);
+
+ sigma = lambda/sqrt(ce);
+ rdc = lambda*sqrt(delta/ce);
+ r2 = lambda*lambda;
+ rr = ((1.-lambda)/lambda)*((1.-lambda)/lambda);
+ dN = (double)N;
+ p1 = p - 1;
+
+ /* canonical Gauss-Legendre nodes and weights */
+ gausslegendre(qm0, 0., 1., z0, w0);
+ gausslegendre(qm1, 0., 1., z1, w1);
+
+ for (s=0; s<N; s++) {
+ b = cos(PI*(2.*(s+1.)-1.)/2./dN); /* Chebyshev nodes */
+ mean = rdc + (1.-lambda)*b;
+ for (r=0; r<N; r++) {
+ a = 1/2. * ( 1. + cos(PI*(2.*(r+1.)-1.)/2./dN) ); /* Chebyshev nodes */
+ eta = rr * ce*(1. - b*b)*a;
+ for (i=0; i<N; i++) {
+ for (j=0; j<N; j++) {
+ term1 = Tn( 2.*a-1., i) * Tn( b, j);
+ term2a = 0.;
+ term2b = 0.;
+ for (k=0; k<qm1; k++) {
+ innen = 0.;
+ alpha = PI/2. * z1[k];
+ v = sin(alpha);
+ v2 = v*v;
+ if ( i==0 ) {
+ uu = ce * (1.-v2) / r2;
+ innen = nCHI(uu, p1, eta);
+ } else {
+ for (l=0; l<qm0; l++) {
+ u = z0[l];
+ u2 = u*u;
+ /*uu = ce * (1.-v2*v2) * u2 / r2;*/
+ uu = ce * (1. - v2) * u2/ r2;
+ innen += w0[l] * Tn( 2.*u2-1., i) * nchi( uu, p1, eta ) * 2.*u;
+ } /* l = 0 .. qm-1*/
+ innen *= ce * (1. - v2) / r2;
+ }
+ /*term2a += w1[k] * Tn( v2, j) * phi( ( v2-mean)/sigma, 0.)/sigma * innen * ce * (1. - v2*v2) / r2 * 2.*v;
+ term2b += w1[k] * Tn( -v2, j) * phi( (-v2-mean)/sigma, 0.)/sigma * innen * ce * (1. - v2*v2) / r2 * 2.*v;*/
+ term2a += PI/2. * w1[k] * Tn( v, j) * phi( ( v-mean)/sigma, 0.)/sigma * cos(alpha) * innen;
+ term2b += PI/2. * w1[k] * Tn( -v, j) * phi( (-v-mean)/sigma, 0.)/sigma * cos(alpha) * innen;
+ } /* k = 0 .. qm-1*/
+ term2 = term2a + term2b;
+ M[r*N3 + s*N2 + i*N + j] = term1 - term2;
+ } /* j = 0 .. n-1 */
+ } /* i = 0 .. n-1 */
+ } /* r = 0 .. n-1 */
+ } /* s = 0 .. n-1 */
+
+ for (i=0; i<N2; i++) g[i] = 1.;
+ LU_solve(M, g, N2);
+
+ Free(w0);
+ Free(z0);
+ Free(w1);
+ Free(z1);
+ Free(M);
+
+ return 0.;
+}
+
+
+/* collocation with two halfs in the same step */
+double mxewma_arl_1b3(double lambda, double ce, int p, double delta, double hs, int N, int qm0, int qm1)
+{ double rdc, r2, rr, a, b, *z0, *w0, *z1, *w1, *M, *g, dN,
+ term1, term2, term2a, term2b, innen, arl, mean, sigma, eta, u, u2, uu, v, v2, alpha;
+ int r, s, i, j, k, l, N2, N3, p1;
+
+ N2 = N*N;
+ N3 = N2*N;
+
+ M = matrix(N2, N2);
+ g = vector(N2);
+ z0 = vector(qm0);
+ w0 = vector(qm0);
+ z1 = vector(qm1);
+ w1 = vector(qm1);
+
+ ce *= lambda/(2.-lambda);
+ hs *= lambda/(2.-lambda);
+
+ sigma = lambda/sqrt(ce);
+ rdc = lambda*sqrt(delta/ce);
+ r2 = lambda*lambda;
+ rr = ((1.-lambda)/lambda)*((1.-lambda)/lambda);
+ dN = (double)N;
+ p1 = p - 1;
+
+ /* canonical Gauss-Legendre nodes and weights */
+ gausslegendre(qm0, 0., 1., z0, w0);
+ gausslegendre(qm1, 0., 1., z1, w1);
+
+ for (s=0; s<N; s++) {
+ b = cos(PI*(2.*(s+1.)-1.)/2./dN); /* Chebyshev nodes */
+ mean = rdc + (1.-lambda)*b;
+ for (r=0; r<N; r++) {
+ a = 1/2. * ( 1. + cos(PI*(2.*(r+1.)-1.)/2./dN) ); /* Chebyshev nodes */
+ eta = rr * ce*(1. - b*b)*a;
+ for (i=0; i<N; i++) {
+ for (j=0; j<N; j++) {
+ term1 = Tn( 2.*a-1., i) * Tn( b, j);
+ term2a = 0.;
+ term2b = 0.;
+ for (k=0; k<qm1; k++) {
+ innen = 0.;
+ alpha = PI/4. * z1[k];
+ v = tan(alpha);
+ v2 = v*v;
+ if ( i==0 ) {
+ uu = ce * (1.-v2) / r2;
+ innen = nCHI(uu, p1, eta);
+ } else {
+ for (l=0; l<qm0; l++) {
+ u = z0[l];
+ u2 = u*u;
+ /*uu = ce * (1.-v2*v2) * u2 / r2;*/
+ uu = ce * (1. - v2) * u2/ r2;
+ innen += w0[l] * Tn( 2.*u2-1., i) * nchi( uu, p1, eta ) * 2.*u;
+ } /* l = 0 .. qm-1*/
+ innen *= ce * (1. - v2) / r2;
+ }
+ /*term2a += w1[k] * Tn( v2, j) * phi( ( v2-mean)/sigma, 0.)/sigma * innen * ce * (1. - v2*v2) / r2 * 2.*v;
+ term2b += w1[k] * Tn( -v2, j) * phi( (-v2-mean)/sigma, 0.)/sigma * innen * ce * (1. - v2*v2) / r2 * 2.*v;*/
+ term2a += PI/4. * w1[k] * Tn( v, j) * phi( ( v-mean)/sigma, 0.)/sigma / ( cos(alpha)*cos(alpha) ) * innen;
+ term2b += PI/4. * w1[k] * Tn( -v, j) * phi( (-v-mean)/sigma, 0.)/sigma / ( cos(alpha)*cos(alpha) ) * innen;
+ } /* k = 0 .. qm-1*/
+ term2 = term2a + term2b;
+ M[r*N3 + s*N2 + i*N + j] = term1 - term2;
+ } /* j = 0 .. n-1 */
+ } /* i = 0 .. n-1 */
+ } /* r = 0 .. n-1 */
+ } /* s = 0 .. n-1 */
+
+ for (i=0; i<N2; i++) g[i] = 1.;
+ LU_solve(M, g, N2);
+
+ b = 0.;
+ a = 0.;
+ arl = 0.;
+ for (i=0; i<N; i++) {
+ for (j=0; j<N; j++) {
+ arl += g[i*N + j] * Tn( 2.*a-1., i) * Tn( b, j);
+ }
+ }
+
+ Free(w0);
+ Free(z0);
+ Free(w1);
+ Free(z1);
+ Free(g);
+ Free(M);
+
+ return arl;
+}
+
+
+double mxewma_arl_f_1b3(double lambda, double ce, int p, double delta, int N, int qm0, int qm1, double *g)
+{ double rdc, r2, rr, a, b, *z0, *w0, *z1, *w1, *M, dN,
+ term1, term2, term2a, term2b, innen, mean, sigma, eta, u, u2, uu, v, v2, alpha;
+ int r, s, i, j, k, l, N2, N3, p1;
+
+ N2 = N*N;
+ N3 = N2*N;
+
+ M = matrix(N2, N2);
+ z0 = vector(qm0);
+ w0 = vector(qm0);
+ z1 = vector(qm1);
+ w1 = vector(qm1);
+
+ ce *= lambda/(2.-lambda);
+
+ sigma = lambda/sqrt(ce);
+ rdc = lambda*sqrt(delta/ce);
+ r2 = lambda*lambda;
+ rr = ((1.-lambda)/lambda)*((1.-lambda)/lambda);
+ dN = (double)N;
+ p1 = p - 1;
+
+ /* canonical Gauss-Legendre nodes and weights */
+ gausslegendre(qm0, 0., 1., z0, w0);
+ gausslegendre(qm1, 0., 1., z1, w1);
+
+ for (s=0; s<N; s++) {
+ b = cos(PI*(2.*(s+1.)-1.)/2./dN); /* Chebyshev nodes */
+ mean = rdc + (1.-lambda)*b;
+ for (r=0; r<N; r++) {
+ a = 1/2. * ( 1. + cos(PI*(2.*(r+1.)-1.)/2./dN) ); /* Chebyshev nodes */
+ eta = rr * ce*(1. - b*b)*a;
+ for (i=0; i<N; i++) {
+ for (j=0; j<N; j++) {
+ term1 = Tn( 2.*a-1., i) * Tn( b, j);
+ term2a = 0.;
+ term2b = 0.;
+ for (k=0; k<qm1; k++) {
+ innen = 0.;
+ alpha = PI/4. * z1[k];
+ v = tan(alpha);
+ v2 = v*v;
+ if ( i==0 ) {
+ uu = ce * (1.-v2) / r2;
+ innen = nCHI(uu, p1, eta);
+ } else {
+ for (l=0; l<qm0; l++) {
+ u = z0[l];
+ u2 = u*u;
+ /*uu = ce * (1.-v2*v2) * u2 / r2;*/
+ uu = ce * (1. - v2) * u2/ r2;
+ innen += w0[l] * Tn( 2.*u2-1., i) * nchi( uu, p1, eta ) * 2.*u;
+ } /* l = 0 .. qm-1*/
+ innen *= ce * (1. - v2) / r2;
+ }
+ /*term2a += w1[k] * Tn( v2, j) * phi( ( v2-mean)/sigma, 0.)/sigma * innen * ce * (1. - v2*v2) / r2 * 2.*v;
+ term2b += w1[k] * Tn( -v2, j) * phi( (-v2-mean)/sigma, 0.)/sigma * innen * ce * (1. - v2*v2) / r2 * 2.*v;*/
+ term2a += PI/4. * w1[k] * Tn( v, j) * phi( ( v-mean)/sigma, 0.)/sigma / ( cos(alpha)*cos(alpha) ) * innen;
+ term2b += PI/4. * w1[k] * Tn( -v, j) * phi( (-v-mean)/sigma, 0.)/sigma / ( cos(alpha)*cos(alpha) ) * innen;
+ } /* k = 0 .. qm-1*/
+ term2 = term2a + term2b;
+ M[r*N3 + s*N2 + i*N + j] = term1 - term2;
+ } /* j = 0 .. n-1 */
+ } /* i = 0 .. n-1 */
+ } /* r = 0 .. n-1 */
+ } /* s = 0 .. n-1 */
+
+ for (i=0; i<N2; i++) g[i] = 1.;
+ LU_solve(M, g, N2);
+
+ Free(w0);
+ Free(z0);
+ Free(w1);
+ Free(z1);
+ Free(M);
+
+ return 0.;
+}
+
+
+/* collocation with shrinked supports of the outer integral */
+double mxewma_arl_1b2(double lambda, double ce, int p, double delta, double hs, int N, int qm0, int qm1)
+{ double rdc, r2, rr, a, b, *z0, *w0, *z1, *w1, *M, *g, dN, lower, upper, xm, xw, alpha,
+ term1, term2, innen, arl, mean, sigma, eta, u, u2, uu, v, v2;
+ int r, s, i, j, k, l, N2, N3, p1;
+
+ N2 = N*N;
+ N3 = N2*N;
+
+ M = matrix(N2, N2);
+ g = vector(N2);
+ z0 = vector(qm0);
+ w0 = vector(qm0);
+ z1 = vector(qm1);
+ w1 = vector(qm1);
+
+ ce *= lambda/(2.-lambda);
+ hs *= lambda/(2.-lambda);
+
+ sigma = lambda/sqrt(ce);
+ rdc = lambda*sqrt(delta/ce);
+ r2 = lambda*lambda;
+ rr = ((1.-lambda)/lambda)*((1.-lambda)/lambda);
+ dN = (double)N;
+ p1 = p - 1;
+
+ /* canonical Gauss-Legendre nodes and weights */
+ gausslegendre(qm0, 0., 1., z0, w0);
+ gausslegendre(qm1, -1., 1., z1, w1);
+
+ for (s=0; s<N; s++) {
+ b = cos(PI*(2.*(s+1.)-1.)/2./dN); /* Chebyshev nodes */
+ mean = rdc + (1.-lambda)*b;
+ /* reasonable limits for the outer quadrature */
+ lower = mean + sigma*qPHI(1e-9);
+ if ( lower < -1. ) lower = -1.;
+ upper = mean + sigma*qPHI(1.-1e-9);
+ if ( upper > 1. ) upper = 1.;
+ /* substitution sin(alpha) = v */
+ lower = asin(lower);
+ upper = asin(upper);
+ /* constants for (-1,1) <-> (lower,upper) */
+ xm = (lower+upper)/2.;
+ xw = (upper-lower)/2.;
+ for (r=0; r<N; r++) {
+ a = 1/2. * ( 1. + cos(PI*(2.*(r+1.)-1.)/2./dN) ); /* Chebyshev nodes */
+ eta = rr * ce*(1. - b*b)*a;
+ for (i=0; i<N; i++) {
+ for (j=0; j<N; j++) {
+ term1 = Tn( 2.*a-1., i) * Tn( b, j);
+ term2 = 0.;
+ for (k=0; k<qm1; k++) {
+ innen = 0.;
+ alpha = xm + xw*z1[k];
+ v = sin(alpha);
+ v2 = v*v;
+ if ( i==0 ) {
+ uu = ce * (1.-v2) / r2;
+ innen = nCHI(uu, p1, eta);
+ } else {
+ for (l=0; l<qm0; l++) {
+ u = z0[l];
+ u2 = u*u;
+ uu = ce * (1. - v2) * u2 / r2;
+ innen += w0[l] * Tn( 2.*u2-1., i) * nchi( uu, p1, eta ) * 2.*u;
+ }
+ innen *= ce * (1. - v2) / r2;
+ }
+ term2 += xw * w1[k] * Tn( v, j) * phi( ( v-mean)/sigma, 0.)/sigma * cos(alpha) * innen;
+ } /* k = 0 .. qm-1*/
+ M[r*N3 + s*N2 + i*N + j] = term1 - term2;
+ } /* j = 0 .. n-1 */
+ } /* i = 0 .. n-1 */
+ } /* r = 0 .. n-1 */
+ } /* s = 0 .. n-1 */
+
+ for (i=0; i<N2; i++) g[i] = 1.;
+ LU_solve(M, g, N2);
+
+ b = 0.;
+ a = 0.;
+ arl = 0.;
+ for (i=0; i<N; i++) {
+ for (j=0; j<N; j++) {
+ arl += g[i*N + j] * Tn( 2.*a-1., i) * Tn( b, j);
+ }
+ }
+
+ Free(w0);
+ Free(z0);
+ Free(w1);
+ Free(z1);
+ Free(g);
+ Free(M);
+
+ return arl;
+}
+
+
+double mxewma_arl_f_1b2(double lambda, double ce, int p, double delta, int N, int qm0, int qm1, double *g)
+{ double rdc, r2, rr, a, b, *z0, *w0, *z1, *w1, *M, dN, lower, upper, xm, xw, alpha,
+ term1, term2, innen, mean, sigma, eta, u, u2, uu, v, v2;
+ int r, s, i, j, k, l, N2, N3, p1;
+
+ N2 = N*N;
+ N3 = N2*N;
+
+ M = matrix(N2, N2);
+ z0 = vector(qm0);
+ w0 = vector(qm0);
+ z1 = vector(qm1);
+ w1 = vector(qm1);
+
+ ce *= lambda/(2.-lambda);
+
+ sigma = lambda/sqrt(ce);
+ rdc = lambda*sqrt(delta/ce);
+ r2 = lambda*lambda;
+ rr = ((1.-lambda)/lambda)*((1.-lambda)/lambda);
+ dN = (double)N;
+ p1 = p - 1;
+
+ /* canonical Gauss-Legendre nodes and weights */
+ gausslegendre(qm0, 0., 1., z0, w0);
+ gausslegendre(qm1, -1., 1., z1, w1);
+
+ for (s=0; s<N; s++) {
+ b = cos(PI*(2.*(s+1.)-1.)/2./dN); /* Chebyshev nodes */
+ mean = rdc + (1.-lambda)*b;
+ /* reasonable limits for the outer quadrature */
+ lower = mean + sigma*qPHI(1e-9);
+ if ( lower < -1. ) lower = -1.;
+ upper = mean + sigma*qPHI(1.-1e-9);
+ if ( upper > 1. ) upper = 1.;
+ /* substitution sin(alpha) = v */
+ lower = asin(lower);
+ upper = asin(upper);
+ /* constants for (-1,1) <-> (lower,upper) */
+ xm = (lower+upper)/2.;
+ xw = (upper-lower)/2.;
+ for (r=0; r<N; r++) {
+ a = 1/2. * ( 1. + cos(PI*(2.*(r+1.)-1.)/2./dN) ); /* Chebyshev nodes */
+ eta = rr * ce*(1. - b*b)*a;
+ for (i=0; i<N; i++) {
+ for (j=0; j<N; j++) {
+ term1 = Tn( 2.*a-1., i) * Tn( b, j);
+ term2 = 0.;
+ for (k=0; k<qm1; k++) {
+ innen = 0.;
+ alpha = xm + xw*z1[k];
+ v = sin(alpha);
+ v2 = v*v;
+ if ( i==0 ) {
+ uu = ce * (1.-v2) / r2;
+ innen = nCHI(uu, p1, eta);
+ } else {
+ for (l=0; l<qm0; l++) {
+ u = z0[l];
+ u2 = u*u;
+ uu = ce * (1. - v2) * u2 / r2;
+ innen += w0[l] * Tn( 2.*u2-1., i) * nchi( uu, p1, eta ) * 2.*u;
+ }
+ innen *= ce * (1. - v2) / r2;
+ }
+ term2 += xw * w1[k] * Tn( v, j) * phi( ( v-mean)/sigma, 0.)/sigma * cos(alpha) * innen;
+ } /* k = 0 .. qm-1*/
+ M[r*N3 + s*N2 + i*N + j] = term1 - term2;
+ } /* j = 0 .. n-1 */
+ } /* i = 0 .. n-1 */
+ } /* r = 0 .. n-1 */
+ } /* s = 0 .. n-1 */
+
+ for (i=0; i<N2; i++) g[i] = 1.;
+ LU_solve(M, g, N2);
+
+ Free(w0);
+ Free(z0);
+ Free(w1);
+ Free(z1);
+ Free(M);
+
+ return 0.;
+}
+
+
+/* collocation with two halfs in the same step + sinh() instead of sin() */
+double mxewma_arl_1b4(double lambda, double ce, int p, double delta, double hs, int N, int qm0, int qm1)
+{ double rdc, r2, rr, a, b, *z0, *w0, *z1, *w1, *M, *g, dN,
+ term1, term2, term2a, term2b, innen, arl, mean, sigma, eta, u, u2, uu, v, v2, norm;
+ int r, s, i, j, k, l, N2, N3, p1;
+
+ N2 = N*N;
+ N3 = N2*N;
+
+ M = matrix(N2, N2);
+ g = vector(N2);
+ z0 = vector(qm0);
+ w0 = vector(qm0);
+ z1 = vector(qm1);
+ w1 = vector(qm1);
+
+ ce *= lambda/(2.-lambda);
+ hs *= lambda/(2.-lambda);
+
+ sigma = lambda/sqrt(ce);
+ rdc = lambda*sqrt(delta/ce);
+ r2 = lambda*lambda;
+ rr = ((1.-lambda)/lambda)*((1.-lambda)/lambda);
+ dN = (double)N;
+ p1 = p - 1;
+
+ /* canonical Gauss-Legendre nodes and weights */
+ gausslegendre(qm0, 0., 1., z0, w0);
+ gausslegendre(qm1, 0., 1., z1, w1);
+ norm = sinh(1.);
+
+ for (s=0; s<N; s++) {
+ b = cos(PI*(2.*(s+1.)-1.)/2./dN); /* Chebyshev nodes */
+ mean = rdc + (1.-lambda)*b;
+ for (r=0; r<N; r++) {
+ a = 1/2. * ( 1. + cos(PI*(2.*(r+1.)-1.)/2./dN) ); /* Chebyshev nodes */
+ eta = rr * ce*(1. - b*b)*a;
+ for (i=0; i<N; i++) {
+ for (j=0; j<N; j++) {
+ term1 = Tn( 2.*a-1., i) * Tn( b, j);
+ term2a = 0.;
+ term2b = 0.;
+ for (k=0; k<qm1; k++) {
+ innen = 0.;
+ v = sinh(z1[k])/norm;
+ v2 = v*v;
+ if ( i==0 ) {
+ uu = ce * (1.-v2) / r2;
+ innen = nCHI(uu, p1, eta);
+ } else {
+ for (l=0; l<qm0; l++) {
+ u = z0[l];
+ u2 = u*u;
+ /*uu = ce * (1.-v2*v2) * u2 / r2;*/
+ uu = ce * (1. - v2) * u2/ r2;
+ innen += w0[l] * Tn( 2.*u2-1., i) * nchi( uu, p1, eta ) * 2.*u;
+ } /* l = 0 .. qm-1*/
+ innen *= ce * (1. - v2) / r2;
+ }
+ /*term2a += w1[k] * Tn( v2, j) * phi( ( v2-mean)/sigma, 0.)/sigma * innen * ce * (1. - v2*v2) / r2 * 2.*v;
+ term2b += w1[k] * Tn( -v2, j) * phi( (-v2-mean)/sigma, 0.)/sigma * innen * ce * (1. - v2*v2) / r2 * 2.*v;*/
+ term2a += w1[k] * Tn( v, j) * phi( ( v-mean)/sigma, 0.)/sigma * cosh(z1[k])/norm * innen;
+ term2b += w1[k] * Tn( -v, j) * phi( (-v-mean)/sigma, 0.)/sigma * cosh(z1[k])/norm * innen;
+ } /* k = 0 .. qm-1*/
+ term2 = term2a + term2b;
+ M[r*N3 + s*N2 + i*N + j] = term1 - term2;
+ } /* j = 0 .. n-1 */
+ } /* i = 0 .. n-1 */
+ } /* r = 0 .. n-1 */
+ } /* s = 0 .. n-1 */
+
+ for (i=0; i<N2; i++) g[i] = 1.;
+ LU_solve(M, g, N2);
+
+ b = 0.;
+ a = 0.;
+ arl = 0.;
+ for (i=0; i<N; i++) {
+ for (j=0; j<N; j++) {
+ arl += g[i*N + j] * Tn( 2.*a-1., i) * Tn( b, j);
+ }
+ }
+
+ Free(w0);
+ Free(z0);
+ Free(w1);
+ Free(z1);
+ Free(g);
+ Free(M);
+
+ return arl;
+}
+
+
+double mxewma_arl_f_1b4(double lambda, double ce, int p, double delta, int N, int qm0, int qm1, double *g)
+{ double rdc, r2, rr, a, b, *z0, *w0, *z1, *w1, *M, dN,
+ term1, term2, term2a, term2b, innen, mean, sigma, eta, u, u2, uu, v, v2, norm;
+ int r, s, i, j, k, l, N2, N3, p1;
+
+ N2 = N*N;
+ N3 = N2*N;
+
+ M = matrix(N2, N2);
+ z0 = vector(qm0);
+ w0 = vector(qm0);
+ z1 = vector(qm1);
+ w1 = vector(qm1);
+
+ ce *= lambda/(2.-lambda);
+
+ sigma = lambda/sqrt(ce);
+ rdc = lambda*sqrt(delta/ce);
+ r2 = lambda*lambda;
+ rr = ((1.-lambda)/lambda)*((1.-lambda)/lambda);
+ dN = (double)N;
+ p1 = p - 1;
+
+ /* canonical Gauss-Legendre nodes and weights */
+ gausslegendre(qm0, 0., 1., z0, w0);
+ gausslegendre(qm1, 0., 1., z1, w1);
+ norm = sinh(1.);
+
+ for (s=0; s<N; s++) {
+ b = cos(PI*(2.*(s+1.)-1.)/2./dN); /* Chebyshev nodes */
+ mean = rdc + (1.-lambda)*b;
+ for (r=0; r<N; r++) {
+ a = 1/2. * ( 1. + cos(PI*(2.*(r+1.)-1.)/2./dN) ); /* Chebyshev nodes */
+ eta = rr * ce*(1. - b*b)*a;
+ for (i=0; i<N; i++) {
+ for (j=0; j<N; j++) {
+ term1 = Tn( 2.*a-1., i) * Tn( b, j);
+ term2a = 0.;
+ term2b = 0.;
+ for (k=0; k<qm1; k++) {
+ innen = 0.;
+ v = sinh(z1[k])/norm;
+ v2 = v*v;
+ if ( i==0 ) {
+ uu = ce * (1.-v2) / r2;
+ innen = nCHI(uu, p1, eta);
+ } else {
+ for (l=0; l<qm0; l++) {
+ u = z0[l];
+ u2 = u*u;
+ /*uu = ce * (1.-v2*v2) * u2 / r2;*/
+ uu = ce * (1. - v2) * u2/ r2;
+ innen += w0[l] * Tn( 2.*u2-1., i) * nchi( uu, p1, eta ) * 2.*u;
+ } /* l = 0 .. qm-1*/
+ innen *= ce * (1. - v2) / r2;
+ }
+ /*term2a += w1[k] * Tn( v2, j) * phi( ( v2-mean)/sigma, 0.)/sigma * innen * ce * (1. - v2*v2) / r2 * 2.*v;
+ term2b += w1[k] * Tn( -v2, j) * phi( (-v2-mean)/sigma, 0.)/sigma * innen * ce * (1. - v2*v2) / r2 * 2.*v;*/
+ term2a += w1[k] * Tn( v, j) * phi( ( v-mean)/sigma, 0.)/sigma * cosh(z1[k])/norm * innen;
+ term2b += w1[k] * Tn( -v, j) * phi( (-v-mean)/sigma, 0.)/sigma * cosh(z1[k])/norm * innen;
+ } /* k = 0 .. qm-1*/
+ term2 = term2a + term2b;
+ M[r*N3 + s*N2 + i*N + j] = term1 - term2;
+ } /* j = 0 .. n-1 */
+ } /* i = 0 .. n-1 */
+ } /* r = 0 .. n-1 */
+ } /* s = 0 .. n-1 */
+
+ for (i=0; i<N2; i++) g[i] = 1.;
+ LU_solve(M, g, N2);
+
+ Free(w0);
+ Free(z0);
+ Free(w1);
+ Free(z1);
+ Free(M);
+
+ return 0.;
+}
+
+
+/* Radau/Gauß-Legendre Nyström -- Rigdon 1995b */
+double mxewma_arl_1c(double lambda, double ce, int p, double delta, double hs, int N)
+{ double rdc, r2, rr, a, b, *z0, *w0, *z1, *w1, *M, *g, term1, term2,arl, mean, sigma, eta, korr;
+ int i, j, k, l, N2, N3, p1;
+
+ N2 = N*N;
+ N3 = N2*N;
+
+ M = matrix(N2, N2);
+ g = vector(N2);
+ z0 = vector(N);
+ w0 = vector(N);
+ z1 = vector(N);
+ w1 = vector(N);
+
+ ce *= lambda/(2.-lambda);
+ hs *= lambda/(2.-lambda);
+
+ sigma = lambda/sqrt(ce);
+ rdc = lambda*sqrt(delta/ce);
+ r2 = lambda*lambda;
+ rr = ((1.-lambda)/lambda)*((1.-lambda)/lambda);
+ p1 = p - 1;
+
+ radau(N, 0., 1., z0, w0);
+ gausslegendre(N, -1., 1., z1, w1);
+
+ for (i=0; i<N; i++) {
+ mean = rdc + (1.-lambda)*z1[i];
+ for (j=0; j<N; j++) {
+ eta = rr * ce * (1. - z1[i]*z1[i]) * z0[j];
+ for (k=0; k<N; k++) {
+ korr = ce * (1.-z1[k]*z1[k]) / r2;
+ term1 = w1[k] * phi( ( z1[k]-mean)/sigma, 0.)/sigma * korr;
+ for (l=0; l<N; l++) {
+ term2 = w0[l] * nchi( korr*z0[l], p1, eta );
+ M[i*N3 + j*N2 + k*N + l] = - term1 * term2;
+ } /* l = 0 .. N-1 */
+ } /* k = 0 .. N-1 */
+ ++M[i*N3 + j*N2 + i*N + j];
+ } /* j = 0 .. N-1 */
+ } /* i = 0 .. N-1 */
+
+ for (j=0; j<N2; j++) g[j] = 1.;
+ LU_solve(M, g, N2);
+
+ /* arl = g[ N*(N-1)/2 + 0 ]; */
+
+ b = 0.;
+ a = 0.;
+ mean = rdc + (1.-lambda)*b;
+ eta = rr * ce*(1. - b*b)*a;
+ arl = 1.;
+ for (k=0; k<N; k++) {
+ korr = ce*(1.-z1[k]*z1[k])/r2;
+ term1 = w1[k] * phi( ( z1[k]-mean)/sigma, 0.)/sigma * korr;
+ for (l=0; l<N; l++) {
+ term2 = w0[l] * nchi( korr*z0[l], p1, eta );
+ arl += term1 * term2 * g[k*N + l];
+ } /* l = 0 .. N-1 */
+ } /* k = 0 .. N-1 */
+
+ Free(w0);
+ Free(z0);
+ Free(w1);
+ Free(z1);
+ Free(g);
+ Free(M);
+
+ return arl;
+}
+
+
+double mxewma_arl_f_1c(double lambda, double ce, int p, double delta, int N, double *g, double *w0, double *z0, double *w1, double *z1)
+{ double rdc, r2, rr, *M, term1, term2, mean, sigma, eta, korr;
+ int i, j, k, l, N2, N3, p1;
+
+ N2 = N*N;
+ N3 = N2*N;
+
+ M = matrix(N2, N2);
+
+ ce *= lambda/(2.-lambda);
+
+ sigma = lambda/sqrt(ce);
+ rdc = lambda*sqrt(delta/ce);
+ r2 = lambda*lambda;
+ rr = ((1.-lambda)/lambda)*((1.-lambda)/lambda);
+ p1 = p - 1;
+
+ radau(N, 0., 1., z0, w0);
+ gausslegendre(N, -1., 1., z1, w1);
+
+ for (i=0; i<N; i++) {
+ mean = rdc + (1.-lambda)*z1[i];
+ for (j=0; j<N; j++) {
+ eta = rr * ce * (1. - z1[i]*z1[i]) * z0[j];
+ for (k=0; k<N; k++) {
+ korr = ce * (1.-z1[k]*z1[k]) / r2;
+ term1 = w1[k] * phi( ( z1[k]-mean)/sigma, 0.)/sigma * korr;
+ for (l=0; l<N; l++) {
+ term2 = w0[l] * nchi( korr*z0[l], p1, eta );
+ M[i*N3 + j*N2 + k*N + l] = - term1 * term2;
+ } /* l = 0 .. N-1 */
+ } /* k = 0 .. N-1 */
+ ++M[i*N3 + j*N2 + i*N + j];
+ } /* j = 0 .. N-1 */
+ } /* i = 0 .. N-1 */
+
+ for (j=0; j<N2; j++) g[j] = 1.;
+ LU_solve(M, g, N2);
+
+ Free(M);
+
+ return 0.;
+}
+
+
+/* Clenshaw–Curtis quadrature */
+double mxewma_arl_1d(double lambda, double ce, int p, double delta, double hs, int N)
+{ double rdc, r2, rr, a, b, *z0, *w0, *z1, *w1, *M, *g, term1, term2,arl, mean, sigma, eta, korr, dN, *D;
+ int i, j, k, l, N2, N3, p1;
+
+ N2 = N*N;
+ N3 = N2*N;
+
+ M = matrix(N2, N2);
+ g = vector(N2);
+ D = matrix(N, N);
+ z0 = vector(N);
+ w0 = vector(N);
+ z1 = vector(N);
+ w1 = vector(N);
+
+ ce *= lambda/(2.-lambda);
+ hs *= lambda/(2.-lambda);
+
+ dN = (double)N;
+ sigma = lambda/sqrt(ce);
+ rdc = lambda*sqrt(delta/ce);
+ r2 = lambda*lambda;
+ rr = ((1.-lambda)/lambda)*((1.-lambda)/lambda);
+ p1 = p - 1;
+
+ /* nodes */
+ for (i=0; i<N; i++) z0[i] = ( cos( i*PI/(dN-1.) ) + 1.)/2.;
+ for (i=0; i<N; i++) z1[i] = cos( i*PI/(dN-1.) );
+ /* weights */
+ for (i=0; i<N; i++) {
+ for (j=0; j<N; j++) D[i*N+j] = cos( i*j*PI/(dN-1.) );
+ }
+ for (j=0; j<N; j++) w1[j] = iTn(1.,j) - iTn(-1,j);
+ LU_solve(D, w1, N);
+ for (j=0; j<N; j++) w0[j] = w1[j]/2.;
+
+ for (i=0; i<N; i++) {
+ mean = rdc + (1.-lambda)*z1[i];
+ for (j=0; j<N; j++) {
+ eta = rr * ce * (1. - z1[i]*z1[i]) * z0[j];
+ for (k=0; k<N; k++) {
+ korr = ce * (1.-z1[k]*z1[k]) / r2;
+ term1 = w1[k] * phi( ( z1[k]-mean)/sigma, 0.)/sigma * korr;
+ for (l=0; l<N; l++) {
+ term2 = w0[l] * nchi( korr*z0[l], p1, eta );
+ M[i*N3 + j*N2 + k*N + l] = - term1 * term2;
+ } /* l = 0 .. N-1 */
+ } /* k = 0 .. N-1 */
+ ++M[i*N3 + j*N2 + i*N + j];
+ } /* j = 0 .. N-1 */
+ } /* i = 0 .. N-1 */
+
+ for (j=0; j<N2; j++) g[j] = 1.;
+ LU_solve(M, g, N2);
+
+ b = 0.;
+ a = 0.;
+ mean = rdc + (1.-lambda)*b;
+ eta = rr * ce*(1. - b*b)*a;
+ arl = 1.;
+ for (k=0; k<N; k++) {
+ korr = ce*(1.-z1[k]*z1[k])/r2;
+ term1 = w1[k] * phi( ( z1[k]-mean)/sigma, 0.)/sigma * korr;
+ for (l=0; l<N; l++) {
+ term2 = w0[l] * nchi( korr*z0[l], p1, eta );
+ arl += term1 * term2 * g[k*N + l];
+ } /* l = 0 .. N-1 */
+ } /* k = 0 .. N-1 */
+
+ Free(w0);
+ Free(z0);
+ Free(w1);
+ Free(z1);
+ Free(D);
+ Free(g);
+ Free(M);
+
+ return arl;
+}
+
+
+double mxewma_arl_f_1d(double lambda, double ce, int p, double delta, int N, double *g, double *w0, double *z0, double *w1, double *z1)
+{ double rdc, r2, rr, *M, term1, term2, mean, sigma, eta, korr, dN, *D;
+ int i, j, k, l, N2, N3, p1;
+
+ N2 = N*N;
+ N3 = N2*N;
+
+ M = matrix(N2, N2);
+ D = matrix(N, N);
+
+ ce *= lambda/(2.-lambda);
+
+ dN = (double)N;
+ sigma = lambda/sqrt(ce);
+ rdc = lambda*sqrt(delta/ce);
+ r2 = lambda*lambda;
+ rr = ((1.-lambda)/lambda)*((1.-lambda)/lambda);
+ p1 = p - 1;
+
+ /* nodes */
+ for (i=0; i<N; i++) z0[i] = ( cos( i*PI/(dN-1.) ) + 1.)/2.;
+ for (i=0; i<N; i++) z1[i] = cos( i*PI/(dN-1.) );
+ /* weights */
+ for (i=0; i<N; i++) {
+ for (j=0; j<N; j++) D[i*N+j] = cos( i*j*PI/(dN-1.) );
+ }
+ for (j=0; j<N; j++) w1[j] = iTn(1.,j) - iTn(-1,j);
+ LU_solve(D, w1, N);
+ for (j=0; j<N; j++) w0[j] = w1[j]/2.;
+
+ for (i=0; i<N; i++) {
+ mean = rdc + (1.-lambda)*z1[i];
+ for (j=0; j<N; j++) {
+ eta = rr * ce * (1. - z1[i]*z1[i]) * z0[j];
+ for (k=0; k<N; k++) {
+ korr = ce * (1.-z1[k]*z1[k]) / r2;
+ term1 = w1[k] * phi( ( z1[k]-mean)/sigma, 0.)/sigma * korr;
+ for (l=0; l<N; l++) {
+ term2 = w0[l] * nchi( korr*z0[l], p1, eta );
+ M[i*N3 + j*N2 + k*N + l] = - term1 * term2;
+ } /* l = 0 .. N-1 */
+ } /* k = 0 .. N-1 */
+ ++M[i*N3 + j*N2 + i*N + j];
+ } /* j = 0 .. N-1 */
+ } /* i = 0 .. N-1 */
+
+ for (j=0; j<N2; j++) g[j] = 1.;
+ LU_solve(M, g, N2);
+
+ Free(D);
+ Free(M);
+
+ return 0.;
+}
+
+
+/* Markov chain (Runger and Prabhu 1996) and (Molnau, Runger, Montgomery, Skenner, Loredo, and Prabhu 2001) */
+double mxewma_arl_1e(double lambda, double ce, int p, double delta, double hs, int N)
+{ double *Q, *g, arl, rr, w, ncp, wl, dN, ce2, *V, *H, ci, z1, z2;
+ int ix, jx, iy, jy, index, N2, X, Y, i, i0=0;
+
+ dN = (double)N;
+ ce = sqrt( ce * lambda/(2.-lambda) );
+ w = 2.*ce/(2.*dN+1.);
+
+ ce2 = ce*ce;
+ N2 = 2*N+1;
+ rr = (1.-lambda)/lambda * (1.-lambda)/lambda;
+ wl = w*w/(lambda*lambda);
+
+ index = 0;
+ for (ix=0; ix<N2; ix++)
+ for (iy=0; iy<N+1; iy++)
+ index += ( (ix-dN)*(ix-dN) + iy*iy < ce2/(w*w) );
+
+ V = matrix(N+1, N+1);
+ for (iy=0; iy<N+1; iy++) {
+ ncp = (w*iy*iy*w) * rr;
+ V[iy*(N+1)] = nCHI( 0.25*wl, p-1, ncp );
+ for (jy=1; jy<N+1; jy++) V[iy*(N+1)+jy] = nCHI( (jy+.5)*(jy+.5)*wl, p-1, ncp ) - nCHI( (jy-.5)*(jy-.5)*wl, p-1, ncp );
+ }
+
+ H = matrix(N2, N2);
+ for (ix=0; ix<N2; ix++) {
+ ci = -ce + (ix+.5)*w;
+ for (jx=0; jx<N2; jx++) {
+ z1 = ( -ce+(jx+1.)*w - (1.-lambda)*ci )/lambda - delta;
+ z2 = ( -ce+ jx*w - (1.-lambda)*ci )/lambda - delta;
+ H[ix*N2+jx] = PHI(z1, 0.) - PHI(z2, 0.);
+ }
+ }
+
+ Q = matrix(index, index);
+ g = vector(index);
+ X = 0;
+ for (ix=0; ix<N2; ix++) {
+ for (iy=0; iy<N+1; iy++) {
+ if ( (ix-dN)*(ix-dN) + iy*iy < ce2/(w*w) ) {
+ X++;
+ if ( ix==N && iy==0 ) i0 = X-1;
+ Y = 0;
+ for (jx=0; jx<N2; jx++) {
+ for (jy=0; jy<N+1; jy++) {
+ if ( (jx-dN)*(jx-dN) + jy*jy < ce2/(w*w) ) {
+ Y++;
+ Q[(X-1)*index + Y-1] = - H[ix*N2+jx] * V[iy*(N+1)+jy];
+ if ( X == Y ) ++Q[(X-1)*index + X-1];
+ }
+ } /* l = 0 .. N-1 */
+ } /* k = 0 .. N2-1 */
+ }
+ } /* j = 0 .. N-1 */
+ } /* i = 0 .. N2-1 */
+
+ for (i=0; i<index; i++) g[i] = 1.;
+ LU_solve(Q, g, index);
+
+ arl = g[i0];
+
+ Free(Q);
+ Free(g);
+ Free(V);
+ Free(H);
+
+ return arl;
+}
+
+
+double mxewma_arl_f_1e(double lambda, double ce, int p, double delta, int N, double *g, int *dQ)
+{ double *Q, rr, w, ncp, wl, dN, ce2, *V, *H, ci, z1, z2;
+ int ix, jx, iy, jy, index, N2, X, Y, i;
+
+ dN = (double)N;
+ ce = sqrt( ce * lambda/(2.-lambda) );
+ w = 2.*ce/(2.*dN+1.);
+
+ ce2 = ce*ce;
+ N2 = 2*N+1;
+ rr = (1.-lambda)/lambda * (1.-lambda)/lambda;
+ wl = (w*w) / (lambda*lambda);
+
+ index = 0;
+ for (ix=0; ix<N2; ix++)
+ for (iy=0; iy<N+1; iy++)
+ index += ( (ix-dN)*(ix-dN) + iy*iy < ce2/(w*w) );
+ *dQ = index;
+
+ V = matrix(N+1, N+1);
+ for (iy=0; iy<N+1; iy++) {
+ ncp = (w*iy*iy*w) * rr;
+ V[iy*(N+1)] = nCHI( 0.25*wl, p-1, ncp );
+ for (jy=1; jy<N+1; jy++) V[iy*(N+1)+jy] = nCHI( (jy+.5)*(jy+.5)*wl, p-1, ncp ) - nCHI( (jy-.5)*(jy-.5)*wl, p-1, ncp );
+ }
+
+ H = matrix(N2, N2);
+ for (ix=0; ix<N2; ix++) {
+ ci = -ce + (ix+.5)*w;
+ for (jx=0; jx<N2; jx++) {
+ z1 = ( -ce+(jx+1.)*w - (1.-lambda)*ci )/lambda - delta;
+ z2 = ( -ce+ jx*w - (1.-lambda)*ci )/lambda - delta;
+ H[ix*N2+jx] = PHI(z1, 0.) - PHI(z2, 0.);
+ }
+ }
+
+ Q = matrix(index, index);
+ X = 0;
+ for (ix=0; ix<N2; ix++) {
+ for (iy=0; iy<N+1; iy++) {
+ if ( (ix-dN)*(ix-dN) + iy*iy < ce2/(w*w) ) {
+ X++;
+ /* if ( ix==N && iy==0 ) i0 = X; */
+ Y = 0;
+ for (jx=0; jx<N2; jx++) {
+ for (jy=0; jy<N+1; jy++) {
+ if ( (jx-dN)*(jx-dN) + jy*jy < ce2/(w*w) ) {
+ Y++;
+ Q[(X-1)*index + Y-1] = - H[ix*N2+jx] * V[iy*(N+1)+jy];
+ if ( X == Y ) ++Q[(X-1)*index + X-1];
+ }
+ } /* l = 0 .. N-1 */
+ } /* k = 0 .. N2-1 */
+ }
+ } /* j = 0 .. N-1 */
+ } /* i = 0 .. N2-1 */
+
+ for (i=0; i<index; i++) g[i] = 1.;
+ LU_solve(Q, g, index);
+
+ Free(Q);
+ Free(V);
+ Free(H);
+
+ return 0.;
+}
+
+
+/* Simpson rule Nyström */
+double mxewma_arl_1f(double lambda, double ce, int p, double delta, double hs, int N)
+{ double rdc, r2, rr, *z0, *w0, *z1, *w1, *M, *g, term1, term2,arl, mean, sigma, eta, korr, b, a;
+ int i, j, k, l, N2, N3, p1;
+
+ N2 = N*N;
+ N3 = N2*N;
+
+ M = matrix(N2, N2);
+ g = vector(N2);
+ z0 = vector(N);
+ w0 = vector(N);
+ z1 = vector(N);
+ w1 = vector(N);
+
+ ce *= lambda/(2.-lambda);
+ hs *= lambda/(2.-lambda);
+
+ sigma = lambda/sqrt(ce);
+ rdc = lambda*sqrt(delta/ce);
+ r2 = lambda*lambda;
+ rr = ((1.-lambda)/lambda)*((1.-lambda)/lambda);
+ p1 = p - 1;
+
+ b = ce/((double)N-1.);
+ for (i=0; i<N; i++) {
+ z0[i] = (double)i * b;
+ z1[i] = -1. + 2.*(double)i * b;
+ if ( (i+1) % 2 == 0 ) w0[i] = 4.;
+ if ( (i+1) % 2 == 1 ) w0[i] = 2.;
+ if ( i==0 || i==(N-1) ) w0[i] = 1.;
+ w0[i] *= b/3.;
+ w1[i] = 2*w0[i];
+ }
+
+ for (i=0; i<N; i++) {
+ mean = rdc + (1.-lambda)*z1[i];
+ for (j=0; j<N; j++) {
+ eta = rr * ce * (1. - z1[i]*z1[i]) * z0[j];
+ for (k=0; k<N; k++) {
+ korr = ce * (1.-z1[k]*z1[k]) / r2;
+ term1 = w1[k] * phi( ( z1[k]-mean)/sigma, 0.)/sigma * korr;
+ for (l=0; l<N; l++) {
+ term2 = w0[l] * nchi( korr*z0[l], p1, eta );
+ M[i*N3 + j*N2 + k*N + l] = - term1 * term2;
+ } /* l = 0 .. N-1 */
+ } /* k = 0 .. N-1 */
+ ++M[i*N3 + j*N2 + i*N + j];
+ } /* j = 0 .. N-1 */
+ } /* i = 0 .. N-1 */
+
+ for (j=0; j<N2; j++) g[j] = 1.;
+ LU_solve(M, g, N2);
+
+ b = 0.;
+ a = 0.;
+ mean = rdc + (1.-lambda)*b;
+ eta = rr * ce*(1. - b*b)*a;
+ arl = 1.;
+ for (k=0; k<N; k++) {
+ korr = ce*(1.-z1[k]*z1[k])/r2;
+ term1 = w1[k] * phi( ( z1[k]-mean)/sigma, 0.)/sigma * korr;
+ for (l=0; l<N; l++) {
+ term2 = w0[l] * nchi( korr*z0[l], p1, eta );
+ arl += term1 * term2 * g[k*N + l];
+ } /* l = 0 .. N-1 */
+ } /* k = 0 .. N-1 */
+
+ Free(w0);
+ Free(z0);
+ Free(w1);
+ Free(z1);
+ Free(g);
+ Free(M);
+
+ return arl;
+}
+
+
+double mxewma_arl_f_1f(double lambda, double ce, int p, double delta, int N, double *g, double *w0, double *z0, double *w1, double *z1)
+{ double rdc, r2, rr, *M, term1, term2, mean, sigma, eta, korr, b;
+ int i, j, k, l, N2, N3, p1;
+
+ N2 = N*N;
+ N3 = N2*N;
+
+ M = matrix(N2, N2);
+
+ ce *= lambda/(2.-lambda);
+
+ sigma = lambda/sqrt(ce);
+ rdc = lambda*sqrt(delta/ce);
+ r2 = lambda*lambda;
+ rr = ((1.-lambda)/lambda)*((1.-lambda)/lambda);
+ p1 = p - 1;
+
+ b = ce/((double)N-1.);
+ for (i=0; i<N; i++) {
+ z0[i] = (double)i * b;
+ z1[i] = -1. + 2.*(double)i * b;
+ if ( (i+1) % 2 == 0 ) w0[i] = 4.;
+ if ( (i+1) % 2 == 1 ) w0[i] = 2.;
+ if ( i==0 || i==(N-1) ) w0[i] = 1.;
+ w0[i] *= b/3.;
+ w1[i] = 2*w0[i];
+ }
+
+ for (i=0; i<N; i++) {
+ mean = rdc + (1.-lambda)*z1[i];
+ for (j=0; j<N; j++) {
+ eta = rr * ce * (1. - z1[i]*z1[i]) * z0[j];
+ for (k=0; k<N; k++) {
+ korr = ce * (1.-z1[k]*z1[k]) / r2;
+ term1 = w1[k] * phi( ( z1[k]-mean)/sigma, 0.)/sigma * korr;
+ for (l=0; l<N; l++) {
+ term2 = w0[l] * nchi( korr*z0[l], p1, eta );
+ M[i*N3 + j*N2 + k*N + l] = - term1 * term2;
+ } /* l = 0 .. N-1 */
+ } /* k = 0 .. N-1 */
+ ++M[i*N3 + j*N2 + i*N + j];
+ } /* j = 0 .. N-1 */
+ } /* i = 0 .. N-1 */
+
+ for (j=0; j<N2; j++) g[j] = 1.;
+ LU_solve(M, g, N2);
+
+ Free(M);
+
+ return 0.;
+}
+
+
+double mxewma_crit(double lambda, double L0, int p, double hs, int N)
+{ double c1, c2, c3, L1=0., L2=0., L3=0., dc;
+ /*int numAlg;
+
+ numAlg = remainder((double)p, 2.)==0;*/
+
+ c2 = .5;
+ L2 = 1.;
+ do {
+ c1 = c2;
+ L1 = L2;
+ c2 += 1.;
+ /*if ( numAlg ) L2 = mxewma_arl_0a(lambda, c2, p, hs, N); else L2 = mxewma_arl_0b(lambda, c2, p, hs, N, qm);*/
+ L2 = mxewma_arl_0a2(lambda, c2, p, hs, N);
+ } while ( L2 < L0 );
+
+ do {
+ c3 = c1 + (L0-L1)/(L2-L1) * (c2-c1);
+ /*if ( numAlg ) L3 = mxewma_arl_0a(lambda, c3, p, hs, N); else L3 = mxewma_arl_0b(lambda, c3, p, hs, N, qm);*/
+ L3 = mxewma_arl_0a2(lambda, c3, p, hs, N);
+ dc = c3 - c2; c1 = c2; L1 = L2; c2 = c3; L2 = L3;
+ } while ( (fabs(L0-L3)>1e-8 ) && ( fabs(dc)>1e-10) );
+
+ return c3;
+}
+
+
+double mxewma_psi (double lambda, double ce, int p, int N, double *PSI, double *w, double *z)
+{ double *a, rr, r2, rho, norm;
+ int i, j, status, noofit;
+
+ a = matrix(N, N);
+
+ ce *= lambda/(2.-lambda);
+ rr = ( (1.-lambda)/lambda ) * ( (1.-lambda)/lambda );
+ r2 = lambda*lambda;
+
+ gausslegendre(N, 0., sqrt(ce), z, w);
+
+ for (i=0; i<N; i++)
+ for (j=0; j<N; j++) a[i*N+j] = w[j] * nchi( z[i]*z[i]/r2, p, rr*z[j]*z[j] ) / r2 * 2.*z[j];
+
+ pmethod(N, a, &status, &rho, PSI, &noofit);
+
+ norm = 0.;
+ for (i=0; i<N; i++) norm += w[i] * PSI[i] * 2.*z[i];
+ for (i=0; i<N; i++) PSI[i] /= norm;
+
+ Free(a);
+
+ return rho;
+}
+
+
+double mxewma_psiS(double lambda, double ce, int p, double hs, int N, double *PSI, double *w, double *z)
+{ double *a, rr, r2, L0, *b;
+ int i, j;
+
+ if ( hs < 0. ) hs = 0.;
+
+ L0 = mxewma_arl_0a2(lambda, ce, p, hs, N);
+
+ a = matrix(N, N);
+ b = vector(N);
+
+ ce *= lambda/(2.-lambda);
+ rr = ((1.-lambda)/lambda)*((1.-lambda)/lambda);
+ r2 = lambda*lambda;
+
+ gausslegendre(N, 0., sqrt(ce), z, w);
+
+ for (i=0; i<N; i++) {
+ for (j=0; j<N; j++) a[i*N+j] = -w[j] * nchi( z[i]*z[i]/r2, p, rr*z[j]*z[j] ) / r2 * 2.*z[j];
+ ++a[i*N+i];
+ }
+ if ( hs < 1e-9 ) {
+ for (i=0; i<N; i++) b[i] = chi( z[i]*z[i]/r2, p ) / r2 / L0;
+ } else {
+ for (i=0; i<N; i++) b[i] = nchi( z[i]*z[i]/r2, p, rr*hs*hs ) / r2 / L0;
+ }
+ LU_solve(a, b, N);
+
+ for (i=0; i<N; i++) PSI[i] = b[i];
+
+ Free(b);
+ Free(a);
+
+ return L0;
+}
+
+
+#define cond 0
+#define cycl 1
+
+#define GL 0
+#define CO 1
+#define RA 2
+#define CC 3
+#define MC 4
+#define SR 5
+#define CO2 6
+#define GL2 7
+#define GL3 8
+#define GL4 9
+#define GL5 10
+#define CO3 11
+#define CO4 12
+
+
+double mxewma_L_of_ab(double lambda, double ce, int p, double delta, int N, int qtype, double *g, double a, double b, double *w0, double *z0, double *w1, double *z1)
+{ double LL=-1., ccee, rr, r2, rdc, sig, a_, b_, m, eta, korr, innen, norm;
+ int i, j;
+
+ ccee = ce * lambda/(2.-lambda);
+ rr = ((1.-lambda)/lambda)*((1.-lambda)/lambda);
+ r2 = lambda*lambda;
+
+ if ( fabs(delta)<1e-10 ) { /* in-control */
+ if ( qtype==GL || qtype==RA || qtype==CC || qtype==SR ) {
+ LL = 1.;
+ for (j=0; j<N; j++) LL += w0[j] * g[j] * nchi( z0[j]/r2, p, rr*a ) / r2;
+ if ( qtype==CC ) LL *= ccee/2.;
+ }
+ if ( qtype==GL2 ) {
+ LL = 1.;
+ for (j=0; j<N; j++) LL += w0[j] * g[j] * 2.*z0[j] * nchi( z0[j]*z0[j]/r2, p, rr*a ) / r2;
+ }
+ if ( qtype==CO ) {
+ LL = 0.;
+ for (j=0; j<N; j++) LL += Tn( (2.*a-ccee)/ccee, j) * g[j];
+ }
+ if ( qtype==MC ) {
+ LL = 1. + g[0] * ( nCHI( z0[0]*z0[0]/r2, p, rr*a ) - 0. );
+ for (j=1; j<N; j++) LL += g[j] * ( nCHI( z0[j]*z0[j]/r2, p, rr*a ) - nCHI( z0[j-1]*z0[j-1]/r2, p, rr*a ) );
+ }
+ } else { /* out-of-control */
+ rdc = lambda * sqrt(delta/ccee);
+ sig = lambda / sqrt(ccee);
+
+ if ( fabs(ccee - a) < 1e-10 ) a_ = 1.; else a_ = (a - b*b/delta) / ( ccee - b*b/delta );
+ b_ = b / sqrt( delta * ccee );
+ m = rdc + (1.-lambda) * b_;
+ eta = rr * ccee * ( 1. - b_*b_ ) * a_;
+ if ( eta < 1e-10 ) eta = 0.;
+
+ if ( qtype==GL || qtype==RA || qtype==CC || qtype==SR ) {
+ LL = 1.;
+ for (i=0; i<N; i++) {
+ korr = ccee * ( 1. - z1[i]*z1[i] ) / r2;
+ innen = 0.;
+ for (j=0; j<N; j++) innen += w0[j] * nchi(korr*z0[j], p-1, eta) * g[i*N + j];
+ LL += korr * w1[i] * phi( (z1[i]-m)/sig, 0. )/sig * innen;
+ }
+ }
+ if ( qtype==GL2 ) {
+ LL = 1.;
+ for (i=0; i<N; i++) {
+ korr = ccee * ( 1. - z1[i]*z1[i] ) / r2;
+ innen = 0.;
+ for (j=0; j<N; j++) innen += w0[j] * nchi(korr*z0[j]*z0[j], p-1, eta) * g[i*N + j] * 2.*z0[j];
+ LL += korr * w1[i] * phi( (z1[i]-m)/sig, 0. )/sig * innen;
+ }
+ }
+ if ( qtype==GL3 ) {
+ LL = 1.;
+ for (i=0; i<N; i++) {
+ korr = ccee * ( 1. - sin(z1[i])*sin(z1[i]) ) / r2;
+ innen = 0.;
+ for (j=0; j<N; j++) innen += w0[j] * nchi(korr*z0[j]*z0[j], p-1, eta) * g[i*N + j] * 2.*z0[j];
+ LL += korr * w1[i] * phi( (sin(z1[i])-m)/sig, 0. )/sig * innen * cos(z1[i]);
+ }
+ }
+ if ( qtype==GL4 ) {
+ LL = 1.;
+ for (i=0; i<N; i++) {
+ korr = ccee * ( 1. - tan(z1[i])*tan(z1[i]) ) / r2;
+ innen = 0.;
+ for (j=0; j<N; j++) innen += w0[j] * nchi(korr*z0[j]*z0[j], p-1, eta) * g[i*N + j] * 2.*z0[j];
+ LL += korr * w1[i] * phi( (tan(z1[i])-m)/sig, 0. )/sig * innen / cos(z1[i])/cos(z1[i]);
+ }
+ }
+ if ( qtype==GL5 ) {
+ norm = sinh(1.);
+ LL = 1.;
+ for (i=0; i<N; i++) {
+ korr = ccee * ( 1. - sinh(z1[i])*sinh(z1[i])/norm/norm ) / r2;
+ innen = 0.;
+ for (j=0; j<N; j++) innen += w0[j] * nchi(korr*z0[j]*z0[j], p-1, eta) * g[i*N + j] * 2.*z0[j];
+ LL += korr * w1[i] * phi( (sinh(z1[i])/norm-m)/sig, 0. )/sig * innen * cosh(z1[i])/norm;
+ }
+ }
+ if ( qtype==CO || qtype==CO2 || qtype==CO3 || qtype==CO4 ) {
+ LL = 0.;
+ for (i=0; i<N; i++) {
+ innen =0.;
+ for (j=0; j<N; j++) innen += Tn(b_, j) * g[i*N + j];
+ LL += Tn(2.*a_-1., i) * innen;
+ }
+ }
+ }
+
+ return LL;
+}
+
+
+double angle_unif_sphere(double x, int p)
+{ double dp, result;
+ dp = (double) p;
+ if ( fabs(dp - 2.) < .001 ) result = 1./PI; else result = gammafn( dp/2. ) / gammafn( (dp-1.)/2. ) * pow(sin(x), dp - 2.) / sqrt(PI);
+ return result;
+}
+
+
+double mxewma_ad(double lambda, double ce, int p, double delta, int N, int qm2, int psi_type, double hs, int qtype, int qm0, int qm1)
+{ double *PSI, *ARL, *w1, *z1, *w2, *z2, *w3, *z3, *w4, *z4, *w5, *z5, zahl, ad, psi0, LL, ccee, rr, r2, xi, yj, sdelta;
+ int i, j, N2;
+
+ PSI = vector(N);
+ w1 = vector(N);
+ z1 = vector(N);
+
+ if ( hs < 0. ) hs = 0.;
+
+ if ( psi_type == cond ) zahl = mxewma_psi (lambda, ce, p, N, PSI, w1, z1);
+ if ( psi_type == cycl ) zahl = mxewma_psiS(lambda, ce, p, hs, N, PSI, w1, z1);
+
+ ccee = ce * lambda/(2.-lambda);
+ rr = ((1.-lambda)/lambda)*((1.-lambda)/lambda);
+ r2 = lambda*lambda;
+
+ w3 = vector(qm2);
+ z3 = vector(qm2);
+ gausslegendre(qm2, 0., sqrt(ccee), z3, w3);
+
+ w5 = vector(qm2);
+ z5 = vector(qm2);
+ gausslegendre(qm2, 0., PI, z5, w5);
+
+ ad = 0.;
+
+ if ( fabs(delta)<1e-10 ) { /* in-control */
+ ARL = vector(N);
+ w2 = vector(N);
+ z2 = vector(N);
+
+ if ( qtype == GL ) LL = mxewma_arl_f_0a (lambda, ce, p, N, ARL, w2, z2);
+ if ( qtype == GL2 ) LL = mxewma_arl_f_0a2(lambda, ce, p, N, ARL, w2, z2);
+ if ( qtype == CO ) LL = mxewma_arl_f_0b (lambda, ce, p, N, qm0, ARL);
+ if ( qtype == RA ) LL = mxewma_arl_f_0c (lambda, ce, p, N, ARL, w2, z2);
+ if ( qtype == CC ) LL = mxewma_arl_f_0d (lambda, ce, p, N, ARL, w2, z2);
+ if ( qtype == MC ) LL = mxewma_arl_f_0e (lambda, ce, p, N, ARL, z2);
+ if ( qtype == SR ) LL = mxewma_arl_f_0f (lambda, ce, p, N, ARL, w2, z2);
+
+ for (i=0; i<qm2; i++) {
+ xi = z3[i]*z3[i];
+
+ psi0 = 0.;
+ if ( psi_type == cycl ) {
+ if ( fabs(hs) <= 1e-10 ) psi0 = chi(xi/r2, p) / r2 / zahl;
+ if ( fabs(hs) > 1e-10 ) psi0 = 2.*hs * nchi(xi/r2, p, rr*hs*hs) / r2 / zahl;
+ }
+ for (j=0; j<N; j++) psi0 += w1[j] * PSI[j] * 2.*z1[j] * nchi( xi/r2, p, rr*z1[j]*z1[j] ) / r2;
+ if ( psi_type == cond ) psi0 /= zahl;
+
+ LL = mxewma_L_of_ab(lambda, ce, p, 0., N, qtype, ARL, xi, 0., w2, z2, w2, z2);
+
+ /*printf("%2d\t%.4f\t%.4f\t%.4f\n", i, z3[i], psi0, LL);*/
+
+ ad += w3[i] * 2.*z3[i] * psi0 * LL;
+ }
+
+ if ( psi_type == cycl ) {
+ psi0 = 1./zahl;
+ LL = mxewma_L_of_ab(lambda, ce, p, 0., N, qtype, ARL, hs, 0., w2, z2, w2, z2);
+ ad += psi0 * LL;
+ }
+
+ Free(z2);
+ Free(w2);
+ Free(ARL);
+
+ } else { /* out-of-control */
+ sdelta = sqrt(delta);
+
+ N2 = N*N;
+ ARL = vector(N2);
+ w2 = vector(N);
+ z2 = vector(N);
+ w4 = vector(N);
+ z4 = vector(N);
+
+ if ( qtype == GL ) LL = mxewma_arl_f_1a (lambda, ce, p, delta, N, ARL, w2, z2, w4, z4);
+ if ( qtype == GL2 ) LL = mxewma_arl_f_1a2(lambda, ce, p, delta, N, ARL, w2, z2, w4, z4);
+ if ( qtype == GL3 ) LL = mxewma_arl_f_1a3(lambda, ce, p, delta, N, ARL, w2, z2, w4, z4);
+ if ( qtype == GL4 ) LL = mxewma_arl_f_1a4(lambda, ce, p, delta, N, ARL, w2, z2, w4, z4);
+ if ( qtype == GL5 ) LL = mxewma_arl_f_1a5(lambda, ce, p, delta, N, ARL, w2, z2, w4, z4);
+
+ if ( qtype == CO ) LL = mxewma_arl_f_1b (lambda, ce, p, delta, N, qm0, qm1, ARL);
+ if ( qtype == CO2 ) LL = mxewma_arl_f_1b2(lambda, ce, p, delta, N, qm0, qm1, ARL);
+ if ( qtype == CO3 ) LL = mxewma_arl_f_1b3(lambda, ce, p, delta, N, qm0, qm1, ARL);
+ if ( qtype == CO4 ) LL = mxewma_arl_f_1b4(lambda, ce, p, delta, N, qm0, qm1, ARL);
+
+ if ( qtype == RA ) LL = mxewma_arl_f_1c(lambda, ce, p, delta, N, ARL, w2, z2, w4, z4);
+ if ( qtype == CC ) LL = mxewma_arl_f_1d(lambda, ce, p, delta, N, ARL, w2, z2, w2, z2);
+ /*if ( qtype == MC ) LL = mxewma_arl_f_1e(lambda, ce, p, delta, N, ARL, &dQ);*/
+ if ( qtype == SR ) LL = mxewma_arl_f_1f(lambda, ce, p, delta, N, ARL, w2, z2, w2, z2);
+
+ for (i=0; i<qm2; i++) {
+ xi = z3[i]*z3[i];
+
+ psi0 = 0.;
+ if ( psi_type == cycl ) {
+ if ( fabs(hs) <= 1e-10 ) psi0 = chi(xi/r2, p) / r2 / zahl;
+ if ( fabs(hs) > 1e-10 ) psi0 = 2.*hs * nchi(xi/r2, p, rr*hs*hs) / r2 / zahl;
+ }
+ for (j=0; j<N; j++) psi0 += w1[j] * PSI[j] * 2.*z1[j] * nchi( xi/r2, p, rr*z1[j]*z1[j] ) / r2;
+ if ( psi_type == cond ) psi0 /= zahl;
+
+ for (j=0; j<qm2; j++) {
+ yj = z3[i] * sdelta * cos(z5[j]);
+
+ LL = mxewma_L_of_ab(lambda, ce, p, delta, N, qtype, ARL, xi, yj, w2, z2, w4, z4);
+
+ ad += w3[i] * 2.*z3[i] * w5[j] * psi0 * angle_unif_sphere(z5[j], p) * LL;
+ }
+ }
+
+ if ( psi_type == cycl ) {
+ psi0 = 1./zahl;
+ LL = mxewma_L_of_ab(lambda, ce, p, delta, N, qtype, ARL, 0., 0., w2, z2, w4, z4);
+ ad += psi0 * LL;
+ }
+
+ Free(z4);
+ Free(w4);
+ Free(z2);
+ Free(z2);
+ Free(ARL);
+ }
+
+ Free(z3);
+ Free(w3);
+ Free(z1);
+ Free(w1);
+ Free(PSI);
+
+ return ad;
+}
+
+
+double xseU_arl(double lx, double ls, double cx, double cs, double hsx, double hss, double mu, double sigma, int df, int Nx, int Ns, int nmax, int qm)
+{ double *Sx, *Pnx, *wx, *zx, *p0x, *p0, *S1s, *S2s, *Pns, *ws, *zs, *p0s, q, *zch, *rside, za=0., s2,
+ arl_minus=0., arl, arl_plus=0., mn_minus=1., mn_plus=0.,
+ mn_minusx, mn_minuss, mn_plusx, mn_pluss, ddf, xl, xu,
+ oben, unten;
+ int i, j, k, n, *ps;
+
+ cx *= sqrt( lx/(2.-lx) );
+ hsx *= sqrt( lx/(2.-lx) );
+
+ s2 = sigma*sigma;
+ ddf = (double)df;
+
+ Sx = matrix(Nx,Nx);
+ wx = vector(Nx);
+ zx = vector(Nx);
+ Pnx = matrix(nmax,Nx);
+ p0x = vector(nmax);
+
+ S1s = matrix(Ns,Ns);
+ S2s = matrix(Ns,Ns);
+ ps = ivector(Ns);
+ zch = vector(Ns);
+ rside = vector(Ns);
+ ws = vector(qm);
+ zs = vector(qm);
+ Pns = matrix(nmax,Ns);
+ p0s = vector(nmax);
+
+ p0 = vector(nmax);
+
+ gausslegendre(Nx,-cx,cx,zx,wx);
+
+ for (i=0;i<Nx;i++) {
+ za = (1.-lx)*zx[i];
+ for (j=0;j<Nx;j++)
+ Sx[i*Nx+j] = wx[j]/lx*phi( ((zx[j]-za)/lx-mu)/sigma, 0.)/sigma;
+ }
+
+/* Chebyshev nodes on [0,cs] */
+ for (i=0;i<Ns;i++)
+ zch[i] = cs/2.*(1.+cos(PI*(2.*(i+1.)-1.)/2./(double)Ns) );
+
+/* P(L>1)(zch[i]) */
+ for (i=0;i<Ns;i++)
+ rside[i] = CHI( ddf/s2*(cs-(1.-ls)*zch[i])/ls, df);
+
+ for (i=0;i<Ns;i++) {
+ za = (1.-ls)*zch[i];
+ if (df==2) { xl = za; xu = cs; }
+ else { xl = 0.; xu = sqrt(cs-za); }
+ gausslegendre(qm,xl,xu,zs,ws);
+ for (j=0;j<Ns;j++) {
+ S1s[i*Ns+j] = 0.;
+ for (k=0;k<qm;k++)
+ if (df==2)
+ S1s[i*Ns+j] += ws[k]*Tn((2.*zs[k]-cs)/cs, j) * exp((za-zs[k])/s2/ls);
+ else
+ S1s[i*Ns+j] += ws[k]*Tn((2.*(zs[k]*zs[k]+za)-cs)/cs, j)
+ *2.*pow(zs[k], ddf-1.) * exp(-ddf*zs[k]*zs[k]/2./s2/ls);
+ if (df==2) S1s[i*Ns+j] /= s2*ls;
+ else S1s[i*Ns+j] /= gammafn(ddf/2.) * pow(2.*s2*ls/ddf,ddf/2.);
+ }
+ }
+
+ for (i=0;i<Ns;i++)
+ for (j=0;j<Ns;j++) S2s[i*Ns+j] = Tn( (2.*zch[i]-cs)/cs, j);
+
+ LU_decompose(S2s,ps,Ns);
+
+ arl = 1.;
+ for (n=1;n<=nmax;n++) {
+
+ if (n==1)
+ for (i=0;i<Nx;i++)
+ Pnx[i] = PHI( (( cx-(1.-lx)*zx[i])/lx-mu)/sigma, 0.) -
+ PHI( ((-cx-(1.-lx)*zx[i])/lx-mu)/sigma, 0.);
+ else
+ for (i=0;i<Nx;i++) {
+ Pnx[(n-1)*Nx+i] = 0.;
+ for (j=0;j<Nx;j++)
+ Pnx[(n-1)*Nx+i] += Sx[i*Nx+j] * Pnx[(n-2)*Nx+j];
+ }
+
+ p0x[n-1] = 0.;
+ if (n==1)
+ p0x[0] = PHI( (( cx-(1.-lx)*hsx)/lx-mu)/sigma, 0.) -
+ PHI( ((-cx-(1.-lx)*hsx)/lx-mu)/sigma, 0.);
+ else
+ for (j=0;j<Nx;j++)
+ p0x[n-1] += wx[j]/lx * phi( ((zx[j]-(1.-lx)*hsx)/lx-mu)/sigma, 0.)/sigma
+ * Pnx[(n-2)*Nx+j];
+
+
+ if (n==1)
+ for (i=0;i<Ns;i++) {
+ Pns[i] = 0.;
+ for (j=0;j<Ns;j++)
+ Pns[i] += 2./Ns * Tn( (2.*zch[j]-cs)/cs, i) * rside[j];
+ if (i==0) Pns[i] /= 2.;
+ }
+ else {
+ for (i=0;i<Ns;i++) {
+ rside[i] = 0.;
+ for (j=0;j<Ns;j++) rside[i] += S1s[i*Ns+j] * Pns[(n-2)*Ns+j];
+ }
+ LU_solve2(S2s,rside,ps,Ns);
+ for (i=0;i<Ns;i++) Pns[(n-1)*Ns+i] = rside[i];
+ }
+
+ p0s[n-1] = 0.;
+ if (n==1)
+ p0s[0] = CHI(ddf/s2*(cs-(1.-ls)*hss)/ls, df);
+ else
+ for (j=0;j<Ns;j++)
+ p0s[n-1] += Pns[(n-1)*Ns+j] * Tn( (2.*hss-cs)/cs, j);
+
+
+ p0[n-1] = p0x[n-1] * p0s[n-1];
+
+ mn_minusx = 1.; mn_plusx = 0.;
+ mn_minuss = 1.; mn_pluss = 0.;
+ if (n>1) {
+ for (i=0;i<Nx;i++) {
+ if (Pnx[(n-1)*Nx+i]==0)
+ if (Pnx[(n-1)*Nx+i]==0) q = 0.;
+ else q = 1.;
+ else q = Pnx[(n-1)*Nx+i]/Pnx[(n-2)*Nx+i];
+ if ( q<mn_minusx ) mn_minusx = q;
+ if ( q>mn_plusx ) mn_plusx = q;
+ }
+
+ for (i=0;i<Ns;i++) {
+ oben = 0.; unten = 0.;
+ for (j=0;j<Ns;j++) {
+ oben += Pns[(n-1)*Ns+j] * Tn( (2.*zch[i]-cs)/cs, j);
+ unten+= Pns[(n-2)*Ns+j] * Tn( (2.*zch[i]-cs)/cs, j);
+ }
+ if (fabs(unten)<1e-16)
+ if (fabs(oben)<1e-16) q = 0.;
+ else q = 1.;
+ else q = oben/unten;
+ if ( q<mn_minuss ) mn_minuss = q;
+ if ( q>mn_pluss ) mn_pluss = q;
+ }
+
+ mn_minus = mn_minusx * mn_minuss;
+ mn_plus = mn_plusx * mn_pluss;
+
+ arl_minus = arl + p0[n-1]/(1.-mn_minus);
+ arl_plus = arl + p0[n-1]/(1.-mn_plus);
+ }
+ arl += p0[n-1];
+ if ( fabs( (arl_plus-arl_minus)/arl_minus )<FINALeps ) n = nmax+1;
+ }
+
+ Free(p0);
+
+ Free(p0s);
+ Free(Pns);
+ Free(zs);
+ Free(ws);
+ Free(rside);
+ Free(zch);
+ Free(ps);
+ Free(S2s);
+ Free(S1s);
+
+ Free(p0x);
+ Free(Pnx);
+ Free(zx);
+ Free(wx);
+ Free(Sx);
+
+ return (arl_plus+arl_minus)/2.;
+}
+
+
+double xseU_sf(double lx, double ls, double cx, double cs, double hsx, double hss, double mu, double sigma, int df, int Nx, int Ns, int nmax, int qm, double *p0)
+{ double *Sx, *Pnx, *wx, *zx, *p0x, *S1s, *S2s, *Pns, *ws, *zs, *p0s, *zch, *rside, za=0., s2, ddf, xl, xu;
+ int i, j, k, n, *ps;
+
+ cx *= sqrt( lx/(2.-lx) );
+ hsx *= sqrt( lx/(2.-lx) );
+
+ s2 = sigma*sigma;
+ ddf = (double)df;
+
+ Sx = matrix(Nx,Nx);
+ wx = vector(Nx);
+ zx = vector(Nx);
+ Pnx = matrix(nmax,Nx);
+ p0x = vector(nmax);
+
+ S1s = matrix(Ns,Ns);
+ S2s = matrix(Ns,Ns);
+ ps = ivector(Ns);
+ zch = vector(Ns);
+ rside = vector(Ns);
+ ws = vector(qm);
+ zs = vector(qm);
+ Pns = matrix(nmax,Ns);
+ p0s = vector(nmax);
+
+ gausslegendre(Nx,-cx,cx,zx,wx);
+
+ for (i=0;i<Nx;i++) {
+ za = (1.-lx)*zx[i];
+ for (j=0;j<Nx;j++)
+ Sx[i*Nx+j] = wx[j]/lx*phi( ((zx[j]-za)/lx-mu)/sigma, 0.)/sigma;
+ }
+
+/* Chebyshev nodes on [0,cs] */
+ for (i=0;i<Ns;i++)
+ zch[i] = cs/2.*(1.+cos(PI*(2.*(i+1.)-1.)/2./(double)Ns) );
+
+/* P(L>1)(zch[i]) */
+ for (i=0;i<Ns;i++)
+ rside[i] = CHI( ddf/s2*(cs-(1.-ls)*zch[i])/ls, df);
+
+ for (i=0;i<Ns;i++) {
+ za = (1.-ls)*zch[i];
+ if (df==2) { xl = za; xu = cs; }
+ else { xl = 0.; xu = sqrt(cs-za); }
+ gausslegendre(qm,xl,xu,zs,ws);
+ for (j=0;j<Ns;j++) {
+ S1s[i*Ns+j] = 0.;
+ for (k=0;k<qm;k++)
+ if (df==2)
+ S1s[i*Ns+j] += ws[k]*Tn((2.*zs[k]-cs)/cs, j) * exp((za-zs[k])/s2/ls);
+ else
+ S1s[i*Ns+j] += ws[k]*Tn((2.*(zs[k]*zs[k]+za)-cs)/cs, j)
+ *2.*pow(zs[k], ddf-1.) * exp(-ddf*zs[k]*zs[k]/2./s2/ls);
+ if (df==2) S1s[i*Ns+j] /= s2*ls;
+ else S1s[i*Ns+j] /= gammafn(ddf/2.) * pow(2.*s2*ls/ddf,ddf/2.);
+ }
+ }
+
+ for (i=0;i<Ns;i++)
+ for (j=0;j<Ns;j++) S2s[i*Ns+j] = Tn( (2.*zch[i]-cs)/cs, j);
+
+ LU_decompose(S2s,ps,Ns);
+
+ for (n=1;n<=nmax;n++) {
+
+ if (n==1)
+ for (i=0;i<Nx;i++)
+ Pnx[i] = PHI( (( cx-(1.-lx)*zx[i])/lx-mu)/sigma, 0.) -
+ PHI( ((-cx-(1.-lx)*zx[i])/lx-mu)/sigma, 0.);
+ else
+ for (i=0;i<Nx;i++) {
+ Pnx[(n-1)*Nx+i] = 0.;
+ for (j=0;j<Nx;j++)
+ Pnx[(n-1)*Nx+i] += Sx[i*Nx+j] * Pnx[(n-2)*Nx+j];
+ }
+
+ p0x[n-1] = 0.;
+ if (n==1)
+ p0x[0] = PHI( (( cx-(1.-lx)*hsx)/lx-mu)/sigma, 0.) -
+ PHI( ((-cx-(1.-lx)*hsx)/lx-mu)/sigma, 0.);
+ else
+ for (j=0;j<Nx;j++)
+ p0x[n-1] += wx[j]/lx * phi( ((zx[j]-(1.-lx)*hsx)/lx-mu)/sigma, 0.)/sigma
+ * Pnx[(n-2)*Nx+j];
+
+ if (n==1)
+ for (i=0;i<Ns;i++) {
+ Pns[i] = 0.;
+ for (j=0;j<Ns;j++)
+ Pns[i] += 2./Ns * Tn( (2.*zch[j]-cs)/cs, i) * rside[j];
+ if (i==0) Pns[i] /= 2.;
+ }
+ else {
+ for (i=0;i<Ns;i++) {
+ rside[i] = 0.;
+ for (j=0;j<Ns;j++) rside[i] += S1s[i*Ns+j] * Pns[(n-2)*Ns+j];
+ }
+ LU_solve2(S2s,rside,ps,Ns);
+ for (i=0;i<Ns;i++) Pns[(n-1)*Ns+i] = rside[i];
+ }
+
+ p0s[n-1] = 0.;
+ if (n==1)
+ p0s[0] = CHI(ddf/s2*(cs-(1.-ls)*hss)/ls, df);
+ else
+ for (j=0;j<Ns;j++)
+ p0s[n-1] += Pns[(n-1)*Ns+j] * Tn( (2.*hss-cs)/cs, j);
+
+
+ p0[n-1] = p0x[n-1] * p0s[n-1];
+ }
+
+ Free(p0s);
+ Free(Pns);
+ Free(zs);
+ Free(ws);
+ Free(rside);
+ Free(zch);
+ Free(ps);
+ Free(S2s);
+ Free(S1s);
+
+ Free(p0x);
+ Free(Pnx);
+ Free(zx);
+ Free(wx);
+ Free(Sx);
+
+ return 0;
+}
+
+
+double xseU_sf_deluxe(double lx, double ls, double cx, double cs, double hsx, double hss, double mu, double sigma, int df, int Nx, int Ns, int nmax, int qm, double *p0, int *nstop, double *rho)
+{ double *Sx, *Pnx, *wx, *zx, *p0x, *S1s, *S2s, *Pns, *ws, *zs, *p0s, q, *zch, *rside, za=0., s2,
+ mn_minus=1., mn_plus=0., mn_minusx, mn_minuss, mn_plusx, mn_pluss, ddf, xl, xu, oben, unten;
+ int i, j, k, n, *ps;
+
+ cx *= sqrt( lx/(2.-lx) );
+ hsx *= sqrt( lx/(2.-lx) );
+
+ s2 = sigma*sigma;
+ ddf = (double)df;
+
+ Sx = matrix(Nx,Nx);
+ wx = vector(Nx);
+ zx = vector(Nx);
+ Pnx = matrix(nmax,Nx);
+ p0x = vector(nmax);
+
+ S1s = matrix(Ns,Ns);
+ S2s = matrix(Ns,Ns);
+ ps = ivector(Ns);
+ zch = vector(Ns);
+ rside = vector(Ns);
+ ws = vector(qm);
+ zs = vector(qm);
+ Pns = matrix(nmax,Ns);
+ p0s = vector(nmax);
+
+ gausslegendre(Nx,-cx,cx,zx,wx);
+
+ for (i=0;i<Nx;i++) {
+ za = (1.-lx)*zx[i];
+ for (j=0;j<Nx;j++)
+ Sx[i*Nx+j] = wx[j]/lx*phi( ((zx[j]-za)/lx-mu)/sigma, 0.)/sigma;
+ }
+
+/* Chebyshev nodes on [0,cs] */
+ for (i=0;i<Ns;i++)
+ zch[i] = cs/2.*(1.+cos(PI*(2.*(i+1.)-1.)/2./(double)Ns) );
+
+/* P(L>1)(zch[i]) */
+ for (i=0;i<Ns;i++)
+ rside[i] = CHI( ddf/s2*(cs-(1.-ls)*zch[i])/ls, df);
+
+ for (i=0;i<Ns;i++) {
+ za = (1.-ls)*zch[i];
+ if (df==2) { xl = za; xu = cs; }
+ else { xl = 0.; xu = sqrt(cs-za); }
+ gausslegendre(qm,xl,xu,zs,ws);
+ for (j=0;j<Ns;j++) {
+ S1s[i*Ns+j] = 0.;
+ for (k=0;k<qm;k++)
+ if (df==2)
+ S1s[i*Ns+j] += ws[k]*Tn((2.*zs[k]-cs)/cs, j) * exp((za-zs[k])/s2/ls);
+ else
+ S1s[i*Ns+j] += ws[k]*Tn((2.*(zs[k]*zs[k]+za)-cs)/cs, j)
+ *2.*pow(zs[k], ddf-1.) * exp(-ddf*zs[k]*zs[k]/2./s2/ls);
+ if (df==2) S1s[i*Ns+j] /= s2*ls;
+ else S1s[i*Ns+j] /= gammafn(ddf/2.) * pow(2.*s2*ls/ddf,ddf/2.);
+ }
+ }
+
+ for (i=0;i<Ns;i++)
+ for (j=0;j<Ns;j++) S2s[i*Ns+j] = Tn( (2.*zch[i]-cs)/cs, j);
+
+ LU_decompose(S2s,ps,Ns);
+
+ for (n=1;n<=nmax;n++) {
+
+ if (n==1)
+ for (i=0;i<Nx;i++)
+ Pnx[i] = PHI( (( cx-(1.-lx)*zx[i])/lx-mu)/sigma, 0.) -
+ PHI( ((-cx-(1.-lx)*zx[i])/lx-mu)/sigma, 0.);
+ else
+ for (i=0;i<Nx;i++) {
+ Pnx[(n-1)*Nx+i] = 0.;
+ for (j=0;j<Nx;j++)
+ Pnx[(n-1)*Nx+i] += Sx[i*Nx+j] * Pnx[(n-2)*Nx+j];
+ }
+
+ p0x[n-1] = 0.;
+ if (n==1)
+ p0x[0] = PHI( (( cx-(1.-lx)*hsx)/lx-mu)/sigma, 0.) -
+ PHI( ((-cx-(1.-lx)*hsx)/lx-mu)/sigma, 0.);
+ else
+ for (j=0;j<Nx;j++)
+ p0x[n-1] += wx[j]/lx * phi( ((zx[j]-(1.-lx)*hsx)/lx-mu)/sigma, 0.)/sigma
+ * Pnx[(n-2)*Nx+j];
+
+
+ if (n==1)
+ for (i=0;i<Ns;i++) {
+ Pns[i] = 0.;
+ for (j=0;j<Ns;j++)
+ Pns[i] += 2./Ns * Tn( (2.*zch[j]-cs)/cs, i) * rside[j];
+ if (i==0) Pns[i] /= 2.;
+ }
+ else {
+ for (i=0;i<Ns;i++) {
+ rside[i] = 0.;
+ for (j=0;j<Ns;j++) rside[i] += S1s[i*Ns+j] * Pns[(n-2)*Ns+j];
+ }
+ LU_solve2(S2s,rside,ps,Ns);
+ for (i=0;i<Ns;i++) Pns[(n-1)*Ns+i] = rside[i];
+ }
+
+ p0s[n-1] = 0.;
+ if (n==1)
+ p0s[0] = CHI(ddf/s2*(cs-(1.-ls)*hss)/ls, df);
+ else
+ for (j=0;j<Ns;j++)
+ p0s[n-1] += Pns[(n-1)*Ns+j] * Tn( (2.*hss-cs)/cs, j);
+
+ p0[n-1] = p0x[n-1] * p0s[n-1];
+
+ mn_minusx = 1.; mn_plusx = 0.;
+ mn_minuss = 1.; mn_pluss = 0.;
+ if ( n > 1 ) {
+ for (i=0;i<Nx;i++) {
+ if (Pnx[(n-1)*Nx+i]==0)
+ if (Pnx[(n-1)*Nx+i]==0) q = 0.;
+ else q = 1.;
+ else q = Pnx[(n-1)*Nx+i]/Pnx[(n-2)*Nx+i];
+ if ( q<mn_minusx ) mn_minusx = q;
+ if ( q>mn_plusx ) mn_plusx = q;
+ }
+
+ for (i=0;i<Ns;i++) {
+ oben = 0.; unten = 0.;
+ for (j=0;j<Ns;j++) {
+ oben += Pns[(n-1)*Ns+j] * Tn( (2.*zch[i]-cs)/cs, j);
+ unten+= Pns[(n-2)*Ns+j] * Tn( (2.*zch[i]-cs)/cs, j);
+ }
+ if (fabs(unten)<1e-16)
+ if (fabs(oben)<1e-16) q = 0.;
+ else q = 1.;
+ else q = oben/unten;
+ if ( q<mn_minuss ) mn_minuss = q;
+ if ( q>mn_pluss ) mn_pluss = q;
+ }
+
+ mn_minus = mn_minusx * mn_minuss;
+ mn_plus = mn_plusx * mn_pluss;
+
+ *rho = (mn_minus + mn_plus)/2.;
+ if ( fabs(mn_plus - mn_minus) < FINALeps ) {
+ *nstop = n;
+ n = nmax + 1;
+ }
+ } /* n > 1 */
+ } /* n=1; n<=nmax; n++ */
+
+ Free(p0s);
+ Free(Pns);
+ Free(zs);
+ Free(ws);
+ Free(rside);
+ Free(zch);
+ Free(ps);
+ Free(S2s);
+ Free(S1s);
+
+ Free(p0x);
+ Free(Pnx);
+ Free(zx);
+ Free(wx);
+ Free(Sx);
+
+ return 0;
+}
+
+
+double xseU_Wq(double lx, double ls, double cx, double cs, double p, double hsx, double hss, double mu, double sigma, int df, int Nx, int Ns, int nmax, int qm)
+{ double *p0, *Sx, *Pnx, *wx, *zx, *p0x, *S1s, *S2s, *Pns, *ws, *zs, *p0s, q, *zch, *rside, za=0., s2,
+ mn_minus=1., mn_plus=0., mn_minusx, mn_minuss, mn_plusx, mn_pluss, ddf, xl, xu, oben, unten, q_minus=0., q_plus=0., enumerator=0., Wq=0.;
+ int i, j, k, n, *ps;
+
+ cx *= sqrt( lx/(2.-lx) );
+ hsx *= sqrt( lx/(2.-lx) );
+
+ s2 = sigma*sigma;
+ ddf = (double)df;
+
+ Sx = matrix(Nx,Nx);
+ wx = vector(Nx);
+ zx = vector(Nx);
+ Pnx = matrix(nmax,Nx);
+ p0x = vector(nmax);
+
+ S1s = matrix(Ns,Ns);
+ S2s = matrix(Ns,Ns);
+ ps = ivector(Ns);
+ zch = vector(Ns);
+ rside = vector(Ns);
+ ws = vector(qm);
+ zs = vector(qm);
+ Pns = matrix(nmax,Ns);
+ p0s = vector(nmax);
+
+ p0 = vector(nmax);
+
+ gausslegendre(Nx,-cx,cx,zx,wx);
+
+ for (i=0;i<Nx;i++) {
+ za = (1.-lx)*zx[i];
+ for (j=0;j<Nx;j++)
+ Sx[i*Nx+j] = wx[j]/lx*phi( ((zx[j]-za)/lx-mu)/sigma, 0.)/sigma;
+ }
+
+/* Chebyshev nodes on [0,cs] */
+ for (i=0;i<Ns;i++)
+ zch[i] = cs/2.*(1.+cos(PI*(2.*(i+1.)-1.)/2./(double)Ns) );
+
+/* P(L>1)(zch[i]) */
+ for (i=0;i<Ns;i++)
+ rside[i] = CHI( ddf/s2*(cs-(1.-ls)*zch[i])/ls, df);
+
+ for (i=0;i<Ns;i++) {
+ za = (1.-ls)*zch[i];
+ if (df==2) { xl = za; xu = cs; }
+ else { xl = 0.; xu = sqrt(cs-za); }
+ gausslegendre(qm,xl,xu,zs,ws);
+ for (j=0;j<Ns;j++) {
+ S1s[i*Ns+j] = 0.;
+ for (k=0;k<qm;k++)
+ if (df==2)
+ S1s[i*Ns+j] += ws[k]*Tn((2.*zs[k]-cs)/cs, j) * exp((za-zs[k])/s2/ls);
+ else
+ S1s[i*Ns+j] += ws[k]*Tn((2.*(zs[k]*zs[k]+za)-cs)/cs, j)
+ *2.*pow(zs[k], ddf-1.) * exp(-ddf*zs[k]*zs[k]/2./s2/ls);
+ if (df==2) S1s[i*Ns+j] /= s2*ls;
+ else S1s[i*Ns+j] /= gammafn(ddf/2.) * pow(2.*s2*ls/ddf,ddf/2.);
+ }
+ }
+
+ for (i=0;i<Ns;i++)
+ for (j=0;j<Ns;j++) S2s[i*Ns+j] = Tn( (2.*zch[i]-cs)/cs, j);
+
+ LU_decompose(S2s,ps,Ns);
+
+ for (n=1; n<=nmax; n++) {
+
+ if (n==1)
+ for (i=0;i<Nx;i++)
+ Pnx[i] = PHI( (( cx-(1.-lx)*zx[i])/lx-mu)/sigma, 0.) -
+ PHI( ((-cx-(1.-lx)*zx[i])/lx-mu)/sigma, 0.);
+ else
+ for (i=0;i<Nx;i++) {
+ Pnx[(n-1)*Nx+i] = 0.;
+ for (j=0;j<Nx;j++)
+ Pnx[(n-1)*Nx+i] += Sx[i*Nx+j] * Pnx[(n-2)*Nx+j];
+ }
+
+ p0x[n-1] = 0.;
+ if (n==1)
+ p0x[0] = PHI( (( cx-(1.-lx)*hsx)/lx-mu)/sigma, 0.) -
+ PHI( ((-cx-(1.-lx)*hsx)/lx-mu)/sigma, 0.);
+ else
+ for (j=0;j<Nx;j++)
+ p0x[n-1] += wx[j]/lx * phi( ((zx[j]-(1.-lx)*hsx)/lx-mu)/sigma, 0.)/sigma
+ * Pnx[(n-2)*Nx+j];
+
+
+ if (n==1)
+ for (i=0;i<Ns;i++) {
+ Pns[i] = 0.;
+ for (j=0;j<Ns;j++)
+ Pns[i] += 2./Ns * Tn( (2.*zch[j]-cs)/cs, i) * rside[j];
+ if (i==0) Pns[i] /= 2.;
+ }
+ else {
+ for (i=0;i<Ns;i++) {
+ rside[i] = 0.;
+ for (j=0;j<Ns;j++) rside[i] += S1s[i*Ns+j] * Pns[(n-2)*Ns+j];
+ }
+ LU_solve2(S2s,rside,ps,Ns);
+ for (i=0;i<Ns;i++) Pns[(n-1)*Ns+i] = rside[i];
+ }
+
+ p0s[n-1] = 0.;
+ if (n==1)
+ p0s[0] = CHI(ddf/s2*(cs-(1.-ls)*hss)/ls, df);
+ else
+ for (j=0;j<Ns;j++)
+ p0s[n-1] += Pns[(n-1)*Ns+j] * Tn( (2.*hss-cs)/cs, j);
+
+ p0[n-1] = p0x[n-1] * p0s[n-1];
+
+ if ( p0[n-1] < 1.-p ) {
+ Wq = (double)n;
+ n = nmax+1;
+ } else {
+ mn_minusx = 1.; mn_plusx = 0.;
+ mn_minuss = 1.; mn_pluss = 0.;
+ if ( n > 1 ) {
+ for (i=0;i<Nx;i++) {
+ if (Pnx[(n-1)*Nx+i]==0)
+ if (Pnx[(n-1)*Nx+i]==0) q = 0.;
+ else q = 1.;
+ else q = Pnx[(n-1)*Nx+i]/Pnx[(n-2)*Nx+i];
+ if ( q<mn_minusx ) mn_minusx = q;
+ if ( q>mn_plusx ) mn_plusx = q;
+ }
+
+ for (i=0;i<Ns;i++) {
+ oben = 0.; unten = 0.;
+ for (j=0;j<Ns;j++) {
+ oben += Pns[(n-1)*Ns+j] * Tn( (2.*zch[i]-cs)/cs, j);
+ unten+= Pns[(n-2)*Ns+j] * Tn( (2.*zch[i]-cs)/cs, j);
+ }
+ if (fabs(unten)<1e-16)
+ if (fabs(oben)<1e-16) q = 0.;
+ else q = 1.;
+ else q = oben/unten;
+ if ( q<mn_minuss ) mn_minuss = q;
+ if ( q>mn_pluss ) mn_pluss = q;
+ }
+
+ mn_minus = mn_minusx * mn_minuss;
+ mn_plus = mn_plusx * mn_pluss;
+
+ enumerator = log( (1.-p)/p0[n-1] );
+ q_minus = (double)n + enumerator/log(mn_minus);
+ q_plus = (double)n + enumerator/log(mn_plus);
+ if ( fabs( ceil(q_plus) - ceil(q_minus) ) < .5 ) {
+ Wq = ceil(q_plus);
+ n = nmax +1;
+ }
+
+ } /* n > 1 */
+ } /* p0[n-1] >= 1.-p */
+ } /* n=1; n<=nmax; n++ */
+
+ Free(p0);
+
+ Free(p0s);
+ Free(Pns);
+ Free(zs);
+ Free(ws);
+ Free(rside);
+ Free(zch);
+ Free(ps);
+ Free(S2s);
+ Free(S1s);
+
+ Free(p0x);
+ Free(Pnx);
+ Free(zx);
+ Free(wx);
+ Free(Sx);
+
+ return Wq;
+}
+
+
+int xseU_crit(double lx, double ls, double L0, double *cx, double *cs, double hsx, double hss, double mu, double sigma, int df, int Nx, int Ns, int nmax, int qm)
+{ double x1, x2, dx, s1, s2, ds, xARL1, xARL2, sARL1, sARL2, xsARL22, xsARL12, xsARL21,
+ f11, f22, f21, f12, d11, d22, d21, d12, nenner, zr=0., c0=-1.;
+
+ x1 = xe_crit(ewma2,lx,2.*L0,zr,hsx,mu,fix,Nx,c0) - .1;
+ x2 = x1 + .1;
+ s1 = seU_crit(ls,2.*L0,hss,sigma,df,Ns,qm);
+ s2 = s1 + .05;
+
+ xARL2 = xe2_iglarl(lx,x2,hsx,mu,Nx);
+ sARL2 = seU_iglarl(ls,s2,hss,sigma,df,Ns,qm);
+ xsARL22 = xseU_arl(lx,ls,x2,s2,hsx,hss,mu,sigma,df,Nx,Ns,nmax,qm);
+ do {
+ xARL1 = xe2_iglarl(lx,x1,hsx,mu,Nx);
+ sARL1 = seU_iglarl(ls,s1,hss,sigma,df,Ns,qm);
+ xsARL21 = xseU_arl(lx,ls,x2,s1,hsx,hss,mu,sigma,df,Nx,Ns,nmax,qm);
+ xsARL12 = xseU_arl(lx,ls,x1,s2,hsx,hss,mu,sigma,df,Nx,Ns,nmax,qm);
+
+ /* difference quotient */
+ f11 = (xsARL22 - xsARL12)/(x2-x1); f12 = (xsARL22 - xsARL21)/(s2-s1);
+ f21 = (xARL2 - xARL1)/(x2-x1); f22 = (sARL1 - sARL2)/(s2-s1);
+
+ /* inverse of the difference quotient */
+ nenner = f11*f22 - f12*f21;
+ d11 = f22/nenner; d12 = -f12/nenner;
+ d21 = -f21/nenner; d22 = f11/nenner;
+
+ dx = d11*(xsARL22-L0) + d12*(xARL2-sARL2);
+ ds = d21*(xsARL22-L0) + d22*(xARL2-sARL2);
+
+ x1 = x2; s1 = s2;
+ x2 -= dx; s2 -= ds;
+
+ xARL2 = xe2_iglarl(lx,x2,hsx,mu,Nx);
+ sARL2 = seU_iglarl(ls,s2,hss,sigma,df,Ns,qm);
+ xsARL22 = xseU_arl(lx,ls,x2,s2,hsx,hss,mu,sigma,df,Nx,Ns,nmax,qm);
+ } while ( (fabs(L0-xsARL22)>1e-6 || fabs(xARL2-sARL2)>1e-6) && (fabs(x2-x1)>1e-8 || fabs(s2-s1)>1e-8) );
+
+ *cx = x2; *cs = s2;
+
+ return 0;
+}
+
+
+int xseU_q_crit(double lx, double ls, int L0, double alpha, double *cx, double *cs, double hsx, double hss, double mu, double sigma, int df, int Nx, int Ns, int qm, double c_error, double a_error)
+
+{ double x1, x2, dx, s1, s2, ds, xp1, xp2, sp1, sp2, xsp22, xsp12, xsp21,
+ f11, f22, f21, f12, d11, d22, d21, d12, nenner, zr=0., *SF;
+ int result=1;
+
+ SF = vector(L0);
+
+ x1 = xe_q_crit(ewma2, lx, L0, 1. - sqrt(1.-alpha), zr, hsx, mu, fix, Nx, c_error, a_error);
+ x2 = x1 + .1;
+ s1 = seU_q_crit(ls, L0, 1. - sqrt(1.-alpha), hss, sigma, df, Ns, qm, c_error, a_error);
+ s2 = s1 + .05;
+
+ result = xe2_sf(lx, x2, hsx, mu, Nx, L0, SF);
+ if ( result != 0 ) warning("trouble with xseU_q_crit calling xe2_sf [package spc]");
+ xp2 = 1. - SF[L0-1];
+ result = seU_sf(ls, s2, hss, sigma, df, Ns, L0, qm, SF);
+ if ( result != 0 ) warning("trouble with xseU_q_crit calling seU_sf [package spc]");
+ sp2 = 1. - SF[L0-1];
+ result = xseU_sf(lx, ls, x2, s2, hsx, hss, mu, sigma, df, Nx, Ns, L0, qm, SF);
+ if ( result != 0 ) warning("trouble with xseU_q_crit calling xseU_sf [package spc]");
+ xsp22 = 1. - SF[L0-1];
+
+ do {
+ result = xe2_sf(lx, x1, hsx, mu, Nx, L0, SF);
+ if ( result != 0 ) warning("trouble with xseU_q_crit calling xe2_sf [package spc]");
+ xp1 = 1. - SF[L0-1];
+ result = seU_sf(ls, s1, hss, sigma, df, Ns, L0, qm, SF);
+ if ( result != 0 ) warning("trouble with xseU_q_crit calling seU_sf [package spc]");
+ sp1 = 1. - SF[L0-1];
+ result = xseU_sf(lx, ls, x2, s1, hsx, hss, mu, sigma, df, Nx, Ns, L0, qm, SF);
+ if ( result != 0 ) warning("trouble with xseU_q_crit calling xseU_sf [package spc]");
+ xsp21 = 1. - SF[L0-1];
+ result = xseU_sf(lx, ls, x1, s2, hsx, hss, mu, sigma, df, Nx, Ns, L0, qm, SF);
+ if ( result != 0 ) warning("trouble with xseU_q_crit calling xseU_sf [package spc]");
+ xsp12 = 1. - SF[L0-1];
+
+ /* difference quotient */
+ f11 = (xsp22 - xsp12)/(x2-x1); f12 = (xsp22 - xsp21)/(s2-s1);
+ f21 = (xp2 - xp1)/(x2-x1); f22 = (sp1 - sp2)/(s2-s1);
+
+ /* inverse of the difference quotient */
+ nenner = f11*f22 - f12*f21;
+ d11 = f22/nenner; d12 = -f12/nenner;
+ d21 = -f21/nenner; d22 = f11/nenner;
+
+ dx = d11*(xsp22-alpha) + d12*(xp2-sp2);
+ ds = d21*(xsp22-alpha) + d22*(xp2-sp2);
+
+ x1 = x2; s1 = s2;
+ x2 -= dx; s2 -= ds;
+
+ result = xe2_sf(lx, x2, hsx, mu, Nx, L0, SF);
+ if ( result != 0 ) warning("trouble with xseU_q_crit calling xe2_sf [package spc]");
+ xp2 = 1. - SF[L0-1];
+ result = seU_sf(ls, s2, hss, sigma, df, Ns, L0, qm, SF);
+ if ( result != 0 ) warning("trouble with xseU_q_crit calling seU_sf [package spc]");
+ sp2 = 1. - SF[L0-1];
+ result = xseU_sf(lx, ls, x2, s2, hsx, hss, mu, sigma, df, Nx, Ns, L0, qm, SF);
+ if ( result != 0 ) warning("trouble with xseU_q_crit calling xseU_sf [package spc]");
+ xsp22 = 1. - SF[L0-1];
+
+ } while ( (fabs(alpha - xsp22)>a_error || fabs(xp2-sp2)>a_error) && (fabs(x2-x1)>c_error || fabs(s2-s1)>c_error) );
+
+ *cx = x2; *cs = s2;
+
+ Free(SF);
+
+ return 0;
+}
+
+
+int xse2fu_q_crit(double lx, double ls, int L0, double alpha, double *cx, double *csl, double csu, double hsx, double hss, double mu, double sigma, int df, int Nx, int Ns, int qm, double c_error, double a_error)
+{ double x1, x2, dx, s1, s2, ds, xp1, xp2, sp1, sp2, xsp22, xsp12, xsp21,
+ f11, f22, f21, f12, d11, d22, d21, d12, nenner, zr=0., *SF;
+ int result=1;
+
+ SF = vector(L0);
+
+ x1 = xe_q_crit(ewma2, lx, L0, 1. - sqrt(1.-alpha), zr, hsx, mu, fix, Nx, c_error, a_error);
+ x2 = x1 + .05;
+ s1 = se2fu_q_crit(ls, L0, 1. - sqrt(1.-alpha), csu, hss, sigma, df, Ns, qm, c_error, a_error);
+ s2 = s1 + .05;
+
+ result = xe2_sf(lx, x2, hsx, mu, Nx, L0, SF);
+ if ( result != 0 ) warning("trouble with xse2fu_q_crit calling xe2_sf [package spc]");
+ xp2 = 1. - SF[L0-1];
+ result = se2_sf(ls, s2, csu, hss, sigma, df, Ns, L0, qm, SF);
+ if ( result != 0 ) warning("trouble with xse2fu_q_crit calling se2_sf [package spc]");
+ sp2 = 1. - SF[L0-1];
+ result = xse2_sf(lx, ls, x2, s2, csu, hsx, hss, mu, sigma, df, Nx, Ns, L0, qm, SF);
+ if ( result != 0 ) warning("trouble with xse2fu_q_crit calling xse2_sf [package spc]");
+ xsp22 = 1. - SF[L0-1];
+
+ do {
+ result = xe2_sf(lx, x1, hsx, mu, Nx, L0, SF);
+ if ( result != 0 ) warning("trouble with xse2fu_q_crit calling xe2_sf [package spc]");
+ xp1 = 1. - SF[L0-1];
+ result = se2_sf(ls, s1, csu, hss, sigma, df, Ns, L0, qm, SF);
+ if ( result != 0 ) warning("trouble with xse2fu_q_crit calling se2_sf [package spc]");
+ sp1 = 1. - SF[L0-1];
+ result = xse2_sf(lx, ls, x2, s1, csu, hsx, hss, mu, sigma, df, Nx, Ns, L0, qm, SF);
+ if ( result != 0 ) warning("trouble with xse2fu_q_crit calling xse2_sf [package spc]");
+ xsp21 = 1. - SF[L0-1];
+ result = xse2_sf(lx, ls, x1, s2, csu, hsx, hss, mu, sigma, df, Nx, Ns, L0, qm, SF);
+ if ( result != 0 ) warning("trouble with xse2fu_q_crit calling xse2_sf [package spc]");
+ xsp12 = 1. - SF[L0-1];
+
+ /* difference quotient */
+ f11 = (xsp22 - xsp12)/(x2-x1); f12 = (xsp22 - xsp21)/(s2-s1);
+ f21 = (xp2 - xp1)/(x2-x1); f22 = (sp1 - sp2)/(s2-s1);
+
+ /* inverse of the difference quotient */
+ nenner = f11*f22 - f12*f21;
+ d11 = f22/nenner; d12 = -f12/nenner;
+ d21 = -f21/nenner; d22 = f11/nenner;
+
+ dx = d11*(xsp22-alpha) + d12*(xp2-sp2);
+ ds = d21*(xsp22-alpha) + d22*(xp2-sp2);
+
+ x1 = x2; s1 = s2;
+ x2 -= dx; s2 -= ds;
+
+ result = xe2_sf(lx, x2, hsx, mu, Nx, L0, SF);
+ if ( result != 0 ) warning("trouble with xse2fu_q_crit calling xe2_sf [package spc]");
+ xp2 = 1. - SF[L0-1];
+ result = se2_sf(ls, s2, csu, hss, sigma, df, Ns, L0, qm, SF);
+ if ( result != 0 ) warning("trouble with xse2fu_q_crit calling se2_sf [package spc]");
+ sp2 = 1. - SF[L0-1];
+ result = xse2_sf(lx, ls, x2, s2, csu, hsx, hss, mu, sigma, df, Nx, Ns, L0, qm, SF);
+ if ( result != 0 ) warning("trouble with xse2fu_q_crit calling xse2_sf [package spc]");
+ xsp22 = 1. - SF[L0-1];
+ } while ( (fabs(alpha - xsp22)>a_error || fabs(xp2-sp2)>a_error) && (fabs(x2-x1)>c_error || fabs(s2-s1)>c_error) );
+
+ *cx = x2; *csl = s2;
+
+ Free(SF);
+
+ return 0;
+}
+
+
+int xse2_q_crit(double lx, double ls, int L0, double alpha, double *cx, double *csl, double *csu, double hsx, double hss, double mu, double sigma, int df, int Nx, int Ns, int qm, double c_error, double a_error)
+{ double s1, s2, s3, ds, sl1, sl2, sl3, Lm, Lp, x, cl, *SF;
+ int result=1;
+
+ SF = vector(L0);
+
+ cl = 0.;
+ result = xseU_q_crit(lx, ls, L0, alpha, &x, &s1, hsx, hss, mu, sigma, df, Nx, Ns, qm, c_error, a_error);
+ if ( result != 0 ) warning("trouble with xse2_q_crit calling xseU_q_crit [package spc]");
+ result = xseU_sf(lx, ls, x, s1, hsx, hss, mu, sigma-lmEPS, df, Nx, Ns, L0, qm, SF);
+ if ( result != 0 ) warning("trouble with xse2_q_crit calling xseU_sf [package spc]");
+ Lm = 1. - SF[L0-1];
+ result = xseU_sf(lx, ls, x, s1, hsx, hss, mu, sigma+lmEPS, df, Nx, Ns, L0, qm, SF);
+ if ( result != 0 ) warning("trouble with xse2_q_crit calling xseU_sf [package spc]");
+ Lp = 1. - SF[L0-1];
+ sl1 = (Lp-Lm)/(2.*lmEPS);
+
+ s2 = s1 + .15;
+ result = xse2fu_q_crit(lx, ls, L0, alpha, &x, &cl, s2, hsx, hss, mu, sigma, df, Nx, Ns, qm, c_error, a_error);
+ if ( result != 0 ) warning("trouble with xse2_q_crit calling xse2fu_q_crit [package spc]");
+ result = xse2_sf(lx, ls, x, cl, s2, hsx, hss, mu, sigma-lmEPS, df, Nx, Ns, L0, qm, SF);
+ if ( result != 0 ) warning("trouble with xse2_q_crit calling xse2_sf [package spc]");
+ Lm = 1. - SF[L0-1];
+ result = xse2_sf(lx, ls, x, cl, s2, hsx, hss, mu, sigma+lmEPS, df, Nx, Ns, L0, qm, SF);
+ if ( result != 0 ) warning("trouble with xse2_q_crit calling xse2_sf [package spc]");
+ Lp = 1. - SF[L0-1];
+ sl2 = (Lp-Lm)/(2.*lmEPS);
+
+ do {
+ s3 = s1 - sl1/(sl2-sl1) * (s2-s1);
+ result = xse2fu_q_crit(lx, ls, L0, alpha, &x, &cl, s3, hsx, hss, mu, sigma, df, Nx, Ns, qm, c_error, a_error);
+ if ( result != 0 ) warning("trouble with xse2_q_crit calling xse2fu_q_crit [package spc]");
+ result = xse2_sf(lx, ls, x, cl, s3, hsx, hss, mu, sigma-lmEPS, df, Nx, Ns, L0, qm, SF);
+ if ( result != 0 ) warning("trouble with xse2_q_crit calling xse2_sf [package spc]");
+ Lm = 1. - SF[L0-1];
+ result = xse2_sf(lx, ls, x, cl, s3, hsx, hss, mu, sigma+lmEPS, df, Nx, Ns, L0, qm, SF);
+ if ( result != 0 ) warning("trouble with xse2_q_crit calling xse2_sf [package spc]");
+ Lp = 1. - SF[L0-1];
+ sl3 = (Lp-Lm)/(2.*lmEPS);
+ ds = s3-s2; s1 = s2; sl1 = sl2; s2 = s3; sl2 = sl3;
+ } while ( fabs(sl3)>a_error && fabs(ds)>c_error );
+
+ *cx = x; *csl = cl; *csu = s3;
+
+ Free(SF);
+
+ return 0;
+}
+
+
+double xse2_arl(double lx, double ls, double cx, double csl, double csu, double hsx, double hss, double mu, double sigma, int df, int Nx, int Ns, int nmax, int qm)
+{ double *Sx, *Pnx, *wx, *zx, *p0x, *p0, *S1s, *S2s, *Pns, *ws, *zs, *p0s, q, *zch, *rside, *b, za=0., s2, dN, Hij,
+ arl_minus=0., arl, arl_plus=0., mn_minus=1., mn_plus=0., mn_minusx, mn_minuss, mn_plusx, mn_pluss, ddf, xl, xu, oben, unten;
+ int i, j, k, n, *ps, Ntilde, ihs, M, NN, ii, jj;
+
+ cx *= sqrt( lx/(2.-lx) );
+ hsx *= sqrt( lx/(2.-lx) );
+
+ M = ceil( (log(csl)-log(csu))/log(1.-ls) );
+ Ntilde = ceil( (double)Ns/(double)M );
+ NN = M*Ntilde;
+ s2 = sigma*sigma;
+ ddf = (double)df;
+ dN = (double)Ntilde;
+
+ ihs = floor( (log(csl)-log(hss))/log(1.-ls) );
+ if (ihs<0) ihs = 0;
+
+ Sx = matrix(Nx,Nx);
+ wx = vector(Nx);
+ zx = vector(Nx);
+ Pnx = matrix(nmax,Nx);
+ p0x = vector(nmax);
+
+ S1s = matrix(NN,NN);
+ S2s = matrix(NN,NN);
+ ps = ivector(NN);
+ zch = matrix(M,Ntilde);
+ rside = vector(NN);
+ b = vector(M+1);
+ ws = vector(qm);
+ zs = vector(qm);
+ Pns = matrix(nmax,NN);
+ p0s = vector(nmax);
+
+ p0 = vector(nmax);
+
+ gausslegendre(Nx,-cx,cx,zx,wx);
+
+ for (i=0;i<Nx;i++) {
+ za = (1.-lx)*zx[i];
+ for (j=0;j<Nx;j++)
+ Sx[i*Nx+j] = wx[j]/lx*phi( ((zx[j]-za)/lx-mu)/sigma, 0.)/sigma;
+ }
+
+/* interval borders b_i = cl/(1-l)^i */
+ for (i=0;i<M;i++) b[i] = csl/pow(1.-ls, (double)(i));
+ b[M] = csu;
+
+ /* Chebyshev nodes on [b_0,b_1],[b_1,b_2],...,[b_M-1,cu] */
+ for (i=0;i<M;i++)
+ for (j=0;j<Ntilde;j++) {
+ zch[ i*Ntilde+j ] = b[i] + (b[i+1]-b[i])/2.*(1.+cos(PI*(2.*j+1.)/2./dN));
+ }
+
+ /* P(L>1)(zch[i,j]) */
+ for (i=0;i<M;i++)
+ for (j=0;j<Ntilde;j++) {
+ rside[ i*Ntilde+j ] = CHI( ddf/s2*(csu-(1.-ls)*zch[ i*Ntilde+j ])/ls, df)
+ - CHI( ddf/s2*(csl-(1.-ls)*zch[ i*Ntilde+j ])/ls, df);
+ }
+
+ for (i=0;i<M;i++)
+ for (j=0;j<Ntilde;j++) {
+ za = (1.-ls)*zch[ i*Ntilde+j ];
+ for (ii=0;ii<M;ii++)
+ for (jj=0;jj<Ntilde;jj++) {
+ if (b[ii+1]<za) S1s[ (i*Ntilde+j)*NN + ii*Ntilde+jj ] = 0.;
+ else {
+ if (za<b[ii]) xl = b[ii]; else xl = za;
+ xu = b[ii+1];
+ if (df!=2) {
+ xl = sqrt(xl-za);
+ xu = sqrt(xu-za);
+ }
+ gausslegendre(qm,xl,xu,zs,ws);
+ Hij = 0.;
+ for (k=0;k<qm;k++)
+ if (df==2)
+ Hij += ws[k]*Tn( (2.*zs[k]-b[ii+1]-b[ii])/(b[ii+1]-b[ii]), jj)
+ * exp(-zs[k]/s2/ls);
+ else
+ Hij +=
+ ws[k]*Tn( (2.*(zs[k]*zs[k]+za)-b[ii+1]-b[ii])/(b[ii+1]-b[ii]), jj)
+ * 2. * pow(zs[k], ddf-1.) * exp(-ddf*zs[k]*zs[k]/2./s2/ls);
+
+ if (df==2) Hij *= exp(za/s2/ls)/s2/ls;
+ else Hij /= gammafn(ddf/2.) * pow(2.*s2*ls/ddf, ddf/2.);
+ S1s[ (i*Ntilde+j)*NN + ii*Ntilde+jj ] = Hij;
+ }
+ }
+ }
+
+ for (i=0;i<NN;i++)
+ for (j=0;j<NN;j++) S2s[i*NN+j] = 0.;
+
+ for (i=0;i<M;i++)
+ for (j=0;j<Ntilde;j++)
+ for (jj=0;jj<Ntilde;jj++)
+ S2s[ (i*Ntilde+j)*NN + i*Ntilde+jj ] =
+ Tn( (2.*zch[ i*Ntilde+j ]-b[i+1]-b[i])/(b[i+1]-b[i]), jj);
+
+ LU_decompose(S2s,ps,NN);
+
+ arl = 1.;
+
+ for (n=1;n<=nmax;n++) {
+
+ if (n==1)
+ for (i=0;i<Nx;i++)
+ Pnx[i] = PHI( (( cx-(1.-lx)*zx[i])/lx-mu)/sigma, 0.) -
+ PHI( ((-cx-(1.-lx)*zx[i])/lx-mu)/sigma, 0.);
+ else
+ for (i=0;i<Nx;i++) {
+ Pnx[(n-1)*Nx+i] = 0.;
+ for (j=0;j<Nx;j++)
+ Pnx[(n-1)*Nx+i] += Sx[i*Nx+j] * Pnx[(n-2)*Nx+j];
+ }
+
+ p0x[n-1] = 0.;
+ if (n==1)
+ p0x[0] = PHI( (( cx-(1.-lx)*hsx)/lx-mu)/sigma, 0.) -
+ PHI( ((-cx-(1.-lx)*hsx)/lx-mu)/sigma, 0.);
+ else
+ for (j=0;j<Nx;j++)
+ p0x[n-1] += wx[j]/lx * phi( ((zx[j]-(1.-lx)*hsx)/lx-mu)/sigma, 0.)/sigma
+ * Pnx[(n-2)*Nx+j];
+
+ if (n==1)
+ for (i=0;i<M;i++)
+ for (j=0;j<Ntilde;j++) {
+ Pns[ i*Ntilde+j ] = 0.;
+ for (jj=0;jj<Ntilde;jj++)
+ Pns[ i*Ntilde+j ] += /* usual Chebyshev approximation */
+ 2./Ntilde * Tn( (2.*zch[i*Ntilde+jj]-b[i+1]-b[i])/(b[i+1]-b[i]), j)
+ * rside[ i*Ntilde+jj ];
+ if (j==0) Pns[ i*Ntilde+j ] /= 2.;
+ }
+ else {
+ for (i=0;i<NN;i++) {
+ rside[i] = 0.;
+ for (j=0;j<NN;j++) rside[i] += S1s[ i*NN+j ] * Pns[ (n-2)*NN+j ];
+ }
+ LU_solve2(S2s,rside,ps,NN);
+ for (i=0;i<NN;i++) Pns[ (n-1)*NN+i ] = rside[i];
+ }
+
+ p0s[n-1] = 0.;
+ if (n==1)
+ p0s[0] = CHI( ddf/s2*(csu-(1.-ls)*hss)/ls, df)
+ - CHI( ddf/s2*(csl-(1.-ls)*hss)/ls, df);
+ else
+ for (j=0;j<Ntilde;j++)
+ p0s[n-1] += Pns[ (n-1)*NN + ihs*Ntilde+j ]
+ * Tn( (2.*hss-b[ihs+1]-b[ihs])/(b[ihs+1]-b[ihs]), j);
+
+
+ p0[n-1] = p0x[n-1] * p0s[n-1];
+
+ mn_minusx = 1.; mn_plusx = 0.;
+ mn_minuss = 1.; mn_pluss = 0.;
+ if (n>1) {
+ for (i=0;i<Nx;i++) {
+ if (Pnx[(n-1)*Nx+i]==0)
+ if (Pnx[(n-1)*Nx+i]==0) q = 0.;
+ else q = 1.;
+ else q = Pnx[(n-1)*Nx+i]/Pnx[(n-2)*Nx+i];
+ if ( q<mn_minusx ) mn_minusx = q;
+ if ( q>mn_plusx ) mn_plusx = q;
+ }
+
+ for (i=0;i<M;i++)
+ for (j=0;j<Ntilde;j++) {
+ oben = 0.;
+ unten = 0.;
+ for (jj=0;jj<Ntilde;jj++) {
+ oben += Pns[ (n-1)*NN + i*Ntilde+jj ]
+ * Tn((2.*zch[i*Ntilde+j]-b[i+1]-b[i])/(b[i+1]-b[i]), jj);
+ unten+= Pns[ (n-2)*NN + i*Ntilde+jj ]
+ * Tn((2.*zch[i*Ntilde+j]-b[i+1]-b[i])/(b[i+1]-b[i]), jj);
+ }
+ if (fabs(unten)<1e-16)
+ if (fabs(oben)<1e-16) q = 0.;
+ else q = 1.;
+ else q = oben/unten;
+ if ( q<mn_minuss ) mn_minuss = q;
+ if ( q>mn_pluss ) mn_pluss = q;
+ }
+
+ mn_minus = mn_minusx * mn_minuss;
+ mn_plus = mn_plusx * mn_pluss;
+
+ arl_minus = arl + p0[n-1]/(1.-mn_minus);
+ arl_plus = arl + p0[n-1]/(1.-mn_plus);
+ }
+ arl += p0[n-1];
+
+ if ( fabs( (arl_plus-arl_minus)/arl_minus )<FINALeps ) n = nmax+1;
+ }
+
+ Free(p0);
+
+ Free(p0s);
+ Free(Pns);
+ Free(zs);
+ Free(ws);
+ Free(b);
+ Free(rside);
+ Free(zch);
+ Free(ps);
+ Free(S2s);
+ Free(S1s);
+
+ Free(p0x);
+ Free(Pnx);
+ Free(zx);
+ Free(wx);
+ Free(Sx);
+
+ return (arl_plus+arl_minus)/2.;
+}
+
+
+double xse2_sf(double lx, double ls, double cx, double csl, double csu, double hsx, double hss, double mu, double sigma, int df, int Nx, int Ns, int nmax, int qm, double *p0)
+{ double *Sx, *Pnx, *wx, *zx, *p0x, *S1s, *S2s, *Pns, *ws, *zs, *p0s, *zch, *rside, *b, za=0., s2, dN, Hij, ddf, xl, xu;
+ int i, j, k, n, *ps, Ntilde, ihs, M, NN, ii, jj;
+
+ cx *= sqrt( lx/(2.-lx) );
+ hsx *= sqrt( lx/(2.-lx) );
+
+ M = ceil( (log(csl)-log(csu))/log(1.-ls) );
+ Ntilde = ceil( (double)Ns/(double)M );
+ NN = M*Ntilde;
+ s2 = sigma*sigma;
+ ddf = (double)df;
+ dN = (double)Ntilde;
+
+ ihs = floor( (log(csl)-log(hss))/log(1.-ls) );
+ if (ihs<0) ihs = 0;
+
+ Sx = matrix(Nx,Nx);
+ wx = vector(Nx);
+ zx = vector(Nx);
+ Pnx = matrix(nmax,Nx);
+ p0x = vector(nmax);
+
+ S1s = matrix(NN,NN);
+ S2s = matrix(NN,NN);
+ ps = ivector(NN);
+ zch = matrix(M,Ntilde);
+ rside = vector(NN);
+ b = vector(M+1);
+ ws = vector(qm);
+ zs = vector(qm);
+ Pns = matrix(nmax,NN);
+ p0s = vector(nmax);
+
+ gausslegendre(Nx,-cx,cx,zx,wx);
+
+ for (i=0;i<Nx;i++) {
+ za = (1.-lx)*zx[i];
+ for (j=0;j<Nx;j++)
+ Sx[i*Nx+j] = wx[j]/lx*phi( ((zx[j]-za)/lx-mu)/sigma, 0.)/sigma;
+ }
+
+/* interval borders b_i = cl/(1-l)^i */
+ for (i=0;i<M;i++) b[i] = csl/pow(1.-ls, (double)(i));
+ b[M] = csu;
+
+ /* Chebyshev nodes on [b_0,b_1],[b_1,b_2],...,[b_M-1,cu] */
+ for (i=0;i<M;i++)
+ for (j=0;j<Ntilde;j++) {
+ zch[ i*Ntilde+j ] = b[i] + (b[i+1]-b[i])/2.*(1.+cos(PI*(2.*j+1.)/2./dN));
+ }
+
+ /* P(L>1)(zch[i,j]) */
+ for (i=0;i<M;i++)
+ for (j=0;j<Ntilde;j++) {
+ rside[ i*Ntilde+j ] = CHI( ddf/s2*(csu-(1.-ls)*zch[ i*Ntilde+j ])/ls, df)
+ - CHI( ddf/s2*(csl-(1.-ls)*zch[ i*Ntilde+j ])/ls, df);
+ }
+
+ for (i=0;i<M;i++)
+ for (j=0;j<Ntilde;j++) {
+ za = (1.-ls)*zch[ i*Ntilde+j ];
+ for (ii=0;ii<M;ii++)
+ for (jj=0;jj<Ntilde;jj++) {
+ if (b[ii+1]<za) S1s[ (i*Ntilde+j)*NN + ii*Ntilde+jj ] = 0.;
+ else {
+ if (za<b[ii]) xl = b[ii]; else xl = za;
+ xu = b[ii+1];
+ if (df!=2) {
+ xl = sqrt(xl-za);
+ xu = sqrt(xu-za);
+ }
+ gausslegendre(qm,xl,xu,zs,ws);
+ Hij = 0.;
+ for (k=0;k<qm;k++)
+ if (df==2)
+ Hij += ws[k]*Tn( (2.*zs[k]-b[ii+1]-b[ii])/(b[ii+1]-b[ii]), jj)
+ * exp(-zs[k]/s2/ls);
+ else
+ Hij +=
+ ws[k]*Tn( (2.*(zs[k]*zs[k]+za)-b[ii+1]-b[ii])/(b[ii+1]-b[ii]), jj)
+ * 2. * pow(zs[k], ddf-1.) * exp(-ddf*zs[k]*zs[k]/2./s2/ls);
+
+ if (df==2) Hij *= exp(za/s2/ls)/s2/ls;
+ else Hij /= gammafn(ddf/2.) * pow(2.*s2*ls/ddf, ddf/2.);
+ S1s[ (i*Ntilde+j)*NN + ii*Ntilde+jj ] = Hij;
+ }
+ }
+ }
+
+ for (i=0;i<NN;i++)
+ for (j=0;j<NN;j++) S2s[i*NN+j] = 0.;
+
+ for (i=0;i<M;i++)
+ for (j=0;j<Ntilde;j++)
+ for (jj=0;jj<Ntilde;jj++)
+ S2s[ (i*Ntilde+j)*NN + i*Ntilde+jj ] =
+ Tn( (2.*zch[ i*Ntilde+j ]-b[i+1]-b[i])/(b[i+1]-b[i]), jj);
+
+ LU_decompose(S2s,ps,NN);
+
+ for (n=1;n<=nmax;n++) {
+
+ if (n==1)
+ for (i=0;i<Nx;i++)
+ Pnx[i] = PHI( (( cx-(1.-lx)*zx[i])/lx-mu)/sigma, 0.) -
+ PHI( ((-cx-(1.-lx)*zx[i])/lx-mu)/sigma, 0.);
+ else
+ for (i=0;i<Nx;i++) {
+ Pnx[(n-1)*Nx+i] = 0.;
+ for (j=0;j<Nx;j++)
+ Pnx[(n-1)*Nx+i] += Sx[i*Nx+j] * Pnx[(n-2)*Nx+j];
+ }
+
+ p0x[n-1] = 0.;
+ if (n==1)
+ p0x[0] = PHI( (( cx-(1.-lx)*hsx)/lx-mu)/sigma, 0.) -
+ PHI( ((-cx-(1.-lx)*hsx)/lx-mu)/sigma, 0.);
+ else
+ for (j=0;j<Nx;j++)
+ p0x[n-1] += wx[j]/lx * phi( ((zx[j]-(1.-lx)*hsx)/lx-mu)/sigma, 0.)/sigma
+ * Pnx[(n-2)*Nx+j];
+
+ if (n==1)
+ for (i=0;i<M;i++)
+ for (j=0;j<Ntilde;j++) {
+ Pns[ i*Ntilde+j ] = 0.;
+ for (jj=0;jj<Ntilde;jj++)
+ Pns[ i*Ntilde+j ] += /* usual Chebyshev approximation */
+ 2./Ntilde * Tn( (2.*zch[i*Ntilde+jj]-b[i+1]-b[i])/(b[i+1]-b[i]), j)
+ * rside[ i*Ntilde+jj ];
+ if (j==0) Pns[ i*Ntilde+j ] /= 2.;
+ }
+ else {
+ for (i=0;i<NN;i++) {
+ rside[i] = 0.;
+ for (j=0;j<NN;j++) rside[i] += S1s[ i*NN+j ] * Pns[ (n-2)*NN+j ];
+ }
+ LU_solve2(S2s,rside,ps,NN);
+ for (i=0;i<NN;i++) Pns[ (n-1)*NN+i ] = rside[i];
+ }
+
+ p0s[n-1] = 0.;
+ if (n==1)
+ p0s[0] = CHI( ddf/s2*(csu-(1.-ls)*hss)/ls, df)
+ - CHI( ddf/s2*(csl-(1.-ls)*hss)/ls, df);
+ else
+ for (j=0;j<Ntilde;j++)
+ p0s[n-1] += Pns[ (n-1)*NN + ihs*Ntilde+j ]
+ * Tn( (2.*hss-b[ihs+1]-b[ihs])/(b[ihs+1]-b[ihs]), j);
+
+
+ p0[n-1] = p0x[n-1] * p0s[n-1];
+ }
+
+ Free(p0s);
+ Free(Pns);
+ Free(zs);
+ Free(ws);
+ Free(b);
+ Free(rside);
+ Free(zch);
+ Free(ps);
+ Free(S2s);
+ Free(S1s);
+
+ Free(p0x);
+ Free(Pnx);
+ Free(zx);
+ Free(wx);
+ Free(Sx);
+
+ return 0;
+}
+
+
+double xse2_sf_deluxe(double lx, double ls, double cx, double csl, double csu, double hsx, double hss, double mu, double sigma, int df, int Nx, int Ns, int nmax, int qm, double *p0, int *nstop, double *rho)
+{ double *Sx, *Pnx, *wx, *zx, *p0x, *S1s, *S2s, *Pns, *ws, *zs, *p0s, q, *zch, *rside, *b, za=0., s2, dN, Hij,
+ mn_minus=1., mn_plus=0., mn_minusx, mn_minuss, mn_plusx, mn_pluss, ddf, xl, xu, oben, unten;
+ int i, j, k, n, *ps, Ntilde, ihs, M, NN, ii, jj;
+
+ cx *= sqrt( lx/(2.-lx) );
+ hsx *= sqrt( lx/(2.-lx) );
+
+ M = ceil( (log(csl)-log(csu))/log(1.-ls) );
+ Ntilde = ceil( (double)Ns/(double)M );
+ NN = M*Ntilde;
+ s2 = sigma*sigma;
+ ddf = (double)df;
+ dN = (double)Ntilde;
+
+ ihs = floor( (log(csl)-log(hss))/log(1.-ls) );
+ if (ihs<0) ihs = 0;
+
+ Sx = matrix(Nx,Nx);
+ wx = vector(Nx);
+ zx = vector(Nx);
+ Pnx = matrix(nmax,Nx);
+ p0x = vector(nmax);
+
+ S1s = matrix(NN,NN);
+ S2s = matrix(NN,NN);
+ ps = ivector(NN);
+ zch = matrix(M,Ntilde);
+ rside = vector(NN);
+ b = vector(M+1);
+ ws = vector(qm);
+ zs = vector(qm);
+ Pns = matrix(nmax,NN);
+ p0s = vector(nmax);
+
+ gausslegendre(Nx,-cx,cx,zx,wx);
+
+ for (i=0;i<Nx;i++) {
+ za = (1.-lx)*zx[i];
+ for (j=0;j<Nx;j++)
+ Sx[i*Nx+j] = wx[j]/lx*phi( ((zx[j]-za)/lx-mu)/sigma, 0.)/sigma;
+ }
+
+/* interval borders b_i = cl/(1-l)^i */
+ for (i=0;i<M;i++) b[i] = csl/pow(1.-ls, (double)(i));
+ b[M] = csu;
+
+ /* Chebyshev nodes on [b_0,b_1],[b_1,b_2],...,[b_M-1,cu] */
+ for (i=0;i<M;i++)
+ for (j=0;j<Ntilde;j++) {
+ zch[ i*Ntilde+j ] = b[i] + (b[i+1]-b[i])/2.*(1.+cos(PI*(2.*j+1.)/2./dN));
+ }
+
+ /* P(L>1)(zch[i,j]) */
+ for (i=0;i<M;i++)
+ for (j=0;j<Ntilde;j++) {
+ rside[ i*Ntilde+j ] = CHI( ddf/s2*(csu-(1.-ls)*zch[ i*Ntilde+j ])/ls, df)
+ - CHI( ddf/s2*(csl-(1.-ls)*zch[ i*Ntilde+j ])/ls, df);
+ }
+
+ for (i=0;i<M;i++)
+ for (j=0;j<Ntilde;j++) {
+ za = (1.-ls)*zch[ i*Ntilde+j ];
+ for (ii=0;ii<M;ii++)
+ for (jj=0;jj<Ntilde;jj++) {
+ if (b[ii+1]<za) S1s[ (i*Ntilde+j)*NN + ii*Ntilde+jj ] = 0.;
+ else {
+ if (za<b[ii]) xl = b[ii]; else xl = za;
+ xu = b[ii+1];
+ if (df!=2) {
+ xl = sqrt(xl-za);
+ xu = sqrt(xu-za);
+ }
+ gausslegendre(qm,xl,xu,zs,ws);
+ Hij = 0.;
+ for (k=0;k<qm;k++)
+ if (df==2)
+ Hij += ws[k]*Tn( (2.*zs[k]-b[ii+1]-b[ii])/(b[ii+1]-b[ii]), jj)
+ * exp(-zs[k]/s2/ls);
+ else
+ Hij +=
+ ws[k]*Tn( (2.*(zs[k]*zs[k]+za)-b[ii+1]-b[ii])/(b[ii+1]-b[ii]), jj)
+ * 2. * pow(zs[k], ddf-1.) * exp(-ddf*zs[k]*zs[k]/2./s2/ls);
+
+ if (df==2) Hij *= exp(za/s2/ls)/s2/ls;
+ else Hij /= gammafn(ddf/2.) * pow(2.*s2*ls/ddf, ddf/2.);
+ S1s[ (i*Ntilde+j)*NN + ii*Ntilde+jj ] = Hij;
+ }
+ }
+ }
+
+ for (i=0;i<NN;i++)
+ for (j=0;j<NN;j++) S2s[i*NN+j] = 0.;
+
+ for (i=0;i<M;i++)
+ for (j=0;j<Ntilde;j++)
+ for (jj=0;jj<Ntilde;jj++)
+ S2s[ (i*Ntilde+j)*NN + i*Ntilde+jj ] =
+ Tn( (2.*zch[ i*Ntilde+j ]-b[i+1]-b[i])/(b[i+1]-b[i]), jj);
+
+ LU_decompose(S2s,ps,NN);
+
+ for (n=1;n<=nmax;n++) {
+
+ if (n==1)
+ for (i=0;i<Nx;i++)
+ Pnx[i] = PHI( (( cx-(1.-lx)*zx[i])/lx-mu)/sigma, 0.) -
+ PHI( ((-cx-(1.-lx)*zx[i])/lx-mu)/sigma, 0.);
+ else
+ for (i=0;i<Nx;i++) {
+ Pnx[(n-1)*Nx+i] = 0.;
+ for (j=0;j<Nx;j++)
+ Pnx[(n-1)*Nx+i] += Sx[i*Nx+j] * Pnx[(n-2)*Nx+j];
+ }
+
+ p0x[n-1] = 0.;
+ if (n==1)
+ p0x[0] = PHI( (( cx-(1.-lx)*hsx)/lx-mu)/sigma, 0.) -
+ PHI( ((-cx-(1.-lx)*hsx)/lx-mu)/sigma, 0.);
+ else
+ for (j=0;j<Nx;j++)
+ p0x[n-1] += wx[j]/lx * phi( ((zx[j]-(1.-lx)*hsx)/lx-mu)/sigma, 0.)/sigma
+ * Pnx[(n-2)*Nx+j];
+
+ if (n==1)
+ for (i=0;i<M;i++)
+ for (j=0;j<Ntilde;j++) {
+ Pns[ i*Ntilde+j ] = 0.;
+ for (jj=0;jj<Ntilde;jj++)
+ Pns[ i*Ntilde+j ] += /* usual Chebyshev approximation */
+ 2./Ntilde * Tn( (2.*zch[i*Ntilde+jj]-b[i+1]-b[i])/(b[i+1]-b[i]), j)
+ * rside[ i*Ntilde+jj ];
+ if (j==0) Pns[ i*Ntilde+j ] /= 2.;
+ }
+ else {
+ for (i=0;i<NN;i++) {
+ rside[i] = 0.;
+ for (j=0;j<NN;j++) rside[i] += S1s[ i*NN+j ] * Pns[ (n-2)*NN+j ];
+ }
+ LU_solve2(S2s,rside,ps,NN);
+ for (i=0;i<NN;i++) Pns[ (n-1)*NN+i ] = rside[i];
+ }
+
+ p0s[n-1] = 0.;
+ if (n==1)
+ p0s[0] = CHI( ddf/s2*(csu-(1.-ls)*hss)/ls, df)
+ - CHI( ddf/s2*(csl-(1.-ls)*hss)/ls, df);
+ else
+ for (j=0;j<Ntilde;j++)
+ p0s[n-1] += Pns[ (n-1)*NN + ihs*Ntilde+j ]
+ * Tn( (2.*hss-b[ihs+1]-b[ihs])/(b[ihs+1]-b[ihs]), j);
+
+
+ p0[n-1] = p0x[n-1] * p0s[n-1];
+
+ mn_minusx = 1.; mn_plusx = 0.;
+ mn_minuss = 1.; mn_pluss = 0.;
+ if ( n>1 ) {
+ for (i=0;i<Nx;i++) {
+ if (Pnx[(n-1)*Nx+i]==0)
+ if (Pnx[(n-1)*Nx+i]==0) q = 0.;
+ else q = 1.;
+ else q = Pnx[(n-1)*Nx+i]/Pnx[(n-2)*Nx+i];
+ if ( q<mn_minusx ) mn_minusx = q;
+ if ( q>mn_plusx ) mn_plusx = q;
+ }
+
+ for (i=0;i<M;i++)
+ for (j=0;j<Ntilde;j++) {
+ oben = 0.;
+ unten = 0.;
+ for (jj=0;jj<Ntilde;jj++) {
+ oben += Pns[ (n-1)*NN + i*Ntilde+jj ]
+ * Tn((2.*zch[i*Ntilde+j]-b[i+1]-b[i])/(b[i+1]-b[i]), jj);
+ unten+= Pns[ (n-2)*NN + i*Ntilde+jj ]
+ * Tn((2.*zch[i*Ntilde+j]-b[i+1]-b[i])/(b[i+1]-b[i]), jj);
+ }
+ if (fabs(unten)<1e-16)
+ if (fabs(oben)<1e-16) q = 0.;
+ else q = 1.;
+ else q = oben/unten;
+ if ( q<mn_minuss ) mn_minuss = q;
+ if ( q>mn_pluss ) mn_pluss = q;
+ }
+
+ mn_minus = mn_minusx * mn_minuss;
+ mn_plus = mn_plusx * mn_pluss;
+
+ *rho = (mn_minus + mn_plus)/2.;
+ if ( fabs(mn_plus - mn_minus) < FINALeps ) {
+ *nstop = n;
+ n = nmax + 1;
+ }
+ } /* n > 1 */
+ } /* n=1; n<=nmax; n++ */
+
+ Free(p0s);
+ Free(Pns);
+ Free(zs);
+ Free(ws);
+ Free(b);
+ Free(rside);
+ Free(zch);
+ Free(ps);
+ Free(S2s);
+ Free(S1s);
+
+ Free(p0x);
+ Free(Pnx);
+ Free(zx);
+ Free(wx);
+ Free(Sx);
+
+ return 0;
+}
+
+
+double xse2_Wq(double lx, double ls, double cx, double csl, double csu, double p, double hsx, double hss, double mu, double sigma, int df, int Nx, int Ns, int nmax, int qm)
+{ double *p0, *Sx, *Pnx, *wx, *zx, *p0x, *S1s, *S2s, *Pns, *ws, *zs, *p0s, q, *zch, *rside, *b, za=0., s2, dN, Hij,
+ mn_minus=1., mn_plus=0., mn_minusx, mn_minuss, mn_plusx, mn_pluss, ddf, xl, xu, oben, unten, q_minus=0., q_plus=0., enumerator=0., Wq=0.;
+ int i, j, k, n, *ps, Ntilde, ihs, M, NN, ii, jj;
+
+ cx *= sqrt( lx/(2.-lx) );
+ hsx *= sqrt( lx/(2.-lx) );
+
+ M = ceil( (log(csl)-log(csu))/log(1.-ls) );
+ Ntilde = ceil( (double)Ns/(double)M );
+ NN = M*Ntilde;
+ s2 = sigma*sigma;
+ ddf = (double)df;
+ dN = (double)Ntilde;
+
+ ihs = floor( (log(csl)-log(hss))/log(1.-ls) );
+ if (ihs<0) ihs = 0;
+
+ Sx = matrix(Nx,Nx);
+ wx = vector(Nx);
+ zx = vector(Nx);
+ Pnx = matrix(nmax,Nx);
+ p0x = vector(nmax);
+
+ S1s = matrix(NN,NN);
+ S2s = matrix(NN,NN);
+ ps = ivector(NN);
+ zch = matrix(M,Ntilde);
+ rside = vector(NN);
+ b = vector(M+1);
+ ws = vector(qm);
+ zs = vector(qm);
+ Pns = matrix(nmax,NN);
+ p0s = vector(nmax);
+
+ p0 = vector(nmax);
+
+ gausslegendre(Nx,-cx,cx,zx,wx);
+
+ for (i=0;i<Nx;i++) {
+ za = (1.-lx)*zx[i];
+ for (j=0;j<Nx;j++)
+ Sx[i*Nx+j] = wx[j]/lx*phi( ((zx[j]-za)/lx-mu)/sigma, 0.)/sigma;
+ }
+
+/* interval borders b_i = cl/(1-l)^i */
+ for (i=0;i<M;i++) b[i] = csl/pow(1.-ls, (double)(i));
+ b[M] = csu;
+
+ /* Chebyshev nodes on [b_0,b_1],[b_1,b_2],...,[b_M-1,cu] */
+ for (i=0;i<M;i++)
+ for (j=0;j<Ntilde;j++) {
+ zch[ i*Ntilde+j ] = b[i] + (b[i+1]-b[i])/2.*(1.+cos(PI*(2.*j+1.)/2./dN));
+ }
+
+ /* P(L>1)(zch[i,j]) */
+ for (i=0;i<M;i++)
+ for (j=0;j<Ntilde;j++) {
+ rside[ i*Ntilde+j ] = CHI( ddf/s2*(csu-(1.-ls)*zch[ i*Ntilde+j ])/ls, df)
+ - CHI( ddf/s2*(csl-(1.-ls)*zch[ i*Ntilde+j ])/ls, df);
+ }
+
+ for (i=0;i<M;i++)
+ for (j=0;j<Ntilde;j++) {
+ za = (1.-ls)*zch[ i*Ntilde+j ];
+ for (ii=0;ii<M;ii++)
+ for (jj=0;jj<Ntilde;jj++) {
+ if (b[ii+1]<za) S1s[ (i*Ntilde+j)*NN + ii*Ntilde+jj ] = 0.;
+ else {
+ if (za<b[ii]) xl = b[ii]; else xl = za;
+ xu = b[ii+1];
+ if (df!=2) {
+ xl = sqrt(xl-za);
+ xu = sqrt(xu-za);
+ }
+ gausslegendre(qm,xl,xu,zs,ws);
+ Hij = 0.;
+ for (k=0;k<qm;k++)
+ if (df==2)
+ Hij += ws[k]*Tn( (2.*zs[k]-b[ii+1]-b[ii])/(b[ii+1]-b[ii]), jj)
+ * exp(-zs[k]/s2/ls);
+ else
+ Hij +=
+ ws[k]*Tn( (2.*(zs[k]*zs[k]+za)-b[ii+1]-b[ii])/(b[ii+1]-b[ii]), jj)
+ * 2. * pow(zs[k], ddf-1.) * exp(-ddf*zs[k]*zs[k]/2./s2/ls);
+
+ if (df==2) Hij *= exp(za/s2/ls)/s2/ls;
+ else Hij /= gammafn(ddf/2.) * pow(2.*s2*ls/ddf, ddf/2.);
+ S1s[ (i*Ntilde+j)*NN + ii*Ntilde+jj ] = Hij;
+ }
+ }
+ }
+
+ for (i=0;i<NN;i++)
+ for (j=0;j<NN;j++) S2s[i*NN+j] = 0.;
+
+ for (i=0;i<M;i++)
+ for (j=0;j<Ntilde;j++)
+ for (jj=0;jj<Ntilde;jj++)
+ S2s[ (i*Ntilde+j)*NN + i*Ntilde+jj ] =
+ Tn( (2.*zch[ i*Ntilde+j ]-b[i+1]-b[i])/(b[i+1]-b[i]), jj);
+
+ LU_decompose(S2s,ps,NN);
+
+ for (n=1;n<=nmax;n++) {
+
+ if (n==1)
+ for (i=0;i<Nx;i++)
+ Pnx[i] = PHI( (( cx-(1.-lx)*zx[i])/lx-mu)/sigma, 0.) -
+ PHI( ((-cx-(1.-lx)*zx[i])/lx-mu)/sigma, 0.);
+ else
+ for (i=0;i<Nx;i++) {
+ Pnx[(n-1)*Nx+i] = 0.;
+ for (j=0;j<Nx;j++)
+ Pnx[(n-1)*Nx+i] += Sx[i*Nx+j] * Pnx[(n-2)*Nx+j];
+ }
+
+ p0x[n-1] = 0.;
+ if (n==1)
+ p0x[0] = PHI( (( cx-(1.-lx)*hsx)/lx-mu)/sigma, 0.) -
+ PHI( ((-cx-(1.-lx)*hsx)/lx-mu)/sigma, 0.);
+ else
+ for (j=0;j<Nx;j++)
+ p0x[n-1] += wx[j]/lx * phi( ((zx[j]-(1.-lx)*hsx)/lx-mu)/sigma, 0.)/sigma
+ * Pnx[(n-2)*Nx+j];
+
+ if (n==1)
+ for (i=0;i<M;i++)
+ for (j=0;j<Ntilde;j++) {
+ Pns[ i*Ntilde+j ] = 0.;
+ for (jj=0;jj<Ntilde;jj++)
+ Pns[ i*Ntilde+j ] += /* usual Chebyshev approximation */
+ 2./Ntilde * Tn( (2.*zch[i*Ntilde+jj]-b[i+1]-b[i])/(b[i+1]-b[i]), j)
+ * rside[ i*Ntilde+jj ];
+ if (j==0) Pns[ i*Ntilde+j ] /= 2.;
+ }
+ else {
+ for (i=0;i<NN;i++) {
+ rside[i] = 0.;
+ for (j=0;j<NN;j++) rside[i] += S1s[ i*NN+j ] * Pns[ (n-2)*NN+j ];
+ }
+ LU_solve2(S2s,rside,ps,NN);
+ for (i=0;i<NN;i++) Pns[ (n-1)*NN+i ] = rside[i];
+ }
+
+ p0s[n-1] = 0.;
+ if (n==1)
+ p0s[0] = CHI( ddf/s2*(csu-(1.-ls)*hss)/ls, df)
+ - CHI( ddf/s2*(csl-(1.-ls)*hss)/ls, df);
+ else
+ for (j=0;j<Ntilde;j++)
+ p0s[n-1] += Pns[ (n-1)*NN + ihs*Ntilde+j ]
+ * Tn( (2.*hss-b[ihs+1]-b[ihs])/(b[ihs+1]-b[ihs]), j);
+
+
+ p0[n-1] = p0x[n-1] * p0s[n-1];
+
+ if ( p0[n-1] < 1.-p ) {
+ Wq = (double)n;
+ n = nmax+1;
+ } else {
+ mn_minusx = 1.; mn_plusx = 0.;
+ mn_minuss = 1.; mn_pluss = 0.;
+ if ( n>1 ) {
+ for (i=0;i<Nx;i++) {
+ if (Pnx[(n-1)*Nx+i]==0)
+ if (Pnx[(n-1)*Nx+i]==0) q = 0.;
+ else q = 1.;
+ else q = Pnx[(n-1)*Nx+i]/Pnx[(n-2)*Nx+i];
+ if ( q<mn_minusx ) mn_minusx = q;
+ if ( q>mn_plusx ) mn_plusx = q;
+ }
+
+ for (i=0;i<M;i++)
+ for (j=0;j<Ntilde;j++) {
+ oben = 0.;
+ unten = 0.;
+ for (jj=0;jj<Ntilde;jj++) {
+ oben += Pns[ (n-1)*NN + i*Ntilde+jj ]
+ * Tn((2.*zch[i*Ntilde+j]-b[i+1]-b[i])/(b[i+1]-b[i]), jj);
+ unten+= Pns[ (n-2)*NN + i*Ntilde+jj ]
+ * Tn((2.*zch[i*Ntilde+j]-b[i+1]-b[i])/(b[i+1]-b[i]), jj);
+ }
+ if (fabs(unten)<1e-16)
+ if (fabs(oben)<1e-16) q = 0.;
+ else q = 1.;
+ else q = oben/unten;
+ if ( q<mn_minuss ) mn_minuss = q;
+ if ( q>mn_pluss ) mn_pluss = q;
+ }
+
+ mn_minus = mn_minusx * mn_minuss;
+ mn_plus = mn_plusx * mn_pluss;
+
+ enumerator = log( (1.-p)/p0[n-1] );
+ q_minus = (double)n + enumerator/log(mn_minus);
+ q_plus = (double)n + enumerator/log(mn_plus);
+ if ( fabs( ceil(q_plus) - ceil(q_minus) ) < .5 ) {
+ Wq = ceil(q_plus);
+ n = nmax +1;
+ }
+ } /* n > 1 */
+ } /* p0[n-1] >= 1.-p */
+ } /* n=1; n<=nmax; n++ */
+
+ Free(p0);
+
+ Free(p0s);
+ Free(Pns);
+ Free(zs);
+ Free(ws);
+ Free(b);
+ Free(rside);
+ Free(zch);
+ Free(ps);
+ Free(S2s);
+ Free(S1s);
+
+ Free(p0x);
+ Free(Pnx);
+ Free(zx);
+ Free(wx);
+ Free(Sx);
+
+ return Wq;
+}
+
+
+int xse2lu_crit(double lx, double ls, double L0, double *cx, double csl, double *csu, double hsx, double hss, double mu, double sigma, int df, int Nx, int Ns, int nmax, int qm)
+{ double x1, x2, dx, s1, s2, ds, xARL1, xARL2, sARL1, sARL2, xsARL22, xsARL12, xsARL21,
+ f11, f22, f21, f12, d11, d22, d21, d12, nenner, zr=0, c0=-1.;
+
+ x1 = xe_crit(ewma2,lx,2.*L0,zr,hsx,mu,fix,Nx,c0) - .1;
+ x2 = x1 + .2;
+ s1 = se2lu_crit(ls,2.*L0,csl,hss,sigma,df,Ns,qm) - .1;
+ s2 = s1 + .2;
+
+ xARL2 = xe2_iglarl(lx,x2,hsx,mu,Nx);
+ sARL2 = se2_iglarl(ls,csl,s2,hss,sigma,df,Ns,qm);
+ xsARL22 = xse2_arl(lx,ls,x2,csl,s2,hsx,hss,mu,sigma,df,Nx,Ns,nmax,qm);
+
+ do {
+ xARL1 = xe2_iglarl(lx,x1,hsx,mu,Nx);
+ sARL1 = se2_iglarl(ls,csl,s1,hss,sigma,df,Ns,qm);
+ xsARL21 = xse2_arl(lx,ls,x2,csl,s1,hsx,hss,mu,sigma,df,Nx,Ns,nmax,qm);
+ xsARL12 = xse2_arl(lx,ls,x1,csl,s2,hsx,hss,mu,sigma,df,Nx,Ns,nmax,qm);
+
+ /* difference quotient */
+ f11 = (xsARL22 - xsARL12)/(x2-x1); f12 = (xsARL22 - xsARL21)/(s2-s1);
+ f21 = (xARL2 - xARL1)/(x2-x1); f22 = (sARL1 - sARL2)/(s2-s1);
+
+ /* inverse of the difference quotient */
+ nenner = f11*f22 - f12*f21;
+ d11 = f22/nenner; d12 = -f12/nenner;
+ d21 = -f21/nenner; d22 = f11/nenner;
+
+ dx = d11*(xsARL22-L0) + d12*(xARL2-sARL2);
+ ds = d21*(xsARL22-L0) + d22*(xARL2-sARL2);
+
+ x1 = x2; s1 = s2;
+ x2 -= dx; s2 -= ds;
+
+ xARL2 = xe2_iglarl(lx,x2,hsx,mu,Nx);
+ sARL2 = se2_iglarl(ls,csl,s2,hss,sigma,df,Ns,qm);
+ xsARL22 = xse2_arl(lx,ls,x2,csl,s2,hsx,hss,mu,sigma,df,Nx,Ns,nmax,qm);
+
+ } while ( (fabs(L0-xsARL22)>1e-6 || fabs(xARL2-sARL2)>1e-6) && (fabs(x2-x1)>1e-7 || fabs(s2-s1)>1e-7) );
+
+ *cx = x2; *csu = s2;
+
+ return 0;
+}
+
+
+int xse2fu_crit(double lx, double ls, double L0, double *cx, double *csl, double csu, double hsx, double hss, double mu, double sigma, int df, int Nx, int Ns, int nmax, int qm)
+{ double x1, x2, dx, s1, s2, ds, xARL1, xARL2, sARL1, sARL2, xsARL22, xsARL12, xsARL21,
+ f11, f22, f21, f12, d11, d22, d21, d12, nenner, zr=0, c0=-1.;
+
+ x1 = xe_crit(ewma2,lx,2.*L0,zr,hsx,mu,fix,Nx,c0) - .1;
+ x2 = x1 + .2;
+ s1 = se2fu_crit(ls,2.*L0,csu,hss,sigma,df,Ns,qm) - .1;
+ s2 = s1 + .2;
+
+ xARL2 = xe2_iglarl(lx,x2,hsx,mu,Nx);
+ sARL2 = se2_iglarl(ls,s2,csu,hss,sigma,df,Ns,qm);
+ xsARL22 = xse2_arl(lx,ls,x2,s2,csu,hsx,hss,mu,sigma,df,Nx,Ns,nmax,qm);
+ /*printf("cx = %.4f,\tcsk = %.4f,\tcsu = %.4f\t,\txARL = %.2f,\tsARL = %.2f,\txsARL = %.2f\n", x2, s2, csu, xARL2, sARL2, xsARL22);*/
+ do {
+ xARL1 = xe2_iglarl(lx,x1,hsx,mu,Nx);
+ sARL1 = se2_iglarl(ls,s1,csu,hss,sigma,df,Ns,qm);
+ xsARL21 = xse2_arl(lx,ls,x2,s1,csu,hsx,hss,mu,sigma,df,Nx,Ns,nmax,qm);
+ xsARL12 = xse2_arl(lx,ls,x1,s2,csu,hsx,hss,mu,sigma,df,Nx,Ns,nmax,qm);
+
+ /* difference quotient */
+ f11 = (xsARL22 - xsARL12)/(x2-x1); f12 = (xsARL22 - xsARL21)/(s2-s1);
+ f21 = (xARL2 - xARL1)/(x2-x1); f22 = (sARL1 - sARL2)/(s2-s1);
+
+ /* inverse of the difference quotient */
+ nenner = f11*f22 - f12*f21;
+ d11 = f22/nenner; d12 = -f12/nenner;
+ d21 = -f21/nenner; d22 = f11/nenner;
+
+ dx = d11*(xsARL22-L0) + d12*(xARL2-sARL2);
+ ds = d21*(xsARL22-L0) + d22*(xARL2-sARL2);
+
+ x1 = x2; s1 = s2;
+ x2 -= dx; s2 -= ds;
+
+ xARL2 = xe2_iglarl(lx,x2,hsx,mu,Nx);
+ sARL2 = se2_iglarl(ls,s2,csu,hss,sigma,df,Ns,qm);
+ xsARL22 = xse2_arl(lx,ls,x2,s2,csu,hsx,hss,mu,sigma,df,Nx,Ns,nmax,qm);
+ /*printf("cx = %.4f,\tcsk = %.4f,\tcsu = %.4f\t,\txARL = %.2f,\tsARL = %.2f,\txsARL = %.2f\n", x2, s2, csu, xARL2, sARL2, xsARL22);*/
+ } while ( (fabs(L0-xsARL22)>1e-6 || fabs(xARL2-sARL2)>1e-6) && (fabs(x2-x1)>1e-8 || fabs(s2-s1)>1e-8) );
+
+ *cx = x2; *csl = s2;
+
+ return 0;
+}
+
+
+int xse2_crit(double lx, double ls, double L0, double *cx, double *csl, double *csu, double hsx, double hss, double mu, double sigma, int df, int Nx, int Ns, int nmax, int qm)
+{ double s1, s2, s3, ds, sl1, sl2, sl3, Lm, Lp, x, cl;
+ int flag;
+
+ cl = 0.;
+ flag = xseU_crit(lx,ls,L0,&x,&s1,hsx,hss,mu,sigma,df,Nx,Ns,nmax,qm);
+ /*printf("cx = %.4f,\tcsl = %.4f,\tcsu = %.4f\n", x, cl, s1);*/
+
+ Lm = xseU_arl(lx,ls,x,s1,hsx,hss,mu,sigma-lmEPS,df,Nx,Ns,nmax,qm);
+ Lp = xseU_arl(lx,ls,x,s1,hsx,hss,mu,sigma+lmEPS,df,Nx,Ns,nmax,qm);
+ sl1 = (Lp-Lm)/(2.*lmEPS);
+ s2 = s1 + .15;
+ flag = xse2fu_crit(lx,ls,L0,&x,&cl,s2,hsx,hss,mu,sigma,df,Nx,Ns,nmax,qm);
+ /*printf("cx = %.4f,\tcsl = %.4f,\tcsu = %.4f\n", x, cl, s2);*/
+ Lm = xse2_arl(lx,ls,x,cl,s2,hsx,hss,mu,sigma-lmEPS,df,Nx,Ns,nmax,qm);
+ Lp = xse2_arl(lx,ls,x,cl,s2,hsx,hss,mu,sigma+lmEPS,df,Nx,Ns,nmax,qm);
+ sl2 = (Lp-Lm)/(2.*lmEPS);
+
+ do {
+ s3 = s1 - sl1/(sl2-sl1) * (s2-s1);
+ flag = xse2fu_crit(lx,ls,L0,&x,&cl,s3,hsx,hss,mu,sigma,df,Nx,Ns,nmax,qm);
+ Lm = xse2_arl(lx,ls,x,cl,s3,hsx,hss,mu,sigma-lmEPS,df,Nx,Ns,nmax,qm);
+ Lp = xse2_arl(lx,ls,x,cl,s3,hsx,hss,mu,sigma+lmEPS,df,Nx,Ns,nmax,qm);
+ sl3 = (Lp-Lm)/(2.*lmEPS);
+ /*printf("cx = %.4f,\tcsl = %.4f,\tcsu = %.4f\t,\tslope = %.6f\n", x, cl, s3, sl3);*/
+ ds = s3-s2; s1 = s2; sl1 = sl2; s2 = s3; sl2 = sl3;
+ } while ( fabs(sl3)>1e-6 && fabs(ds)>1e-7 );
+
+ *cx = x; *csl = cl; *csu = s3;
+
+ return flag;
+}
+
+
+/* EWMA p under sampling by variables */
+
+/* p = h(mu, sigma) */
+
+double WK_h(double mu, double sigma, double LSL, double USL)
+{ double result;
+ result = PHI( (LSL-mu)/sigma, 0.) + PHI( (mu-USL)/sigma, 0.);
+ return result;
+}
+
+
+/* d/dmu h(mu, sigma) */
+
+double wk_h_mu(double mu, double sigma, double LSL, double USL)
+{ double result;
+ result = ( -phi( (LSL-mu)/sigma, 0.) + phi( (mu-USL)/sigma, 0.) )/sigma;
+ return result;
+}
+
+
+/* d/dsigma h(mu, sigma) */
+
+double wk_h_sigma(double mu, double sigma, double LSL, double USL)
+{ double result;
+ result = -( (LSL-mu)*phi( (LSL-mu)/sigma, 0.) + (mu-USL)*phi( (mu-USL)/sigma, 0.) )/sigma/sigma;
+ return result;
+}
+
+
+/* mu = h^-1(p, sigma) */
+
+double WK_h_invers_mu(double p, double sigma, double LSL, double USL)
+{ double mu, old_mu, merror, perror;
+ mu = sigma*qPHI(p) + USL;
+ perror = WK_h(mu, sigma, LSL, USL) - p;
+ do {
+ old_mu = mu;
+ mu = mu - perror / wk_h_mu(mu, sigma, LSL, USL);
+ merror = mu - old_mu;
+ perror = WK_h(mu, sigma, LSL, USL) - p;
+ } while ( fabs(merror) > 1e-10 && fabs(perror) > 1e-12 );
+ return mu;
+}
+
+
+/* sigma = h^-1(p, mu) */
+
+double WK_h_invers_sigma(double p, double mu, double LSL, double USL)
+{ double sigma, old_sigma, serror, perror;
+ sigma = (mu-USL)/qPHI(p);
+ perror = WK_h(mu, sigma, LSL, USL) - p;
+ do {
+ old_sigma = sigma;
+ sigma = sigma - perror / wk_h_sigma(mu, sigma, LSL, USL);
+ serror = sigma - old_sigma;
+ perror = WK_h(mu, sigma, LSL, USL) - p;
+ } while ( fabs(serror) > 1e-10 && fabs(perror) > 1e-12 );
+ return sigma;
+}
+
+
+/* alpha, the upper limit of the cdf (and pdf) definite integral */
+double wk_alpha(double p, double sigma, int n, double LSL, double USL)
+{ double alpha, dn, zphalf;
+ dn = (double)n;
+ zphalf = qPHI(p/2.);
+ alpha = (dn-1.)/sigma/sigma * (USL-LSL)*(USL-LSL)/4. / (zphalf*zphalf);
+ return alpha;
+}
+
+
+/* cdf of h(xbar, sigma0=1) for X ~ N(mu, sigma) */
+
+double cdf_phat(double p, double mu, double sigma, int n, double LSL, double USL)
+{ double result, pstar, mu_of_p, dn, centre;
+ dn = (double)n;
+ result = 0.;
+ if ( p >= 1. ) result = 1.;
+ centre = (LSL+USL)/2.;
+ /*pstar = WK_h(centre, sigma, LSL, USL);*/
+ pstar = WK_h(centre, 1., LSL, USL);
+ if ( pstar < p && p < 1. ) {
+ mu_of_p = WK_h_invers_mu(p, 1., LSL, USL);
+ result = PHI( (mu_of_p - mu)*sqrt(dn)/sigma, 0. ) - PHI( (-mu_of_p - mu)*sqrt(dn)/sigma, 0. );
+ }
+ return result;
+}
+
+
+/* pdf of h(xbar, sigma0=1) for X ~ N(mu, sigma) */
+
+double pdf_phat(double p, double mu, double sigma, int n, double LSL, double USL)
+{ double result, pstar, mu_of_p, dn, centre;
+ dn = (double)n;
+ result = 0.;
+ centre = (LSL+USL)/2.;
+ /*pstar = WK_h(centre, sigma, LSL, USL);*/
+ pstar = WK_h(centre, 1., LSL, USL);
+ if ( pstar < p && p < 1. ) {
+ mu_of_p = WK_h_invers_mu(p, 1., LSL, USL);
+ result = sqrt(dn)*( phi( (mu_of_p - mu)*sqrt(dn)/sigma, 0. ) + phi( (-mu_of_p - mu)*sqrt(dn)/sigma, 0. ) ) / wk_h_mu(mu_of_p, 1., LSL, USL)/sigma;
+ }
+ return result;
+}
+
+
+/* quantile function of h(xbar, sigma0=1) for X ~ N(mu, sigma) */
+
+double qf_phat(double p0, double mu, double sigma, int n, double LSL, double USL)
+{ double pstar, centre, c1, c2, c3, p1, p2, p3, dc, cstep;
+ centre = (LSL+USL)/2.;
+ pstar = WK_h(centre, sigma, LSL, USL);
+ c2 = pstar;
+ p2 = 0.;
+ cstep = p0/1e3;
+ do {
+ c1 = c2;
+ p1 = p2;
+ c2 += cstep;
+ p2 = cdf_phat(c2, mu, sigma, n, LSL, USL);
+ } while ( p2 < p0 );
+ if ( c2 <= pstar + cstep + 1e-9 ) {
+ c1 = c2 - cstep/2.;
+ p1 = cdf_phat(c1, mu, sigma, n, LSL, USL);
+ }
+ do {
+ c3 = c1 + ( p0 - p1 )/( p2 - p1 ) * ( c2 - c1 );
+ p3 = cdf_phat(c3, mu, sigma, n, LSL, USL);
+ dc = c3 - c2; c1 = c2; p1 = p2; c2 = c3; p2 = p3;
+ } while ( fabs( p0 - p3 )>1e-10 && fabs(dc)>1e-10 );
+ return c3;
+}
+
+
+/* integrand for cdf of h(xbar, s) for X ~ N(mu, sigma) */
+
+double wk_cdf_i(double y, double p, double mu, double sigma, int n, double LSL, double USL)
+{ double result, alpha, x, s, mu_p, dn, atrim;
+ dn = (double)n;
+ alpha = wk_alpha(p, sigma, n, LSL, USL);
+ atrim = qCHI(0.9999999999, n-1);
+ if ( atrim < alpha ) alpha = atrim;
+ x = alpha - pow(y,2.);
+ s = sigma * sqrt( x/(dn-1.) );
+ mu_p = WK_h_invers_mu(p, s, LSL, USL);
+ result = PHI( (mu_p-mu)*sqrt(dn)/sigma, 0.) - PHI( (-mu_p-mu)*sqrt(dn)/sigma, 0.);
+ result *= chi(x, n-1) * 2*y;
+ return result;
+}
+
+/* cdf of h(xbar, s) for X ~ N(mu, sigma) */
+
+double cdf_phat2(double p, double mu, double sigma, int n, double LSL, double USL, int nodes)
+{ double result, alpha, *w, *z, xl, xu, atrim;
+ int i;
+ w = vector(nodes);
+ z = vector(nodes);
+ result = 0.;
+ if ( p >= 1. ) result = 1.;
+ xl = 0.;
+ if ( 0. < p && p < 1. ) {
+ alpha = wk_alpha(p, sigma, n, LSL, USL);
+ atrim = qCHI(0.9999999999, n-1);
+ if ( atrim < alpha ) alpha = atrim;
+ xu = pow(alpha,0.5);
+ gausslegendre(nodes, xl, xu, z, w);
+ for (i=0; i<nodes; i++) result += w[i] * wk_cdf_i(z[i], p, mu, sigma, n, LSL, USL);
+ }
+ Free(z);
+ Free(w);
+ return result;
+}
+
+/* integrand for pdf of h(xbar, s) for X ~ N(mu, sigma) */
+
+double wk_pdf_i(double y, double p, double mu, double sigma, int n, double LSL, double USL)
+{ double result, alpha, x, s, mu_p, dn;
+ dn = (double)n;
+ alpha = wk_alpha(p, sigma, n, LSL, USL);
+ x = alpha - y*y;
+ s = sigma * sqrt( x/(dn-1.) );
+ mu_p = WK_h_invers_mu(p, s, LSL, USL);
+ result = ( phi( (mu_p-mu)*sqrt(dn)/sigma, 0.) + phi( (-mu_p-mu)*sqrt(dn)/sigma, 0.) ) * sqrt(dn)/sigma;
+ result /= wk_h_mu(mu_p, s, LSL, USL);
+ result *= chi(x, n-1) * 2.*y;
+ return result;
+}
+
+/* pdf of h(xbar, s) for X ~ N(mu, sigma) */
+
+double pdf_phat2(double p, double mu, double sigma, int n, double LSL, double USL, int nodes)
+{ double result, alpha, *w, *z, xl, xu;
+ int i;
+ w = vector(nodes);
+ z = vector(nodes);
+ result = 0.;
+ xl = 0.;
+ if ( 0. < p && p < 1. ) {
+ alpha = wk_alpha(p, sigma, n, LSL, USL);
+ xu = sqrt(alpha);
+ gausslegendre(nodes, xl, xu, z, w);
+ for (i=0; i<nodes; i++) result += w[i] * wk_pdf_i(z[i], p, mu, sigma, n, LSL, USL);
+ }
+ Free(z);
+ Free(w);
+ return result;
+}
+
+/* quantile function of h(xbar, s) for X ~ N(mu, sigma) */
+
+double qf_phat2(double p0, double mu, double sigma, int n, double LSL, double USL, int nodes)
+{ double c1, c2, c3, p1, p2, p3, dc, cstep;
+ c2 = 0.;
+ p2 = 0.;
+ cstep = p0/1e3;
+ do {
+ c1 = c2;
+ p1 = p2;
+ c2 += cstep;
+ p2 = cdf_phat2(c2, mu, sigma, n, LSL, USL, nodes);
+ } while ( p2 < p0 );
+ if ( c2 <= cstep + 1e-9 ) {
+ c1 = c2 - cstep/2.;
+ p1 = cdf_phat2(c1, mu, sigma, n, LSL, USL, nodes);
+ }
+ do {
+ c3 = c1 + ( p0 - p1 )/( p2 - p1 ) * ( c2 - c1 );
+ p3 = cdf_phat2(c3, mu, sigma, n, LSL, USL, nodes);
+ dc = c3 - c2; c1 = c2; p1 = p2; c2 = c3; p2 = p3;
+ } while ( fabs( p0 - p3 )>1e-10 && fabs(dc)>1e-10 );
+ return c3;
+}
+
+
+/* collocation */
+
+double ewma_phat_arl(double lambda, double ucl, double mu, double sigma, int n, double z0, double LSL, double USL, int N, int qm)
+{ double *a, *g, *w, *z, arl, Hij, dN, xl, xu, za, ll, pstar, xi, centre;
+ int i, j, k;
+
+ dN = (double)N;
+ a = matrix(N,N);
+ g = vector(N);
+ w = vector(qm);
+ z = vector(qm);
+
+ centre = (LSL+USL)/2.;
+ /*pstar = WK_h(centre, sigma, LSL, USL);*/
+ pstar = WK_h(centre, 1., LSL, USL);
+
+ for (i=0; i<N; i++) {
+ xi = pstar + (ucl - pstar)/2. * (1.+cos(PI*(2.*(i+1.)-1.)/2./dN));
+ za = (1.-lambda)*xi;
+ ll = za + lambda*pstar;
+ xl = 0.;
+ xu = sqrt(ucl - ll);
+ gausslegendre(qm, xl, xu, z, w);
+ a[i*N] = 1. - cdf_phat( (ucl - za)/lambda, mu, sigma, n, LSL, USL);
+ for (j=1; j<N; j++) {
+ Hij = 0.;
+ for (k=0; k<qm; k++) {
+ Hij += w[k] * Tn( 2.*(z[k]*z[k] + ll - pstar)/(ucl - pstar) - 1. ,j) * 2.*z[k]*pdf_phat(z[k]*z[k]/lambda + pstar, mu, sigma, n, LSL, USL)/lambda;
+ }
+ a[i*N+j] = Tn( 2.*(xi - pstar)/(ucl - pstar) - 1., j) - Hij;
+ }
+ }
+
+ for (j=0; j<N; j++) g[j] = 1.;
+ LU_solve(a, g, N);
+ arl = g[0];
+ for (j=1;j<N;j++) arl += g[j] * Tn( 2.*(z0 - pstar)/(ucl - pstar)-1., j);
+
+ Free(z);
+ Free(w);
+ Free(g);
+ Free(a);
+
+ return arl;
+}
+
+
+double ewma_phat_arl_be(double lambda, double ucl, double mu, double sigma, int n, double z0, double LSL, double USL, int N)
+{ double *a, *g, w, arl, dN, pstar, centre;
+ int i, j;
+
+ dN = (double)N;
+
+ a = matrix(N,N);
+ g = vector(N);
+
+ centre = (LSL+USL)/2.;
+ /*pstar = WK_h(centre, sigma, LSL, USL);*/
+ pstar = WK_h(centre, 1., LSL, USL);
+
+ w = (ucl - pstar)/dN;
+
+ for (i=0; i<N; i++) {
+ for (j=0; j<N; j++)
+ a[i*N+j] = - ( cdf_phat( pstar + ((j+1)*w-(1.-lambda)*(i+0.5)*w)/lambda, mu, sigma, n, LSL, USL) -
+ cdf_phat( pstar + ( j*w-(1.-lambda)*(i+0.5)*w)/lambda, mu, sigma, n, LSL, USL) );
+ ++a[i*N+i];
+ }
+
+ for (j=0; j<N; j++) g[j] = 1.;
+ LU_solve(a, g, N);
+
+ arl = 1.;
+ for (j=0;j<N;j++)
+ arl += ( cdf_phat( (pstar+(j+1)*w-(1.-lambda)*z0)/lambda, mu, sigma, n, LSL, USL) -
+ cdf_phat( (pstar+ j*w-(1.-lambda)*z0)/lambda, mu, sigma, n, LSL, USL) ) * g[j];
+
+ Free(g);
+ Free(a);
+
+ return arl;
+}
+
+
+/* collocation */
+
+double ewma_phat_arl2(double lambda, double ucl, double mu, double sigma, int n, double z0, double LSL, double USL, int N, int qm, int M)
+{ double *a, *g, *w, *z, arl, Hij, dN, xl, xu, za, xi, dM, x, FF;
+ int i, j, k, nodes=30;
+
+ dN = (double)N;
+ dM = (double)M;
+
+ a = matrix(N,N);
+ g = vector(N);
+ w = vector(qm);
+ z = vector(qm);
+
+ for (i=0; i<N; i++) {
+ xi = ucl/2. * (1.+cos(PI*(2.*(i+1.)-1.)/2./dN));
+ za = (1.-lambda)*xi;
+ FF = cdf_phat2( (ucl-za)/lambda, mu, sigma, n, LSL, USL, nodes);
+ a[i*N] = 1. - FF;
+ xl = 0.;
+ xu = pow(ucl - za, 1./dM);
+ gausslegendre(qm, xl, xu, z, w);
+ for (j=1; j<N; j++) {
+ Hij = 0.;
+ for (k=0; k<qm; k++) {
+ x = pow(z[k],dM) + za;
+ Hij += w[k] * dTn( 2.*x/ucl-1. ,j)*2./ucl * cdf_phat2( (x-za)/lambda, mu, sigma, n, LSL, USL, nodes) * dM*pow(z[k],dM-1.);
+ }
+ a[i*N+j] = Tn( 2.*xi/ucl - 1., j) - (FF - Hij);
+ }
+ }
+
+ for (j=0; j<N; j++) g[j] = 1.;
+ LU_solve(a, g, N);
+ arl = g[0];
+ for (j=1;j<N;j++) arl += g[j] * Tn( 2.*z0/ucl-1., j);
+
+ Free(z);
+ Free(w);
+ Free(g);
+ Free(a);
+
+ return arl;
+}
+
+
+double ewma_phat_arl2_be(double lambda, double ucl, double mu, double sigma, int n, double z0, double LSL, double USL, int N)
+{ double *a, *g, w, arl, dN;
+ int i, j, nodes=30;
+
+ dN = (double)N;
+ w = ucl/dN;
+
+ a = matrix(N,N);
+ g = vector(N);
+
+ for (i=0; i<N; i++) {
+ for (j=0; j<N; j++)
+ a[i*N+j] = - ( cdf_phat2( ((j+1)*w-(1.-lambda)*(i+0.5)*w)/lambda, mu, sigma, n, LSL, USL, nodes) -
+ cdf_phat2( ( j*w-(1.-lambda)*(i+0.5)*w)/lambda, mu, sigma, n, LSL, USL, nodes) );
+ ++a[i*N+i];
+ }
+
+ for (j=0; j<N; j++) g[j] = 1.;
+ LU_solve(a, g, N);
+
+ arl = 1.;
+ for (j=0;j<N;j++)
+ arl += ( cdf_phat2( ((j+1)*w-(1.-lambda)*z0)/lambda, mu, sigma, n, LSL, USL, nodes) -
+ cdf_phat2( ( j*w-(1.-lambda)*z0)/lambda, mu, sigma, n, LSL, USL, nodes) ) * g[j];
+
+ Free(g);
+ Free(a);
+
+ return arl;
+}
+
+
+double ewma_phat_crit(double lambda, double L0, double mu, double sigma, int n, double z0, double LSL, double USL, int N, int qm)
+{ double c1, c2, c3, L1, L2, L3, dc, pstar, cstep, centre;
+ centre = (LSL+USL)/2.;
+ pstar = WK_h(centre, sigma, LSL, USL);
+ c2 = pstar;
+ cstep = lambda/10.;
+ do {
+ c2 += cstep;
+ L2 = ewma_phat_arl(lambda, c2, mu, sigma, n, z0, LSL, USL, N, qm);
+ } while ( L2 < L0 );
+ c1 = c2 - cstep;
+ if ( c2 <= pstar + cstep + 1e-9 ) c1 = c2 - cstep/2.;
+ L1 = ewma_phat_arl(lambda, c1, mu, sigma, n, z0, LSL, USL, N, qm);
+ do {
+ c3 = c1 + ( L0 - L1 )/( L2 - L1 ) * ( c2 - c1 );
+ L3 = ewma_phat_arl(lambda, c3, mu, sigma, n, z0, LSL, USL, N, qm);
+ dc = c3 - c2; c1 = c2; L1 = L2; c2 = c3; L2 = L3;
+ } while ( fabs( L0 - L3 )>1e-6 && fabs(dc)>1e-12 );
+ return c3;
+}
+
+
+double ewma_phat_crit2(double lambda, double L0, double mu, double sigma, int n, double z0, double LSL, double USL, int N, int qm, int M)
+{ double c1, c2, c3, L1, L2, L3, dc, cstep;
+ c2 = 0.;
+ L2 = 0.;
+ cstep = lambda/10.;
+ do {
+ c1 = c2;
+ L1 = L2;
+ c2 += cstep;
+ L2 = ewma_phat_arl2(lambda, c2, mu, sigma, n, z0, LSL, USL, N, qm, M);
+ } while ( L2 < L0 );
+ if ( c2 <= cstep + 1e-9 ) {
+ c1 = c2 - cstep/2.;
+ L1 = ewma_phat_arl2(lambda, c1, mu, sigma, n, z0, LSL, USL, N, qm, M);
+ }
+ do {
+ c3 = c1 + ( L0 - L1 )/( L2 - L1 ) * ( c2 - c1 );
+ L3 = ewma_phat_arl2(lambda, c3, mu, sigma, n, z0, LSL, USL, N, qm, M);
+ dc = c3 - c2; c1 = c2; L1 = L2; c2 = c3; L2 = L3;
+ } while ( fabs( L0 - L3 )>1e-6 && fabs(dc)>1e-12 );
+ return c3;
+}
+
+
+int N_of_l(double lambda)
+{ int N;
+ N = 20;
+ if ( lambda < 1e-1 ) N = 40;
+ if ( lambda < 1e-2 ) N = 60;
+ if ( lambda < 1e-3 ) N = 120;
+ if ( lambda < 1e-4 ) N = 200;
+ return N;
+}
+
+
+double ewma_phat_lambda(double L0, double mu, double sigma, double max_l, double min_l, int n, double z0, double LSL, double USL, int qm)
+{ double dn, cS, cE, ldelta, one, L1, L1_, lambda;
+ int i, j, N;
+ lambda = 1.;
+ dn = (double)n;
+ cS = qPHI( 1. - 1./(2.*L0) )/sqrt(dn)*sigma;
+ cE = WK_h( cS, 1., LSL, USL );
+ L1 = 1./( PHI( (-cS-mu)*sqrt(dn)/sigma, 0.) + 1. - PHI( (cS-mu)*sqrt(dn)/sigma, 0.) );
+ ldelta = .1;
+ one = 1;
+ for (j=0; j<4; j++) {
+ for (i=0; i<20; i++) {
+ lambda = lambda - ldelta*one;
+ if ( lambda <= min_l ) { lambda = min_l; i = 23; }
+ if ( lambda >= max_l ) { lambda = max_l; i = 23; }
+ N = N_of_l(lambda);
+ cE = ewma_phat_crit(lambda, L0, 0., sigma, n, z0, LSL, USL, N, qm);
+ L1_ = ewma_phat_arl(lambda, cE, mu, sigma, n, z0, LSL, USL, N, qm);
+ if ( L1_ > L1 && i < 23 ) i = 21;
+ L1 = L1_;
+ }
+ ldelta /= 10.;
+ one *= -1.;
+ }
+ if ( i < 23 ) lambda -= 10.*ldelta*one;
+ return lambda;
+}
+
+
+double ewma_phat_lambda2(double L0, double mu, double sigma, double max_l, double min_l, int n, double z0, double LSL, double USL, int qm, int M)
+{ double dn, cS, cE, ldelta, one, L1, L1_, lambda;
+ int i, j, N;
+ lambda = 1.;
+ dn = (double)n;
+ cS = qPHI( 1. - 1./(2.*L0) )/sqrt(dn)*sigma;
+ cE = WK_h( cS, 1., LSL, USL );
+ L1 = 1./( PHI( (-cS-mu)*sqrt(dn)/sigma, 0.) + 1. - PHI( (cS-mu)*sqrt(dn)/sigma, 0.) );
+ ldelta = .1;
+ one = 1;
+ for (j=0; j<4; j++) {
+ for (i=0; i<20; i++) {
+ lambda = lambda - ldelta*one;
+ if ( lambda <= min_l ) { lambda = min_l; i = 23; }
+ if ( lambda >= max_l ) { lambda = max_l; i = 23; }
+ N = N_of_l(lambda);
+ cE = ewma_phat_crit2(lambda, L0, 0., sigma, n, z0, LSL, USL, N, qm, M);
+ L1_ = ewma_phat_arl2 (lambda, cE, mu, sigma, n, z0, LSL, USL, N, qm, M);
+ if ( L1_ > L1 && i < 23 ) i = 21;
+ L1 = L1_;
+ }
+ ldelta /= 10.;
+ one *= -1.;
+ }
+ if ( i < 23 ) lambda -= 10.*ldelta*one;
+ return lambda;
+}
+
+
+/* attributive EWMA */
+double ewma_p_arl(double lambda, double ucl, int n, double p, double z0, int d_res, int round_mode, int mid_mode)
+{ double *a, *g, arl, zj=0, pju, pj;
+ int i, j, k, N, NN/*, k_max*/;
+
+ N = (int)ceil(ucl*d_res);
+ /*N = (int)floor(ucl*d_res);*/
+ NN = N + 1;
+ a = matrix(NN, NN);
+ g = vector(NN);
+
+ for (i=0; i<=N; i++) for (j=0; j<=N; j++) a[i*NN+j] = 0.;
+
+ for (i=0; i<=N; i++) {
+ /*k_max = (int)ceil( (ucl+1. - (1.-lambda)*i)/lambda );*/
+ for (k=0; k<=n; k++) {
+ zj = (1.-lambda)*i/d_res + lambda*k;
+ pj = pdf_binom((double)k, n, p);
+ switch (round_mode) {
+ case -1: /* round down as probably Gan did */
+ j = (int)floor(zj*d_res + 1e-9);
+ if ( j <= N ) a[i*NN+j] += -pj;
+ break;
+ case 0: /* round down */
+ j = (int)floor(zj*d_res);
+ if ( j <= N ) a[i*NN+j] += -pj;
+ break;
+ case 1: /* round up */
+ j = (int)ceil(zj*d_res);
+ if ( j <= N ) a[i*NN+j] += -pj;
+ break;
+ case 2: /* round to nearest -- round half to even, IEEE 754 */
+ j = (int)round(zj*d_res);
+ if ( j <= N ) a[i*NN+j] += -pj;
+ break;
+ case 3: /* round to nearest -- round half up */
+ j = (int)floor(zj*d_res+.5);
+ if ( j <= N ) a[i*NN+j] += -pj;
+ break;
+ case 4: /* distribute */
+ j = (int)floor(zj*d_res);
+ pju = zj - j/d_res;
+ if ( j <= N ) a[i*NN+j] += -(1.-pju)*pj;
+ if ( j < N ) a[i*NN+j+1] += -pju*pj;
+ break;
+ }
+ }
+ ++a[i*NN+i];
+ }
+
+ for (j=0; j<=N; j++) g[j] = 1.;
+ LU_solve(a, g, NN);
+
+ arl = 1.;
+ /*k_max = (int)ceil( (ucl+1. - (1.-lambda)*z0)/lambda );*/
+ for (k=0; k<=n; k++) {
+ zj = (1.-lambda)*z0 + lambda*k;
+ pj = pdf_binom((double)k, n, p);
+ switch (round_mode) {
+ case -1: /* round down as probably Gan did */
+ j = (int)floor(zj*d_res + 1e-9);
+ if ( j <= N ) arl += pj*g[j];
+ break;
+ case 0: /* round down */
+ j = (int)floor(zj*d_res);
+ if ( j <= N ) arl += pj*g[j];
+ break;
+ case 1: /* round up */
+ j = (int)ceil(zj*d_res);
+ if ( j <= N ) arl += pj*g[j];
+ break;
+ case 2: /* round to nearest -- round half to even, IEEE 754 */
+ j = (int)round(zj*d_res);
+ if ( j <= N ) arl += pj*g[j];
+ break;
+ case 3: /* round to nearest -- round half up */
+ j = (int)floor(zj*d_res+.5);
+ if ( j <= N ) arl += pj*g[j];
+ break;
+ case 4: /* distribute */
+ j = (int)floor(zj*d_res);
+ pju = zj - j/d_res;
+ if ( j <= N ) arl += (1.-pju)*pj*g[j];
+ if ( j < N ) arl += pju*pj*g[j+1];
+ break;
+ }
+ }
+
+ Free(a);
+ Free(g);
+
+ return arl;
+}
+
+
+/* 2-sided tolerance limits factors */
+
+/* Wald & Wolfowitz */
+
+double r_Fww (int n, double r)
+{ double x1, x2;
+ x1 = 1./sqrt(n*1.) - r; x2 = x1 + 2.*r;
+ return ( PHI(x2,0.) - PHI(x1,0.) );
+}
+
+double r_fww (int n, double r)
+{ return(
+ exp(-(1./n+r*r)/2.)*(exp(-r/sqrt(n*1.))+exp(r/sqrt(n*1.)))/sqrt(2.*PI)
+ );
+}
+
+double rww(int n, double p)
+{ double r;
+ r = .5;
+ do r = r - (r_Fww(n,r)-p)/r_fww(n,r);
+ while ( fabs(r_Fww(n,r)-p) > 1e-8 );
+ return r;
+}
+
+double kww(int n, double p, double a)
+{ double k;
+ k = rww(n,p);
+ k *= sqrt( (n-1.) );
+ k /= sqrt( qCHI(a,n-1) );
+ return k;
+}
+
+/* exact by Gauss-Legendre quadrature */
+
+double tl_rx_f(double x, double r)
+{ return ( PHI(x+r,0.) - PHI(x-r,0.) );
+}
+
+double tl_rx(double x, double p)
+{ double r1, r2, r3, f1, f2, f3;
+ r1 = 1.; f1 = tl_rx_f(x,r1);
+ r2 = .8; f2 = tl_rx_f(x,r2);
+ do {
+ r3 = r1 - (f1-p)*(r2-r1)/(f2-f1);
+ f3 = tl_rx_f(x,r3);
+ if (f3<p) { r1 = r3; f1 = f3; }
+ else { r2 = r3; f2 = f3; }
+ } while ( (fabs(f3-p)>1e-8) && (fabs(r1-r2)>1e-8) );
+ return r3;
+}
+
+double tl_niveau(int n, double p, double k, int m)
+{ double ni, xmax, *w, *z, dn, rxi;
+ int i;
+ ni = 0.;
+ dn = (double) n;
+ xmax = qPHI(1.-(1e-10)/2.)/sqrt(dn);
+ w = vector(m);
+ z = vector(m);
+ gausslegendre(m,0.,xmax,z,w);
+ for (i=0;i<m;i++) {
+ rxi = tl_rx (z[i],p);
+ ni += 2. * w[i] * (1-CHI((dn-1.)*rxi*rxi/k/k,n-1))
+ * sqrt(dn)*phi(sqrt(dn)*z[i],0.);
+ }
+ Free(z);
+ Free(w);
+ return ni;
+}
+
+double tl_factor (int n, double p, double a, int m)
+{ double k0, k1, k2, n0, n1, n2, dk;
+
+ k1 = kww(n,p,a);
+ k0 = k1 - .2; k1 += .2;
+ n0 = tl_niveau(n,p,k0,m);
+ n1 = tl_niveau(n,p,k1,m);
+
+ do {
+ k2 = k0 + ( (1.-a) - n0 )/( n1 - n0 ) * ( k1 - k0);
+ n2 = tl_niveau(n,p,k2,m);
+/* Regula falsi */
+ if ( n2 < (1.-a) ) { dk = k2-k0; k0 = k2; n0 = n2; }
+ else { dk = k1-k0; k1 = k2; n1 = n2; }
+ } while ( ( fabs((1.-a)-n2) > 1e-8 ) && ( fabs(dk) > 1e-7 ) );
+ return k2;
+}
+
+
+/* solution of Ax = b with nxn matrix A and and n-dim vectors x and b */
+/* by means of LU decomposition etc. */
+
+int LU_decompose(double *a, int *ps, int n)
+{ int i, j, k;
+ int pii = 0;
+ double pivot, biggest, mult, t, *lu, *scales;
+
+ lu = matrix(n,n);
+ scales = vector(n);
+
+ for (i=0;i<n;i++) {
+ biggest = 0.;
+ for (j=0;j<n;j++)
+ if (biggest < (t = fabs(lu[i*n+j] = a[i*n+j]))) biggest = t;
+ if (biggest != 0.) scales[i] = 1. / biggest;
+ else {
+ scales[i] = 0.;
+ Free(lu); Free(scales);
+ return(0);
+ }
+ ps[i] = i;
+ }
+
+ for (k=0;k<n-1;k++) {
+ biggest = 0.;
+ for (i=k;i<n;i++) {
+ if (biggest < (t = fabs(lu[ps[i]*n+k]) * scales[ps[i]])) {
+ biggest = t;
+ pii = i;
+ }
+ }
+ if (biggest == 0.) { Free(lu); Free(scales); return(0); }
+ if (pii != k) {
+ j = ps[k];
+ ps[k] = ps[pii];
+ ps[pii] = j;
+ }
+ pivot = lu[ps[k]*n+k];
+ for (i=k+1;i<n;i++) {
+ lu[ps[i]*n+k] = mult = lu[ps[i]*n+k] / pivot;
+ if (mult != 0.) {
+ for (j=k+1;j<n;j++)
+ lu[ps[i]*n+j] -= mult * lu[ps[k]*n+j];
+ }
+ }
+ }
+
+ if (lu[ps[n-1]*n+n-1] == 0.) { Free(lu); Free(scales); return(0); }
+
+ for (i=0;i<n;i++) for (j=0;j<n;j++) a[i*n+j] = lu[i*n+j];
+
+ Free(lu); Free(scales);
+
+ return(1);
+}
+
+
+void LU_solve(double *a, double *b, int n)
+{ int i, j, *ps;
+ double dot, *x;
+
+ x = vector(n);
+ ps = ivector(n);
+
+ LU_decompose(a,ps,n);
+
+ for (i=0;i<n;i++) {
+ dot = 0.;
+ for (j=0;j<i;j++)
+ dot += a[ps[i]*n+j] * x[j];
+ x[i] = b[ps[i]] - dot;
+ }
+
+ for (i=n-1;i>=0;i--) {
+ dot = 0.;
+ for (j=i+1;j<n;j++)
+ dot += a[ps[i]*n+j] * x[j];
+ x[i] = (x[i] - dot) / a[ps[i]*n+i];
+ }
+
+ for (i=0;i<n;i++) b[i] = x[i];
+
+ Free(x); Free(ps);
+}
+
+
+void LU_solve2(double *a, double *b, int *ps, int n)
+{ int i, j;
+ double dot, *x;
+
+ x = vector(n);
+
+ for (i=0;i<n;i++) {
+ dot = 0.;
+ for (j=0;j<i;j++)
+ dot += a[ps[i]*n+j] * x[j];
+ x[i] = b[ps[i]] - dot;
+ }
+
+ for (i=n-1;i>=0;i--) {
+ dot = 0.;
+ for (j=i+1;j<n;j++)
+ dot += a[ps[i]*n+j] * x[j];
+ x[i] = (x[i] - dot) / a[ps[i]*n+i];
+ }
+
+ for (i=0;i<n;i++) b[i] = x[i];
+
+ Free(x);
+}
diff --git a/src/ewma_p_arl_be.c b/src/ewma_p_arl_be.c
new file mode 100644
index 0000000..5120e3f
--- /dev/null
+++ b/src/ewma_p_arl_be.c
@@ -0,0 +1,13 @@
+#include <stdio.h>
+#include <math.h>
+#include <stdlib.h>
+#include <R.h>
+
+double ewma_p_arl(double lambda, double ucl, int n, double p, double z0, int d_res, int round_mode, int mid_mode);
+
+void ewma_p_arl_be
+(double *lambda, double *ucl, int *n, double *p, double *z0, int *d_res, int *round_mode, int *mid_mode, double *arl)
+{
+ *arl = -1.;
+ *arl = ewma_p_arl(*lambda, *ucl, *n, *p, *z0, *d_res, *round_mode, *mid_mode);
+}
diff --git a/src/ewma_phat_arl_coll.c b/src/ewma_phat_arl_coll.c
new file mode 100644
index 0000000..04af5c3
--- /dev/null
+++ b/src/ewma_phat_arl_coll.c
@@ -0,0 +1,25 @@
+#include <stdio.h>
+#include <math.h>
+#include <stdlib.h>
+#include <R.h>
+
+double ewma_phat_arl(double lambda, double ucl, double mu, double sigma, int n, double z0, double LSL, double USL, int N, int qm);
+double ewma_phat_arl_be(double lambda, double ucl, double mu, double sigma, int n, double z0, double LSL, double USL, int N);
+
+double ewma_phat_arl2(double lambda, double ucl, double mu, double sigma, int n, double z0, double LSL, double USL, int N, int qm, int M);
+double ewma_phat_arl2_be(double lambda, double ucl, double mu, double sigma, int n, double z0, double LSL, double USL, int N);
+
+
+void ewma_phat_arl_coll
+(double *lambda, double *ucl, double *mu, double *sigma, int *n, double *z0, int *ctyp, double *LSL, double *USL, int *N, int *qm, int *ntyp, double *arl)
+{ int M=4;
+ *arl = -1.;
+ if ( *ctyp == 0 ) {
+ if ( *ntyp == 0 ) *arl = ewma_phat_arl(*lambda, *ucl, *mu, *sigma, *n, *z0, *LSL, *USL, *N, *qm);
+ if ( *ntyp == 1 ) *arl = ewma_phat_arl_be(*lambda, *ucl, *mu, *sigma, *n, *z0, *LSL, *USL, *N);
+ }
+ if ( *ctyp == 1 ) {
+ if ( *ntyp == 0 ) *arl = ewma_phat_arl2(*lambda, *ucl, *mu, *sigma, *n, *z0, *LSL, *USL, *N, *qm, M);
+ if ( *ntyp == 1 ) *arl = ewma_phat_arl2_be(*lambda, *ucl, *mu, *sigma, *n, *z0, *LSL, *USL, *N);
+ }
+}
diff --git a/src/ewma_phat_crit_coll.c b/src/ewma_phat_crit_coll.c
new file mode 100644
index 0000000..40c8459
--- /dev/null
+++ b/src/ewma_phat_crit_coll.c
@@ -0,0 +1,15 @@
+#include <stdio.h>
+#include <math.h>
+#include <stdlib.h>
+#include <R.h>
+
+double ewma_phat_crit(double lambda, double L0, double mu, double sigma, int n, double z0, double LSL, double USL, int N, int qm);
+double ewma_phat_crit2(double lambda, double L0, double mu, double sigma, int n, double z0, double LSL, double USL, int N, int qm, int M);
+
+void ewma_phat_crit_coll
+(double *lambda, double *L0, double *mu, double *sigma, int *n, double *z0, int *ctyp, double *LSL, double *USL, int *N, int *qm, double *ucl)
+{ int M=4;
+ *ucl = -1.;
+ if ( *ctyp == 0 ) *ucl = ewma_phat_crit(*lambda, *L0, *mu, *sigma, *n, *z0, *LSL, *USL, *N, *qm);
+ if ( *ctyp == 1 ) *ucl = ewma_phat_crit2(*lambda, *L0, *mu, *sigma, *n, *z0, *LSL, *USL, *N, *qm, M);
+}
diff --git a/src/ewma_phat_lambda_coll.c b/src/ewma_phat_lambda_coll.c
new file mode 100644
index 0000000..3f22ea1
--- /dev/null
+++ b/src/ewma_phat_lambda_coll.c
@@ -0,0 +1,15 @@
+#include <stdio.h>
+#include <math.h>
+#include <stdlib.h>
+#include <R.h>
+
+double ewma_phat_lambda(double L0, double mu, double sigma, double max_l, double min_l, int n, double z0, double LSL, double USL, int qm);
+double ewma_phat_lambda2(double L0, double mu, double sigma, double max_l, double min_l, int n, double z0, double LSL, double USL, int qm, int M);
+
+void ewma_phat_lambda_coll
+(double *L0, double *mu, double *sigma, int *ctyp, double *max_l, double *min_l, int *n, double *z0, double *LSL, double *USL, int *qm, double *lambda)
+{ int M=4;
+ *lambda = -1.;
+ if ( *ctyp == 0 ) *lambda = ewma_phat_lambda(*L0, *mu, *sigma, *max_l, *min_l, *n, *z0, *LSL, *USL, *qm);
+ if ( *ctyp == 1 ) *lambda = ewma_phat_lambda2(*L0, *mu, *sigma, *max_l, *min_l, *n, *z0, *LSL, *USL, *qm, M);
+}
diff --git a/src/lns2ewma_arl.c b/src/lns2ewma_arl.c
new file mode 100644
index 0000000..ecdc5a8
--- /dev/null
+++ b/src/lns2ewma_arl.c
@@ -0,0 +1,20 @@
+#include <stdio.h>
+#include <math.h>
+#include <stdlib.h>
+#include <R.h>
+
+#define ewmaU 0
+#define ewmaL 1
+#define ewma2 2
+
+double lns2ewmaU_arl_igl(double l, double cl, double cu, double hs, double sigma, int df, int N);
+double lns2ewma2_arl_igl(double l, double cl, double cu, double hs, double sigma, int df, int N);
+
+void lns2ewma_arl
+( int *ctyp, double *l, double *cl, double *cu, double *hs, double *sigma, int *df, int *r, double *arl)
+{
+ *arl = -1.;
+ if ( *ctyp==ewmaU ) *arl = lns2ewmaU_arl_igl(*l, *cl, *cu, *hs, *sigma, *df, *r);
+ /*if ( *ctyp==ewmaL ) *arl = lns2ewmaL_arl_igl(*l, *cl, *cu, *hs, *sigma, *df, *r);*/
+ if ( *ctyp==ewma2 ) *arl = lns2ewma2_arl_igl(*l, *cl, *cu, *hs, *sigma, *df, *r);
+}
diff --git a/src/lns2ewma_crit.c b/src/lns2ewma_crit.c
new file mode 100644
index 0000000..982a647
--- /dev/null
+++ b/src/lns2ewma_crit.c
@@ -0,0 +1,44 @@
+#include <stdio.h>
+#include <math.h>
+#include <stdlib.h>
+#include <R.h>
+
+#define ewmaU 0
+#define ewmaL 1
+#define ewma2 2
+
+#define fixed 0
+#define unbiased 1
+#define eqtails 2
+#define sym 3
+
+double lns2ewmaU_crit(double l, double L0, double cl, double hs, double sigma, int df, int N);
+
+double lns2ewma2_crit_cufix(double l, double cu, double L0, double hs, double sigma, int df, int N);
+double lns2ewma2_crit_sym(double l, double L0, double hs, double sigma, int df, int N);
+int lns2ewma2_crit_unbiased(double l, double L0, double *cl, double *cu, double hs, double sigma, int df, int N);
+
+void lns2ewma_crit
+( int *ctyp, int *ltyp, double *l, double *L0, double *cl0, double *cu0, double *hs, double *sigma, int *df, int *r, double *c_values)
+{ int result=0;
+ double cl=0., cu=1., ddf=1., mitte=0.;
+
+ ddf = (double)*df;
+ mitte = -1./ddf - 1./3./ddf/ddf + 2./15./ddf/ddf/ddf/ddf;
+
+ if ( *ctyp==ewmaU ) cu = lns2ewmaU_crit(*l, *L0, *cl0, *hs, *sigma, *df, *r);
+ /*if ( *ctyp==ewmaL ) cl = lns2ewmaL_crit(*l, *L0, *cu0, *hs, *sigma, *df, *r);*/
+
+ if ( *ctyp==ewma2 ) {
+ if (*ltyp==fixed) {
+ cl = lns2ewma2_crit_cufix(*l, *cu0, *L0, *hs, *sigma, *df, *r);
+ cu = *cu0;
+ }
+ if ( *ltyp==unbiased ) result = lns2ewma2_crit_unbiased(*l, *L0, &cl, &cu, *hs, *sigma, *df, *r);
+ /*if ( *ltyp==eqtails ) result = lns2ewma2_crit_eqtails(*l, *L0, &cl, &cu, *hs, *sigma, *df, *r);*/
+ if ( *ltyp==sym ) { cl = lns2ewma2_crit_sym(*l, *L0, *hs, *sigma, *df, *r); cu = 2*mitte - cl; }
+ }
+ if ( result != 0 ) warning("trouble with lns2ewma2_crit_unbiased called from lns2ewma_crit [package spc]");
+ c_values[0] = cl;
+ c_values[1] = cu;
+}
diff --git a/src/mewma_ad.c b/src/mewma_ad.c
new file mode 100644
index 0000000..e8a4dec
--- /dev/null
+++ b/src/mewma_ad.c
@@ -0,0 +1,11 @@
+#include <stdio.h>
+#include <math.h>
+#include <stdlib.h>
+#include <R.h>
+
+double mxewma_ad (double lambda, double ce, int p, double delta, int N, int qm2, int psi_type, double hs, int qtype, int qm0, int qm1);
+
+void mewma_ad(double *l, double *c, int *p, double *delta, int *r, int *qm2, int *ptype, double *hs, int *qtype, int *qm0, int *qm1, double *ad)
+{
+ *ad = mxewma_ad(*l, *c, *p, *delta, *r, *qm2, *ptype, *hs, *qtype, *qm0, *qm1);
+}
diff --git a/src/mewma_arl.c b/src/mewma_arl.c
new file mode 100644
index 0000000..3398a56
--- /dev/null
+++ b/src/mewma_arl.c
@@ -0,0 +1,70 @@
+#include <stdio.h>
+#include <math.h>
+#include <stdlib.h>
+#include <R.h>
+
+#define GL 0
+#define CO 1
+#define RA 2
+#define CC 3
+#define MC 4
+#define SR 5
+#define CO2 6
+#define GL2 7
+#define GL3 8
+#define GL4 9
+#define GL5 10
+#define CO3 11
+#define CO4 12
+
+double mxewma_arl_0a(double lambda, double ce, int p, double hs, int N);
+double mxewma_arl_0a2(double lambda, double ce, int p, double hs, int N);
+double mxewma_arl_0b(double lambda, double ce, int p, double hs, int N, int qm);
+double mxewma_arl_0c(double lambda, double ce, int p, double hs, int N);
+double mxewma_arl_0d(double lambda, double ce, int p, double hs, int N);
+double mxewma_arl_0e(double lambda, double ce, int p, double hs, int N);
+double mxewma_arl_0f(double lambda, double ce, int p, double hs, int N);
+
+double mxewma_arl_1a(double lambda, double ce, int p, double delta, double hs, int N);
+double mxewma_arl_1a2(double lambda, double ce, int p, double delta, double hs, int N);
+double mxewma_arl_1a3(double lambda, double ce, int p, double delta, double hs, int N);
+double mxewma_arl_1a4(double lambda, double ce, int p, double delta, double hs, int N);
+double mxewma_arl_1a5(double lambda, double ce, int p, double delta, double hs, int N);
+
+double mxewma_arl_1b(double lambda, double ce, int p, double delta, double hs, int N, int qm0, int qm1);
+double mxewma_arl_1b2(double lambda, double ce, int p, double delta, double hs, int N, int qm0, int qm1);
+double mxewma_arl_1b3(double lambda, double ce, int p, double delta, double hs, int N, int qm0, int qm1);
+double mxewma_arl_1b4(double lambda, double ce, int p, double delta, double hs, int N, int qm0, int qm1);
+double mxewma_arl_1c(double lambda, double ce, int p, double delta, double hs, int N);
+double mxewma_arl_1d(double lambda, double ce, int p, double delta, double hs, int N);
+double mxewma_arl_1e(double lambda, double ce, int p, double delta, double hs, int N);
+double mxewma_arl_1f(double lambda, double ce, int p, double delta, double hs, int N);
+
+void mewma_arl(double *l, double *c, int *p, double *delta, double *hs, int *r, int *qtype, int *qm0, int *qm1, double *arl)
+{
+ if ( fabs(*delta)<1e-10 ) {
+ if ( *qtype == GL ) *arl = mxewma_arl_0a(*l, *c, *p, *hs, *r);
+ if ( *qtype == GL2 ) *arl = mxewma_arl_0a2(*l, *c, *p, *hs, *r);
+ if ( *qtype == CO ) *arl = mxewma_arl_0b(*l, *c, *p, *hs, *r, *qm0);
+ if ( *qtype == RA ) *arl = mxewma_arl_0c(*l, *c, *p, *hs, *r);
+ if ( *qtype == CC ) *arl = mxewma_arl_0d(*l, *c, *p, *hs, *r);
+ if ( *qtype == MC ) *arl = mxewma_arl_0e(*l, *c, *p, *hs, *r);
+ if ( *qtype == SR ) *arl = mxewma_arl_0f(*l, *c, *p, *hs, *r);
+ }
+ else {
+ if ( *qtype == GL ) *arl = mxewma_arl_1a(*l, *c, *p, *delta, *hs, *r);
+ if ( *qtype == GL2 ) *arl = mxewma_arl_1a2(*l, *c, *p, *delta, *hs, *r);
+ if ( *qtype == GL3 ) *arl = mxewma_arl_1a3(*l, *c, *p, *delta, *hs, *r);
+ if ( *qtype == GL4 ) *arl = mxewma_arl_1a4(*l, *c, *p, *delta, *hs, *r);
+ if ( *qtype == GL5 ) *arl = mxewma_arl_1a5(*l, *c, *p, *delta, *hs, *r);
+
+ if ( *qtype == CO ) *arl = mxewma_arl_1b(*l, *c, *p, *delta, *hs, *r, *qm0, *qm1);
+ if ( *qtype == CO2 ) *arl = mxewma_arl_1b2(*l, *c, *p, *delta, *hs, *r, *qm0, *qm1);
+ if ( *qtype == CO3 ) *arl = mxewma_arl_1b3(*l, *c, *p, *delta, *hs, *r, *qm0, *qm1);
+ if ( *qtype == CO4 ) *arl = mxewma_arl_1b4(*l, *c, *p, *delta, *hs, *r, *qm0, *qm1);
+ if ( *qtype == RA ) *arl = mxewma_arl_1c(*l, *c, *p, *delta, *hs, *r);
+ if ( *qtype == CC ) *arl = mxewma_arl_1d(*l, *c, *p, *delta, *hs, *r);
+ if ( *qtype == MC ) *arl = mxewma_arl_1e(*l, *c, *p, *delta, *hs, *r);
+ if ( *qtype == SR ) *arl = mxewma_arl_1f(*l, *c, *p, *delta, *hs, *r);
+ }
+}
diff --git a/src/mewma_arl_f.c b/src/mewma_arl_f.c
new file mode 100644
index 0000000..ce7c144
--- /dev/null
+++ b/src/mewma_arl_f.c
@@ -0,0 +1,120 @@
+#include <stdio.h>
+#include <math.h>
+#include <stdlib.h>
+#include <R.h>
+
+#define GL 0
+#define CO 1
+#define RA 2
+#define CC 3
+#define MC 4
+#define SR 5
+#define CO2 6
+#define GL2 7
+#define GL3 8
+#define GL4 9
+#define GL5 10
+#define CO3 11
+#define CO4 12
+
+double mxewma_arl_f_0a(double lambda, double ce, int p, int N, double *ARL, double *w, double *z);
+double mxewma_arl_f_0a2(double lambda, double ce, int p, int N, double *ARL, double *w, double *z);
+double mxewma_arl_f_0b(double lambda, double ce, int p, int N, int qm, double *ARL);
+double mxewma_arl_f_0c(double lambda, double ce, int p, int N, double *ARL, double *w, double *z);
+double mxewma_arl_f_0d(double lambda, double ce, int p, int N, double *ARL, double *w, double *z);
+double mxewma_arl_f_0e(double lambda, double ce, int p, int N, double *ARL, double *z);
+double mxewma_arl_f_0f(double lambda, double ce, int p, int N, double *ARL, double *w, double *z);
+
+double mxewma_arl_f_1a (double lambda, double ce, int p, double delta, int N, double *g, double *w0, double *z0, double *w1, double *z1); /* GL class */
+double mxewma_arl_f_1a2(double lambda, double ce, int p, double delta, int N, double *g, double *w0, double *z0, double *w1, double *z1); /* GL mod */
+double mxewma_arl_f_1a3(double lambda, double ce, int p, double delta, int N, double *g, double *w0, double *z0, double *w1, double *z1); /* GL again mod sin, default for 2 and 4 */
+double mxewma_arl_f_1a4(double lambda, double ce, int p, double delta, int N, double *g, double *w0, double *z0, double *w1, double *z1); /* GL again mod tan */
+double mxewma_arl_f_1a5(double lambda, double ce, int p, double delta, int N, double *g, double *w0, double *z0, double *w1, double *z1); /* GL again mod sinh, default for all other p */
+
+double mxewma_arl_f_1b (double lambda, double ce, int p, double delta, int N, int qm0, int qm1, double *g); /* collocation with two halfs in the same step + sin() */
+double mxewma_arl_f_1b3(double lambda, double ce, int p, double delta, int N, int qm0, int qm1, double *g); /* collocation with two halfs in the same step */
+double mxewma_arl_f_1b2(double lambda, double ce, int p, double delta, int N, int qm0, int qm1, double *g); /* collocation with shrinked supports of the outer integral */
+double mxewma_arl_f_1b4(double lambda, double ce, int p, double delta, int N, int qm0, int qm1, double *g); /* collocation with two halfs in the same step + sinh() instead of sin() */
+
+double mxewma_arl_f_1c (double lambda, double ce, int p, double delta, int N, double *g, double *w0, double *z0, double *w1, double *z1); /* GL + Radau (Rigdon) */
+double mxewma_arl_f_1d (double lambda, double ce, int p, double delta, int N, double *g, double *w0, double *z0, double *w1, double *z1); /* Clenshaw-Curtis */
+double mxewma_arl_f_1e (double lambda, double ce, int p, double delta, int N, double *g, int *dQ); /* Markov Chain (Runger/Prabhu) */
+double mxewma_arl_f_1f (double lambda, double ce, int p, double delta, int N, double *g, double *w0, double *z0, double *w1, double *z); /* Simpson rule */
+
+double *vector (long n);
+
+void mewma_arl_f(double *l, double *c, int *p, double *delta, int *r, int *qtype, int *qm0, int *qm1, double *zeug)
+{ double *ARL, *w, *z, *w1, *z1, zahl=0.;
+ int i, j, r2, dQ;
+
+ if ( fabs(*delta)<1e-10 ) {
+ ARL = vector(*r);
+ w = vector(*r);
+ z = vector(*r);
+
+ for (i = 0; i < *r; i++) { w[i] = -1.; z[i] = 0.; } /* init */
+
+ if ( *qtype == GL ) zahl = mxewma_arl_f_0a (*l, *c, *p, *r, ARL, w, z);
+ if ( *qtype == GL2 ) zahl = mxewma_arl_f_0a2(*l, *c, *p, *r, ARL, w, z);
+ if ( *qtype == CO ) zahl = mxewma_arl_f_0b (*l, *c, *p, *r, *qm0, ARL);
+ if ( *qtype == RA ) zahl = mxewma_arl_f_0c (*l, *c, *p, *r, ARL, w, z);
+ if ( *qtype == CC ) zahl = mxewma_arl_f_0d (*l, *c, *p, *r, ARL, w, z);
+ if ( *qtype == MC ) zahl = mxewma_arl_f_0e (*l, *c, *p, *r, ARL, z);
+ if ( *qtype == SR ) zahl = mxewma_arl_f_0f (*l, *c, *p, *r, ARL, w, z);
+
+ for (i = 0; i < *r; i++) {
+ zeug[i] = ARL[i];
+ zeug[i + *r] = w[i];
+ zeug[i + *r + *r] = z[i];
+ }
+
+ Free(z);
+ Free(w);
+ Free(ARL);
+ }
+ else {
+ r2 = (*r) * (*r);
+ ARL = vector(r2);
+ w = vector(*r);
+ z = vector(*r);
+ w1 = vector(*r);
+ z1 = vector(*r);
+
+ if ( *qtype == GL ) zahl = mxewma_arl_f_1a (*l, *c, *p, *delta, *r, ARL, w, z, w1, z1);
+ if ( *qtype == GL2 ) zahl = mxewma_arl_f_1a2(*l, *c, *p, *delta, *r, ARL, w, z, w1, z1);
+ if ( *qtype == GL3 ) zahl = mxewma_arl_f_1a3(*l, *c, *p, *delta, *r, ARL, w, z, w1, z1);
+ if ( *qtype == GL4 ) zahl = mxewma_arl_f_1a4(*l, *c, *p, *delta, *r, ARL, w, z, w1, z1);
+ if ( *qtype == GL5 ) zahl = mxewma_arl_f_1a5(*l, *c, *p, *delta, *r, ARL, w, z, w1, z1);
+
+ if ( *qtype == CO ) zahl = mxewma_arl_f_1b (*l, *c, *p, *delta, *r, *qm0, *qm1, ARL);
+ if ( *qtype == CO2 ) zahl = mxewma_arl_f_1b2(*l, *c, *p, *delta, *r, *qm0, *qm1, ARL);
+ if ( *qtype == CO3 ) zahl = mxewma_arl_f_1b3(*l, *c, *p, *delta, *r, *qm0, *qm1, ARL);
+ if ( *qtype == CO4 ) zahl = mxewma_arl_f_1b4(*l, *c, *p, *delta, *r, *qm0, *qm1, ARL);
+
+ if ( *qtype == RA ) zahl = mxewma_arl_f_1c(*l, *c, *p, *delta, *r, ARL, w, z, w1, z1);
+ if ( *qtype == CC ) zahl = mxewma_arl_f_1d(*l, *c, *p, *delta, *r, ARL, w, z, w1, z1);
+ if ( *qtype == MC ) zahl = mxewma_arl_f_1e(*l, *c, *p, *delta, *r, zeug, &dQ);
+ if ( *qtype == SR ) zahl = mxewma_arl_f_1f(*l, *c, *p, *delta, *r, ARL, w, z, w1, z1);
+
+ if ( *qtype != MC ) {
+ for (i = 0; i < *r; i++) {
+ for (j = 0; j < *r; j++) zeug[ i*(*r) + j ] = ARL[ i*(*r) + j ];
+ zeug[i + r2] = w[i];
+ zeug[i + r2 + *r] = z[i];
+ zeug[i + r2 + 2*(*r)] = w1[i];
+ zeug[i + r2 + 3*(*r)] = z1[i];
+ }
+ } /*else {
+ printf("\n\ndQ = %d\n\n", dQ);
+ for (i=0; i < dQ; i++) zeug[i] = ARL[i];
+ } */
+
+ Free(z1);
+ Free(w1);
+ Free(z);
+ Free(w);
+ Free(ARL);
+ }
+
+ if ( fabs(zahl) > 1e-9 ) warning("trouble in mewma_arl_f [package spc]");
+}
diff --git a/src/mewma_crit.c b/src/mewma_crit.c
new file mode 100644
index 0000000..64736ad
--- /dev/null
+++ b/src/mewma_crit.c
@@ -0,0 +1,11 @@
+#include <stdio.h>
+#include <math.h>
+#include <stdlib.h>
+#include <R.h>
+
+double mxewma_crit(double lambda, double L0, int p, double hs, int N);
+
+void mewma_crit(double *l, double *L0, int *p, double *hs, int *r, double *h)
+{
+ *h = mxewma_crit(*l, *L0, *p, *hs, *r);
+}
diff --git a/src/mewma_psi.c b/src/mewma_psi.c
new file mode 100644
index 0000000..761fae0
--- /dev/null
+++ b/src/mewma_psi.c
@@ -0,0 +1,35 @@
+#include <stdio.h>
+#include <math.h>
+#include <stdlib.h>
+#include <R.h>
+
+#define cond 0
+#define cycl 1
+
+double *vector (long n);
+
+double mxewma_psi (double lambda, double ce, int p, int N, double *PSI, double *w, double *z);
+double mxewma_psiS(double lambda, double ce, int p, double hs, int N, double *PSI, double *w, double *z);
+
+void mewma_psi(double *l, double *c, int *p, int *type, double *hs, int *r, double *zeug)
+{ double *PSI, *w, *z, zahl=0.;
+ int i;
+
+ PSI = vector(*r);
+ w = vector(*r);
+ z = vector(*r);
+
+ if ( *type == cond ) zahl = mxewma_psi (*l, *c, *p, *r, PSI, w, z);
+ if ( *type == cycl ) zahl = mxewma_psiS(*l, *c, *p, *hs, *r, PSI, w, z);
+
+ zeug[0] = zahl;
+ for (i = 1; i <= *r; i++) {
+ zeug[i] = PSI[i-1];
+ zeug[i + *r] = w[i-1];
+ zeug[i + *r + *r] = z[i-1];
+ }
+
+ Free(z);
+ Free(w);
+ Free(PSI);
+}
diff --git a/src/phat_cdf.c b/src/phat_cdf.c
new file mode 100644
index 0000000..15a51fc
--- /dev/null
+++ b/src/phat_cdf.c
@@ -0,0 +1,15 @@
+#include <stdio.h>
+#include <math.h>
+#include <stdlib.h>
+#include <R.h>
+
+double cdf_phat(double p, double mu, double sigma, int n, double LSL, double USL);
+double cdf_phat2(double p, double mu, double sigma, int n, double LSL, double USL, int nodes);
+
+void phat_cdf
+(double *x, int *n, double *mu, double *sigma, int *ctyp, double *LSL, double *USL, int *nodes, double *cdf)
+{
+ *cdf = -1.;
+ if ( *ctyp == 0 ) *cdf = cdf_phat(*x, *mu, *sigma, *n, *LSL, *USL);
+ if ( *ctyp == 1 ) *cdf = cdf_phat2(*x, *mu, *sigma, *n, *LSL, *USL, *nodes);
+}
diff --git a/src/phat_pdf.c b/src/phat_pdf.c
new file mode 100644
index 0000000..f3b17b1
--- /dev/null
+++ b/src/phat_pdf.c
@@ -0,0 +1,15 @@
+#include <stdio.h>
+#include <math.h>
+#include <stdlib.h>
+#include <R.h>
+
+double pdf_phat (double p, double mu, double sigma, int n, double LSL, double USL);
+double pdf_phat2(double p, double mu, double sigma, int n, double LSL, double USL, int nodes);
+
+void phat_pdf
+(double *x, int *n, double *mu, double *sigma, int *ctyp, double *LSL, double *USL, int *nodes, double *pdf)
+{
+ *pdf = -1.;
+ if ( *ctyp == 0 ) *pdf = pdf_phat (*x, *mu, *sigma, *n, *LSL, *USL);
+ if ( *ctyp == 1 ) *pdf = pdf_phat2(*x, *mu, *sigma, *n, *LSL, *USL, *nodes);
+}
diff --git a/src/phat_qf.c b/src/phat_qf.c
new file mode 100644
index 0000000..41489ee
--- /dev/null
+++ b/src/phat_qf.c
@@ -0,0 +1,15 @@
+#include <stdio.h>
+#include <math.h>
+#include <stdlib.h>
+#include <R.h>
+
+double qf_phat(double p0, double mu, double sigma, int n, double LSL, double USL);
+double qf_phat2(double p0, double mu, double sigma, int n, double LSL, double USL, int nodes);
+
+void phat_qf
+(double *x, int *n, double *mu, double *sigma, int *ctyp, double *LSL, double *USL, int *nodes, double *qf)
+{
+ *qf = -1.;
+ if ( *ctyp == 0 ) *qf = qf_phat(*x, *mu, *sigma, *n, *LSL, *USL);
+ if ( *ctyp == 1 ) *qf = qf_phat2(*x, *mu, *sigma, *n, *LSL, *USL, *nodes);
+}
diff --git a/src/quadrature_nodes_weights.c b/src/quadrature_nodes_weights.c
new file mode 100644
index 0000000..a08a42f
--- /dev/null
+++ b/src/quadrature_nodes_weights.c
@@ -0,0 +1,30 @@
+#include <stdio.h>
+#include <math.h>
+#include <stdlib.h>
+#include <R.h>
+
+#define GL 0
+#define Ra 1
+
+double *vector (long n);
+void gausslegendre(int n, double x1, double x2, double *x, double *w);
+void radau(int n, double x1, double x2, double *x, double *w);
+
+void quadrature_nodes_weights(int *n, double *x1, double *x2, int *type, double *nodes_weights)
+{ double *knoten, *gewichte;
+ int i;
+
+ knoten = vector(*n);
+ gewichte = vector(*n);
+
+ if ( *type==GL ) gausslegendre(*n, *x1, *x2, knoten, gewichte);
+ if ( *type==Ra ) radau(*n, *x1, *x2, knoten, gewichte);
+
+ for (i=0; i<*n; i++) {
+ nodes_weights[i] = knoten[i];
+ nodes_weights[i+*n] = gewichte[i];
+ }
+
+ Free(gewichte);
+ Free(knoten);
+}
diff --git a/src/scusum_arl.c b/src/scusum_arl.c
new file mode 100644
index 0000000..6d8351b
--- /dev/null
+++ b/src/scusum_arl.c
@@ -0,0 +1,31 @@
+#include <stdio.h>
+#include <math.h>
+#include <stdlib.h>
+#include <R.h>
+
+#define cusumU 0
+#define cusumL 1
+#define cusum2 2
+
+double scU_iglarl_v1(double refk, double h, double hs, double sigma, int df, int N, int qm);
+double scU_iglarl_v2(double refk, double h, double hs, double sigma, int df, int N, int qm);
+double scL_iglarl_v2(double refk, double h, double hs, double sigma, int df, int N, int qm);
+double sc2_iglarl_v2(double refkl, double refku, double hl, double hu, double hsl, double hsu, double sigma, int df, int N, int qm);
+
+void scusum_arl
+( int *ctyp, double *k, double *h, double *hs, double *sigma, int *df, double *k2, double *h2, double *hs2, int *r, int *qm, int *version, double *arl)
+{
+ *arl = -1.;
+ if ( *ctyp==cusumU ) {
+ if ( *version==1 ) *arl = scU_iglarl_v1(*k, *h, *hs, *sigma, *df, *r, *qm);
+ if ( *version==2 ) *arl = scU_iglarl_v2(*k, *h, *hs, *sigma, *df, *r, *qm);
+ }
+ if ( *ctyp==cusumL ) {
+ /*if ( *version==1 ) *arl = scL_iglarl_v1(*k, *h, *hs, *sigma, *df, *r, *qm);*/
+ if ( *version==2 ) *arl = scL_iglarl_v2(*k, *h, *hs, *sigma, *df, *r, *qm);
+ }
+ if ( *ctyp==cusum2 ) {
+ /*if ( *version==1 ) *arl = sc2_iglarl_v1(*k2, *k, *h2, *h, *hs2, *hs, *sigma, *df, *r, *qm);*/
+ if ( *version==2 ) *arl = sc2_iglarl_v2(*k2, *k, *h2, *h, *hs2, *hs, *sigma, *df, *r, *qm);
+ }
+}
diff --git a/src/scusum_crit.c b/src/scusum_crit.c
new file mode 100644
index 0000000..c122807
--- /dev/null
+++ b/src/scusum_crit.c
@@ -0,0 +1,26 @@
+#include <stdio.h>
+#include <math.h>
+#include <stdlib.h>
+#include <R.h>
+
+#define cusumU 0
+#define cusumL 1
+#define cusum2 2
+
+double scU_crit(double refk, double L0, double hs, double sigma, int df, int N, int qm);
+double scL_crit(double refk, double L0, double hs, double sigma, int df, int N, int qm);
+int sc2_crit_unbiased(double refkl, double refku, double L0, double *hl, double *hu, double hsl, double hsu, double sigma, int df, int N, int qm);
+
+void scusum_crit(int *ctyp, double *k, double *L0, double *hs, double *sigma, int *df, int *ltyp, double *k2, double *hs2, int *r, int *qm, double *h)
+{ int result=0;
+ double hl=0., hu=0.;
+
+ if ( *ctyp==cusumU ) *h = scU_crit(*k, *L0, *hs, *sigma, *df, *r, *qm);
+ if ( *ctyp==cusumL ) *h = scL_crit(*k, *L0, *hs, *sigma, *df, *r, *qm);
+ if ( *ctyp==cusum2 ) {
+ result = sc2_crit_unbiased(*k2, *k, *L0, &hl, &hu, *hs2, *hs, *sigma, *df, *r, *qm);
+ if ( result != 0 ) warning("trouble with sc2_crit_unbiased called from scusum_crit [package spc]");
+ h[0] = hl;
+ h[1] = hu;
+ }
+}
diff --git a/src/sewma_arl.c b/src/sewma_arl.c
new file mode 100644
index 0000000..e5fbe31
--- /dev/null
+++ b/src/sewma_arl.c
@@ -0,0 +1,36 @@
+#include <stdio.h>
+#include <math.h>
+#include <stdlib.h>
+#include <R.h>
+
+#define ewmaU 0
+#define ewmaUR 1
+#define ewma2 2
+#define ewmaLR 3
+
+double seU_iglarl(double l, double cu, double hs, double sigma, int df, int N, int qm);
+double se2_iglarl(double l, double cl, double cu, double hs, double sigma, int df, int N, int qm);
+double seUR_iglarl(double l, double cl, double cu, double hs, double sigma, int df, int N, int qm);
+double seLR_iglarl(double l, double cl, double cu, double hs, double sigma, int df, int N, int qm);
+
+double stdeU_iglarl(double l, double cu, double hs, double sigma, int df, int N, int qm);
+double stde2_iglarl(double l, double cl, double cu, double hs, double sigma, int df, int N, int qm);
+double stdeUR_iglarl(double l, double cl, double cu, double hs, double sigma, int df, int N, int qm);
+double stdeLR_iglarl(double l, double cl, double cu, double hs, double sigma, int df, int N, int qm);
+
+void sewma_arl
+( int *ctyp, double *l, double *cl, double *cu, double *hs, double *sigma, int *df, int *r, int *qm, int *s_squared, double *arl)
+{
+ *arl = -1.;
+ if ( *s_squared==1 ) {
+ if ( *ctyp==ewmaU ) *arl = seU_iglarl(*l,*cu,*hs,*sigma,*df,*r,*qm);
+ if ( *ctyp==ewma2 ) *arl = se2_iglarl(*l,*cl,*cu,*hs,*sigma,*df,*r,*qm);
+ if ( *ctyp==ewmaUR ) *arl = seUR_iglarl(*l,*cl,*cu,*hs,*sigma,*df,*r,*qm);
+ if ( *ctyp==ewmaLR ) *arl = seLR_iglarl(*l,*cl,*cu,*hs,*sigma,*df,*r,*qm);
+ } else {
+ if ( *ctyp==ewmaU ) *arl = stdeU_iglarl(*l,*cu,*hs,*sigma,*df,*r,*qm);
+ if ( *ctyp==ewma2 ) *arl = stde2_iglarl(*l,*cl,*cu,*hs,*sigma,*df,*r,*qm);
+ if ( *ctyp==ewmaUR ) *arl = stdeUR_iglarl(*l,*cl,*cu,*hs,*sigma,*df,*r,*qm);
+ if ( *ctyp==ewmaLR ) *arl = stdeLR_iglarl(*l,*cl,*cu,*hs,*sigma,*df,*r,*qm);
+ }
+}
diff --git a/src/sewma_arl_prerun.c b/src/sewma_arl_prerun.c
new file mode 100644
index 0000000..a45d414
--- /dev/null
+++ b/src/sewma_arl_prerun.c
@@ -0,0 +1,24 @@
+#include <stdio.h>
+#include <math.h>
+#include <stdlib.h>
+#include <R.h>
+
+#define ewmaU 0
+#define ewmaUR 1
+#define ewma2 2
+#define ewmaLR 3
+
+double seU_iglarl_prerun_SIGMA(double l, double cu, double hs, double sigma, int df1, int df2, int N, int qm1, int qm2, double truncate);
+double seUR_iglarl_prerun_SIGMA(double l, double cl, double cu, double hs, double sigma, int df1, int df2, int N, int qm1, int qm2, double truncate);
+double se2_iglarl_prerun_SIGMA(double l, double cl, double cu, double hs, double sigma, int df1, int df2, int N, int qm1, int qm2, double truncate);
+double seLR_iglarl_prerun_SIGMA(double l, double cl, double cu, double hs, double sigma, int df1, int df2, int N, int qm1, int qm2, double truncate);
+
+void sewma_arl_prerun
+( int *ctyp, double *l, double *cl, double *cu, double *hs, double *sigma, int *df1, int *N, int *qm1, int *df2, int *qm2, double *truncate, double *arl)
+{
+ *arl = -1.;
+ if ( *ctyp==ewmaU ) *arl = seU_iglarl_prerun_SIGMA(*l, *cu, *hs, *sigma, *df1, *df2, *N, *qm1, *qm2, *truncate);
+ if ( *ctyp==ewma2 ) *arl = se2_iglarl_prerun_SIGMA(*l, *cl, *cu, *hs, *sigma, *df1, *df2, *N, *qm1, *qm2, *truncate);
+ if ( *ctyp==ewmaUR ) *arl = seUR_iglarl_prerun_SIGMA(*l, *cl, *cu, *hs, *sigma, *df1, *df2, *N, *qm1, *qm2, *truncate);
+ if ( *ctyp==ewmaLR ) *arl = seLR_iglarl_prerun_SIGMA(*l, *cl, *cu, *hs, *sigma, *df1, *df2, *N, *qm1, *qm2, *truncate);
+}
diff --git a/src/sewma_crit.c b/src/sewma_crit.c
new file mode 100644
index 0000000..f5c900d
--- /dev/null
+++ b/src/sewma_crit.c
@@ -0,0 +1,73 @@
+#include <stdio.h>
+#include <math.h>
+#include <stdlib.h>
+#include <R.h>
+
+#define ewmaU 0
+#define ewmaUR 1
+#define ewma2 2
+#define ewmaLR 3
+#define fixed 0
+#define unbiased 1
+#define eqtails 2
+#define sym 3
+
+double seU_crit(double l, double L0, double hs, double sigma, int df, int N, int qm);
+double seUR_crit(double l, double L0, double cl, double hs, double sigma, int df, int N, int qm);
+double seLR_crit(double l, double L0, double cu, double hs, double sigma, int df, int N, int qm);
+double se2fu_crit(double l, double L0, double cu, double hs, double sigma, int df, int N, int qm);
+
+int se2_crit_unbiased(double l, double L0, double *cl, double *cu, double hs, double sigma, int df, int N, int qm);
+int se2_crit_eqtails(double l, double L0, double *cl, double *cu, double hs, double sigma, int df, double ur, int N, int qm);
+double se2_crit_sym(double l, double L0, double hs, double sigma, int df, int N, int qm);
+
+double stdeU_crit(double l, double L0, double hs, double sigma, int df, int N, int qm);
+double stdeUR_crit(double l, double L0, double cl, double hs, double sigma, int df, int N, int qm);
+double stdeLR_crit(double l, double L0, double cu, double hs, double sigma, int df, int N, int qm);
+double stde2fu_crit(double l, double L0, double cu, double hs, double sigma, int df, int N, int qm);
+
+int stde2_crit_unbiased(double l, double L0, double *cl, double *cu, double hs, double sigma, int df, int N, int qm);
+int stde2_crit_eqtails(double l, double L0, double *cl, double *cu, double hs, double sigma, int df, double ur, int N, int qm);
+double stde2_crit_sym(double l, double L0, double hs, double sigma, int df, int N, int qm);
+
+double c_four(double ddf);
+
+void sewma_crit
+( int *ctyp, int *ltyp, double *l, double *L0, double *cl0, double *cu0, double *hs, double *sigma, int *df, int *r, int *qm, double *ur, int *s_squared, double *c_values)
+{ int result=0;
+ double cl=0., cu=1., mitte=1.;
+
+ if ( *s_squared==1 ) {
+ if (*ctyp==ewmaU) cu = seU_crit(*l,*L0,*hs,*sigma,*df,*r,*qm);
+ if (*ctyp==ewmaUR) cu = seUR_crit(*l,*L0,*cl0,*hs,*sigma,*df,*r,*qm);
+ if (*ctyp==ewmaLR) cl = seLR_crit(*l,*L0,*cu0,*hs,*sigma,*df,*r,*qm);
+ if (*ctyp==ewma2) {
+ if (*ltyp==fixed) {
+ cl = se2fu_crit(*l,*L0,*cu0,*hs,*sigma,*df,*r,*qm);
+ cu = *cu0;
+ }
+ if (*ltyp==unbiased) result = se2_crit_unbiased(*l, *L0, &cl, &cu, *hs, *sigma, *df, *r, *qm);
+ if (*ltyp==eqtails) result = se2_crit_eqtails(*l, *L0, &cl, &cu, *hs, *sigma, *df, *ur, *r, *qm);
+ if (*ltyp==sym) { cu = se2_crit_sym(*l, *L0, *hs, *sigma, *df, *r, *qm); cl = 2. - cu; }
+ }
+ } else {
+ mitte = c_four((double)*df);
+ if ( *ctyp==ewmaU ) cu = stdeU_crit(*l,*L0,*hs,*sigma,*df,*r,*qm);
+ if ( *ctyp==ewmaUR ) cu = stdeUR_crit(*l,*L0,*cl0,*hs,*sigma,*df,*r,*qm);
+ if ( *ctyp==ewmaLR ) cl = stdeLR_crit(*l,*L0,*cu0,*hs,*sigma,*df,*r,*qm);
+ if ( *ctyp==ewma2 ) {
+ if ( *ltyp==fixed ) {
+ cl = stde2fu_crit(*l,*L0,*cu0,*hs,*sigma,*df,*r,*qm);
+ cu = *cu0;
+ }
+ if ( *ltyp==unbiased ) result = stde2_crit_unbiased(*l, *L0, &cl, &cu, *hs, *sigma, *df, *r, *qm);
+ if ( *ltyp==eqtails ) result = stde2_crit_eqtails(*l, *L0, &cl, &cu, *hs, *sigma, *df, *ur, *r, *qm);
+ if ( *ltyp==sym ) { cu = stde2_crit_sym(*l, *L0, *hs, *sigma, *df, *r, *qm); cl = 2.*mitte - cu; }
+ }
+ }
+
+ if ( result != 0 ) warning("trouble with se2_crit called from sewma_crit [package spc]");
+
+ c_values[0] = cl;
+ c_values[1] = cu;
+}
diff --git a/src/sewma_crit_prerun.c b/src/sewma_crit_prerun.c
new file mode 100644
index 0000000..dbc91fe
--- /dev/null
+++ b/src/sewma_crit_prerun.c
@@ -0,0 +1,48 @@
+#include <stdio.h>
+#include <math.h>
+#include <stdlib.h>
+#include <R.h>
+
+#define ewmaU 0
+#define ewmaUR 1
+#define ewma2 2
+#define ewmaLR 3
+
+#define fixed 0
+#define unbiased 1
+
+double seU_crit_prerun_SIGMA(double l, double L0, double hs, double sigma, int df1, int df2, int N, int qm1, int qm2, double truncate);
+double se2fu_crit_prerun_SIGMA(double l, double L0, double cu, double hs, double sigma, int df1, int df2, int N, int qm1, int qm2, double truncate);
+int se2_crit_prerun_SIGMA(double l, double L0, double *cl, double *cu, double hs, double sigma, int df1, int df2, int N, int qm1, int qm2, double truncate);
+double seUR_crit_prerun_SIGMA(double l, double L0, double cl, double hs, double sigma, int df1, int df2, int N, int qm1, int qm2, double truncate);
+double seLR_crit_prerun_SIGMA(double l, double L0, double cu, double hs, double sigma, int df1, int df2, int N, int qm1, int qm2, double truncate);
+
+void sewma_crit_prerun
+( int *ctyp, int *ltyp, double *l, int *L0, double *cl0, double *cu0, double *hs, double *sigma, int *df1, int *r, int *qm1,
+ int *df2, int *qm2, double *truncate, int *tail_approx, double *c_error, double *a_error, double *c_values)
+{ int result=0;
+ double cl=0., cu=1.;
+
+ if ( *ctyp==ewmaU )
+ { cu = seU_crit_prerun_SIGMA(*l, *L0, *hs, *sigma, *df1, *df2, *r, *qm1, *qm2, *truncate); cl = 0.; }
+
+ if ( *ctyp==ewmaUR )
+ { cu = seUR_crit_prerun_SIGMA(*l, *L0, *cl0, *hs, *sigma, *df1, *df2, *r, *qm1, *qm2, *truncate); cl = *cl0; }
+
+ if ( *ctyp==ewmaLR )
+ { cl = seLR_crit_prerun_SIGMA(*l, *L0, *cu0, *hs, *sigma, *df1, *df2, *r, *qm1, *qm2, *truncate); cu = *cu0; }
+
+ if ( *ctyp==ewma2 ) {
+ if ( *ltyp==fixed ) {
+ cl = se2fu_crit_prerun_SIGMA(*l, *L0, *cu0, *hs, *sigma, *df1, *df2, *r, *qm1, *qm2, *truncate);
+ cu = *cu0;
+ }
+ if ( *ltyp==unbiased )
+ result = se2_crit_prerun_SIGMA(*l, *L0, &cl, &cu, *hs, *sigma, *df1, *df2, *r, *qm1, *qm2, *truncate);
+ }
+
+ if ( result != 0 ) warning("trouble with se2_crit_prerun_SIGMA called from sewma_crit_prerun [package spc]");
+
+ c_values[0] = cl;
+ c_values[1] = cu;
+}
diff --git a/src/sewma_q.c b/src/sewma_q.c
new file mode 100644
index 0000000..8418296
--- /dev/null
+++ b/src/sewma_q.c
@@ -0,0 +1,24 @@
+#include <stdio.h>
+#include <math.h>
+#include <stdlib.h>
+#include <R.h>
+
+#define ewmaU 0
+#define ewmaUR 1
+#define ewma2 2
+#define ewmaLR 3
+
+double seU_Wq(double l, double cu, double p, double hs, double sigma, int df, int N, int nmax, int qm);
+double se2_Wq(double l, double cl, double cu, double p, double hs, double sigma, int df, int N, int nmax, int qm);
+double seUR_Wq(double l, double cl, double cu, double p, double hs, double sigma, int df, int N, int nmax, int qm);
+double seLR_Wq(double l, double cl, double cu, double p, double hs, double sigma, int df, int N, int nmax, int qm);
+
+void sewma_q(int *ctyp, double *l, double *cl, double *cu, double *p, double *hs, int *N, double *sigma, int *df, int *qm, double *tq)
+{ int nmax=100000;
+
+ if ( *ctyp == ewmaU ) *tq = seU_Wq(*l, *cu, *p, *hs, *sigma, *df, *N, nmax, *qm);
+ if ( *ctyp == ewma2 ) *tq = se2_Wq(*l, *cl, *cu, *p, *hs, *sigma, *df, *N, nmax, *qm);
+ if ( *ctyp == ewmaUR ) *tq = seUR_Wq(*l, *cl, *cu, *p, *hs, *sigma, *df, *N, nmax, *qm);
+ if ( *ctyp == ewmaLR ) *tq = seLR_Wq(*l, *cl, *cu, *p, *hs, *sigma, *df, *N, nmax, *qm);
+
+}
diff --git a/src/sewma_q_crit.c b/src/sewma_q_crit.c
new file mode 100644
index 0000000..1394eeb
--- /dev/null
+++ b/src/sewma_q_crit.c
@@ -0,0 +1,45 @@
+#include <stdio.h>
+#include <math.h>
+#include <stdlib.h>
+#include <R.h>
+
+#define ewmaU 0
+#define ewmaUR 1
+#define ewma2 2
+#define ewmaLR 3
+
+#define fixed 0
+#define unbiased 1
+#define classic 2
+
+double seU_q_crit(double l, int L0, double alpha, double hs, double sigma, int df, int N, int qm, double c_error, double a_error);
+/*double se2lu_q_crit(double l, int L0, double alpha, double cl, double hs, double sigma, int df, int N, int qm, double c_error, double a_error);*/
+double se2fu_q_crit(double l, int L0, double alpha, double cu, double hs, double sigma, int df, int N, int qm, double c_error, double a_error);
+int se2_q_crit(double l, int L0, double alpha, double *cl, double *cu, double hs, double sigma, int df, int N, int qm, double c_error, double a_error);
+int se2_q_crit_class(double l, int L0, double alpha, double *cl, double *cu, double hs, double sigma, int df, double ur, int N, int qm, double c_error, double a_error);
+double seUR_q_crit(double l, int L0, double alpha, double cl, double hs, double sigma, int df, int N, int qm, double c_error, double a_error);
+double seLR_q_crit(double l, int L0, double alpha, double cu, double hs, double sigma, int df, int N, int qm, double c_error, double a_error);
+
+void sewma_q_crit
+( int *ctyp, int *ltyp, double *l, int *L0, double *alpha, double *cl0, double *cu0, double *hs, double *sigma, int *df, int *r, int *qm, double *ur,
+ double *c_error, double *a_error, double *c_values)
+{ int result=0;
+ double cl=0., cu=1.;
+
+ if ( *ctyp==ewmaU ) { cu = seU_q_crit(*l, *L0, *alpha, *hs, *sigma, *df, *r, *qm, *c_error, *a_error); cl = 0.; }
+ if ( *ctyp==ewmaUR ) { cu = seUR_q_crit(*l, *L0, *alpha, *cl0, *hs, *sigma, *df, *r, *qm, *c_error, *a_error); cl = *cl0; }
+ if ( *ctyp==ewmaLR ) { cl = seLR_q_crit(*l, *L0, *alpha, *cu0, *hs, *sigma, *df, *r, *qm, *c_error, *a_error); cu = *cu0; }
+ if ( *ctyp==ewma2 ) {
+ if ( *ltyp==fixed ) {
+ cl = se2fu_q_crit(*l, *L0, *alpha, *cu0, *hs, *sigma, *df, *r, *qm, *c_error, *a_error);
+ cu = *cu0;
+ }
+ if ( *ltyp==unbiased ) result = se2_q_crit(*l, *L0, *alpha, &cl, &cu, *hs, *sigma, *df, *r, *qm, *c_error, *a_error);
+ if ( *ltyp==classic ) result = se2_q_crit_class(*l, *L0, *alpha, &cl, &cu, *hs, *sigma, *df, *ur, *r, *qm, *c_error, *a_error);
+ }
+
+ if ( result != 0 ) warning("trouble with se2_crit called from sewma_q_crit [package spc]");
+
+ c_values[0] = cl;
+ c_values[1] = cu;
+}
diff --git a/src/sewma_q_crit_prerun.c b/src/sewma_q_crit_prerun.c
new file mode 100644
index 0000000..0223799
--- /dev/null
+++ b/src/sewma_q_crit_prerun.c
@@ -0,0 +1,51 @@
+#include <stdio.h>
+#include <math.h>
+#include <stdlib.h>
+#include <R.h>
+
+#define ewmaU 0
+#define ewmaUR 1
+#define ewma2 2
+#define ewmaLR 3
+
+#define fixed 0
+#define unbiased 1
+
+double seU_q_crit_prerun_SIGMA(double l, int L0, double alpha, double hs, double sigma, int df1, int df2, int N, int qm1, int qm2,
+ double truncate, int tail_approx, double c_error, double a_error);
+double se2fu_q_crit_prerun_SIGMA(double l, int L0, double alpha, double cu, double hs, double sigma, int df1, int df2, int N, int qm1, int qm2,
+ double truncate, int tail_approx, double c_error, double a_error);
+int se2_q_crit_prerun_SIGMA(double l, int L0, double alpha, double *cl, double *cu, double hs, double sigma, int df1, int df2, int N, int qm1, int qm2,
+ double truncate, int tail_approx, double c_error, double a_error);
+double seUR_q_crit_prerun_SIGMA(double l, int L0, double alpha, double cl, double hs, double sigma, int df1, int df2, int N, int qm1, int qm2,
+ double truncate, int tail_approx, double c_error, double a_error);
+double seLR_q_crit_prerun_SIGMA(double l, int L0, double alpha, double cu, double hs, double sigma, int df1, int df2, int N, int qm1, int qm2,
+ double truncate, int tail_approx, double c_error, double a_error);
+
+void sewma_q_crit_prerun
+( int *ctyp, int *ltyp, double *l, int *L0, double *alpha, double *cl0, double *cu0, double *hs, double *sigma, int *df1, int *r, int *qm1,
+ int *df2, int *qm2, double *truncate, int *tail_approx, double *c_error, double *a_error, double *c_values)
+{ int result=0;
+ double cl=0., cu=1.;
+
+ if ( *ctyp==ewmaU )
+ { cu = seU_q_crit_prerun_SIGMA(*l, *L0, *alpha, *hs, *sigma, *df1, *df2, *r, *qm1, *qm2, *truncate, *tail_approx, *c_error, *a_error); cl = 0.; }
+
+ if ( *ctyp==ewmaUR )
+ { cu = seUR_q_crit_prerun_SIGMA(*l, *L0, *alpha, *cl0, *hs, *sigma, *df1, *df2, *r, *qm1, *qm2, *truncate, *tail_approx, *c_error, *a_error); cl = *cl0; }
+ if ( *ctyp==ewmaLR )
+ { cl = seLR_q_crit_prerun_SIGMA(*l, *L0, *alpha, *cu0, *hs, *sigma, *df1, *df2, *r, *qm1, *qm2, *truncate, *tail_approx, *c_error, *a_error); cu = *cu0; }
+ if ( *ctyp==ewma2 ) {
+ if ( *ltyp==fixed ) {
+ cl = se2fu_q_crit_prerun_SIGMA(*l, *L0, *alpha, *cu0, *hs, *sigma, *df1, *df2, *r, *qm1, *qm2, *truncate, *tail_approx, *c_error, *a_error);
+ cu = *cu0;
+ }
+ if ( *ltyp==unbiased )
+ result = se2_q_crit_prerun_SIGMA(*l, *L0, *alpha, &cl, &cu, *hs, *sigma, *df1, *df2, *r, *qm1, *qm2, *truncate, *tail_approx, *c_error, *a_error);
+ }
+
+ if ( result != 0 ) warning("trouble with se2_crit called from sewma_q_crit_prerun [package spc]");
+
+ c_values[0] = cl;
+ c_values[1] = cu;
+}
diff --git a/src/sewma_q_prerun.c b/src/sewma_q_prerun.c
new file mode 100644
index 0000000..44ab17e
--- /dev/null
+++ b/src/sewma_q_prerun.c
@@ -0,0 +1,25 @@
+#include <stdio.h>
+#include <math.h>
+#include <stdlib.h>
+#include <R.h>
+
+#define ewmaU 0
+#define ewmaUR 1
+#define ewma2 2
+#define ewmaLR 3
+
+double seU_Wq_prerun_SIGMA_deluxe(double l, double cu, double p, double hs, double sigma, int df1, int df2, int nmax, int qm1, int qm2, double truncate);
+double seUR_Wq_prerun_SIGMA_deluxe(double l, double cl, double cu, double p, double hs, double sigma, int df1, int df2, int nmax, int qm1, int qm2, double truncate);
+double seLR_Wq_prerun_SIGMA_deluxe(double l, double cl, double cu, double p, double hs, double sigma, int df1, int df2, int nmax, int qm1, int qm2, double truncate);
+double se2_Wq_prerun_SIGMA_deluxe(double l, double cl, double cu, double p, double hs, double sigma, int df1, int df2, int nmax, int qm1, int qm2, double truncate);
+
+void sewma_q_prerun
+( int *ctyp, double *l, double *cl, double *cu, double *p, double *hs, double *sigma, int *df1, int *r, int *qm1, int *df2, int *qm2, double *truncate, double *tq)
+{ int nmax=100000;
+
+ if ( *ctyp == ewmaU ) *tq = seU_Wq_prerun_SIGMA_deluxe(*l, *cu, *p, *hs, *sigma, *df1, *df2, nmax, *qm1, *qm2, *truncate);
+ if ( *ctyp == ewma2 ) *tq = se2_Wq_prerun_SIGMA_deluxe(*l, *cl, *cu, *p, *hs, *sigma, *df1, *df2, nmax, *qm1, *qm2, *truncate);
+ if ( *ctyp == ewmaUR ) *tq = seUR_Wq_prerun_SIGMA_deluxe(*l, *cl, *cu, *p, *hs, *sigma, *df1, *df2, nmax, *qm1, *qm2, *truncate);
+ if ( *ctyp == ewmaLR ) *tq = seLR_Wq_prerun_SIGMA_deluxe(*l, *cl, *cu, *p, *hs, *sigma, *df1, *df2, nmax, *qm1, *qm2, *truncate);
+
+}
diff --git a/src/sewma_res_arl.c b/src/sewma_res_arl.c
new file mode 100644
index 0000000..4d03e21
--- /dev/null
+++ b/src/sewma_res_arl.c
@@ -0,0 +1,13 @@
+#include <stdio.h>
+#include <math.h>
+#include <stdlib.h>
+#include <R.h>
+
+double seU_iglarl_RES(double l, double cu, double hs, double sigma, int df, int N, int qm, double alpha, double mu);
+
+void s_res_ewma_arl
+( double *alpha, int *n, int *ctyp, double *l, double *cu, double *hs, double *sigma, double *mu, int *r, int *qm, double *arl)
+{
+ *arl = -1.;
+ *arl = seU_iglarl_RES(*l,*cu,*hs,*sigma,*n,*r,*qm,*alpha,*mu);
+}
diff --git a/src/sewma_sf.c b/src/sewma_sf.c
new file mode 100644
index 0000000..8e22839
--- /dev/null
+++ b/src/sewma_sf.c
@@ -0,0 +1,43 @@
+#include <stdio.h>
+#include <math.h>
+#include <stdlib.h>
+#include <R.h>
+
+#define ewmaU 0
+#define ewmaUR 1
+#define ewma2 2
+#define ewmaLR 3
+
+double *vector (long n);
+double seU_sf(double l, double cu, double hs, double sigma, int df, int N, int nmax, int qm, double *p0);
+double se2_sf(double l, double cl, double cu, double hs, double sigma, int df, int N, int nmax, int qm, double *p0);
+double seUR_sf(double l, double cl, double cu, double hs, double sigma, int df, int N, int nmax, int qm, double *p0);
+double seLR_sf(double l, double cl, double cu, double hs, double sigma, int df, int N, int nmax, int qm, double *p0);
+
+void sewma_sf
+( int *ctyp,
+ double *l, double *cl, double *cu, double *hs, int *N,
+ double *sigma,
+ int *df, int *qm, int *n, double *sf)
+{ int result=0, i;
+ double *p0;
+ p0 = vector(*n);
+
+ if ( *ctyp == ewmaU )
+ result = seU_sf(*l, *cu, *hs, *sigma, *df, *N, *n, *qm, p0);
+
+ if ( *ctyp == ewmaUR )
+ result = seUR_sf(*l, *cl, *cu, *hs, *sigma, *df, *N, *n, *qm, p0);
+
+ if ( *ctyp == ewma2 )
+ result = se2_sf(*l, *cl, *cu, *hs, *sigma, *df, *N, *n, *qm, p0);
+
+ if ( *ctyp == ewmaLR )
+ result = seLR_sf(*l, *cl, *cu, *hs, *sigma, *df, *N, *n, *qm, p0);
+
+ if ( result != 0 ) warning("trouble in sewma_sf [package spc]");
+
+ for (i=0; i<*n; i++) sf[i] = p0[i];
+
+ Free(p0);
+}
diff --git a/src/sewma_sf_prerun.c b/src/sewma_sf_prerun.c
new file mode 100644
index 0000000..7c5d954
--- /dev/null
+++ b/src/sewma_sf_prerun.c
@@ -0,0 +1,55 @@
+#include <stdio.h>
+#include <math.h>
+#include <stdlib.h>
+#include <R.h>
+
+#define ewmaU 0
+#define ewmaUR 1
+#define ewma2 2
+#define ewmaLR 3
+
+double *vector (long n);
+
+double seU_sf_prerun_SIGMA_deluxe(double l, double cu, double hs, double sigma, int df1, int df2, int nmax, int qm1, int qm2, double truncate, double *p0);
+double seU_sf_prerun_SIGMA(double l, double cu, double hs, double sigma, int df1, int df2, int nmax, int qm1, int qm2, double truncate, double *p0);
+
+double seUR_sf_prerun_SIGMA_deluxe(double l, double cl, double cu, double hs, double sigma, int df1, int df2, int nmax, int qm1, int qm2, double truncate, double *p0);
+double seUR_sf_prerun_SIGMA(double l, double cl, double cu, double hs, double sigma, int df1, int df2, int nmax, int qm1, int qm2, double truncate, double *p0);
+
+double se2_sf_prerun_SIGMA_deluxe(double l, double cl, double cu, double hs, double sigma, int df1, int df2, int nmax, int qm1, int qm2, double truncate, double *p0);
+double se2_sf_prerun_SIGMA(double l, double cl, double cu, double hs, double sigma, int df1, int df2, int nmax, int qm1, int qm2, double truncate, double *p0);
+
+double seLR_sf_prerun_SIGMA_deluxe(double l, double cl, double cu, double hs, double sigma, int df1, int df2, int nmax, int qm1, int qm2, double truncate, double *p0);
+double seLR_sf_prerun_SIGMA(double l, double cl, double cu, double hs, double sigma, int df1, int df2, int nmax, int qm1, int qm2, double truncate, double *p0);
+
+void sewma_sf_prerun
+( int *ctyp, double *l, double *cl, double *cu, double *hs, double *sigma, int *df1, int *qm1, int *n,
+ int *df2, int *qm2, double *truncate, int *tail_approx, double *sf)
+{ int result=0, i;
+ double *p0;
+ p0 = vector(*n);
+
+ if ( *ctyp == ewmaU ) {
+ if ( *tail_approx ) result = seU_sf_prerun_SIGMA_deluxe(*l, *cu, *hs, *sigma, *df1, *df2, *n, *qm1, *qm2, *truncate, p0);
+ else result = seU_sf_prerun_SIGMA(*l, *cu, *hs, *sigma, *df1, *df2, *n, *qm1, *qm2, *truncate, p0);
+ }
+
+ if ( *ctyp == ewmaUR ) {
+ if ( *tail_approx ) result = seUR_sf_prerun_SIGMA_deluxe(*l, *cl, *cu, *hs, *sigma, *df1, *df2, *n, *qm1, *qm2, *truncate, p0);
+ else result = seUR_sf_prerun_SIGMA(*l, *cl, *cu, *hs, *sigma, *df1, *df2, *n, *qm1, *qm2, *truncate, p0);
+ }
+
+ if ( *ctyp == ewma2 ) {
+ if ( *tail_approx ) result = se2_sf_prerun_SIGMA_deluxe(*l, *cl, *cu, *hs, *sigma, *df1, *df2, *n, *qm1, *qm2, *truncate, p0);
+ else result = se2_sf_prerun_SIGMA(*l, *cl, *cu, *hs, *sigma, *df1, *df2, *n, *qm1, *qm2, *truncate, p0);
+ }
+
+ if ( *ctyp == ewmaLR ) {
+ if ( *tail_approx ) result = seLR_sf_prerun_SIGMA_deluxe(*l, *cl, *cu, *hs, *sigma, *df1, *df2, *n, *qm1, *qm2, *truncate, p0);
+ else result = seLR_sf_prerun_SIGMA(*l, *cl, *cu, *hs, *sigma, *df1, *df2, *n, *qm1, *qm2, *truncate, p0);
+ }
+
+ if ( result != 0 ) warning("trouble in sewma_sf_prerun [package spc]");
+
+ for (i=0; i<*n; i++) sf[i] = p0[i];
+}
diff --git a/src/tol_lim_fac.c b/src/tol_lim_fac.c
new file mode 100644
index 0000000..f34a1d8
--- /dev/null
+++ b/src/tol_lim_fac.c
@@ -0,0 +1,16 @@
+#include <stdio.h>
+#include <math.h>
+#include <stdlib.h>
+#include <R.h>
+
+#define WW 0
+#define exact 1
+
+double kww(int n, double p, double a);
+double tl_factor(int n, double p, double a, int m);
+
+void tol_lim_fac(int *n, double *p, double *a, int *mtype, int *m, double *tlf )
+{
+ if (*mtype==WW) *tlf = kww(*n,*p,*a);
+ else *tlf = tl_factor(*n,*p,*a,*m);
+}
diff --git a/src/xDcusum_arl.c b/src/xDcusum_arl.c
new file mode 100644
index 0000000..f4647a7
--- /dev/null
+++ b/src/xDcusum_arl.c
@@ -0,0 +1,25 @@
+#include <stdio.h>
+#include <math.h>
+#include <stdlib.h>
+#include <R.h>
+
+#define cusum1 0
+#define cusum2 1
+#define cusumC 2
+
+#define Gan 0
+#define Knoth 1
+
+extern double rho0;
+
+double xc1_iglarl_drift(double k, double h, double hs, double delta, int m, int N, int with0);
+double xc1_iglarl_drift_wo_m(double k, double h, double hs, double delta, int *m, int N, int with0);
+double xc1_iglarlm_drift(double k, double h, double hs, int q, double delta, int N, int nmax, int with0);
+
+void xDcusum_arl
+( int *ctyp, double *k, double *h, double *hs, double *delta, int *m, int *r, int *with0, int *mode, int *q, double *arl)
+{
+ if (*ctyp==cusum1 && *m>0) *arl = xc1_iglarl_drift(*k, *h, *hs, *delta, *m, *r, *with0);
+ if (*ctyp==cusum1 && *m==0 && *mode==Gan) *arl = xc1_iglarl_drift_wo_m(*k, *h, *hs, *delta, m, *r, *with0);
+ if (*ctyp==cusum1 && *m==0 && *mode==Knoth) *arl = xc1_iglarlm_drift(*k, *h, *hs, *q, *delta, *r, 10000, *with0);
+}
diff --git a/src/xDewma_arl.c b/src/xDewma_arl.c
new file mode 100644
index 0000000..3b05bc5
--- /dev/null
+++ b/src/xDewma_arl.c
@@ -0,0 +1,50 @@
+#include <stdio.h>
+#include <math.h>
+#include <stdlib.h>
+#include <R.h>
+
+#define ewma1 0
+#define ewma2 1
+#define fix 0
+#define vacl 1
+#define fir 2
+#define both 3
+#define steiner 4
+#define sven 5
+#define fink 6
+#define waldmann 7
+#define collocation 8
+
+#define Gan 0
+#define Knoth 1
+#define Waldm 2
+
+extern double rho0;
+
+double xe1_iglarl_drift(double l, double c, double zr, double hs, double delta, int m, int N, int with0);
+double xe1_iglarl_drift_wo_m(double l, double c, double zr, double hs, double delta, int *m, int N, int with0);
+double xe1_iglarlm_drift(double l, double c, double zr, double hs, int q, double delta, int N, int nmax, int with0);
+double xe2_iglarl_drift(double l, double c, double hs, double delta, int m, int N, int with0);
+double xe2_iglarl_drift_wo_m(double l, double c, double hs, double delta, int *m, int N, int with0);
+double xe2_iglarlm_drift(double l, double c, double hs, int q, double delta, int N, int nmax, int with0);
+double xe2_Warl_drift(double l, double c, double hs, double delta, int N, int nmax, int with0);
+
+void xDewma_arl
+( int *ctyp, double *l, double *c, double *zr, double *hs, double *delta, int *ltyp, int *m, int *r, int *with0, int *mode, int *q, double *arl)
+{
+ if (*ctyp==ewma1 && *m>0)
+ *arl = xe1_iglarl_drift(*l,*c,*zr,*hs,*delta,*m,*r,*with0);
+ if (*ctyp==ewma1 && *m==0 && *mode==Gan)
+ *arl = xe1_iglarl_drift_wo_m(*l,*c,*zr,*hs,*delta,m,*r,*with0);
+ if (*ctyp==ewma1 && *m==0 && *mode==Knoth)
+ *arl = xe1_iglarlm_drift(*l,*c,*zr,*hs,*q,*delta,*r,10000,*with0);
+
+ if (*ctyp==ewma2 && *m>0)
+ *arl = xe2_iglarl_drift(*l,*c,*hs,*delta,*m,*r,*with0);
+ if (*ctyp==ewma2 && *m==0 && *mode==Gan)
+ *arl = xe2_iglarl_drift_wo_m(*l,*c,*hs,*delta,m,*r,*with0);
+ if (*ctyp==ewma2 && *m==0 && *mode==Knoth)
+ *arl = xe2_iglarlm_drift(*l,*c,*hs,*q,*delta,*r,10000,*with0);
+ if (*ctyp==ewma2 && *m==0 && *mode==Waldm)
+ *arl = xe2_Warl_drift(*l,*c,*hs,*delta,*r,10000,*with0);
+}
diff --git a/src/xDgrsr_arl.c b/src/xDgrsr_arl.c
new file mode 100644
index 0000000..8256de5
--- /dev/null
+++ b/src/xDgrsr_arl.c
@@ -0,0 +1,24 @@
+#include <stdio.h>
+#include <math.h>
+#include <stdlib.h>
+#include <R.h>
+
+#define grsr1 0
+#define grsr2 1
+
+#define Gan 0
+#define Knoth 1
+
+extern double rho0;
+
+double xsr1_iglarl_drift(double k, double h, double zr, double hs, double delta, int m, int N, int with0);
+double xsr1_iglarl_drift_wo_m(double k, double h, double zr, double hs, double delta, int *m, int N, int with0);
+double xsr1_iglarlm_drift(double k, double h, double zr, double hs, int q, double delta, int N, int nmax, int with0);
+
+void xDgrsr_arl
+( double *k, double *h, double *zr, double *hs, double *delta, int *m, int *r, int *with0, int *mode, int *q, double *arl)
+{
+ if (*m>0) *arl = xsr1_iglarl_drift(*k, *h, *zr, *hs, *delta, *m, *r, *with0);
+ if (*m==0 && *mode==Gan) *arl = xsr1_iglarl_drift_wo_m(*k, *h, *zr, *hs, *delta, m, *r, *with0);
+ if (*m==0 && *mode==Knoth) *arl = xsr1_iglarlm_drift(*k, *h, *zr, *hs, *q, *delta, *r, 10000, *with0);
+}
diff --git a/src/xcusum_ad.c b/src/xcusum_ad.c
new file mode 100644
index 0000000..25d6ec9
--- /dev/null
+++ b/src/xcusum_ad.c
@@ -0,0 +1,24 @@
+#include <stdio.h>
+#include <math.h>
+#include <stdlib.h>
+#include <R.h>
+
+#define cusum1 0
+#define cusum2 1
+#define cusumC 2
+
+extern double rho0;
+
+double xc1_iglad (double k, double h, double mu0, double mu1, int N);
+double xc2_iglad (double k, double h, double mu0, double mu1, int N);
+double xc2_igladR(double k, double h, double mu0, double mu1, int r);
+double xcC_iglad (double k, double h, double mu0, double mu1, int N);
+
+void xcusum_ad
+( int *ctyp, double *k, double *h, double *mu0, double *mu1, int *r, double *ad)
+{
+ if (*ctyp==cusum1) *ad = xc1_iglad(*k,*h,*mu0,*mu1,*r);
+ if (*ctyp==cusum2 && *r>0) *ad = xc2_iglad(*k,*h,*mu0,*mu1,*r);
+ if (*ctyp==cusum2 && *r<0) *ad = xc2_igladR(*k,*h,*mu0,*mu1,-*r);
+ if (*ctyp==cusumC) *ad = xcC_iglad(*k,*h,*mu0,*mu1,*r);
+}
diff --git a/src/xcusum_arl.c b/src/xcusum_arl.c
new file mode 100644
index 0000000..749dae3
--- /dev/null
+++ b/src/xcusum_arl.c
@@ -0,0 +1,42 @@
+#include <stdio.h>
+#include <math.h>
+#include <stdlib.h>
+#include <R.h>
+
+#define cusum1 0
+#define cusum2 1
+#define cusumC 2
+
+#define igl 0
+#define mc 1
+
+extern double rho0;
+
+double *vector (long n);
+double xc1_iglarl(double k, double h, double hs, double mu, int N);
+double xc1_arlm(double k, double h, double hs, int q, double mu0, double mu1, int N, int nmax);
+double xc1_arlm_hom(double k, double h, double hs, int q, double mu0, double mu1, int N, double *ced);
+double xc2_iglarl(double k, double h, double hs, double mu, int N);
+double xc2_be_arl(double k, double h, double hs1, double hs2, double mu, int N);
+double xcC_iglarl(double k, double h, double hs, double mu, int N);
+
+void xcusum_arl
+( int *ctyp, double *k, double *h, double *hs, double *mu, int *q, int *r, int *method, double *arl)
+{ int i, /*nmax=100000,*/ result=0;
+ double lhs, *ced, arl1=-1.;
+ ced = vector(*q);
+
+ if ( *ctyp == cusum1 && *q==1 ) arl1 = xc1_iglarl(*k,*h,*hs,*mu,*r);
+ if ( *ctyp == cusum1 && *q>1 ) result = xc1_arlm_hom(*k, *h, *hs, *q, 0., *mu, *r, ced);
+ /* *arl = xc1_arlm(*k, *h, *hs, *q, 0., *mu, *r, nmax); */
+ if ( *ctyp == cusum2 ) {
+ if ( *method == igl ) arl1 = xc2_iglarl(*k,*h,*hs,*mu,*r);
+ lhs = - *hs;
+ if ( *method == mc ) arl1 = xc2_be_arl(*k,*h,*hs,lhs,*mu,*r);
+ }
+ if ( *ctyp == cusumC ) arl1 = xcC_iglarl(*k,*h,*hs,*mu,*r);
+
+ if ( result != 0 ) warning("trouble in xgrsr_arl [package spc]");
+
+ if ( *q > 1 ) for (i=0; i<*q; i++) arl[i] = ced[i]; else *arl = arl1;
+}
diff --git a/src/xcusum_crit.c b/src/xcusum_crit.c
new file mode 100644
index 0000000..afd1716
--- /dev/null
+++ b/src/xcusum_crit.c
@@ -0,0 +1,13 @@
+#include <stdio.h>
+#include <math.h>
+#include <stdlib.h>
+#include <R.h>
+
+extern double rho0;
+
+double xc_crit(int ctyp, double k, double L0, double hs, double m0, int N);
+
+void xcusum_crit(int *ctyp, double *k, double *L0, double *hs, double *mu0, int *r, double *h)
+{
+ *h = xc_crit(*ctyp,*k,*L0,*hs,*mu0,*r);
+}
diff --git a/src/xcusum_q.c b/src/xcusum_q.c
new file mode 100644
index 0000000..8d5afa1
--- /dev/null
+++ b/src/xcusum_q.c
@@ -0,0 +1,14 @@
+#include <stdio.h>
+#include <math.h>
+#include <stdlib.h>
+#include <R.h>
+
+#define cusum1 0
+#define cusum2 1
+
+double xc1_Wq(double k, double h, double p, double hs, double mu, int N, int nmax);
+
+void xcusum_q(int *ctyp, double *k, double *h, double *p, double *hs, double *mu, int *r, double *q)
+{
+ if (*ctyp==cusum1) *q = xc1_Wq(*k, *h, *p, *hs, *mu, *r, 10000);
+}
diff --git a/src/xcusum_sf.c b/src/xcusum_sf.c
new file mode 100644
index 0000000..41624eb
--- /dev/null
+++ b/src/xcusum_sf.c
@@ -0,0 +1,19 @@
+#include <stdio.h>
+#include <math.h>
+#include <stdlib.h>
+#include <R.h>
+
+#define cusum1 0
+#define cusum2 1
+
+double *vector (long n);
+double xc1_sf(double k, double h, double hs, double mu, int N, int nmax, double *p0);
+
+void xcusum_sf(int *ctyp, double *k, double *h, double *hs, double *mu, int *r, int *n, double *sf)
+{ int result=0, i;
+ double *p0;
+ p0 = vector(*n);
+ if (*ctyp==cusum1) result = xc1_sf(*k, *h, *hs, *mu, *r, *n, p0);
+ if ( result != 0 ) warning("trouble with xc1_sf called from xcusum_sf [package spc]");
+ for (i=0; i<*n; i++) sf[i] = p0[i];
+}
diff --git a/src/xewma_ad.c b/src/xewma_ad.c
new file mode 100644
index 0000000..7f36840
--- /dev/null
+++ b/src/xewma_ad.c
@@ -0,0 +1,38 @@
+#include <stdio.h>
+#include <math.h>
+#include <stdlib.h>
+#include <R.h>
+
+#define ewma1 0
+#define ewma2 1
+#define fix 0
+#define vacl 1
+#define fir 2
+#define both 3
+#define steiner 4
+#define stat 5
+#define fink 6
+
+#define conditional 0
+#define cyclical 1
+
+extern double rho0;
+
+double xe1_iglad(double l, double c, double zr, double mu0, double mu1, int N);
+double xe1_arlm(double l, double c, double zr, double hs, int q, double mu0, double mu1, int mode, int N, int nmax);
+
+double xe2_iglad (double l, double c, double mu0, double mu1, int N);
+double xe2_igladc(double l, double c, double mu0, double mu1, double z0, int N);
+double xe2_arlm (double l, double c, double hs, int q, double mu0, double mu1, int mode, int N, int nmax);
+
+void xewma_ad(int *ctyp, double *l, double *c, double *zr, double *mu0, double *mu1, double *z0, int *ltyp, int *styp, int *r, double *ad)
+{ int nmax=1000000;
+ if ( *styp==conditional ) {
+ if ( *ctyp==ewma1 && *ltyp==fix ) *ad = xe1_iglad(*l,*c,*zr,*mu0,*mu1,*r);
+ if ( *ctyp==ewma1 && *ltyp>fix ) *ad = xe1_arlm(*l,*c,*zr,0.,200,*mu0,*mu1,*ltyp,*r,nmax);
+ if ( *ctyp==ewma2 && *ltyp==fix ) *ad = xe2_iglad(*l,*c,*mu0,*mu1,*r);
+ if ( *ctyp==ewma2 && *ltyp>fix ) *ad = xe2_arlm(*l,*c,0.,200,*mu0,*mu1,*ltyp,*r,nmax);
+ } else {
+ if ( *ctyp==ewma2 && *ltyp==fix ) *ad = xe2_igladc(*l, *c, *mu0, *mu1, *z0, *r);
+ }
+}
diff --git a/src/xewma_arl.c b/src/xewma_arl.c
new file mode 100644
index 0000000..29ac4ec
--- /dev/null
+++ b/src/xewma_arl.c
@@ -0,0 +1,66 @@
+#include <stdio.h>
+#include <math.h>
+#include <stdlib.h>
+#include <R.h>
+
+#define ewma1 0
+#define ewma2 1
+#define fix 0
+#define vacl 1
+#define fir 2
+#define both 3
+#define steiner 4
+#define stat 5
+#define fink 6
+#define elimit 7
+#define waldmann 8
+#define collocation 9
+
+extern double rho0;
+
+double *vector (long n);
+double xe1_iglarl(double l, double c, double zr, double hs, double mu, int N);
+double xe1_arlm(double l, double c, double zr, double hs, int q, double mu0, double mu1,int mode, int N, int nmax);
+double xe1_arlm_hom(double l, double c, double zr, double hs, int q, double mu0, double mu1, int N, double *ced);
+double xlimit1_arlm(double c, double zr, int q, double mu0, double mu1, int N, int nmax);
+double xe1_Warl(double l, double c, double zr, double hs, double mu, int N, int nmax);
+
+double xe2_iglarl(double l, double c, double hs, double mu, int N);
+double xe2_Warl(double l, double c, double hs, double mu, int N, int nmax);
+double xe2_Carl(double l, double c, double hs, double mu, int N, int qm);
+double xe2_arlm(double l, double c, double hs, int q, double mu0, double mu1, int mode, int N, int nmax);
+double xe2_arlm_hom(double l, double c, double hs, int q, double mu0, double mu1, int N, double *ced);
+
+void xewma_arl(int *ctyp, double *l, double *c, double *zr, double *hs, double *mu, int *ltyp, int *r, int *q, double *arl)
+{ int nmax=100000, i, result=0;
+ double *ced, arl1=-1.;
+ ced = vector(*q);
+
+ if (*ctyp==ewma1 && *ltyp==fix && *q==1)
+ arl1 = xe1_iglarl(*l,*c,*zr,*hs,*mu,*r);
+ if (*ctyp==ewma1 && *ltyp==fix && *q>1)
+ result = xe1_arlm_hom(*l, *c, *zr, *hs, *q, 0., *mu, *r, ced);
+ /* *arl = xe1_arlm(*l,*c,*zr,*hs,*q,0.,*mu,*ltyp,*r,nmax);*/
+ if (*ctyp==ewma1 && *ltyp>fix && *ltyp<elimit)
+ arl1 = xe1_arlm(*l,*c,*zr,*hs,*q,0.,*mu,*ltyp,*r,nmax);
+ if (*ctyp==ewma1 && *ltyp==elimit)
+ arl1 = xlimit1_arlm(*c,*zr,*q,0.,*mu,*r,nmax);
+ if (*ctyp==ewma1 && *ltyp==waldmann)
+ arl1 = xe1_Warl(*l,*c,*zr,*hs,*mu,*r,nmax);
+
+ if (*ctyp==ewma2 && *ltyp==fix && *q==1)
+ arl1 = xe2_iglarl(*l,*c,*hs,*mu,*r);
+ if (*ctyp==ewma2 && *ltyp==fix && *q>1)
+ result = xe2_arlm_hom(*l, *c, *hs, *q, 0., *mu, *r, ced);
+ /* arl1 = xe2_arlm(*l,*c,*hs,*q,0.,*mu,*ltyp,*r,nmax);*/
+ if (*ctyp==ewma2 && *ltyp>fix && *ltyp<waldmann)
+ arl1 = xe2_arlm(*l,*c,*hs,*q,0.,*mu,*ltyp,*r,nmax);
+ if (*ctyp==ewma2 && *ltyp==waldmann)
+ arl1 = xe2_Warl(*l,*c,*hs,*mu,*r,nmax);
+ if (*ctyp==ewma2 && *ltyp==collocation)
+ arl1 = xe2_Carl(*l,*c,*hs,*mu,*r,50);
+
+ if ( result != 0 ) warning("trouble in xewma_arl [package spc]");
+
+ if ( *ltyp==fix && *q>1 ) for (i=0; i<*q; i++) arl[i] = ced[i]; else *arl = arl1;
+}
diff --git a/src/xewma_arl_prerun.c b/src/xewma_arl_prerun.c
new file mode 100644
index 0000000..8e7469f
--- /dev/null
+++ b/src/xewma_arl_prerun.c
@@ -0,0 +1,47 @@
+#include <stdio.h>
+#include <math.h>
+#include <stdlib.h>
+#include <R.h>
+
+#define ewma1 0
+#define ewma2 1
+#define fix 0
+#define vacl 1
+#define fir 2
+#define both 3
+#define steiner 4
+#define stat 5
+
+#define MU 0
+#define SIGMA 1
+#define BOTH 2
+
+double xe2_iglarl_prerun_MU(double l, double c, double hs, double mu, int pn, int qm, double truncate);
+double xe2_iglarl_prerun_SIGMA(double l, double c, double hs, double mu, int pn, int qm, double truncate);
+double xe2_iglarl_prerun_BOTH(double l, double c, double hs, double mu, int pn, int df, int qm1, int qm2, double truncate);
+
+double xe2_arlm_prerun_MU(double l, double c, double hs, int q, double mu0, double mu1, int pn, int mode, int nmax, int qm, double truncate);
+double xe2_arlm_prerun_SIGMA(double l, double c, double hs, int q, double mu0, double mu1, int pn, int mode, int nmax, int qm, double truncate);
+double xe2_arlm_prerun_BOTH(double l, double c, double hs, int q, double mu0, double mu1, int pn, int df, int mode, int nmax, int qm1, int qm2, double truncate);
+
+void xewma_arl_prerun
+( int *ctyp, double *l, double *c, double *zr, double *hs, double *mu, int *ltyp, int *q, int *size, int *df, int *mode,
+ int *qm1, int *qm2, double *truncate, double *arl)
+{ int nmax = 100000;
+
+ if ( *mode == MU ) {
+ if (*ctyp==ewma2 && *ltyp==fix && *q==1) *arl = xe2_iglarl_prerun_MU(*l, *c, *hs, *mu, *size, *qm1, *truncate);
+ if (*ctyp==ewma2 && *ltyp==fix && *q>1) *arl = xe2_arlm_prerun_MU(*l, *c, *hs, *q, 0., *mu, *size, *ltyp, nmax, *qm1, *truncate);
+ if (*ctyp==ewma2 && *ltyp>fix) *arl = xe2_arlm_prerun_MU(*l, *c, *hs, *q, 0., *mu, *size, *ltyp, nmax, *qm1, *truncate);
+ }
+ if ( *mode == SIGMA ) {
+ if (*ctyp==ewma2 && *ltyp==fix && *q==1) *arl = xe2_iglarl_prerun_SIGMA(*l, *c, *hs, *mu, *size, *qm2, *truncate);
+ if (*ctyp==ewma2 && *ltyp==fix && *q>1) *arl = xe2_arlm_prerun_SIGMA(*l, *c, *hs, *q, 0., *mu, *size, *ltyp, nmax, *qm2, *truncate);
+ if (*ctyp==ewma2 && *ltyp>fix) *arl = xe2_arlm_prerun_SIGMA(*l, *c, *hs, *q, 0., *mu, *size, *ltyp, nmax, *qm2, *truncate);
+ }
+ if ( *mode == BOTH ) {
+ if (*ctyp==ewma2 && *ltyp==fix && *q==1) *arl = xe2_iglarl_prerun_BOTH(*l, *c, *hs, *mu, *size, *df, *qm1, *qm2, *truncate);
+ if (*ctyp==ewma2 && *ltyp==fix && *q>1) *arl = xe2_arlm_prerun_BOTH(*l, *c, *hs, *q, 0., *mu, *size, *df, *ltyp, nmax, *qm1, *qm2, *truncate);
+ if (*ctyp==ewma2 && *ltyp>fix) *arl = xe2_arlm_prerun_BOTH(*l, *c, *hs, *q, 0., *mu, *size, *df, *ltyp, nmax, *qm1, *qm2, *truncate);
+ }
+}
diff --git a/src/xewma_crit.c b/src/xewma_crit.c
new file mode 100644
index 0000000..5e3f6c4
--- /dev/null
+++ b/src/xewma_crit.c
@@ -0,0 +1,13 @@
+#include <stdio.h>
+#include <math.h>
+#include <stdlib.h>
+#include <R.h>
+
+extern double rho0;
+
+double xe_crit(int ctyp, double l, double L0, double zr, double hs, double m0, int ltyp, int N, double c0);
+
+void xewma_crit(int *ctyp, double *l, double *L0, double *zr, double *hs, double *mu0, int *ltyp, int *r, double *c0, double *h)
+{
+ *h = xe_crit(*ctyp,*l,*L0,*zr,*hs,*mu0,*ltyp,*r,*c0);
+}
diff --git a/src/xewma_q.c b/src/xewma_q.c
new file mode 100644
index 0000000..82820a8
--- /dev/null
+++ b/src/xewma_q.c
@@ -0,0 +1,31 @@
+#include <stdio.h>
+#include <math.h>
+#include <stdlib.h>
+#include <R.h>
+
+#define ewma1 0
+#define ewma2 1
+#define fix 0
+#define vacl 1
+#define fir 2
+#define both 3
+#define steiner 4
+#define stat 5
+#define test 6
+
+double xe1_Wq(double l, double c, double p, double zr, double hs, double mu, int N, int nmax);
+double xe1_Wqm(double l, double c, double p, double zr, double hs, int q, double mu0, double mu1, int mode, int N, int nmax);
+double xe2_Wq(double l, double c, double p, double hs, double mu, int N, int nmax);
+double xe2_Wqm(double l, double c, double p, double hs, int q, double mu0, double mu1, int mode, int N, int nmax);
+
+void xewma_q(int *ctyp, double *l, double *c, double *p, double *zr, double *hs, double *mu, int *ltyp, int *r, int *q, double *tq)
+{ int nmax=1000000;
+
+ if ( *ctyp==ewma1 && *ltyp==fix && *q==1 ) *tq = xe1_Wq(*l, *c, *p, *zr, *hs, *mu, *r, nmax);
+ if ( *ctyp==ewma1 && *ltyp==fix && *q>1 ) *tq = xe1_Wqm(*l, *c, *p, *zr, *hs, *q, 0., *mu, *ltyp, *r, nmax);
+ if ( *ctyp==ewma1 && *ltyp>fix ) *tq = xe1_Wqm(*l, *c, *p, *zr, *hs, *q, 0., *mu, *ltyp, *r, nmax);
+
+ if ( *ctyp==ewma2 && *ltyp==fix && *q==1 ) *tq = xe2_Wq(*l, *c, *p, *hs, *mu, *r, nmax);
+ if ( *ctyp==ewma2 && *ltyp==fix && *q>1 ) *tq = xe2_Wqm(*l, *c, *p, *hs, *q, 0., *mu, *ltyp, *r, nmax);
+ if ( *ctyp==ewma2 && *ltyp>fix ) *tq = xe2_Wqm(*l, *c, *p, *hs, *q, 0., *mu, *ltyp, *r, nmax);
+}
diff --git a/src/xewma_q_prerun.c b/src/xewma_q_prerun.c
new file mode 100644
index 0000000..bb20f91
--- /dev/null
+++ b/src/xewma_q_prerun.c
@@ -0,0 +1,47 @@
+#include <stdio.h>
+#include <math.h>
+#include <stdlib.h>
+#include <R.h>
+
+#define ewma1 0
+#define ewma2 1
+#define fix 0
+#define vacl 1
+#define fir 2
+#define both 3
+#define steiner 4
+#define stat 5
+
+#define MU 0
+#define SIGMA 1
+#define BOTH 2
+
+double xe2_Wq_prerun_MU_deluxe(double l, double c, double p, double hs, double mu, int pn, int nmax, int qm, double truncate, double BOUND);
+double xe2_Wq_prerun_SIGMA_deluxe(double l, double c, double p, double hs, double mu, int pn, int nmax, int qm, double truncate, double BOUND);
+double xe2_Wq_prerun_BOTH_deluxe(double l, double c, double p, double hs, double mu, int pn, int df, int nmax, int qm1, int qm2, double truncate, double BOUND);
+
+double xe2_Wqm_prerun_MU_deluxe(double l, double c, double p, double hs, int q, double mu0, double mu1, int pn, int mode, int nmax, int qm, double truncate, double BOUND);
+double xe2_Wqm_prerun_SIGMA_deluxe(double l, double c, double p, double hs, int q, double mu0, double mu1, int pn, int mode, int nmax, int qm, double truncate, double BOUND);
+double xe2_Wqm_prerun_BOTH_deluxe(double l, double c, double p, double hs, int q, double mu0, double mu1, int pn, int df, int mode, int nmax, int qm1, int qm2, double truncate, double BOUND);
+
+void xewma_q_prerun
+( int *ctyp, double *l, double *c, double *p, double *zr, double *hs, double *mu, int *ltyp, int *q, int *size, int *df, int *mode,
+ int *qm1, int *qm2, double *truncate, double *bound, double *tq)
+{ int nmax=1000000;
+
+ if ( *mode == MU ) {
+ if ( *ctyp==ewma2 && *ltyp==fix && *q==1 ) *tq = xe2_Wq_prerun_MU_deluxe(*l, *c, *p, *hs, *mu, *size, nmax, *qm1, *truncate, *bound);
+ if ( *ctyp==ewma2 && *ltyp==fix && *q>1 ) *tq = xe2_Wqm_prerun_MU_deluxe(*l, *c, *p, *hs, *q, 0., *mu, *size, *ltyp, nmax, *qm1, *truncate, *bound);
+ if ( *ctyp==ewma2 && *ltyp>fix ) *tq = xe2_Wqm_prerun_MU_deluxe(*l, *c, *p, *hs, *q, 0., *mu, *size, *ltyp, nmax, *qm1, *truncate, *bound);
+ }
+ if ( *mode == SIGMA ) {
+ if ( *ctyp==ewma2 && *ltyp==fix && *q==1 ) *tq = xe2_Wq_prerun_SIGMA_deluxe(*l, *c, *p, *hs, *mu, *size, nmax, *qm2, *truncate, *bound);
+ if ( *ctyp==ewma2 && *ltyp==fix && *q>1 ) *tq = xe2_Wqm_prerun_SIGMA_deluxe(*l, *c, *p, *hs, *q, 0., *mu, *size, *ltyp, nmax, *qm2, *truncate, *bound);
+ if ( *ctyp==ewma2 && *ltyp>fix ) *tq = xe2_Wqm_prerun_SIGMA_deluxe(*l, *c, *p, *hs, *q, 0., *mu, *size, *ltyp, nmax, *qm2, *truncate, *bound);
+ }
+ if ( *mode == BOTH ) {
+ if ( *ctyp==ewma2 && *ltyp==fix && *q==1 ) *tq = xe2_Wq_prerun_BOTH_deluxe(*l, *c, *p, *hs, *mu, *size, *df, nmax, *qm1, *qm2, *truncate, *bound);
+ if ( *ctyp==ewma2 && *ltyp==fix && *q>1 ) *tq = xe2_Wqm_prerun_BOTH_deluxe(*l, *c, *p, *hs, *q, 0., *mu, *size, *df, *ltyp, nmax, *qm1, *qm2, *truncate, *bound);
+ if ( *ctyp==ewma2 && *ltyp>fix ) *tq = xe2_Wqm_prerun_BOTH_deluxe(*l, *c, *p, *hs, *q, 0., *mu, *size, *df, *ltyp, nmax, *qm1, *qm2, *truncate, *bound);
+ }
+}
diff --git a/src/xewma_res_arl.c b/src/xewma_res_arl.c
new file mode 100644
index 0000000..dd58592
--- /dev/null
+++ b/src/xewma_res_arl.c
@@ -0,0 +1,12 @@
+#include <stdio.h>
+#include <math.h>
+#include <stdlib.h>
+#include <R.h>
+
+double xe2_iglarl_RES(double l, double c, double hs, double mu, int N, double alpha, int df);
+
+void x_res_ewma_arl(double *alpha, int *n, int *ctyp, double *l, double *c, double *hs, double *mu, int *r, double *arl)
+{
+ *arl = -1.;
+ *arl = xe2_iglarl_RES(*l,*c,*hs,*mu,*r,*alpha,*n);
+}
diff --git a/src/xewma_sf.c b/src/xewma_sf.c
new file mode 100644
index 0000000..d8029e4
--- /dev/null
+++ b/src/xewma_sf.c
@@ -0,0 +1,40 @@
+#include <stdio.h>
+#include <math.h>
+#include <stdlib.h>
+#include <R.h>
+
+#define ewma1 0
+#define ewma2 1
+#define fix 0
+#define vacl 1
+#define fir 2
+#define both 3
+#define steiner 4
+#define stat 5
+#define test 6
+
+double *vector (long n);
+
+double xe1_sf (double l, double c, double zr, double hs, double mu, int N, int nmax, double *p0);
+double xe1_sfm(double l, double c, double zr, double hs, int q, double mu0, double mu1, int mode, int N, int nmax, double *p0);
+
+double xe2_sf (double l, double c, double hs, double mu, int N, int nmax, double *p0);
+double xe2_sfm(double l, double c, double hs, int q, double mu0, double mu1, int mode, int N, int nmax, double *p0);
+
+void xewma_sf(int *ctyp, double *l, double *c, double *zr, double *hs, double *mu, int *ltyp, int *r, int *q, int *n, double *sf)
+{ int result=0, i;
+ double *p0;
+ p0 = vector(*n);
+
+ if ( *ctyp==ewma1 && *ltyp==fix && *q==1 ) result = xe1_sf (*l, *c, *zr, *hs, *mu, *r, *n, p0);
+ if ( *ctyp==ewma1 && *ltyp==fix && *q>1 ) result = xe1_sfm(*l, *c, *zr, *hs, *q, 0., *mu, *ltyp, *r, *n, p0);
+ if ( *ctyp==ewma1 && *ltyp>fix ) result = xe1_sfm(*l, *c, *zr, *hs, *q, 0., *mu, *ltyp, *r, *n, p0);
+
+ if ( *ctyp==ewma2 && *ltyp==fix && *q==1 ) result = xe2_sf (*l, *c, *hs, *mu, *r, *n, p0);
+ if ( *ctyp==ewma2 && *ltyp==fix && *q>1 ) result = xe2_sfm(*l, *c, *hs, *q, 0., *mu, *ltyp, *r, *n, p0);
+ if ( *ctyp==ewma2 && *ltyp>fix ) result = xe2_sfm(*l, *c, *hs, *q, 0., *mu, *ltyp, *r, *n, p0);
+
+ if ( result != 0 ) warning("trouble in xewma_sf [package spc]");
+
+ for (i=0; i<*n; i++) sf[i] = p0[i];
+}
diff --git a/src/xewma_sf_prerun.c b/src/xewma_sf_prerun.c
new file mode 100644
index 0000000..499339a
--- /dev/null
+++ b/src/xewma_sf_prerun.c
@@ -0,0 +1,97 @@
+#include <stdio.h>
+#include <math.h>
+#include <stdlib.h>
+#include <R.h>
+
+#define ewma1 0
+#define ewma2 1
+#define fix 0
+#define vacl 1
+#define fir 2
+#define both 3
+#define steiner 4
+#define stat 5
+
+#define MU 0
+#define SIGMA 1
+#define BOTH 2
+
+double *vector (long n);
+
+double xe2_sf_prerun_MU_deluxe(double l, double c, double hs, double mu, int pn, int nmax, int qm, double truncate, double BOUND, double *p0);
+double xe2_sf_prerun_MU(double l, double c, double hs, double mu, int pn, int nmax, int qm, double truncate, double *p0);
+
+double xe2_sf_prerun_SIGMA_deluxe(double l, double c, double hs, double mu, int pn, int nmax, int qm, double truncate, double BOUND, double *p0);
+double xe2_sf_prerun_SIGMA(double l, double c, double hs, double mu, int pn, int nmax, int qm, double truncate, double *p0);
+
+double xe2_sf_prerun_BOTH_deluxe(double l, double c, double hs, double mu, int pn, int df, int nmax, int qm1, int qm2, double truncate, double BOUND, double *p0);
+double xe2_sf_prerun_BOTH(double l, double c, double hs, double mu, int pn, int df, int nmax, int qm1, int qm2, double truncate, double *p0);
+
+
+double xe2_sfm_prerun_MU_deluxe(double l, double c, double hs, int q, double mu0, double mu1, int pn, int mode, int nmax, int qm, double truncate, double BOUND, double *p0);
+double xe2_sfm_prerun_MU(double l, double c, double hs, int q, double mu0, double mu1, int pn, int mode, int nmax, int qm, double truncate, double *p0);
+
+double xe2_sfm_prerun_SIGMA_deluxe(double l, double c, double hs, int q, double mu0, double mu1, int pn, int mode, int nmax, int qm, double truncate, double BOUND, double *p0);
+double xe2_sfm_prerun_SIGMA(double l, double c, double hs, int q, double mu0, double mu1, int pn, int mode, int nmax, int qm, double truncate, double *p0);
+
+double xe2_sfm_prerun_BOTH_deluxe(double l, double c, double hs, int q, double mu0, double mu1, int pn, int df, int mode, int nmax, int qm1, int qm2, double truncate, double BOUND, double *p0);
+double xe2_sfm_prerun_BOTH(double l, double c, double hs, int q, double mu0, double mu1, int pn, int df, int mode, int nmax, int qm1, int qm2, double truncate, double *p0);
+
+
+void xewma_sf_prerun
+( int *ctyp, double *l, double *c, double *zr, double *hs, double *mu, int *ltyp, int *q, int *n, int *size, int *df, int *mode,
+ int *qm1, int *qm2, double *truncate, int *tail_approx, double *bound, double *sf)
+
+{ int i, result=0;
+ double *p0;
+ p0 = vector(*n);
+
+ if ( *mode == MU ) {
+ if ( *ctyp==ewma2 && *ltyp==fix && *q==1 ) {
+ if ( *tail_approx ) result = xe2_sf_prerun_MU_deluxe(*l, *c, *hs, *mu, *size, *n, *qm1, *truncate, *bound, p0);
+ else result = xe2_sf_prerun_MU(*l, *c, *hs, *mu, *size, *n, *qm1, *truncate, p0);
+ }
+ if ( *ctyp==ewma2 && *ltyp==fix && *q>1 ) {
+ if ( *tail_approx ) result = xe2_sfm_prerun_MU_deluxe(*l, *c, *hs, *q, 0., *mu, *size, *ltyp, *n, *qm1, *truncate, *bound, p0);
+ else result = xe2_sfm_prerun_MU(*l, *c, *hs, *q, 0., *mu, *size, *ltyp, *n, *qm1, *truncate, p0);
+ }
+ if ( *ctyp==ewma2 && *ltyp>fix ) {
+ if ( *tail_approx ) result = xe2_sfm_prerun_MU_deluxe(*l, *c, *hs, *q, 0., *mu, *size, *ltyp, *n, *qm1, *truncate, *bound, p0);
+ else result = xe2_sfm_prerun_MU(*l, *c, *hs, *q, 0., *mu, *size, *ltyp, *n, *qm1, *truncate, p0);
+ }
+ }
+
+ if ( *mode == SIGMA ) {
+ if ( *ctyp==ewma2 && *ltyp==fix && *q==1 ) {
+ if ( *tail_approx ) result = xe2_sf_prerun_SIGMA_deluxe(*l, *c, *hs, *mu, *size, *n, *qm2, *truncate, *bound, p0);
+ else result = xe2_sf_prerun_SIGMA(*l, *c, *hs, *mu, *size, *n, *qm2, *truncate, p0);
+ }
+ if ( *ctyp==ewma2 && *ltyp==fix && *q>1 ) {
+ if ( *tail_approx ) result = xe2_sfm_prerun_SIGMA_deluxe(*l, *c, *hs, *q, 0., *mu, *size, *ltyp, *n, *qm2, *truncate, *bound, p0);
+ else result = xe2_sfm_prerun_SIGMA(*l, *c, *hs, *q, 0., *mu, *size, *ltyp, *n, *qm2, *truncate, p0);
+ }
+ if ( *ctyp==ewma2 && *ltyp>fix ) {
+ if ( *tail_approx ) result = xe2_sfm_prerun_SIGMA_deluxe(*l, *c, *hs, *q, 0., *mu, *size, *ltyp, *n, *qm2, *truncate, *bound, p0);
+ else result = xe2_sfm_prerun_SIGMA(*l, *c, *hs, *q, 0., *mu, *size, *ltyp, *n, *qm2, *truncate, p0);
+ }
+ }
+
+ if ( *mode == BOTH ) {
+ if ( *ctyp==ewma2 && *ltyp==fix && *q==1 ) {
+ if ( *tail_approx ) result = xe2_sf_prerun_BOTH_deluxe(*l, *c, *hs, *mu, *size, *df, *n, *qm1, *qm2, *truncate, *bound, p0);
+ else result = xe2_sf_prerun_BOTH(*l, *c, *hs, *mu, *size, *df, *n, *qm1, *qm2, *truncate, p0);
+ }
+ if ( *ctyp==ewma2 && *ltyp==fix && *q>1 ) {
+ if ( *tail_approx ) result = xe2_sfm_prerun_BOTH_deluxe(*l, *c, *hs, *q, 0., *mu, *size, *df, *ltyp, *n, *qm1, *qm2, *truncate, *bound, p0);
+ else result = xe2_sfm_prerun_BOTH(*l, *c, *hs, *q, 0., *mu, *size, *df, *ltyp, *n, *qm1, *qm2, *truncate, p0);
+ }
+ if ( *ctyp==ewma2 && *ltyp>fix ) {
+ if ( *tail_approx ) result = xe2_sfm_prerun_BOTH_deluxe(*l, *c, *hs, *q, 0., *mu, *size, *df, *ltyp, *n, *qm1, *qm2, *truncate, *bound, p0);
+ else result = xe2_sfm_prerun_BOTH(*l, *c, *hs, *q, 0., *mu, *size, *df, *ltyp, *n, *qm1, *qm2, *truncate, p0);
+ }
+ }
+
+ if ( result != 0 ) warning("\nSomething bad happened!\n\n");
+
+ for (i=0; i<*n; i++) sf[i] = p0[i];
+}
diff --git a/src/xgrsr_ad.c b/src/xgrsr_ad.c
new file mode 100644
index 0000000..b203918
--- /dev/null
+++ b/src/xgrsr_ad.c
@@ -0,0 +1,16 @@
+#include <stdio.h>
+#include <math.h>
+#include <stdlib.h>
+#include <R.h>
+
+#define grsr1 0
+#define grsr2 1
+
+extern double rho0;
+
+double xsr1_iglad(double k, double h, double zr, double mu0, double mu1, int N, int MPT);
+
+void xgrsr_ad(int *ctyp, double *k, double *h, double *mu0, double *mu1, double *zr, int *r, int *MPT, double *ad)
+{
+ if (*ctyp==grsr1) *ad = xsr1_iglad(*k, *h, *zr, *mu0, *mu1, *r, *MPT);
+}
diff --git a/src/xgrsr_arl.c b/src/xgrsr_arl.c
new file mode 100644
index 0000000..90c1445
--- /dev/null
+++ b/src/xgrsr_arl.c
@@ -0,0 +1,28 @@
+#include <stdio.h>
+#include <math.h>
+#include <stdlib.h>
+#include <R.h>
+
+#define grsr1 0
+#define grsr2 1
+
+extern double rho0;
+
+double *vector (long n);
+double xsr1_iglarl(double k, double h, double zr, double hs, double mu, int N, int MPT);
+double xsr1_arlm(double k, double h, double zr, double hs, int q, double mu0, double mu1, int N, int nmax, int MPT);
+double xsr1_arlm_hom(double k, double h, double zr, double hs, int q, double mu0, double mu1, int N, int MPT, double *ced);
+
+void xgrsr_arl(int *ctyp, double *k, double *h, double *zr, double *hs, double *mu, int *q, int *r, int *MPT, double *arl)
+{ int i, /*nmax=100000,*/ result=0;
+ double *ced, arl1=-1.;
+ ced = vector(*q);
+
+ if ( *ctyp==grsr1 && *q==1 ) arl1 = xsr1_iglarl(*k, *h, *zr, *hs, *mu, *r, *MPT);
+ if ( *ctyp==grsr1 && *q>1 ) result = xsr1_arlm_hom(*k, *h, *zr, *hs, *q, 0., *mu, *r, *MPT, ced);
+ /* *arl = xsr1_arlm(*k, *h, *zr, *hs, *q, 0., *mu, *r, nmax, *MPT);*/
+
+ if ( result != 0 ) warning("trouble in xgrsr_arl [package spc]");
+
+ if ( *q > 1 ) for (i=0; i<*q; i++) arl[i] = ced[i]; else *arl = arl1;
+}
diff --git a/src/xgrsr_crit.c b/src/xgrsr_crit.c
new file mode 100644
index 0000000..bcb32e8
--- /dev/null
+++ b/src/xgrsr_crit.c
@@ -0,0 +1,16 @@
+#include <stdio.h>
+#include <math.h>
+#include <stdlib.h>
+#include <R.h>
+
+#define grsr1 0
+#define grsr2 1
+
+extern double rho0;
+
+double xsr1_crit(double k, double L0, double zr, double hs, double m0, int N, int MPT);
+
+void xgrsr_crit(double *k, double *L0, double *zr, double *hs, double *mu0, int *r, int *MPT, double *h)
+{
+ *h = xsr1_crit(*k, *L0, *zr, *hs, *mu0, *r, *MPT);
+}
diff --git a/src/xsewma_arl.c b/src/xsewma_arl.c
new file mode 100644
index 0000000..edf6b29
--- /dev/null
+++ b/src/xsewma_arl.c
@@ -0,0 +1,27 @@
+#include <stdio.h>
+#include <math.h>
+#include <stdlib.h>
+#include <R.h>
+
+#define ewmaU 0
+#define ewmaUR 1
+#define ewma2 2
+
+double xseU_arl
+ (double lx, double ls, double cx, double cs, double hsx, double hss, double mu, double sigma, int df, int Nx, int Ns, int nmax, int qm);
+double xse2_arl
+ (double lx, double ls, double cx, double csl, double csu, double hsx, double hss, double mu, double sigma, int df, int Nx, int Ns, int nmax, int qm);
+
+void xsewma_arl
+( int *ctyp,
+ double *lx, double *cx, double *hsx, int *Nx,
+ double *ls, double *csl, double *csu, double *hss, int *Ns,
+ double *mu, double *sigma,
+ int *df, int *qm, int *s_squared, double *arl)
+{
+ *arl = -1.;
+ if (*ctyp==ewmaU)
+ *arl = xseU_arl(*lx,*ls,*cx,*csu,*hsx,*hss,*mu,*sigma,*df,*Nx,*Ns,10000,*qm);
+ if (*ctyp==ewma2)
+ *arl = xse2_arl(*lx,*ls,*cx,*csl,*csu,*hsx,*hss,*mu,*sigma,*df,*Nx,*Ns,10000,*qm);
+}
diff --git a/src/xsewma_crit.c b/src/xsewma_crit.c
new file mode 100644
index 0000000..58eb826
--- /dev/null
+++ b/src/xsewma_crit.c
@@ -0,0 +1,55 @@
+#include <stdio.h>
+#include <math.h>
+#include <stdlib.h>
+#include <R.h>
+
+#define ewmaU 0
+#define ewmaUR 1
+#define ewma2 2
+#define ewmaLR 3
+#define fixed 0
+#define unbiased 1
+
+int xseU_crit
+ (double lx, double ls, double L0, double *cx, double *cs,
+ double hsx, double hss,
+ double mu, double sigma, int df, int Nx, int Ns, int nmax, int qm);
+int xse2lu_crit
+ (double lx, double ls, double L0, double *cx, double csl, double *csu,
+ double hsx, double hss,
+ double mu, double sigma, int df, int Nx, int Ns, int nmax, int qm);
+int xse2fu_crit
+ (double lx, double ls, double L0, double *cx, double *csl, double csu,
+ double hsx, double hss,
+ double mu, double sigma, int df, int Nx, int Ns, int nmax, int qm);
+int xse2_crit
+ (double lx, double ls, double L0, double *cx, double *csl, double *csu,
+ double hsx, double hss,
+ double mu, double sigma, int df, int Nx, int Ns, int nmax, int qm);
+
+void xsewma_crit
+( int *ctyp, int *ltyp,
+ double *lx, double *ls, double *L0, double *cu0, double *hsx, double *hss,
+ double *mu, double *sigma, int *df,
+ int *Nx, int *Ns, int *qm, double *c_values)
+{ int result=0;
+ double cx, cl, cu;
+ cx = -1.;
+ cl = 0.;
+ cu = -1.;
+
+ if (*ctyp==ewmaU)
+ result = xseU_crit(*lx,*ls,*L0,&cx,&cu,*hsx,*hss,*mu,*sigma,*df,*Nx,*Ns,10000,*qm);
+ if (*ctyp==ewma2) {
+ if (*ltyp==fixed) {
+ result = xse2fu_crit(*lx,*ls,*L0,&cx,&cl,*cu0,*hsx,*hss,*mu,*sigma,*df,*Nx,*Ns,10000,*qm);
+ cu = *cu0;
+ }
+ if (*ltyp==unbiased)
+ result = xse2_crit(*lx,*ls,*L0,&cx,&cl,&cu,*hsx,*hss,*mu,*sigma,*df,*Nx,*Ns,10000,*qm);
+ }
+ if ( result != 0 ) warning("trouble with xsewma_crit [package spc]");
+ c_values[0] = cx;
+ c_values[1] = cl;
+ c_values[2] = cu;
+}
diff --git a/src/xsewma_q.c b/src/xsewma_q.c
new file mode 100644
index 0000000..7e9ad17
--- /dev/null
+++ b/src/xsewma_q.c
@@ -0,0 +1,25 @@
+#include <stdio.h>
+#include <math.h>
+#include <stdlib.h>
+#include <R.h>
+
+#define ewmaU 0
+#define ewma2 1
+
+double xseU_Wq(double lx, double ls, double cx, double cs, double p, double hsx, double hss,
+ double mu, double sigma, int df, int Nx, int Ns, int nmax, int qm);
+double xse2_Wq(double lx, double ls, double cx, double csl, double csu, double p, double hsx, double hss,
+ double mu, double sigma, int df, int Nx, int Ns, int nmax, int qm);
+
+void xsewma_q
+( int *ctyp,
+ double *alpha,
+ double *lx, double *cx, double *hsx, int *Nx,
+ double *ls, double *csl, double *csu, double *hss, int *Ns,
+ double *mu, double *sigma,
+ int *df, int *qm, double *tq)
+{ int nmax=100000;
+ *tq = -1.;
+ if ( *ctyp == ewmaU ) *tq = xseU_Wq(*lx, *ls, *cx, *csu, *alpha, *hsx, *hss, *mu, *sigma, *df, *Nx, *Ns, nmax, *qm);
+ if ( *ctyp == ewma2 ) *tq = xse2_Wq(*lx, *ls, *cx, *csl, *csu, *alpha, *hsx, *hss, *mu, *sigma, *df, *Nx, *Ns, nmax, *qm);
+}
diff --git a/src/xsewma_q_crit.c b/src/xsewma_q_crit.c
new file mode 100644
index 0000000..1eeaa6c
--- /dev/null
+++ b/src/xsewma_q_crit.c
@@ -0,0 +1,46 @@
+#include <stdio.h>
+#include <math.h>
+#include <stdlib.h>
+#include <R.h>
+
+#define ewmaU 0
+#define ewma2 1
+
+#define fixed 0
+#define unbiased 1
+
+int xseU_q_crit(double lx, double ls, int L0, double alpha, double *cx, double *cs, double hsx, double hss, double mu, double sigma, int df,
+ int Nx, int Ns, int qm, double c_error, double a_error);
+int xse2fu_q_crit(double lx, double ls, int L0, double alpha, double *cx, double *csl, double csu, double hsx, double hss, double mu, double sigma, int df,
+ int Nx, int Ns, int qm, double c_error, double a_error);
+int xse2_q_crit(double lx, double ls, int L0, double alpha, double *cx, double *csl, double *csu, double hsx, double hss, double mu, double sigma, int df,
+ int Nx, int Ns, int qm, double c_error, double a_error);
+
+void xsewma_q_crit
+( int *ctyp, int *ltyp,
+ double *lx, double *ls, double *L0, double *alpha, double *cu0, double *hsx, double *hss,
+ double *mu, double *sigma, int *df,
+ int *Nx, int *Ns, int *qm,
+ double *c_error, double *a_error, double *c_values)
+
+{ int result=0;
+ double cx=-1., cl=0., cu=-1.;
+
+ if ( *ctyp==ewmaU ) result = xseU_q_crit(*lx, *ls, *L0, *alpha, &cx, &cu, *hsx, *hss, *mu, *sigma, *df, *Nx, *Ns, *qm, *c_error, *a_error);
+
+ if ( *ctyp==ewma2 ) {
+ if ( *ltyp==fixed ) {
+ result = xse2fu_q_crit(*lx, *ls, *L0, *alpha, &cx, &cl, *cu0, *hsx, *hss, *mu, *sigma, *df, *Nx, *Ns, *qm, *c_error, *a_error);
+ cu = *cu0;
+ }
+ if ( *ltyp==unbiased )
+ result = xse2_q_crit(*lx, *ls, *L0, *alpha, &cx, &cl, &cu, *hsx, *hss, *mu, *sigma, *df, *Nx, *Ns, *qm, *c_error, *a_error);
+ }
+
+ if ( result != 0 ) warning("trouble with xsewma_q_crit [package spc]");
+
+ c_values[0] = cx;
+ c_values[1] = cl;
+ c_values[2] = cu;
+
+}
diff --git a/src/xsewma_res_arl.c b/src/xsewma_res_arl.c
new file mode 100644
index 0000000..95dbc3a
--- /dev/null
+++ b/src/xsewma_res_arl.c
@@ -0,0 +1,19 @@
+#include <stdio.h>
+#include <math.h>
+#include <stdlib.h>
+#include <R.h>
+
+double xseU_arl_RES
+ (double lx, double ls, double cx, double cs, double hsx, double hss,
+ double mu, double sigma, int df, int Nx, int Ns, int nmax, int qm, double alpha);
+
+void xsewma_res_arl
+( double *alpha, int *n, int *ctyp,
+ double *lx, double *cx, double *hsx, int *Nx,
+ double *ls, double *csu, double *hss, int *Ns,
+ double *mu, double *sigma,
+ int *qm, double *arl)
+{
+ *arl = -1.;
+ *arl = xseU_arl_RES(*lx,*ls,*cx,*csu,*hsx,*hss,*mu,*sigma,*n,*Nx,*Ns,10000,*qm,*alpha);
+}
diff --git a/src/xsewma_res_pms.c b/src/xsewma_res_pms.c
new file mode 100644
index 0000000..51f134d
--- /dev/null
+++ b/src/xsewma_res_pms.c
@@ -0,0 +1,19 @@
+#include <stdio.h>
+#include <math.h>
+#include <stdlib.h>
+#include <R.h>
+
+double xseU_mu_before_sigma_RES
+ (double lx, double ls, double cx, double cs, double hsx, double hss,
+ double mu, double sigma, int df, int Nx, int Ns, int nmax, int qm, double alpha, int vice_versa);
+
+void xsewma_res_pms
+( double *alpha, int *n, int *ctyp,
+ double *lx, double *cx, double *hsx, int *Nx,
+ double *ls, double *csu, double *hss, int *Ns,
+ double *mu, double *sigma,
+ int *qm, int *vice_versa, double *pms)
+{
+ *pms = -1.;
+ *pms = xseU_mu_before_sigma_RES(*lx,*ls,*cx,*csu,*hsx,*hss,*mu,*sigma,*n,*Nx,*Ns,10000,*qm,*alpha,*vice_versa);
+}
diff --git a/src/xsewma_sf.c b/src/xsewma_sf.c
new file mode 100644
index 0000000..56fb1ee
--- /dev/null
+++ b/src/xsewma_sf.c
@@ -0,0 +1,32 @@
+#include <stdio.h>
+#include <math.h>
+#include <stdlib.h>
+#include <R.h>
+
+#define ewmaU 0
+#define ewmaUR 1
+#define ewma2 2
+
+double *vector (long n);
+double xseU_sf(double lx, double ls, double cx, double cs, double hsx, double hss, double mu, double sigma, int df, int Nx, int Ns, int nmax, int qm, double *p0);
+double xse2_sf(double lx, double ls, double cx, double csl, double csu, double hsx, double hss, double mu, double sigma, int df, int Nx, int Ns, int nmax, int qm, double *p0);
+
+void xsewma_sf
+( int *ctyp,
+ double *lx, double *cx, double *hsx, int *Nx,
+ double *ls, double *csl, double *csu, double *hss, int *Ns,
+ double *mu, double *sigma,
+ int *df, int *qm, int *n, double *sf)
+{ int result=0, i;
+ double *p0;
+ p0 = vector(*n);
+
+ if ( *ctyp == ewmaU )
+ result = xseU_sf(*lx, *ls, *cx, *csu, *hsx, *hss, *mu, *sigma, *df, *Nx, *Ns, *n, *qm, p0);
+ if ( *ctyp == ewma2 )
+ result = xse2_sf(*lx, *ls, *cx, *csl, *csu, *hsx, *hss, *mu, *sigma, *df, *Nx, *Ns, *n, *qm, p0);
+
+ if ( result != 0 ) warning("trouble in xsewma_sf [package spc]");
+
+ for (i=0; i<*n; i++) sf[i] = p0[i];
+}
diff --git a/src/xshewhart_ar1_arl.c b/src/xshewhart_ar1_arl.c
new file mode 100644
index 0000000..17e5b8a
--- /dev/null
+++ b/src/xshewhart_ar1_arl.c
@@ -0,0 +1,11 @@
+#include <stdio.h>
+#include <math.h>
+#include <stdlib.h>
+#include <R.h>
+
+double x_shewhart_ar1_arl(double alpha, double cS, double delta, int N1, int N2);
+
+void xshewhart_ar1_arl(double *alpha, double *cS, double *delta, int *N1, int *N2, double *arl)
+{
+ *arl = x_shewhart_ar1_arl(*alpha, *cS, *delta, *N1, *N2);
+}
diff --git a/src/xtcusum_arl.c b/src/xtcusum_arl.c
new file mode 100644
index 0000000..61efee2
--- /dev/null
+++ b/src/xtcusum_arl.c
@@ -0,0 +1,17 @@
+#include <stdio.h>
+#include <math.h>
+#include <stdlib.h>
+#include <R.h>
+
+#define cusum1 0
+#define cusum2 1
+
+double xtc1_iglarl(double k, double h, double hs, int df, double mu, int N, int subst);
+double xtc2_iglarl(double k, double h, double hs, int df, double mu, int N, int subst);
+
+void xtcusum_arl
+( int *ctyp, double *k, double *h, double *hs, int *df, double *mu, int *r, int *ntyp, double *arl)
+{
+ if ( *ctyp == cusum1 ) *arl = xtc1_iglarl(*k, *h, *hs, *df, *mu, *r, *ntyp);
+ if ( *ctyp == cusum2 ) *arl = xtc2_iglarl(*k, *h, *hs, *df, *mu, *r, *ntyp);
+}
diff --git a/src/xtewma_ad.c b/src/xtewma_ad.c
new file mode 100644
index 0000000..04bd7ad
--- /dev/null
+++ b/src/xtewma_ad.c
@@ -0,0 +1,33 @@
+#include <stdio.h>
+#include <math.h>
+#include <stdlib.h>
+#include <R.h>
+
+#define ewma1 0
+#define ewma2 1
+#define fix 0
+#define vacl 1
+
+#define conditional 0
+#define cyclical 1
+
+extern double rho0;
+
+/*
+double xe2_iglad (double l, double c, double mu0, double mu1, int N);
+double xe2_igladc(double l, double c, double mu0, double mu1, double z0, int N);
+double xe2_arlm (double l, double c, double hs, int q, double mu0, double mu1, int mode, int N, int nmax);*/
+
+double xte2_iglad(double l, double c, int df, double mu0, double mu1, int N, int subst);
+double xte2_igladc(double l, double c, int df, double mu0, double mu1, double z0, int N, int subst);
+double xte2_arlm (double l, double c, double hs, int df, int q, double mu0, double mu1, int mode, int N, int nmax, int subst);
+
+void xtewma_ad(int *ctyp, double *l, double *c, double *zr, int *df, double *mu0, double *mu1, double *z0, int *ltyp, int *styp, int *r, int *ntyp, double *ad)
+{ int nmax=1000000;
+ if ( *styp==conditional ) {
+ if ( *ctyp==ewma2 && *ltyp==fix ) *ad = xte2_iglad(*l,*c,*df,*mu0,*mu1,*r,*ntyp);
+ if ( *ctyp==ewma2 && *ltyp>fix ) *ad = xte2_arlm(*l,*c,0.,*df,200,*mu0,*mu1,*ltyp,*r,nmax,*ntyp);
+ } else {
+ if ( *ctyp==ewma2 && *ltyp==fix ) *ad = xte2_igladc(*l,*c,*df,*mu0,*mu1,*z0,*r,*ntyp);
+ }
+}
diff --git a/src/xtewma_arl.c b/src/xtewma_arl.c
new file mode 100644
index 0000000..a0265aa
--- /dev/null
+++ b/src/xtewma_arl.c
@@ -0,0 +1,34 @@
+#include <stdio.h>
+#include <math.h>
+#include <stdlib.h>
+#include <R.h>
+
+#define ewma1 0
+#define ewma2 1
+#define fix 0
+#define vacl 1
+
+extern double rho0;
+
+double *vector (long n);
+
+double xte2_iglarl(double l, double c, double hs, int df, double mu, int N, int subst);
+double xte2_arlm(double l, double c, double hs, int df, int q, double mu0, double mu1, int mode, int N, int nmax, int subst);
+double xte2_arlm_hom(double l, double c, double hs, int df, int q, double mu0, double mu1, int N, double *ced, int subst);
+
+void xtewma_arl(int *ctyp, double *l, double *c, double *zr, double *hs, int *df, double *mu, int *ltyp, int *r, int *ntyp, int *q, double *arl)
+{ int nmax=100000, i, result=0;
+ double *ced, arl1=-1.;
+
+ ced = vector(*q);
+
+ if (*ctyp==ewma2 && *ltyp==fix && *q==1) arl1 = xte2_iglarl(*l,*c,*hs,*df,*mu,*r,*ntyp);
+
+ if (*ctyp==ewma2 && *ltyp==fix && *q>1) result = xte2_arlm_hom(*l,*c,*hs,*df,*q,0.,*mu,*r,ced,*ntyp);
+
+ if (*ctyp==ewma2 && *ltyp>fix ) arl1 = xte2_arlm(*l,*c,*hs,*df,*q,0.,*mu,*ltyp,*r,nmax,*ntyp);
+
+ if ( result != 0 ) warning("trouble in xtewma_arl [package spc]");
+
+ if ( *ltyp==fix && *q>1 ) for (i=0; i<*q; i++) arl[i] = ced[i]; else *arl = arl1;
+}
diff --git a/src/xtewma_q.c b/src/xtewma_q.c
new file mode 100644
index 0000000..518afcf
--- /dev/null
+++ b/src/xtewma_q.c
@@ -0,0 +1,24 @@
+#include <stdio.h>
+#include <math.h>
+#include <stdlib.h>
+#include <R.h>
+
+#define ewma1 0
+#define ewma2 1
+#define fix 0
+#define vacl 1
+
+/*double xe1_Wq(double l, double c, double p, double zr, double hs, double mu, int N, int nmax);
+double xe1_Wqm(double l, double c, double p, double zr, double hs, int q, double mu0, double mu1, int mode, int N, int nmax);*/
+
+double xte2_Wq(double l, double c, double p, double hs, int df, double mu, int N, int nmax, int subst);
+
+double xte2_Wqm(double l, double c, double p, double hs, int df, int q, double mu0, double mu1, int mode, int N, int nmax, int subst);
+
+void xtewma_q(int *ctyp, double *l, double *c, double *p, double *zr, double *hs, int *df, double *mu, int *ltyp, int *r, int *ntyp, int *q, double *tq)
+{ int nmax=1000000;
+
+ if ( *ctyp==ewma2 && *ltyp==fix && *q==1 ) *tq = xte2_Wq(*l, *c, *p, *hs, *df, *mu, *r, nmax, *ntyp);
+ if ( *ctyp==ewma2 && *ltyp==fix && *q>1 ) *tq = xte2_Wqm(*l, *c, *p, *hs, *df, *q, 0., *mu, *ltyp, *r, nmax, *ntyp);
+ if ( *ctyp==ewma2 && *ltyp>fix ) *tq = xte2_Wqm(*l, *c, *p, *hs, *df, *q, 0., *mu, *ltyp, *r, nmax, *ntyp);
+}
diff --git a/src/xtewma_sf.c b/src/xtewma_sf.c
new file mode 100644
index 0000000..1fae897
--- /dev/null
+++ b/src/xtewma_sf.c
@@ -0,0 +1,39 @@
+#include <stdio.h>
+#include <math.h>
+#include <stdlib.h>
+#include <R.h>
+
+#define ewma1 0
+#define ewma2 1
+#define fix 0
+#define vacl 1
+
+double *vector (long n);
+
+/*
+double xe1_sf (double l, double c, double zr, double hs, double mu, int N, int nmax, double *p0);
+double xe1_sfm(double l, double c, double zr, double hs, int q, double mu0, double mu1, int mode, int N, int nmax, double *p0);
+*/
+
+double xte2_sf(double l, double c, double hs, int df, double mu, int N, int nmax, double *p0, int subst);
+
+double xte2_sfm(double l, double c, double hs, int df, int q, double mu0, double mu1, int mode, int N, int nmax, double *p0, int subst);
+
+
+void xtewma_sf(int *ctyp, double *l, double *c, double *zr, double *hs, int *df, double *mu, int *ltyp, int *r, int *ntyp, int *q, int *n, double *sf)
+{ int result=0, i;
+ double *p0;
+ p0 = vector(*n);
+
+ if ( *ctyp==ewma2 && *ltyp==fix && *q==1 ) {
+ result = xte2_sf(*l, *c, *hs, *df, *mu, *r, *n, p0, *ntyp);
+ }
+
+ if ( *ctyp==ewma2 && ( ( *ltyp==fix && *q>1 ) || ( *ltyp>fix) ) ) {
+ result = xte2_sfm(*l, *c, *hs, *df, *q, 0., *mu, *ltyp, *r, *n, p0, *ntyp);
+ }
+
+ if ( result != 0 ) warning("trouble in xtewma_sf [package spc]");
+
+ for (i=0; i<*n; i++) sf[i] = p0[i];
+}
--
Alioth's /usr/local/bin/git-commit-notice on /srv/git.debian.org/git/debian-science/packages/r-cran-spc.git
More information about the debian-science-commits
mailing list